From 0c155e68607fede6fab17704a9a7aee38df5408e Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 18 Dec 2024 15:13:06 +0100 Subject: [PATCH 1/8] Rename ctx -> man --- src/analyses/abortUnless.ml | 34 +- src/analyses/accessAnalysis.ml | 94 +-- src/analyses/activeLongjmp.ml | 14 +- src/analyses/activeSetjmp.ml | 18 +- src/analyses/apron/relationAnalysis.apron.ml | 230 ++--- src/analyses/assert.ml | 20 +- src/analyses/base.ml | 838 +++++++++---------- src/analyses/baseInvariant.ml | 68 +- src/analyses/basePriv.ml | 4 +- src/analyses/callstring.ml | 16 +- src/analyses/condVars.ml | 58 +- src/analyses/deadlock.ml | 26 +- src/analyses/expRelation.ml | 2 +- src/analyses/expsplit.ml | 76 +- src/analyses/extractPthread.ml | 148 ++-- src/analyses/locksetAnalysis.ml | 38 +- src/analyses/loopTermination.ml | 20 +- src/analyses/loopfreeCallstring.ml | 2 +- src/analyses/mCP.ml | 400 ++++----- src/analyses/mCPRegistry.ml | 4 +- src/analyses/mHPAnalysis.ml | 2 +- src/analyses/mallocFresh.ml | 32 +- src/analyses/malloc_null.ml | 80 +- src/analyses/mayLocks.ml | 38 +- src/analyses/memLeak.ml | 110 +-- src/analyses/memOutOfBounds.ml | 146 ++-- src/analyses/modifiedSinceSetjmp.ml | 34 +- src/analyses/mutexAnalysis.ml | 76 +- src/analyses/mutexEventsAnalysis.ml | 30 +- src/analyses/mutexGhosts.ml | 56 +- src/analyses/mutexTypeAnalysis.ml | 34 +- src/analyses/poisonVariables.ml | 54 +- src/analyses/pthreadSignals.ml | 28 +- src/analyses/ptranalAnalysis.ml | 2 +- src/analyses/raceAnalysis.ml | 64 +- src/analyses/region.ml | 86 +- src/analyses/stackTrace.ml | 22 +- src/analyses/symbLocks.ml | 46 +- src/analyses/taintPartialContexts.ml | 52 +- src/analyses/threadAnalysis.ml | 66 +- src/analyses/threadEscape.ml | 92 +- src/analyses/threadFlag.ml | 36 +- src/analyses/threadId.ml | 56 +- src/analyses/threadJoins.ml | 58 +- src/analyses/threadReturn.ml | 16 +- src/analyses/tmpSpecial.ml | 26 +- src/analyses/tutorials/constants.ml | 36 +- src/analyses/tutorials/signs.ml | 8 +- src/analyses/tutorials/taint.ml | 38 +- src/analyses/tutorials/unitAnalysis.ml | 34 +- src/analyses/unassumeAnalysis.ml | 54 +- src/analyses/uninit.ml | 54 +- src/analyses/useAfterFree.ml | 106 +-- src/analyses/varEq.ml | 86 +- src/analyses/vla.ml | 22 +- src/analyses/wrapperFunctionAnalysis.ml | 46 +- src/cdomains/apron/sharedFunctions.apron.ml | 2 +- src/domains/events.ml | 2 +- src/domains/queries.ml | 6 +- src/framework/analyses.ml | 110 ++- src/framework/constraints.ml | 186 ++-- src/framework/control.ml | 42 +- src/framework/resultQuery.ml | 32 +- src/lifters/contextGasLifter.ml | 64 +- src/lifters/longjmpLifter.ml | 162 ++-- src/lifters/recursionTermLifter.ml | 70 +- src/lifters/specLifters.ml | 508 +++++------ src/lifters/wideningTokenLifter.ml | 64 +- src/witness/observerAnalysis.ml | 44 +- src/witness/witnessConstraints.ml | 148 ++-- src/witness/z3/violationZ3.z3.ml | 56 +- 71 files changed, 2711 insertions(+), 2721 deletions(-) diff --git a/src/analyses/abortUnless.ml b/src/analyses/abortUnless.ml index 34d5b1a89b..f523b21970 100644 --- a/src/analyses/abortUnless.ml +++ b/src/analyses/abortUnless.ml @@ -13,61 +13,61 @@ struct module D = BoolDomain.MustBool module C = Printable.Unit - let context ctx _ _ = () + let context man _ _ = () let startcontext () = () (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = + let assign man (lval:lval) (rval:exp) : D.t = false - let branch ctx (exp:exp) (tv:bool) : D.t = - ctx.local + let branch man (exp:exp) (tv:bool) : D.t = + man.local - let body ctx (f:fundec) : D.t = - ctx.local + let body man (f:fundec) : D.t = + man.local - let return ctx (exp:exp option) (f:fundec) : D.t = - if ctx.local then + let return man (exp:exp option) (f:fundec) : D.t = + if man.local then match f.sformals with | [arg] when isIntegralType arg.vtype -> - (match ctx.ask (EvalInt (Lval (Var arg, NoOffset))) with + (match man.ask (EvalInt (Lval (Var arg, NoOffset))) with | v when Queries.ID.is_bot v -> false | v -> match Queries.ID.to_bool v with | Some b -> b | None -> false) | _ -> - (* should not happen, ctx.local should always be false in this case *) + (* should not happen, man.local should always be false in this case *) false else false - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = let candidate = match f.sformals with | [arg] when isIntegralType arg.vtype -> true | _ -> false in [false, candidate] - let combine_env ctx lval fexp f args fc au f_ask = + let combine_env man lval fexp f args fc au f_ask = if au then ( (* Assert before combine_assign, so if variables in `arg` are assigned to, asserting doesn't unsoundly yield bot *) (* See test 62/03 *) match args with - | [arg] -> ctx.emit (Events.Assert arg) + | [arg] -> man.emit (Events.Assert arg) | _ -> () ); false - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = false - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = false let startstate v = false - let threadenter ctx ~multiple lval f args = [false] - let threadspawn ctx ~multiple lval f args fctx = false + let threadenter man ~multiple lval f args = [false] + let threadspawn man ~multiple lval f args fman = false let exitstate v = false end diff --git a/src/analyses/accessAnalysis.ml b/src/analyses/accessAnalysis.ml index bf1892fdf0..55d79a1131 100644 --- a/src/analyses/accessAnalysis.ml +++ b/src/analyses/accessAnalysis.ml @@ -31,23 +31,23 @@ struct let activated = get_string_list "ana.activated" in emit_single_threaded := List.mem (ModifiedSinceSetjmp.Spec.name ()) activated || List.mem (PoisonVariables.Spec.name ()) activated - let do_access (ctx: (D.t, G.t, C.t, V.t) ctx) (kind:AccessKind.t) (reach:bool) (e:exp) = + let do_access (man: (D.t, G.t, C.t, V.t) man) (kind:AccessKind.t) (reach:bool) (e:exp) = if M.tracing then M.trace "access" "do_access %a %a %B" d_exp e AccessKind.pretty kind reach; let reach_or_mpt: _ Queries.t = if reach then ReachableFrom e else MayPointTo e in - let ad = ctx.ask reach_or_mpt in - ctx.emit (Access {exp=e; ad; kind; reach}) + let ad = man.ask reach_or_mpt in + man.emit (Access {exp=e; ad; kind; reach}) (** Three access levels: + [deref=false], [reach=false] - Access [exp] without dereferencing, used for all normal reads and all function call arguments. + [deref=true], [reach=false] - Access [exp] by dereferencing once (may-point-to), used for lval writes and shallow special accesses. + [deref=true], [reach=true] - Access [exp] by dereferencing transitively (reachable), used for deep special accesses. *) - let access_one_top ?(force=false) ?(deref=false) ctx (kind: AccessKind.t) reach exp = + let access_one_top ?(force=false) ?(deref=false) man (kind: AccessKind.t) reach exp = if M.tracing then M.traceli "access" "access_one_top %a (kind = %a, reach = %B, deref = %B)" CilType.Exp.pretty exp AccessKind.pretty kind reach deref; - if force || !collect_local || !emit_single_threaded || ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx) then ( + if force || !collect_local || !emit_single_threaded || ThreadFlag.has_ever_been_multi (Analyses.ask_of_man man) then ( if deref && Cil.isPointerType (Cilfacade.typeOf exp) then (* avoid dereferencing integers to unknown pointers, which cause many spurious type-based accesses *) - do_access ctx kind reach exp; + do_access man kind reach exp; if M.tracing then M.tracei "access" "distribute_access_exp"; - Access.distribute_access_exp (do_access ctx Read false) exp; + Access.distribute_access_exp (do_access man Read false) exp; if M.tracing then M.traceu "access" "distribute_access_exp"; ); if M.tracing then M.traceu "access" "access_one_top" @@ -55,88 +55,88 @@ struct (** We just lift start state, global and dependency functions: *) let startstate v = () - let threadenter ctx ~multiple lval f args = [()] + let threadenter man ~multiple lval f args = [()] let exitstate v = () - let context ctx fd d = () + let context man fd d = () (** Transfer functions: *) - let vdecl ctx v = - access_one_top ctx Read false (SizeOf v.vtype); - ctx.local + let vdecl man v = + access_one_top man Read false (SizeOf v.vtype); + man.local - let assign ctx lval rval : D.t = + let assign man lval rval : D.t = (* ignore global inits *) - if !AnalysisState.global_initialization then ctx.local else begin - access_one_top ~deref:true ctx Write false (AddrOf lval); - access_one_top ctx Read false rval; - ctx.local + if !AnalysisState.global_initialization then man.local else begin + access_one_top ~deref:true man Write false (AddrOf lval); + access_one_top man Read false rval; + man.local end - let branch ctx exp tv : D.t = - access_one_top ctx Read false exp; - ctx.local + let branch man exp tv : D.t = + access_one_top man Read false exp; + man.local - let return ctx exp fundec : D.t = + let return man exp fundec : D.t = begin match exp with - | Some exp -> access_one_top ctx Read false exp + | Some exp -> access_one_top man Read false exp | None -> () end; - ctx.local + man.local - let body ctx f : D.t = - ctx.local + let body man f : D.t = + man.local - let special ctx lv f arglist : D.t = + let special man lv f arglist : D.t = let desc = LF.find f in match desc.special arglist with (* TODO: remove Lock/Unlock cases when all those libraryfunctions use librarydescs and don't read mutex contents *) | Lock _ | Unlock _ -> - ctx.local + man.local | _ -> LibraryDesc.Accesses.iter desc.accs (fun {kind; deep = reach} exp -> - access_one_top ~deref:true ctx kind reach exp (* access dereferenced using special accesses *) + access_one_top ~deref:true man kind reach exp (* access dereferenced using special accesses *) ) arglist; (match lv with - | Some x -> access_one_top ~deref:true ctx Write false (AddrOf x) + | Some x -> access_one_top ~deref:true man Write false (AddrOf x) | None -> ()); - List.iter (access_one_top ctx Read false) arglist; (* always read all argument expressions without dereferencing *) - ctx.local + List.iter (access_one_top man Read false) arglist; (* always read all argument expressions without dereferencing *) + man.local - let enter ctx lv f args : (D.t * D.t) list = - [(ctx.local,ctx.local)] + let enter man lv f args : (D.t * D.t) list = + [(man.local,man.local)] - let combine_env ctx lval fexp f args fc au f_ask = + let combine_env man lval fexp f args fc au f_ask = (* These should be in enter, but enter cannot emit events, nor has fexp argument *) - access_one_top ctx Read false fexp; - List.iter (access_one_top ctx Read false) args; + access_one_top man Read false fexp; + List.iter (access_one_top man Read false) args; au - let combine_assign ctx lv fexp f args fc al f_ask = + let combine_assign man lv fexp f args fc al f_ask = begin match lv with | None -> () - | Some lval -> access_one_top ~deref:true ctx Write false (AddrOf lval) + | Some lval -> access_one_top ~deref:true man Write false (AddrOf lval) end; - ctx.local + man.local - let threadspawn ctx ~multiple lval f args fctx = + let threadspawn man ~multiple lval f args fman = (* must explicitly access thread ID lval because special to pthread_create doesn't if singlethreaded before *) begin match lval with | None -> () - | Some lval -> access_one_top ~force:true ~deref:true ctx Write false (AddrOf lval) (* must force because otherwise doesn't if singlethreaded before *) + | Some lval -> access_one_top ~force:true ~deref:true man Write false (AddrOf lval) (* must force because otherwise doesn't if singlethreaded before *) end; - ctx.local + man.local - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | MayAccessed -> - (ctx.global ctx.node: G.t) + (man.global man.node: G.t) | _ -> Queries.Result.top q - let event ctx e octx = + let event man e oman = match e with | Events.Access {ad; kind; _} when !collect_local && !AnalysisState.postsolving -> let events = Queries.AD.fold (fun addr es -> @@ -151,9 +151,9 @@ struct | _ -> es ) ad (G.empty ()) in - ctx.sideg ctx.node events + man.sideg man.node events | _ -> - ctx.local + man.local end let _ = diff --git a/src/analyses/activeLongjmp.ml b/src/analyses/activeLongjmp.ml index 47e2432662..df5fdf5ff5 100644 --- a/src/analyses/activeLongjmp.ml +++ b/src/analyses/activeLongjmp.ml @@ -12,25 +12,25 @@ struct (* The first component are the longjmp targets, the second are the longjmp callers *) module D = JmpBufDomain.ActiveLongjmps - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special arglist, f.vname with | Longjmp {env; value}, _ -> (* Set target to current value of env *) - let bufs = ctx.ask (EvalJumpBuf env) in - bufs, JmpBufDomain.NodeSet.singleton(ctx.prev_node) - | _ -> ctx.local + let bufs = man.ask (EvalJumpBuf env) in + bufs, JmpBufDomain.NodeSet.singleton(man.prev_node) + | _ -> man.local (* Initial values don't really matter: overwritten at longjmp call. *) let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] + let threadenter man ~multiple lval f args = [D.bot ()] let exitstate v = D.top () - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | ActiveJumpBuf -> (* Does not compile without annotation: "This instance (...) is ambiguous: it would escape the scope of its equation" *) - (ctx.local:JmpBufDomain.ActiveLongjmps.t) + (man.local:JmpBufDomain.ActiveLongjmps.t) | _ -> Queries.Result.top q end diff --git a/src/analyses/activeSetjmp.ml b/src/analyses/activeSetjmp.ml index 69db900d4c..d10ac11247 100644 --- a/src/analyses/activeSetjmp.ml +++ b/src/analyses/activeSetjmp.ml @@ -13,24 +13,24 @@ struct include Analyses.ValueContexts(D) module P = IdentityP (D) - let combine_env ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask:Queries.ask): D.t = - ctx.local (* keep local as opposed to IdentitySpec *) + let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask:Queries.ask): D.t = + man.local (* keep local as opposed to IdentitySpec *) - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special arglist with | Setjmp _ -> - let entry = (ctx.prev_node, ctx.control_context ()) in - D.add (Target entry) ctx.local - | _ -> ctx.local + let entry = (man.prev_node, man.control_context ()) in + D.add (Target entry) man.local + | _ -> man.local let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] + let threadenter man ~multiple lval f args = [D.bot ()] let exitstate v = D.top () - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with - | ValidLongJmp -> (ctx.local: D.t) + | ValidLongJmp -> (man.local: D.t) | _ -> Queries.Result.top q end diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index df3cf545c5..9be61523de 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -40,7 +40,7 @@ struct (* Result map used for comparison of results for relational traces paper. *) let results = PCU.RH.create 103 - let context ctx fd x = + let context man fd x = if ContextUtil.should_keep ~isAttr:GobContext ~keepOption:"ana.relation.context" ~removeAttr:"relation.no-context" ~keepAttr:"relation.context" fd then x else @@ -189,8 +189,8 @@ struct else not (ask.f (MaySignedOverflow exp)) - let no_overflow ctx exp = lazy ( - let res = no_overflow ctx exp in + let no_overflow man exp = lazy ( + let res = no_overflow man exp in if M.tracing then M.tracel "no_ov" "no_ov %b exp: %a" res d_exp exp; res ) @@ -245,13 +245,13 @@ struct inner e (* Basic transfer functions. *) - let assign ctx (lv:lval) e = - let st = ctx.local in - let simplified_e = replace_deref_exps ctx.ask e in + let assign man (lv:lval) e = + let st = man.local in + let simplified_e = replace_deref_exps man.ask e in if M.tracing then M.traceli "relation" "assign %a = %a (simplified to %a)" d_lval lv d_exp e d_exp simplified_e; - let ask = Analyses.ask_of_ctx ctx in - let r = assign_to_global_wrapper ask ctx.global ctx.sideg st lv (fun st v -> - assign_from_globals_wrapper ask ctx.global st simplified_e (fun apr' e' -> + let ask = Analyses.ask_of_man man in + let r = assign_to_global_wrapper ask man.global man.sideg st lv (fun st v -> + assign_from_globals_wrapper ask man.global st simplified_e (fun apr' e' -> if M.tracing then M.traceli "relation" "assign inner %a = %a (%a)" CilType.Varinfo.pretty v d_exp e' d_plainexp e'; if M.tracing then M.trace "relation" "st: %a" RD.pretty apr'; let r = RD.assign_exp ask apr' (RV.local v) e' (no_overflow ask simplified_e) in @@ -263,10 +263,10 @@ struct if M.tracing then M.traceu "relation" "-> %a" D.pretty r; r - let branch ctx e b = - let st = ctx.local in - let ask = Analyses.ask_of_ctx ctx in - let res = assign_from_globals_wrapper ask ctx.global st e (fun rel' e' -> + let branch man e b = + let st = man.local in + let ask = Analyses.ask_of_man man in + let res = assign_from_globals_wrapper ask man.global st e (fun rel' e' -> (* not an assign, but must remove g#in-s still *) RD.assert_inv ask rel' e' (not b) (no_overflow ask e) ) @@ -282,9 +282,9 @@ struct let locals_id = List.map (fun v -> v.vid) locals in VS.exists (fun v -> List.mem v.vid locals_id && RD.Tracked.varinfo_tracked v) reachable_from_args - let reachable_from_args ctx args = + let reachable_from_args man args = let to_vs e = - ctx.ask (ReachableFrom e) + man.ask (ReachableFrom e) |> Queries.AD.to_var_may |> VS.of_list in @@ -301,9 +301,9 @@ struct | None -> true | Some v -> any_local_reachable - let make_callee_rel ~thread ctx f args = - let fundec = Node.find_fundec ctx.node in - let st = ctx.local in + let make_callee_rel ~thread man f args = + let fundec = Node.find_fundec man.node in + let st = man.local in let arg_assigns = GobList.combine_short f.sformals args (* TODO: is it right to ignore missing formals/args? *) |> List.filter_map (fun (x, e) -> if RD.Tracked.varinfo_tracked x then Some (RV.arg x, e) else None) @@ -316,14 +316,14 @@ struct if thread then new_rel else - let ask = Analyses.ask_of_ctx ctx in + let ask = Analyses.ask_of_man man in List.fold_left (fun new_rel (var, e) -> - assign_from_globals_wrapper ask ctx.global {st with rel = new_rel} e (fun rel' e' -> + assign_from_globals_wrapper ask man.global {st with rel = new_rel} e (fun rel' e' -> RD.assign_exp ask rel' var e' (no_overflow ask e) ) ) new_rel arg_assigns in - let reachable_from_args = reachable_from_args ctx args in + let reachable_from_args = reachable_from_args man args in let any_local_reachable = any_local_reachable fundec reachable_from_args in RD.remove_filter_with new_rel (fun var -> match RV.find_metadata var with @@ -334,13 +334,13 @@ struct if M.tracing then M.tracel "combine" "relation enter newd: %a" RD.pretty new_rel; new_rel - let enter ctx r f args = - let calle_rel = make_callee_rel ~thread:false ctx f args in - [ctx.local, {ctx.local with rel = calle_rel}] + let enter man r f args = + let calle_rel = make_callee_rel ~thread:false man f args in + [man.local, {man.local with rel = calle_rel}] - let body ctx f = - let st = ctx.local in - let ask = Analyses.ask_of_ctx ctx in + let body man f = + let st = man.local in + let ask = Analyses.ask_of_man man in let formals = List.filter RD.Tracked.varinfo_tracked f.sformals in let locals = List.filter RD.Tracked.varinfo_tracked f.slocals in let new_rel = RD.add_vars st.rel (List.map RV.local (formals @ locals)) in @@ -353,15 +353,15 @@ struct RD.assign_var_parallel_with new_rel local_assigns; (* doesn't need to be parallel since arg vars aren't local vars *) {st with rel = new_rel} - let return ctx e f = - let st = ctx.local in - let ask = Analyses.ask_of_ctx ctx in + let return man e f = + let st = man.local in + let ask = Analyses.ask_of_man man in let new_rel = if RD.Tracked.type_tracked (Cilfacade.fundec_return_type f) then ( let rel' = RD.add_vars st.rel [RV.return] in match e with | Some e -> - assign_from_globals_wrapper ask ctx.global {st with rel = rel'} e (fun rel' e' -> + assign_from_globals_wrapper ask man.global {st with rel = rel'} e (fun rel' e' -> RD.assign_exp ask rel' RV.return e' (no_overflow ask e) ) | None -> @@ -379,15 +379,15 @@ struct let st' = {st with rel = new_rel} in begin match ThreadId.get_current ask with | `Lifted tid when ThreadReturn.is_current ask -> - Priv.thread_return ask ctx.global ctx.sideg tid st' + Priv.thread_return ask man.global man.sideg tid st' | _ -> st' end - let combine_env ctx r fe f args fc fun_st (f_ask : Queries.ask) = - let st = ctx.local in - let reachable_from_args = reachable_from_args ctx args in - let fundec = Node.find_fundec ctx.node in + let combine_env man r fe f args fc fun_st (f_ask : Queries.ask) = + let st = man.local in + let reachable_from_args = reachable_from_args man args in + let fundec = Node.find_fundec man.node in if M.tracing then M.tracel "combine-rel" "relation f: %a" CilType.Varinfo.pretty f.svar; if M.tracing then M.tracel "combine-rel" "relation formals: %a" (d_list "," CilType.Varinfo.pretty) f.sformals; if M.tracing then M.tracel "combine-rel" "relation args: %a" (d_list "," d_exp) args; @@ -406,9 +406,9 @@ struct in (* RD.substitute_exp_parallel_with new_fun_rel arg_substitutes; (* doesn't need to be parallel since exps aren't arg vars directly *) *) (* TODO: parallel version of assign_from_globals_wrapper? *) - let ask = Analyses.ask_of_ctx ctx in + let ask = Analyses.ask_of_man man in let new_fun_rel = List.fold_left (fun new_fun_rel (var, e) -> - assign_from_globals_wrapper ask ctx.global {st with rel = new_fun_rel} e (fun rel' e' -> + assign_from_globals_wrapper ask man.global {st with rel = new_fun_rel} e (fun rel' e' -> (* not an assign, but still works? *) (* substitute is the backwards semantics of assignment *) (* https://antoinemine.github.io/Apron/doc/papers/expose_CEA_2007.pdf *) @@ -435,13 +435,13 @@ struct if M.tracing then M.tracel "combine-rel" "relation unifying %a %a = %a" RD.pretty new_rel RD.pretty new_fun_rel RD.pretty unify_rel; {fun_st with rel = unify_rel} - let combine_assign ctx r fe f args fc fun_st (f_ask : Queries.ask) = - let unify_st = ctx.local in + let combine_assign man r fe f args fc fun_st (f_ask : Queries.ask) = + let unify_st = man.local in if RD.Tracked.type_tracked (Cilfacade.fundec_return_type f) then ( let unify_st' = match r with | Some lv -> - let ask = Analyses.ask_of_ctx ctx in - assign_to_global_wrapper ask ctx.global ctx.sideg unify_st lv (fun st v -> + let ask = Analyses.ask_of_man man in + assign_to_global_wrapper ask man.global man.sideg unify_st lv (fun st v -> let rel = RD.assign_var st.rel (RV.local v) RV.return in assert_type_bounds ask rel v (* TODO: should be done in return instead *) ) @@ -455,8 +455,8 @@ struct unify_st - let invalidate_one ask ctx st lv = - assign_to_global_wrapper ask ctx.global ctx.sideg st lv (fun st v -> + let invalidate_one ask man st lv = + assign_to_global_wrapper ask man.global man.sideg st lv (fun st v -> let rel' = RD.forget_vars st.rel [RV.local v] in assert_type_bounds ask rel' v (* re-establish type bounds after forget *) (* TODO: no_overflow on wrapped *) ) @@ -477,8 +477,8 @@ struct List.fold_right reachable es (Some (Queries.AD.empty ())) - let forget_reachable ctx st es = - let ask = Analyses.ask_of_ctx ctx in + let forget_reachable man st es = + let ask = Analyses.ask_of_man man in let rs = match reachables ask es with | None -> @@ -495,17 +495,17 @@ struct Queries.AD.fold to_cil ad [] in List.fold_left (fun st lval -> - invalidate_one ask ctx st lval + invalidate_one ask man st lval ) st rs - let assert_fn ctx e refine = + let assert_fn man e refine = if not refine then - ctx.local + man.local else (* copied from branch *) - let st = ctx.local in - let ask = Analyses.ask_of_ctx ctx in - let res = assign_from_globals_wrapper ask ctx.global st e (fun apr' e' -> + let st = man.local in + let ask = Analyses.ask_of_man man in + let res = assign_from_globals_wrapper ask man.global st e (fun apr' e' -> (* not an assign, but must remove g#in-s still *) RD.assert_inv ask apr' e' false (no_overflow ask e) ) @@ -513,19 +513,19 @@ struct if RD.is_bot_env res then raise Deadcode; {st with rel = res} - let special ctx r f args = - let ask = Analyses.ask_of_ctx ctx in - let st = ctx.local in + let special man r f args = + let ask = Analyses.ask_of_man man in + let st = man.local in let desc = LibraryFunctions.find f in match desc.special args, f.vname with - | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine + | Assert { exp; refine; _ }, _ -> assert_fn man exp refine | ThreadJoin { thread = id; ret_var = retvar }, _ -> ( (* Forget value that thread return is assigned to *) - let st' = forget_reachable ctx st [retvar] in - let st' = Priv.thread_join ask ctx.global id st' in + let st' = forget_reachable man st [retvar] in + let st' = Priv.thread_join ask man.global id st' in match r with - | Some lv -> invalidate_one ask ctx st' lv + | Some lv -> invalidate_one ask man st' lv | None -> st' ) | ThreadExit _, _ -> @@ -533,19 +533,19 @@ struct | `Lifted tid -> (* value returned from the thread is not used in thread_join or any Priv.thread_join, *) (* thus no handling like for returning from functions required *) - ignore @@ Priv.thread_return ask ctx.global ctx.sideg tid st; + ignore @@ Priv.thread_return ask man.global man.sideg tid st; raise Deadcode | _ -> raise Deadcode end | Unknown, "__goblint_assume_join" -> let id = List.hd args in - Priv.thread_join ~force:true ask ctx.global id st + Priv.thread_join ~force:true ask man.global id st | Rand, _ -> (match r with | Some lv -> - let st = invalidate_one ask ctx st lv in - assert_fn {ctx with local = st} (BinOp (Ge, Lval lv, zero, intType)) true + let st = invalidate_one ask man st lv in + assert_fn {man with local = st} (BinOp (Ge, Lval lv, zero, intType)) true | None -> st) | _, _ -> let lvallist e = @@ -570,33 +570,33 @@ struct else deep_addrs in - let st' = forget_reachable ctx st deep_addrs in + let st' = forget_reachable man st deep_addrs in let shallow_lvals = List.concat_map lvallist shallow_addrs in - let st' = List.fold_left (invalidate_one ask ctx) st' shallow_lvals in + let st' = List.fold_left (invalidate_one ask man) st' shallow_lvals in (* invalidate lval if present *) match r with - | Some lv -> invalidate_one ask ctx st' lv + | Some lv -> invalidate_one ask man st' lv | None -> st' - let query_invariant ctx context = + let query_invariant man context = let keep_local = GobConfig.get_bool "ana.relation.invariant.local" in let keep_global = GobConfig.get_bool "ana.relation.invariant.global" in let one_var = GobConfig.get_bool "ana.relation.invariant.one-var" in let exact = GobConfig.get_bool "witness.invariant.exact" in - let ask = Analyses.ask_of_ctx ctx in - let scope = Node.find_fundec ctx.node in + let ask = Analyses.ask_of_man man in + let scope = Node.find_fundec man.node in let (apr, e_inv) = if ThreadFlag.has_ever_been_multi ask then ( let priv_vars = if keep_global then - Priv.invariant_vars ask ctx.global ctx.local + Priv.invariant_vars ask man.global man.local else [] (* avoid pointless queries *) in - let (rel, e_inv, v_ins_inv) = read_globals_to_locals_inv ask ctx.global ctx.local priv_vars in + let (rel, e_inv, v_ins_inv) = read_globals_to_locals_inv ask man.global man.local priv_vars in (* filter variables *) let var_filter v = match RV.find_metadata v with | Some (Local v) -> @@ -616,7 +616,7 @@ struct | Some (Local _) -> keep_local | _ -> false in - let apr = RD.keep_filter ctx.local.rel var_filter in + let apr = RD.keep_filter man.local.rel var_filter in (apr, Fun.id) ) in @@ -634,90 +634,90 @@ struct ) |> Enum.fold (fun acc x -> Invariant.(acc && of_exp x)) Invariant.none - let query_invariant_global ctx g = - if GobConfig.get_bool "ana.relation.invariant.global" && ctx.ask (GhostVarAvailable Multithreaded) then ( + let query_invariant_global man g = + if GobConfig.get_bool "ana.relation.invariant.global" && man.ask (GhostVarAvailable Multithreaded) then ( let var = WitnessGhost.to_varinfo Multithreaded in - let inv = Priv.invariant_global (Analyses.ask_of_ctx ctx) ctx.global g in + let inv = Priv.invariant_global (Analyses.ask_of_man man) man.global g in Invariant.(of_exp (UnOp (LNot, Lval (GoblintCil.var var), GoblintCil.intType)) || inv) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) ) else Invariant.none - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = let open Queries in - let st = ctx.local in + let st = man.local in let eval_int e no_ov = - let esimple = replace_deref_exps ctx.ask e in + let esimple = replace_deref_exps man.ask e in read_from_globals_wrapper - (Analyses.ask_of_ctx ctx) - ctx.global st esimple - (fun rel' e' -> RD.eval_int (Analyses.ask_of_ctx ctx) rel' e' no_ov) + (Analyses.ask_of_man man) + man.global st esimple + (fun rel' e' -> RD.eval_int (Analyses.ask_of_man man) rel' e' no_ov) in match q with | EvalInt e -> if M.tracing then M.traceli "evalint" "relation query %a (%a)" d_exp e d_plainexp e; - if M.tracing then M.trace "evalint" "relation st: %a" D.pretty ctx.local; - let r = eval_int e (no_overflow (Analyses.ask_of_ctx ctx) e) in + if M.tracing then M.trace "evalint" "relation st: %a" D.pretty man.local; + let r = eval_int e (no_overflow (Analyses.ask_of_man man) e) in if M.tracing then M.traceu "evalint" "relation query %a -> %a" d_exp e ID.pretty r; r | Queries.IterSysVars (vq, vf) -> let vf' x = vf (Obj.repr x) in - Priv.iter_sys_vars ctx.global vq vf' - | Queries.Invariant context -> query_invariant ctx context + Priv.iter_sys_vars man.global vq vf' + | Queries.Invariant context -> query_invariant man context | Queries.InvariantGlobal g -> let g: V.t = Obj.obj g in - query_invariant_global ctx g + query_invariant_global man g | _ -> Result.top q (* Thread transfer functions. *) - let threadenter ctx ~multiple lval f args = - let st = ctx.local in + let threadenter man ~multiple lval f args = + let st = man.local in match Cilfacade.find_varinfo_fundec f with | fd -> (* TODO: HACK: Simulate enter_multithreaded for first entering thread to publish global inits before analyzing thread. 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) ctx.global ctx.sideg st); - let st' = Priv.threadenter (Analyses.ask_of_ctx ctx) ctx.global st in - let new_rel = make_callee_rel ~thread:true ctx fd args in + if not (ThreadFlag.has_ever_been_multi (Analyses.ask_of_man man)) then + ignore (Priv.enter_multithreaded (Analyses.ask_of_man man) man.global man.sideg st); + let st' = Priv.threadenter (Analyses.ask_of_man man) man.global st in + let new_rel = make_callee_rel ~thread:true man fd args in [{st' with rel = new_rel}] | exception Not_found -> (* Unknown functions *) (* TODO: do something like base? *) failwith "relation.threadenter: unknown function" - let threadspawn ctx ~multiple lval f args fctx = - ctx.local + let threadspawn man ~multiple lval f args fman = + man.local - let event ctx e octx = - let ask = Analyses.ask_of_ctx ctx in - let st = ctx.local in + let event man e oman = + let ask = Analyses.ask_of_man man in + let st = man.local in match e with | Events.Lock (addr, _) when ThreadFlag.has_ever_been_multi ask -> (* TODO: is this condition sound? *) CommonPriv.lift_lock ask (fun st m -> - Priv.lock ask ctx.global st m + Priv.lock ask man.global st m ) st addr | Events.Unlock addr when ThreadFlag.has_ever_been_multi ask -> (* TODO: is this condition sound? *) WideningTokenLifter.with_local_side_tokens (fun () -> CommonPriv.lift_unlock ask (fun st m -> - Priv.unlock ask ctx.global ctx.sideg st m + Priv.unlock ask man.global man.sideg st m ) st addr ) | Events.EnterMultiThreaded -> - Priv.enter_multithreaded (Analyses.ask_of_ctx ctx) ctx.global ctx.sideg st + Priv.enter_multithreaded (Analyses.ask_of_man man) man.global man.sideg st | Events.Escape escaped -> - Priv.escape ctx.node (Analyses.ask_of_ctx ctx) ctx.global ctx.sideg st escaped + Priv.escape man.node (Analyses.ask_of_man man) man.global man.sideg st escaped | Assert exp -> - assert_fn ctx exp true + assert_fn man exp true | Events.Unassume {exp = e; tokens} -> let e_orig = e in - let ask = Analyses.ask_of_ctx ctx in - let e = replace_deref_exps ctx.ask e in - let (rel, e, v_ins) = read_globals_to_locals ask ctx.global ctx.local e in + let ask = Analyses.ask_of_man man in + let e = replace_deref_exps man.ask e in + let (rel, e, v_ins) = read_globals_to_locals ask man.global man.local e in let vars = Basetype.CilExp.get_vars e |> List.unique ~eq:CilType.Varinfo.equal |> List.filter RD.Tracked.varinfo_tracked in let rel = RD.forget_vars rel (List.map RV.local vars) in (* havoc *) @@ -732,12 +732,12 @@ struct let esimple = replace_deref_exps dummyask.f e in read_from_globals_wrapper (dummyask) - ctx.global { st with rel } esimple + man.global { st with rel } esimple (fun rel' e' -> RD.eval_int (dummyask) rel' e' no_ov) in match q with | EvalInt e -> - if M.tracing then M.traceli "relation" "evalint query %a (%a), ctx %a" d_exp e d_plainexp e D.pretty ctx.local; + if M.tracing then M.traceli "relation" "evalint query %a (%a), man %a" d_exp e d_plainexp e D.pretty man.local; let r = eval_int e (no_overflow (dummyask) e) in if M.tracing then M.trace "relation" "evalint response %a -> %a" d_exp e ValueDomainQueries.ID.pretty r; r @@ -752,21 +752,21 @@ struct WideningTokenLifter.with_side_tokens (WideningTokenLifter.TS.of_list tokens) (fun () -> VH.fold (fun v v_in st -> (* TODO: is this sideg fine? *) - write_global ask ctx.global ctx.sideg st v v_in - ) v_ins {ctx.local with rel} + write_global ask man.global man.sideg st v v_in + ) v_ins {man.local with rel} ) in let rel = RD.remove_vars st.rel (List.map RV.local (VH.values v_ins |> List.of_enum)) in (* remove temporary g#in-s *) if M.tracing then M.traceli "apron" "unassume join"; - let st = D.join ctx.local {st with rel} in (* (strengthening) join *) + let st = D.join man.local {st with rel} in (* (strengthening) join *) if M.tracing then M.traceu "apron" "unassume join"; M.info ~category:Witness "relation unassumed invariant: %a" d_exp e_orig; st | _ -> st - let sync ctx reason = + let sync man reason = (* After the solver is finished, store the results (for later comparison) *) if !AnalysisState.postsolving && GobConfig.get_string "exp.relation.prec-dump" <> "" then begin let keep_local = GobConfig.get_bool "ana.relation.invariant.local" in @@ -778,13 +778,13 @@ struct | Some (Local _) -> keep_local | _ -> false in - let st = RD.keep_filter ctx.local.rel var_filter in - let old_value = PCU.RH.find_default results ctx.node (RD.bot ()) in + let st = RD.keep_filter man.local.rel var_filter in + let old_value = PCU.RH.find_default results man.node (RD.bot ()) in let new_value = RD.join old_value st in - PCU.RH.replace results ctx.node new_value; + PCU.RH.replace results man.node new_value; end; WideningTokenLifter.with_local_side_tokens (fun () -> - Priv.sync (Analyses.ask_of_ctx ctx) ctx.global ctx.sideg ctx.local (reason :> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return | `Init | `Thread]) + Priv.sync (Analyses.ask_of_man man) man.global man.sideg man.local (reason :> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return | `Init | `Thread]) ) let init marshal = diff --git a/src/analyses/assert.ml b/src/analyses/assert.ml index 8247a0d7e8..c9045037f7 100644 --- a/src/analyses/assert.ml +++ b/src/analyses/assert.ml @@ -13,10 +13,10 @@ struct (* transfer functions *) - let assert_fn ctx e check refine = + let assert_fn man e check refine = let check_assert e st = - match ctx.ask (Queries.EvalInt e) with + match man.ask (Queries.EvalInt e) with | v when Queries.ID.is_bot v -> `Bot | v -> match Queries.ID.to_bool v with @@ -41,25 +41,25 @@ struct warn_fn msg in (* TODO: use format instead of %s for the following messages *) - match check_assert e ctx.local with + match check_assert e man.local with | `Lifted false -> warn (M.error ~category:Assert "%s") ~annot:"FAIL" ("Assertion \"" ^ expr ^ "\" will fail."); - if refine then raise Analyses.Deadcode else ctx.local + if refine then raise Analyses.Deadcode else man.local | `Lifted true -> warn (M.success ~category:Assert "%s") ("Assertion \"" ^ expr ^ "\" will succeed"); - ctx.local + man.local | `Bot -> M.error ~category:Assert "%s" ("Assertion \"" ^ expr ^ "\" produces a bottom. What does that mean? (currently uninitialized arrays' content is bottom)"); - ctx.local + man.local | `Top -> warn (M.warn ~category:Assert "%s") ~annot:"UNKNOWN" ("Assertion \"" ^ expr ^ "\" is unknown."); - ctx.local + man.local - let special ctx (lval: lval option) (f:varinfo) (args:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (args:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special args, f.vname with - | Assert { exp; check; refine }, _ -> assert_fn ctx exp check refine - | _, _ -> ctx.local + | Assert { exp; check; refine }, _ -> assert_fn man exp check refine + | _, _ -> man.local end let _ = diff --git a/src/analyses/base.ml b/src/analyses/base.ml index f6e41361a3..f24ae36b2c 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -143,8 +143,8 @@ struct * Initializing my variables **************************************************************************) - let heap_var on_stack ctx = - let info = match (ctx.ask (Q.AllocVar {on_stack})) with + let heap_var on_stack man = + let info = match (man.ask (Q.AllocVar {on_stack})) with | `Lifted vinfo -> vinfo | _ -> failwith("Ran without a malloc analysis.") in info @@ -243,7 +243,7 @@ struct | _ -> false (* Evaluate binop for two abstract values: *) - let evalbinop_base ~ctx (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = + let evalbinop_base ~man (op: binop) (t1:typ) (a1:value) (t2:typ) (a2:value) (t:typ) :value = if M.tracing then M.tracel "eval" "evalbinop %a %a %a" 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. *) @@ -359,7 +359,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 ctx.ask (Q.IsMultiple v) -> + | Some v when man.ask (Q.IsMultiple v) -> if M.tracing then M.tracel "addr" "IsMultiple %a" CilType.Varinfo.pretty v; None | _ -> @@ -434,32 +434,32 @@ struct * State functions **************************************************************************) - let sync' reason ctx: D.t = + let sync' reason man: D.t = let multi = match reason with | `Init | `Thread -> true | _ -> - ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx) + ThreadFlag.has_ever_been_multi (Analyses.ask_of_man man) in if M.tracing then M.tracel "sync" "sync multi=%B earlyglobs=%B" multi !earlyglobs; if !earlyglobs || multi then WideningTokenLifter.with_local_side_tokens (fun () -> - Priv.sync (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) ctx.local reason + Priv.sync (Analyses.ask_of_man man) (priv_getg man.global) (priv_sideg man.sideg) man.local reason ) else - ctx.local + man.local - let sync ctx reason = sync' (reason :> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return | `Init | `Thread]) ctx + let sync man reason = sync' (reason :> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return | `Init | `Thread]) man - let publish_all ctx reason = - ignore (sync' reason ctx) + let publish_all man reason = + ignore (sync' reason man) - let get_var ~ctx (st: store) (x: varinfo): value = - let ask = Analyses.ask_of_ctx ctx in + let get_var ~man (st: store) (x: varinfo): value = + let ask = Analyses.ask_of_man man in if (!earlyglobs || ThreadFlag.has_ever_been_multi ask) && is_global ask x then - Priv.read_global ask (priv_getg ctx.global) st x + Priv.read_global ask (priv_getg man.global) st x else begin if M.tracing then M.tracec "get" "Singlethreaded mode."; CPA.find x st.cpa @@ -469,15 +469,15 @@ 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) (st: store) (addrs:address) (exp:exp option): value = + let rec get ~man ?(top=VD.top ()) ?(full=false) (st: store) (addrs:address) (exp:exp option): value = 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" AD.pretty addrs CPA.pretty st.cpa; (* Finding a single varinfo*offset pair *) let res = let f_addr (x, offs) = (* get hold of the variable value, either from local or global state *) - 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 + let var = get_var ~man st x in + let v = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_man man)) (fun x -> get ~man 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" 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 @@ -558,9 +558,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 st (adr: address): address = + let reachable_from_address ~man st (adr: address): address = if M.tracing then M.tracei "reachability" "Checking for %a" AD.pretty adr; - let res = reachable_from_value (Analyses.ask_of_ctx ctx) (get ~ctx st adr None) (AD.type_of adr) (AD.show adr) in + let res = reachable_from_value (Analyses.ask_of_man man) (get ~man st adr None) (AD.type_of adr) (AD.show adr) in if M.tracing then M.traceu "reachability" "Reachable addresses: %a" AD.pretty res; res @@ -568,7 +568,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 (st: store) (args: address list): address list = + let reachable_vars ~man (st: store) (args: address list): address list = if M.tracing then M.traceli "reachability" "Checking reachable arguments from [%a]!" (d_list ", " AD.pretty) args; let empty = AD.empty () in (* We begin looking at the parameters: *) @@ -581,7 +581,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 st var) acc in + AD.union (reachable_from_address ~man 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 @@ -590,7 +590,7 @@ struct if M.tracing then M.traceu "reachability" "All reachable vars: %a" AD.pretty !visited; List.map AD.singleton (AD.elements !visited) - let reachable_vars ~ctx st args = Timing.wrap "reachability" (reachable_vars ~ctx st) args + let reachable_vars ~man st args = Timing.wrap "reachability" (reachable_vars ~man st) args let drop_non_ptrs (st:CPA.t) : CPA.t = if CPA.is_top st then st else @@ -624,7 +624,7 @@ struct let drop_intervalSet = CPA.map (function Int x -> Int (ID.no_intervalSet x) | x -> x ) - let context ctx (fd: fundec) (st: store): store = + let context man (fd: fundec) (st: store): store = let f keep drop_fn (st: store) = if keep then st else { st with cpa = drop_fn st.cpa} in st |> (* Here earlyglobs only drops syntactic globals from the context and does not consider e.g. escaped globals. *) @@ -636,7 +636,7 @@ struct %> f (ContextUtil.should_keep ~isAttr:GobContext ~keepOption:"ana.base.context.interval_set" ~removeAttr:"base.no-interval_set" ~keepAttr:"base.interval_set" fd) drop_intervalSet - let reachable_top_pointers_types ctx (ps: AD.t) : Queries.TS.t = + let reachable_top_pointers_types man (ps: AD.t) : Queries.TS.t = let module TS = Queries.TS in let empty = AD.empty () in let reachable_from_address (adr: address) = @@ -662,7 +662,7 @@ struct | Address adrs when AD.is_top adrs -> (empty,TS.bot (), true) | Address adrs -> (adrs,TS.bot (), AD.may_be_unknown adrs) | Union (t,e) -> with_field (reachable_from_value e) t - | Array a -> reachable_from_value (ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) a (None, ValueDomain.ArrIdxDomain.top ())) + | Array a -> reachable_from_value (ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_man man)) a (None, ValueDomain.ArrIdxDomain.top ())) | Blob (e,_,_) -> reachable_from_value e | Struct s -> let join_tr (a1,t1,_) (a2,t2,_) = AD.join a1 a2, TS.join t1 t2, false in @@ -677,7 +677,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 ctx.local adr None) + reachable_from_value (get ~man man.local adr None) in let visited = ref empty in let work = ref ps in @@ -697,14 +697,14 @@ struct !collected (* The evaluation function as mutually recursive eval_lv & eval_rv *) - let rec eval_rv ~(ctx: _ ctx) (st: store) (exp:exp): value = + let rec eval_rv ~(man: _ man) (st: store) (exp:exp): value = if M.tracing then M.traceli "evalint" "base eval_rv %a" 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 st exp + eval_rv_ask_evalint ~man st exp in if M.tracing then M.traceu "evalint" "base eval_rv %a -> %a" d_exp exp VD.pretty r; r @@ -713,14 +713,14 @@ 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 st exp = - let eval_next () = eval_rv_no_ask_evalint ~ctx st exp in + and eval_rv_ask_evalint ~man st exp = + let eval_next () = eval_rv_no_ask_evalint ~man st exp in if M.tracing then M.traceli "evalint" "base eval_rv_ask_evalint %a" 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" d_exp exp; - let a = ctx.ask (Q.EvalInt exp) in (* through queries includes eval_next, so no (exponential) branching is necessary *) + let a = man.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" 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. *) @@ -737,24 +737,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 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_no_ask_evalint ~man st exp = + eval_rv_base ~man st exp (* just as alias, so query doesn't weirdly have to call eval_rv_base *) - and eval_rv_back_up ~ctx st exp = + and eval_rv_back_up ~man st exp = if get_bool "ana.base.eval.deep-query" then - eval_rv ~ctx st exp + eval_rv ~man 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 st exp (* bypass all queries *) + eval_rv_base ~man 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 (st: store) (exp:exp): value = + and eval_rv_base ~man (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" d_exp exp; let binop_remove_same_casts ~extra_is_safe ~e1 ~e2 ~t1 ~t2 ~c1 ~c2 = @@ -776,7 +776,7 @@ struct match constFold true exp with (* Integer literals *) (* seems like constFold already converts CChr to CInt *) - | Const (CChr x) -> eval_rv ~ctx st (Const (charConstToInt x)) (* char becomes int, see Cil doc/ISO C 6.4.4.4.10 *) + | Const (CChr x) -> eval_rv ~man 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 -> if M.tracing then M.tracel "casto" "CInt (%s, %a, %s)" (Z.to_string num) d_ikind ikind x | None -> ()); Int (ID.cast_to ikind (IntDomain.of_const (num,ikind,str))) @@ -792,21 +792,21 @@ struct | Const _ -> VD.top () (* Variables and address expressions *) | Lval lv -> - eval_rv_base_lval ~eval_lv ~ctx st exp lv + eval_rv_base_lval ~eval_lv ~man 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 ~ctx st e1 in - let a2 = eval_rv ~ctx st e2 in + let a1 = eval_rv ~man st e1 in + let a2 = eval_rv ~man st e2 in let extra_is_safe = - match evalbinop_base ~ctx op t1 a1 t2 a2 typ with + match evalbinop_base ~man op t1 a1 t2 a2 typ with | Int i -> ID.to_bool i = Some true | _ | exception IntDomain.IncompatibleIKinds _ -> false 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 st op ~e1 ~t1 ~e2 ~t2 typ + evalbinop ~man 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 *) @@ -839,8 +839,8 @@ struct let eqs_value: value option = let* eqs = split exp in let* (e, es) = find_common eqs in - 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 v = eval_rv ~man st e in (* value of common exp *) + let vs = List.map (eval_rv ~man st) es in (* values of other sides *) let ik = Cilfacade.get_ikind typ in match v with | Address a -> @@ -882,25 +882,25 @@ struct in begin match eqs_value with | Some x -> x - | None -> evalbinop ~ctx st LOr ~e1 ~e2 typ (* fallback to general case *) + | None -> evalbinop ~man st LOr ~e1 ~e2 typ (* fallback to general case *) end | BinOp (op,e1,e2,typ) -> - evalbinop ~ctx st op ~e1 ~e2 typ + evalbinop ~man st op ~e1 ~e2 typ (* Unary operators *) | UnOp (op,arg1,typ) -> - let a1 = eval_rv ~ctx st arg1 in + let a1 = eval_rv ~man st arg1 in evalunop op typ a1 (* The &-operator: we create the address abstract element *) - | AddrOf lval -> Address (eval_lv ~ctx st lval) + | AddrOf lval -> Address (eval_lv ~man 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 ()) Z.zero, `NoOffset) in let array_start = add_offset_varinfo array_ofs in - 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? *) + Address (AD.map array_start (eval_lv ~man st lval)) + | CastE (t, Const (CStr (x,e))) -> (* VD.top () *) eval_rv ~man st (Const (CStr (x,e))) (* TODO safe? *) | CastE (t, exp) -> - (let v = eval_rv ~ctx st exp in + (let v = eval_rv ~man st exp in try VD.cast ~torg:(Cilfacade.typeOf exp) t v with Cilfacade.TypeOfError _ -> @@ -919,10 +919,10 @@ struct if M.tracing then M.traceu "evalint" "base eval_rv_base %a -> %a" d_exp exp VD.pretty r; r - and eval_rv_base_lval ~eval_lv ~ctx (st: store) (exp: exp) (lv: lval): value = + and eval_rv_base_lval ~eval_lv ~man (st: store) (exp: exp) (lv: lval): value = match lv with - | (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)) *) + | (Var v, ofs) -> get ~man st (eval_lv ~man st (Var v, ofs)) (Some exp) + (* | Lval (Mem e, ofs) -> get ~man st (eval_lv ~man (Mem e, ofs)) *) | (Mem e, ofs) -> (*if M.tracing then M.tracel "cast" "Deref: lval: %a" d_plainlval lv;*) let rec contains_vla (t:typ) = match t with @@ -934,7 +934,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 st b in (* abstract base addresses *) + let p = eval_lv ~man 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 = @@ -966,35 +966,35 @@ struct let lookup_with_offs addr = let v = (* abstract base value *) if cast_ok addr then - get ~ctx ~top:(VD.top_value t) st (AD.singleton addr) (Some exp) (* downcasts are safe *) + get ~man ~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!" 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 st ofs) (Some exp) None t in (* handle offset *) + let v' = VD.eval_offset (Queries.to_value_domain_ask (Analyses.ask_of_man man)) (fun x -> get ~man st x (Some exp)) v' (convert_offset ~man 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 (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 + and evalbinop ~man (st: store) (op: binop) ~(e1:exp) ?(t1:typ option) ~(e2:exp) ?(t2:typ option) (t:typ): value = + evalbinop_mustbeequal ~man st op ~e1 ?t1 ~e2 ?t2 t (** 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 = + and evalbinop_mustbeequal ~man (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 st e1 in - let a2 = eval_rv ~ctx st e2 in + let a1 = eval_rv ~man st e1 in + let a2 = eval_rv ~man 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 ~ctx op t1 a1 t2 a2 t in + let r = evalbinop_base ~man 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 (Analyses.ask_of_ctx ctx) e1 e2 in + let r = Q.must_be_equal (Analyses.ask_of_man man) e1 e2 in if M.tracing then M.tracel "query" "MustBeEqual (%a, %a) = %b" d_exp e1 d_exp e2 r; r in @@ -1023,48 +1023,48 @@ struct (* A hackish evaluation of expressions that should immediately yield an * address, e.g. when calling functions. *) - and eval_fv ~ctx st (exp:exp): AD.t = + and eval_fv ~man st (exp:exp): AD.t = match exp with - | Lval lval -> eval_lv ~ctx st lval - | _ -> eval_tv ~ctx st exp + | Lval lval -> eval_lv ~man st lval + | _ -> eval_tv ~man st exp (* Used also for thread creation: *) - and eval_tv ~ctx st (exp:exp): AD.t = - match eval_rv ~ctx st exp with + and eval_tv ~man st (exp:exp): AD.t = + match eval_rv ~man st exp with | Address x -> x | _ -> failwith "Problems evaluating expression to function calls!" - and eval_int ~ctx st exp = - match eval_rv ~ctx st exp with + and eval_int ~man st exp = + match eval_rv ~man 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 (st: store) (ofs: offset) = + and convert_offset ~man (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 st ofs) + | Field (fld, ofs) -> `Field (fld, convert_offset ~man st ofs) | Index (exp, ofs) when CilType.Exp.equal exp (Lazy.force Offset.Index.Exp.any) -> (* special offset added by convertToQueryLval *) - `Index (IdxDom.top (), convert_offset ~ctx st ofs) + `Index (IdxDom.top (), convert_offset ~man st ofs) | Index (exp, 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) + match eval_rv ~man st exp with + | Int i -> `Index (iDtoIdx i, convert_offset ~man st ofs) + | Address add -> `Index (AD.to_int add, convert_offset ~man st ofs) + | Top -> `Index (IdxDom.top (), convert_offset ~man st ofs) + | Bot -> `Index (IdxDom.bot (), convert_offset ~man st ofs) | _ -> failwith "Index not an integer value" (* Evaluation of lvalues to our abstract address domain. *) - and eval_lv ~ctx st (lval:lval): AD.t = + and eval_lv ~man 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 st ofs)) + AD.singleton (Addr.of_mval (x, convert_offset ~man 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 st n with + match eval_rv ~man st n with | Address adr -> ( if AD.is_null adr then ( @@ -1077,14 +1077,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 (Analyses.ask_of_ctx ctx) v) + | AD.Addr.Addr (v, _) -> not (CPA.mem v st.cpa) && not (is_global (Analyses.ask_of_man man) 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 st ofs)) adr + AD.map (add_offset_varinfo (convert_offset ~man st ofs)) adr | _ -> M.debug ~category:Analyzer "Failed evaluating %a to lvalue" d_lval lval; AD.unknown_ptr @@ -1096,17 +1096,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 ~ctx (st: store) (exp:exp): value = + let eval_rv ~man (st: store) (exp:exp): value = try - let r = eval_rv ~ctx st exp in + let r = eval_rv ~man st exp in if M.tracing then M.tracel "eval" "eval_rv %a = %a" 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 st e = + let query_evalint ~man st e = if M.tracing then M.traceli "evalint" "base query_evalint %a" d_exp e; - let r = match eval_rv_no_ask_evalint ~ctx st e with + let r = match eval_rv_no_ask_evalint ~man 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 *) @@ -1116,28 +1116,28 @@ struct if M.tracing then M.traceu "evalint" "base query_evalint %a -> %a" d_exp e Queries.ID.pretty r; r - (* Evaluate an expression containing only locals. This is needed for smart joining the partitioned arrays where ctx is not accessible. *) + (* Evaluate an expression containing only locals. This is needed for smart joining the partitioned arrays where man is not accessible. *) (* This will yield `Top for expressions containing any access to globals, and does not make use of the query system. *) (* Wherever possible, don't use this but the query system or normal eval_rv instead. *) let eval_exp st (exp:exp) = - (* Since ctx is not available here, we need to make some adjustments *) + (* Since man is not available here, we need to make some adjustments *) let rec query: type a. Queries.Set.t -> a Queries.t -> a Queries.result = fun asked q -> let anyq = Queries.Any q in if Queries.Set.mem anyq asked then Queries.Result.top q (* query cycle *) else ( match q with - | EvalInt e -> query_evalint ~ctx:(ctx' (Queries.Set.add anyq asked)) st e (* mimic EvalInt query since eval_rv needs it *) + | EvalInt e -> query_evalint ~man:(man' (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' asked = + and man' 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 - ; control_context = (fun () -> ctx_failwith "Base eval_exp has no context.") - ; context = (fun () -> ctx_failwith "Base eval_exp has no context.") + ; control_context = (fun () -> man_failwith "Base eval_exp has no context.") + ; context = (fun () -> man_failwith "Base eval_exp has no context.") ; edge = MyCFG.Skip ; local = st ; global = gs @@ -1146,12 +1146,12 @@ struct ; sideg = (fun g d -> failwith "Base eval_exp trying to side effect.") } in - match eval_rv ~ctx:(ctx' Queries.Set.empty) st exp with + match eval_rv ~man:(man' Queries.Set.empty) st exp with | Int x -> ValueDomain.ID.to_int x | _ -> None - let eval_funvar ctx fval: Queries.AD.t = - let fp = eval_fv ~ctx ctx.local fval in + let eval_funvar man fval: Queries.AD.t = + let fp = eval_fv ~man man.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 @@ -1162,36 +1162,36 @@ struct (** Evaluate expression as address. Avoids expensive Apron EvalInt if the Int result would be useless to us anyway. *) - let eval_rv_address ~ctx st e = + let eval_rv_address ~man 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 st e + eval_rv ~man st e (* interpreter end *) - let is_not_alloc_var ctx v = - not (ctx.ask (Queries.IsAllocVar v)) + let is_not_alloc_var man v = + not (man.ask (Queries.IsAllocVar v)) - let is_not_heap_alloc_var ctx v = - let is_alloc = ctx.ask (Queries.IsAllocVar v) in - not is_alloc || (is_alloc && not (ctx.ask (Queries.IsHeapVar v))) + let is_not_heap_alloc_var man v = + let is_alloc = man.ask (Queries.IsAllocVar v) in + not is_alloc || (is_alloc && not (man.ask (Queries.IsHeapVar v))) - let query_invariant ctx context = + let query_invariant man context = let keep_local = GobConfig.get_bool "ana.base.invariant.local" in let keep_global = GobConfig.get_bool "ana.base.invariant.global" in - let cpa = ctx.local.BaseDomain.cpa in - let ask = Analyses.ask_of_ctx ctx in + let cpa = man.local.BaseDomain.cpa in + let ask = Analyses.ask_of_man man in let module Arg = struct let context = context - let scope = Node.find_fundec ctx.node - let find v = get_var ~ctx ctx.local v + let scope = Node.find_fundec man.node + let find v = get_var ~man man.local v end in let module I = ValueDomain.ValueInvariant (Arg) in @@ -1226,7 +1226,7 @@ struct in let priv_vars = if keep_global then - Priv.invariant_vars ask (priv_getg ctx.global) ctx.local + Priv.invariant_vars ask (priv_getg man.global) man.local else [] in @@ -1258,24 +1258,24 @@ struct ) context.lvals Invariant.none ) - let query_invariant ctx context = + let query_invariant man context = if GobConfig.get_bool "ana.base.invariant.enabled" then - query_invariant ctx context + query_invariant man context else Invariant.none - let query_invariant_global ctx g = + let query_invariant_global man g = if GobConfig.get_bool "ana.base.invariant.enabled" && GobConfig.get_bool "ana.base.invariant.global" then ( (* Currently these global invariants are only sound with earlyglobs enabled for both single- and multi-threaded programs. Otherwise, the values of globals in single-threaded mode are not accounted for. They are also made sound without earlyglobs using the multithreaded mode ghost variable. *) match g with | `Left g' -> (* priv *) - let inv = Priv.invariant_global (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) g' in + let inv = Priv.invariant_global (Analyses.ask_of_man man) (priv_getg man.global) g' in if get_bool "exp.earlyglobs" then inv else ( - if ctx.ask (GhostVarAvailable Multithreaded) then ( + if man.ask (GhostVarAvailable Multithreaded) then ( let var = WitnessGhost.to_varinfo Multithreaded in Invariant.(of_exp (UnOp (LNot, Lval (GoblintCil.var var), GoblintCil.intType)) || inv) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) ) @@ -1298,7 +1298,7 @@ struct For now we return true if the expression contains a shift left. *) (* TODO: deduplicate https://github.com/goblint/analyzer/pull/1297#discussion_r1477804502 *) - let rec exp_may_signed_overflow ctx exp = + let rec exp_may_signed_overflow man exp = let res = match Cilfacade.get_ikind_exp exp with | exception (Cilfacade.TypeOfError _) (* Cilfacade.typeOf *) | exception (Invalid_argument _) -> (* get_ikind *) @@ -1306,7 +1306,7 @@ struct | ik -> let checkDiv e1 e2 = let binop = (GobOption.map2 Z.div )in - match ctx.ask (EvalInt e1), ctx.ask (EvalInt e2) with + match man.ask (EvalInt e1), man.ask (EvalInt e2) with | `Bot, _ -> false | _, `Bot -> false | `Lifted i1, `Lifted i2 -> @@ -1325,7 +1325,7 @@ struct | _ -> true )) | _ -> true in let checkBinop e1 e2 binop = - match ctx.ask (EvalInt e1), ctx.ask (EvalInt e2) with + match man.ask (EvalInt e1), man.ask (EvalInt e2) with | `Bot, _ -> false | _, `Bot -> false | `Lifted i1, `Lifted i2 -> @@ -1340,7 +1340,7 @@ struct | _ -> true) | _ -> true in let checkPredicate e pred = - match ctx.ask (EvalInt e) with + match man.ask (EvalInt e) with | `Bot -> false | `Lifted i -> (let (min_ik, _) = IntDomain.Size.range ik in @@ -1360,7 +1360,7 @@ struct | Imag e | SizeOfE e | AlignOfE e - | CastE (_, e) -> exp_may_signed_overflow ctx e + | CastE (_, e) -> exp_may_signed_overflow man e | UnOp (unop, e, _) -> (* check if the current operation causes a signed overflow *) begin match unop with @@ -1370,7 +1370,7 @@ struct | BNot|LNot -> false end (* look for overflow in subexpression *) - || exp_may_signed_overflow ctx e + || exp_may_signed_overflow man e | BinOp (binop, e1, e2, _) -> (* check if the current operation causes a signed overflow *) (Cil.isSigned ik && begin match binop with @@ -1385,38 +1385,38 @@ struct (* Shiftlt can cause overflow and also undefined behaviour in case the second operand is non-positive*) | Shiftlt -> true end) (* look for overflow in subexpression *) - || exp_may_signed_overflow ctx e1 || exp_may_signed_overflow ctx e2 + || exp_may_signed_overflow man e1 || exp_may_signed_overflow man e2 | Question (e1, e2, e3, _) -> (* does not result in overflow in C *) - exp_may_signed_overflow ctx e1 || exp_may_signed_overflow ctx e2 || exp_may_signed_overflow ctx e3 + exp_may_signed_overflow man e1 || exp_may_signed_overflow man e2 || exp_may_signed_overflow man e3 | Lval lval | AddrOf lval - | StartOf lval -> lval_may_signed_overflow ctx lval + | StartOf lval -> lval_may_signed_overflow man lval in if M.tracing then M.trace "signed_overflow" "base exp_may_signed_overflow %a. Result = %b" d_plainexp exp res; res - and lval_may_signed_overflow ctx (lval : lval) = + and lval_may_signed_overflow man (lval : lval) = let (host, offset) = lval in let host_may_signed_overflow = function | Var v -> false - | Mem e -> exp_may_signed_overflow ctx e + | Mem e -> exp_may_signed_overflow man e in let rec offset_may_signed_overflow = function | NoOffset -> false - | Index (e, o) -> exp_may_signed_overflow ctx e || offset_may_signed_overflow o + | Index (e, o) -> exp_may_signed_overflow man e || offset_may_signed_overflow o | Field (f, o) -> offset_may_signed_overflow o in host_may_signed_overflow host || offset_may_signed_overflow offset - let query ctx (type a) (q: a Q.t): a Q.result = + let query man (type a) (q: a Q.t): a Q.result = match q with | Q.EvalFunvar e -> - eval_funvar ctx e + eval_funvar man e | Q.EvalJumpBuf e -> - begin match eval_rv_address ~ctx ctx.local e with + begin match eval_rv_address ~man man.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; - begin match get ~ctx ~top:(VD.bot ()) ctx.local jmp_buf None with + begin match get ~man ~top:(VD.bot ()) man.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; @@ -1433,12 +1433,12 @@ struct JmpBufDomain.JmpBufSet.top () end | Q.EvalInt e -> - query_evalint ~ctx ctx.local e + query_evalint ~man man.local e | Q.EvalMutexAttr e -> begin - match eval_rv_address ~ctx ctx.local e with + match eval_rv_address ~man man.local e with | Address a -> let default = `Lifted MutexAttrDomain.MutexKind.NonRec in (* Goblint assumption *) - begin match get ~ctx ~top:(MutexAttr default) ctx.local a None with (* ~top corresponds to default NULL with assume_top *) + begin match get ~man ~top:(MutexAttr default) man.local a None with (* ~top corresponds to default NULL with assume_top *) | MutexAttr a -> a | Bot -> default (* corresponds to default NULL with assume_none *) | _ -> MutexAttrDomain.top () @@ -1446,7 +1446,7 @@ struct | _ -> MutexAttrDomain.top () end | Q.EvalLength e -> begin - match eval_rv_address ~ctx ctx.local e with + match eval_rv_address ~man man.local e with | Address a -> let slen = Seq.map String.length (List.to_seq (AD.to_string a)) in let lenOf = function @@ -1461,16 +1461,16 @@ struct | _ -> Queries.Result.top q end | Q.EvalValue e -> - eval_rv ~ctx ctx.local e + eval_rv ~man man.local e | Q.BlobSize {exp = e; base_address = from_base_addr} -> begin - let p = eval_rv_address ~ctx ctx.local e in + let p = eval_rv_address ~man man.local e in (* ignore @@ printf "BlobSize %a MayPointTo %a\n" d_plainexp e VD.pretty p; *) match p with | Address a -> (* If there's a non-heap var or an offset in the lval set, we answer with bottom *) (* If we're asking for the BlobSize from the base address, then don't check for offsets => we want to avoid getting bot *) if AD.exists (function - | Addr (v,o) -> is_not_alloc_var ctx v || (if not from_base_addr then o <> `NoOffset else false) + | Addr (v,o) -> is_not_alloc_var man v || (if not from_base_addr then o <> `NoOffset else false) | _ -> false) a then Queries.Result.bot q else ( @@ -1482,12 +1482,12 @@ struct else a in - let r = get ~ctx ~full:true ctx.local a None in + let r = get ~man ~full:true man.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 ()) Z.zero)) with + (match ValueDomain.CArrays.get (Queries.to_value_domain_ask (Analyses.ask_of_man man)) a (None, (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) Z.zero)) with | Blob (_,s,_) -> `Lifted s | _ -> Queries.Result.top q ) @@ -1497,14 +1497,14 @@ struct | _ -> Queries.Result.top q end | Q.MayPointTo e -> begin - match eval_rv_address ~ctx ctx.local e with + match eval_rv_address ~man man.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 ctx.local e in + let v = eval_rv ~man man.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 @@ -1512,12 +1512,12 @@ struct | _ -> Queries.Result.top q end | Q.ReachableFrom e -> begin - match eval_rv_address ~ctx ctx.local e with + match eval_rv_address ~man man.local e with | Top -> Queries.Result.top q | 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 ctx.local [a'] in + let addrs = reachable_vars ~man man.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 *) @@ -1532,17 +1532,17 @@ struct | _ -> AD.empty () end | Q.ReachableUkTypes e -> begin - match eval_rv_address ~ctx ctx.local e with + match eval_rv_address ~man man.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 -> Q.TS.top () | Address a -> - reachable_top_pointers_types ctx a + reachable_top_pointers_types man a | _ -> Q.TS.empty () end | Q.EvalStr e -> begin - match eval_rv_address ~ctx ctx.local e with + match eval_rv_address ~man man.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)) @@ -1568,16 +1568,16 @@ struct (* ignore @@ printf "EvalStr Unknown: %a -> %s\n" d_plainexp e (VD.short 80 x); *) Queries.Result.top q end - | Q.IsMultiple v -> WeakUpdates.mem v ctx.local.weak || + | Q.IsMultiple v -> WeakUpdates.mem v man.local.weak || (hasAttribute "thread" v.vattr && v.vaddrof) (* thread-local variables if they have their address taken, as one could then compare several such variables *) | Q.IterSysVars (vq, vf) -> let vf' x = vf (Obj.repr (V.priv x)) in - Priv.iter_sys_vars (priv_getg ctx.global) vq vf' - | Q.Invariant context -> query_invariant ctx context + Priv.iter_sys_vars (priv_getg man.global) vq vf' + | Q.Invariant context -> query_invariant man context | Q.InvariantGlobal g -> let g: V.t = Obj.obj g in - query_invariant_global ctx g - | Q.MaySignedOverflow e -> (let res = exp_may_signed_overflow ctx e in + query_invariant_global man g + | Q.MaySignedOverflow e -> (let res = exp_may_signed_overflow man e in if M.tracing then M.trace "signed_overflow" "base exp_may_signed_overflow %a. Result = %b" d_plainexp e res; res ) | _ -> Q.Result.top q @@ -1610,7 +1610,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 ~(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 ~(man: _ man) ?(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" 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 *) @@ -1623,12 +1623,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 ask = Analyses.ask_of_ctx ctx in + let ask = Analyses.ask_of_man man in let cil_offset = Offs.to_cil_offset offs in let t = match t_override with | Some t -> t | None -> - if ctx.ask (Q.IsAllocVar x) then + if man.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 @@ -1670,18 +1670,18 @@ struct * side-effects here, but the code still distinguishes these cases. *) 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' ..." x.vname; - let priv_getg = priv_getg ctx.global in + let priv_getg = priv_getg man.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 (ctx.ask (IsAllocVar x)) && offs = `NoOffset then begin + let old_value = if not invariant && Cil.isIntegralType x.vtype && not (man.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 in let new_value = update_offset old_value in if M.tracing then M.tracel "set" "update_offset %a -> %a" VD.pretty old_value VD.pretty new_value; - let r = Priv.write_global ~invariant ask priv_getg (priv_sideg ctx.sideg) st x new_value in + let r = Priv.write_global ~invariant ask priv_getg (priv_sideg man.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" x.vname D.pretty r; r end else begin @@ -1725,11 +1725,11 @@ struct VD.affect_move (Queries.to_value_domain_ask a) v x (fun x -> None) else let patched_ask = - (* The usual recursion trick for ctx. *) - (* Must change ctx used by ask to also use new st (not ctx.local), otherwise recursive EvalInt queries use outdated state. *) + (* The usual recursion trick for man. *) + (* Must change man used by ask to also use new st (not man.local), otherwise recursive EvalInt queries use outdated state. *) (* Note: query is just called on base, but not any other analyses. Potentially imprecise, but seems to be sufficient for now. *) - let rec ctx' asked = - { ctx with + let rec man' asked = + { man with ask = (fun (type a) (q: a Queries.t) -> query' asked q) ; local = st } @@ -1739,10 +1739,10 @@ struct Queries.Result.top q (* query cycle *) else ( let asked' = Queries.Set.add anyq asked in - query (ctx' asked') q + query (man' asked') q ) in - Analyses.ask_of_ctx (ctx' Queries.Set.empty) + Analyses.ask_of_man (man' Queries.Set.empty) in let moved_by = fun x -> Some 0 in (* this is ok, the information is not provided if it *) (* TODO: why does affect_move need general ask (of any query) instead of eval_exp? *) @@ -1781,10 +1781,10 @@ struct (* if M.tracing then M.tracel "set" ~var:firstvar "set got an exception '%s'" x; *) M.info ~category:Unsound "Assignment to unknown address, assuming no write happened."; st - let set_many ~ctx (st: store) lval_value_list: store = + let set_many ~man (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 + set ~man acc lval typ value in (* And fold over the list starting from the store turned wstore: *) List.fold_left f st lval_value_list @@ -1836,12 +1836,12 @@ struct let convert_offset = convert_offset let get_var = get_var - let get ~ctx st addrs exp = get ~ctx st addrs exp - let set ~ctx st lval lval_type ?lval_raw value = set ~ctx ~invariant:true st lval lval_type ?lval_raw value + let get ~man st addrs exp = get ~man st addrs exp + let set ~man st lval lval_type ?lval_raw value = set ~man ~invariant:true st lval lval_type ?lval_raw value 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 ~man st exp lval = eval_rv ~man st (Lval lval) let id_meet_down ~old ~c = ID.meet old c let fd_meet_down ~old ~c = FD.meet old c @@ -1854,17 +1854,17 @@ struct let invariant = Invariant.invariant - let set_savetop ~ctx ?lval_raw ?rval_raw st adr lval_t v : store = + let set_savetop ~man ?lval_raw ?rval_raw st adr lval_t v : store = if M.tracing then M.tracel "set" "savetop %a %a %a" 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 - | v -> set ~ctx st adr lval_t v ?lval_raw ?rval_raw + | Top -> set ~man st adr lval_t (VD.top_value (AD.type_of adr)) ?lval_raw ?rval_raw + | v -> set ~man st adr lval_t v ?lval_raw ?rval_raw (************************************************************************** * Simple defs for the transfer functions **************************************************************************) - let assign ctx (lval:lval) (rval:exp):store = + let assign man (lval:lval) (rval:exp):store = let lval_t = Cilfacade.typeOfLval lval in let char_array_hack () = let rec split_offset = function @@ -1901,15 +1901,15 @@ struct | _ -> () in char_array_hack (); - let rval_val = eval_rv ~ctx ctx.local rval in + let rval_val = eval_rv ~man man.local rval in let rval_val = VD.mark_jmpbufs_as_copied rval_val in - let lval_val = eval_lv ~ctx ctx.local lval in + let lval_val = eval_lv ~man man.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 = let not_local x = match Addr.to_var_may x with - | Some x -> is_global (Analyses.ask_of_ctx ctx) x + | Some x -> is_global (Analyses.ask_of_man man) x | None -> x = Addr.UnknownPtr in AD.is_top xs || AD.exists not_local xs @@ -1923,7 +1923,7 @@ struct in let vars = AD.fold find_fps adrs [] in (* filter_map from AD to list *) let funs = Seq.filter (fun x -> isFunctionType x.vtype)@@ List.to_seq vars in - Seq.iter (fun x -> ctx.spawn None x []) funs + Seq.iter (fun x -> man.spawn None x []) funs | _ -> () ); match lval with (* this section ensure global variables contain bottom values of the proper type before setting them *) @@ -1935,7 +1935,7 @@ struct assert (offs = NoOffset); VD.Bot end else - eval_rv_keep_bot ~ctx ctx.local (Lval (Var v, NoOffset)) + eval_rv_keep_bot ~man man.local (Lval (Var v, NoOffset)) in begin match current_val with | Bot -> (* current value is VD Bot *) @@ -1944,29 +1944,29 @@ struct let t = v.vtype in 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): %a" d_plaintype t 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 ctx.local (AD.of_var v) lval_t nv ~lval_raw:lval ~rval_raw:rval (* set top-level variable to updated value *) + let nv = VD.update_offset (Queries.to_value_domain_ask (Analyses.ask_of_man man)) iv offs rval_val (Some (Lval lval)) lval t in (* do desired update to value *) + set_savetop ~man man.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 lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~man man.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval end | _ -> - set_savetop ~ctx ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~man man.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval end | _ -> - set_savetop ~ctx ctx.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval + set_savetop ~man man.local lval_val lval_t rval_val ~lval_raw:lval ~rval_raw:rval - let branch ctx (exp:exp) (tv:bool) : store = - let valu = eval_rv ~ctx ctx.local exp in + let branch man (exp:exp) (tv:bool) : store = + let valu = eval_rv ~man man.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" 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" d_exp exp Queries.ES.pretty (ctx.ask (Queries.CondVars exp)); + let res = invariant man man.local exp tv in + if M.tracing then M.tracec "branch" "EqualSet result for expression %a is %a" d_exp exp Queries.ES.pretty (man.ask (Queries.EqualSet exp)); + if M.tracing then M.tracec "branch" "CondVars result for expression %a is %a" d_exp exp Queries.ES.pretty (man.ask (Queries.CondVars exp)); if M.tracing then M.traceu "branch" "Invariant enforced!"; - match ctx.ask (Queries.CondVars exp) with + match man.ask (Queries.CondVars exp) with | s when Queries.ES.cardinal s = 1 -> let e = Queries.ES.choose s in - invariant ctx res e tv + invariant man res e tv | _ -> res in if M.tracing then M.traceli "branch" ~subsys:["invariant"] "Evaluating branch for expression %a with value %a" d_exp exp VD.pretty valu; @@ -2001,28 +2001,28 @@ struct For example, 50-juliet/08-CWE570_Expression_Always_False__02. *) refine () - let body ctx f = + let body man f = (* First we create a variable-initvalue pair for each variable *) 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 ctx.local inits + set_many ~man man.local inits - let return ctx exp fundec: store = + let return man 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 + let ask = Analyses.ask_of_man man in + let st: store = man.local in match fundec.svar.vname with | "__goblint_dummy_init" -> if M.tracing then M.trace "init" "dummy init: %a" D.pretty st; - publish_all ctx `Init; + publish_all man `Init; (* otherfun uses __goblint_dummy_init, where we can properly side effect global initialization *) (* TODO: move into sync `Init *) - Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st + Priv.enter_multithreaded ask (priv_getg man.global) (priv_sideg man.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 ask) ctx.local locals in + let nst_part = rem_many_partitioning (Queries.to_value_domain_ask ask) man.local locals in let nst: store = rem_many ask nst_part locals in match exp with | None -> nst @@ -2031,65 +2031,65 @@ 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 st' = set ~ctx ~t_override nst (return_var ()) t_override rv in + let rv = eval_rv ~man man.local exp in + let st' = set ~man ~t_override nst (return_var ()) t_override rv in 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 ask (priv_getg ctx.global) (priv_sideg ctx.sideg) tid st' + man.sideg (V.thread tid) (G.create_thread rv); + Priv.thread_return ask (priv_getg man.global) (priv_sideg man.sideg) tid st' | _ -> st' - let vdecl ctx (v:varinfo) = + let vdecl man (v:varinfo) = if not (Cil.isArrayType v.vtype) then - ctx.local + man.local else - 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 + let lval = eval_lv ~man man.local (Var v, NoOffset) in + let current_value = eval_rv ~man man.local (Lval (Var v, NoOffset)) in + let new_value = VD.update_array_lengths (eval_rv ~man man.local) current_value v.vtype in + set ~man man.local lval v.vtype new_value (************************************************************************** * Function calls **************************************************************************) (** 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 collect_funargs ~man ?(warn=false) (st:store) (exps: exp list) = + let ask = Analyses.ask_of_man man in let do_exp e = - 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] + let immediately_reachable = reachable_from_value ask (eval_rv ~man st e) (Cilfacade.typeOf e) (CilType.Exp.show e) in + reachable_vars ~man st [immediately_reachable] in List.concat_map do_exp exps - let collect_invalidate ~deep ~ctx ?(warn=false) (st:store) (exps: exp list) = + let collect_invalidate ~deep ~man ?(warn=false) (st:store) (exps: exp list) = if deep then - collect_funargs ~ctx ~warn st exps + collect_funargs ~man ~warn st exps else ( - let mpt e = match eval_rv_address ~ctx st e with + let mpt e = match eval_rv_address ~man st e with | Address a -> AD.remove NullPtr a | _ -> AD.empty () in List.map mpt exps ) - let invalidate ~(must: bool) ?(deep=true) ~ctx (st:store) (exps: exp list): store = + let invalidate ~(must: bool) ?(deep=true) ~man (st:store) (exps: exp list): store = if M.tracing && exps <> [] then M.tracel "invalidate" "Will invalidate expressions [%a]" (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 invalidate_address st a = let t = try AD.type_of a with Not_found -> voidType in (* TODO: why is this called with empty a to begin with? *) - 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 (Analyses.ask_of_ctx ctx)) t v in + let v = get ~man 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 (Analyses.ask_of_man man)) t v in (a, t, nv) in (* 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 st exps in + let args = collect_invalidate ~deep ~man ~warn:true st exps in List.map (invalidate_address st) args in let invalids = invalidate_exp exps in @@ -2104,7 +2104,7 @@ struct ); (* copied from set_many *) let f (acc: store) ((lval:AD.t),(typ:Cil.typ),(value:value)): store = - let acc' = set ~ctx acc lval typ value in + let acc' = set ~man acc lval typ value in if must then acc' else @@ -2113,11 +2113,11 @@ struct List.fold_left f st invalids' - 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 + let make_entry ?(thread=false) (man:(D.t, G.t, C.t, V.t) Analyses.man) fundec args: D.t = + let ask = Analyses.ask_of_man man in + let st: store = man.local in (* Evaluate the arguments. *) - let vals = List.map (eval_rv ~ctx st) args in + let vals = List.map (eval_rv ~man st) args in (* generate the entry states *) (* If we need the globals, add them *) (* TODO: make this is_private PrivParam dependent? PerMutexOplusPriv should keep *) @@ -2128,12 +2128,12 @@ struct 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 ask) then - ignore (Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st); + ignore (Priv.enter_multithreaded ask (priv_getg man.global) (priv_sideg man.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 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 = if !earlyglobs || ThreadFlag.is_multi man.ask then CPA.filter (fun k v -> is_private man.ask man.local k) globals else globals in *) let new_cpa = globals in {st with cpa = new_cpa} in @@ -2142,7 +2142,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 st (get_ptrs vals)) in + let reachable = List.concat_map AD.to_var_may (reachable_vars ~man 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 @@ -2156,12 +2156,12 @@ struct let new_weak = WeakUpdates.join st.weak (WeakUpdates.of_list reachable_other_copies) in {st' with cpa = new_cpa; weak = new_weak} - let enter ctx lval fn args : (D.t * D.t) list = - [ctx.local, make_entry ctx fn args] + let enter man lval fn args : (D.t * D.t) list = + [man.local, make_entry man fn args] - let forkfun (ctx:(D.t, G.t, C.t, V.t) Analyses.ctx) (lv: lval option) (f: varinfo) (args: exp list) : (lval option * varinfo * exp list * bool) list = + let forkfun (man:(D.t, G.t, C.t, V.t) Analyses.man) (lv: lval option) (f: varinfo) (args: exp list) : (lval option * varinfo * exp list * bool) list = let create_thread ~multiple lval arg v = try (* try to get function declaration *) @@ -2192,9 +2192,9 @@ struct (* handling thread creations *) | ThreadCreate { thread = id; start_routine = start; arg = ptc_arg; multiple }, _ -> begin (* extra sync so that we do not analyze new threads with bottom global invariant *) - publish_all ctx `Thread; + publish_all man `Thread; (* Collect the threads. *) - let start_addr = eval_tv ~ctx ctx.local start in + let start_addr = eval_tv ~man man.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 @@ -2207,23 +2207,23 @@ struct | _, _ -> 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 ctx.local shallow_args in - let deep_flist = collect_invalidate ~deep:true ~ctx ctx.local deep_args in + let shallow_flist = collect_invalidate ~deep:false ~man man.local shallow_args in + let deep_flist = collect_invalidate ~deep:true ~man man.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; List.filter_map (create_thread ~multiple:true None None) addrs - let assert_fn ctx e refine = + let assert_fn man 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 ctx.local e true in + if not refine then man.local else begin + let newst = invariant man man.local e true in (* if check_assert e newst <> `Lifted true then M.warn ~category:Assert ~msg:("Invariant \"" ^ expr ^ "\" does not stick.") (); *) newst end - let special_unknown_invalidate ctx f args = + let special_unknown_invalidate man 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 @@ -2244,19 +2244,19 @@ struct in (* TODO: what about escaped local variables? *) (* invalidate arguments and non-static globals for unknown functions *) - let st' = invalidate ~must:false ~deep:false ~ctx ctx.local shallow_addrs in - invalidate ~must:false ~deep:true ~ctx st' deep_addrs + let st' = invalidate ~must:false ~deep:false ~man man.local shallow_addrs in + invalidate ~must:false ~deep:true ~man st' deep_addrs - let check_invalid_mem_dealloc ctx special_fn ptr = + let check_invalid_mem_dealloc man special_fn ptr = let has_non_heap_var = AD.exists (function - | Addr (v,_) -> is_not_heap_alloc_var ctx v + | Addr (v,_) -> is_not_heap_alloc_var man v | _ -> false) in let has_non_zero_offset = AD.exists (function | Addr (_,o) -> Offs.cmp_zero_offset o <> `MustZero | _ -> false) in - match eval_rv_address ~ctx ctx.local ptr with + match eval_rv_address ~man man.local ptr with | Address a -> if AD.is_top a then ( AnalysisStateUtil.set_mem_safety_flag InvalidFree; @@ -2272,16 +2272,16 @@ struct AnalysisStateUtil.set_mem_safety_flag InvalidFree; M.warn ~category:(Behavior (Undefined InvalidMemoryDeallocation)) ~tags:[CWE 590] "Pointer %a in function %s doesn't evaluate to a valid address. Invalid memory deallocation may occur" d_exp ptr special_fn.vname - let points_to_heap_only ctx ptr = - match ctx.ask (Queries.MayPointTo ptr) with + let points_to_heap_only man ptr = + match man.ask (Queries.MayPointTo ptr) with | a when not (Queries.AD.is_top a)-> Queries.AD.for_all (function - | Addr (v, _) -> ctx.ask (Queries.IsHeapVar v) + | Addr (v, _) -> man.ask (Queries.IsHeapVar v) | _ -> false ) a | _ -> false - let get_size_of_ptr_target ctx ptr = + let get_size_of_ptr_target man ptr = let intdom_of_int x = ID.of_int (Cilfacade.ptrdiff_ikind ()) (Z.of_int x) in @@ -2289,11 +2289,11 @@ struct let typ_size_in_bytes = (bitsSizeOf typ) / 8 in intdom_of_int typ_size_in_bytes in - if points_to_heap_only ctx ptr then + if points_to_heap_only man ptr then (* Ask for BlobSize from the base address (the second component being set to true) in order to avoid BlobSize giving us bot *) - ctx.ask (Queries.BlobSize {exp = ptr; base_address = true}) + man.ask (Queries.BlobSize {exp = ptr; base_address = true}) else - match ctx.ask (Queries.MayPointTo ptr) with + match man.ask (Queries.MayPointTo ptr) with | a when not (Queries.AD.is_top a) -> let pts_list = Queries.AD.elements a in let pts_elems_to_sizes (addr: Queries.AD.elt) = @@ -2302,7 +2302,7 @@ struct begin match v.vtype with | TArray (item_typ, _, _) -> let item_typ_size_in_bytes = size_of_type_in_bytes item_typ in - begin match ctx.ask (Queries.EvalLength ptr) with + begin match man.ask (Queries.EvalLength ptr) with | `Lifted arr_len -> let arr_len_casted = ID.cast_to (Cilfacade.ptrdiff_ikind ()) arr_len in begin @@ -2331,26 +2331,26 @@ struct (M.warn "Pointer %a has a points-to-set of top. An invalid memory access might occur" d_exp ptr; `Top) - let special ctx (lv:lval option) (f: varinfo) (args: exp list) = + let special man (lv:lval option) (f: varinfo) (args: exp list) = let invalidate_ret_lv st = match lv with | Some lv -> if M.tracing then M.tracel "invalidate" "Invalidating lhs %a for function call %s" d_plainlval lv f.vname; - invalidate ~must:true ~deep:false ~ctx st [Cil.mkAddrOrStartOf lv] + invalidate ~must:true ~deep:false ~man st [Cil.mkAddrOrStartOf lv] | None -> st in let addr_type_of_exp exp = let lval = mkMem ~addr:(Cil.stripCasts exp) ~off:NoOffset in - let addr = eval_lv ~ctx ctx.local lval in + let addr = eval_lv ~man man.local lval in (addr, AD.type_of addr) in - let forks = forkfun ctx lv f args in + let forks = forkfun man lv f args in if M.tracing then if not (List.is_empty forks) then M.tracel "spawn" "Base.special %s: spawning functions %a" f.vname (d_list "," CilType.Varinfo.pretty) (List.map BatTuple.Tuple4.second forks); - List.iter (fun (lval, f, args, multiple) -> ctx.spawn ~multiple lval f args) forks; - let st: store = ctx.local in + List.iter (fun (lval, f, args, multiple) -> man.spawn ~multiple lval f args) forks; + let st: store = man.local in let desc = LF.find f in let memory_copying dst src n = - let dest_size = get_size_of_ptr_target ctx dst in - let n_intdom = Option.map_default (fun exp -> ctx.ask (Queries.EvalInt exp)) `Bot n in + let dest_size = get_size_of_ptr_target man dst in + let n_intdom = Option.map_default (fun exp -> man.ask (Queries.EvalInt exp)) `Bot n in let dest_size_equal_n = match dest_size, n_intdom with | `Lifted ds, `Lifted n -> @@ -2366,21 +2366,21 @@ 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 ctx.local src_lval + let src_typ = eval_lv ~man man.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 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 ~man st (Lval src_cast_lval) else VD.top_value (unrollType dest_typ) in - set ~ctx st dest_a dest_typ value in + set ~man 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 *) | Some n -> - begin match eval_rv ~ctx st n with + begin match eval_rv ~man st n with | Int i -> begin match ID.to_int i with | Some x -> Some (Z.to_int x) @@ -2406,10 +2406,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 ~man 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 st s2 in + let s2_v = eval_rv ~man 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 *) @@ -2418,68 +2418,68 @@ 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 st lv_val in + let lv_a = eval_lv ~man 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) + set ~man 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 st lv_a lv_typ (f s1_a s2_a) + set ~man st lv_a lv_typ (f s1_a s2_a) else - set ~ctx st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + set ~man 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 st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + set ~man st s1_a s1_typ (VD.top_value (unrollType s1_typ)) end (* else compute value in array domain *) else let lv_a, lv_typ = match lv with - | Some lv_val -> eval_lv ~ctx st lv_val, Cilfacade.typeOfLval lv_val + | Some lv_val -> eval_lv ~man 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) + begin match (get ~man st s1_a None), get ~man st s2_a None with + | Array array_s1, Array array_s2 -> set ~man ~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 st lv_a lv_typ (op_array array_s1 array_s2) + set ~man ~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 - let size = ctx.ask (Q.BlobSize {exp = s1; base_address = false}) in + let size = man.ask (Q.BlobSize {exp = s1; base_address = false}) in let s_id = 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 st lv_a lv_typ (op_array empty_array array_s2) + set ~man 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 - let size = ctx.ask (Q.BlobSize {exp = s1; base_address = false}) in + let size = man.ask (Q.BlobSize {exp = s1; base_address = false}) in let s_id = 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 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 st lv_a lv_typ (op_array empty_array array_s2) + set ~man 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 st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + set ~man 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 st lv_a lv_typ (op_array array_s1 array_s2) + set ~man st lv_a lv_typ (op_array array_s1 array_s2) | _ -> - set ~ctx st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + set ~man st lv_a lv_typ (VD.top_value (unrollType lv_typ)) end in 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 ~man st ch in let dest_a, dest_typ = addr_type_of_exp dest in let value = match eval_ch with @@ -2488,13 +2488,13 @@ struct | _ -> VD.top_value dest_typ in - set ~ctx st dest_a dest_typ value + set ~man 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 st dest_a dest_typ value + set ~man 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))) @@ -2502,9 +2502,9 @@ struct | Strlen s, _ -> begin match lv with | Some lv_val -> - let dest_a = eval_lv ~ctx st lv_val in + let dest_a = eval_lv ~man st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let v = eval_rv ~ctx st s in + let v = eval_rv ~man st s in let a = address_from_value v in let value:value = (* if s string literal, compute strlen in string literals domain *) @@ -2513,11 +2513,11 @@ struct Int (AD.to_string_length a) (* else compute strlen in array domain *) else - begin match get ~ctx st a None with + begin match get ~man st a None with | Array array_s -> Int (CArrays.to_string_length array_s) | _ -> VD.top_value (unrollType dest_typ) end in - set ~ctx st dest_a dest_typ value + set ~man st dest_a dest_typ value | None -> st end | Strstr { haystack; needle }, _ -> @@ -2530,8 +2530,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 st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) - | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~ctx st + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv ~man st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv ~man st (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Lazy.force Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end @@ -2546,18 +2546,18 @@ struct end | Abort, _ -> raise Deadcode | ThreadExit { ret_val = exp }, _ -> - begin match ThreadId.get_current (Analyses.ask_of_ctx ctx) with + begin match ThreadId.get_current (Analyses.ask_of_man man) with | `Lifted tid -> ( - let rv = eval_rv ~ctx ctx.local exp in - ctx.sideg (V.thread tid) (G.create_thread rv); + let rv = eval_rv ~man man.local exp in + man.sideg (V.thread tid) (G.create_thread rv); (* TODO: emit thread return event so other analyses are aware? *) (* TODO: publish still needed? *) - publish_all ctx `Return; (* like normal return *) - let ask = Analyses.ask_of_ctx ctx in + publish_all man `Return; (* like normal return *) + let ask = Analyses.ask_of_man man 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 + ignore @@ Priv.thread_return ask (priv_getg man.global) (priv_sideg man.sideg) tid st | _ -> ()) | _ -> () end; @@ -2565,47 +2565,47 @@ struct | MutexAttrSetType {attr = attr; typ = mtyp}, _ -> begin let get_type lval = - let address = eval_lv ~ctx st lval in + let address = eval_lv ~man 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 st dst_lval in - match eval_rv ~ctx st mtyp with + let dest_a = eval_lv ~man st dst_lval in + match eval_rv ~man st mtyp with | Int x -> begin match ID.to_int x with | Some z -> if M.tracing then M.tracel "attr" "setting"; - 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 ())) + set ~man st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.of_int z)) + | None -> set ~man st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end - | _ -> set ~ctx st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) + | _ -> set ~man st dest_a dest_typ (MutexAttr (ValueDomain.MutexAttr.top ())) end | Identity e, _ -> begin match lv with - | Some x -> assign ctx x e - | None -> ctx.local + | Some x -> assign man x e + | None -> man.local end (**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 ~man 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 st x in - let eval_y = eval_rv ~ctx st y in + let eval_x = eval_rv ~man st x in + let eval_y = eval_rv ~man 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 st x in + let eval_x = eval_rv ~man st x in begin match eval_x with | Int int_x -> let xcast = ID.cast_to ik int_x in @@ -2655,38 +2655,38 @@ struct end in begin match lv with - | Some lv_val -> set ~ctx st (eval_lv ~ctx st lv_val) (Cilfacade.typeOfLval lv_val) result + | Some lv_val -> set ~man st (eval_lv ~man st lv_val) (Cilfacade.typeOfLval lv_val) result | None -> st end (* handling thread creations *) | ThreadCreate _, _ -> - invalidate_ret_lv ctx.local (* actual results joined via threadspawn *) + invalidate_ret_lv man.local (* actual results joined via threadspawn *) (* handling thread joins... sort of *) | 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 ~man st ret_var with | Int n when GobOption.exists (Z.equal Z.zero) (ID.to_int n) -> st | Address ret_a -> - begin match eval_rv ~ctx st id with - | Thread a when ValueDomain.Threads.is_top a -> invalidate ~must:true ~ctx st [ret_var] + begin match eval_rv ~man st id with + | Thread a when ValueDomain.Threads.is_top a -> invalidate ~must:true ~man 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 + let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (man.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 ~must:true ~ctx st [ret_var] + set ~man st ret_a (Cilfacade.typeOf ret_var) v + | _ -> invalidate ~must:true ~man st [ret_var] end - | _ -> invalidate ~must:true ~ctx st [ret_var] + | _ -> invalidate ~must:true ~man 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' + Priv.thread_join (Analyses.ask_of_man man) (priv_getg man.global) id st' | Unknown, "__goblint_assume_join" -> let id = List.hd args in - Priv.thread_join ~force:true (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) id st + Priv.thread_join ~force:true (Analyses.ask_of_man man) (priv_getg man.global) id st | ThreadSelf, _ -> - begin match lv, ThreadId.get_current (Analyses.ask_of_ctx ctx) with + begin match lv, ThreadId.get_current (Analyses.ask_of_man man) with | Some lv, `Lifted tid -> - set ~ctx st (eval_lv ~ctx st lv) (Cilfacade.typeOfLval lv) (Thread (ValueDomain.Threads.singleton tid)) + set ~man st (eval_lv ~man st lv) (Cilfacade.typeOfLval lv) (Thread (ValueDomain.Threads.singleton tid)) | Some lv, _ -> invalidate_ret_lv st | None, _ -> @@ -2695,10 +2695,10 @@ struct | Alloca size, _ -> begin 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 size); *) - set_many ~ctx st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~ctx st size, ZeroInit.malloc)); - (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + let heap_var = AD.of_var (heap_var true man) in + (* ignore @@ printf "alloca will allocate %a bytes\n" ID.pretty (eval_int ~man size); *) + set_many ~man st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~man st size, ZeroInit.malloc)); + (eval_lv ~man st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Malloc size, _ -> begin @@ -2706,47 +2706,47 @@ struct | Some lv -> let heap_var = if (get_bool "sem.malloc.fail") - then AD.join (AD.of_var (heap_var false ctx)) AD.null_ptr - else AD.of_var (heap_var false ctx) + then AD.join (AD.of_var (heap_var false man)) AD.null_ptr + else AD.of_var (heap_var false man) 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 st size, ZeroInit.malloc)); - (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address heap_var)] + (* ignore @@ printf "malloc will allocate %a bytes\n" ID.pretty (eval_int ~man size); *) + set_many ~man st [(heap_var, TVoid [], Blob (VD.bot (), eval_int ~man st size, ZeroInit.malloc)); + (eval_lv ~man st lv, (Cilfacade.typeOfLval lv), Address heap_var)] | _ -> st end | Calloc { count = n; size }, _ -> begin match lv with | Some lv -> (* array length is set to one, as num*size is done when turning into `Calloc *) - let heap_var = heap_var false ctx in + let heap_var = heap_var false man in let add_null addr = if get_bool "sem.malloc.fail" 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 st size in - let countval = eval_int ~ctx st n in + let sizeval = eval_int ~man st size in + let countval = eval_int ~man st n in if ID.to_int countval = Some Z.one then ( - set_many ~ctx st [ + set_many ~man st [ (add_null (AD.of_var heap_var), TVoid [], Blob (VD.bot (), sizeval, ZeroInit.calloc)); - (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) + (eval_lv ~man st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_var heap_var))) ] ) 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 st [ + set_many ~man st [ (add_null (AD.of_var heap_var), TVoid [], Array (CArrays.make (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) Z.one) (Blob (VD.bot (), blobsize, ZeroInit.calloc)))); - (eval_lv ~ctx st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) Z.zero, `NoOffset))))) + (eval_lv ~man st lv, (Cilfacade.typeOfLval lv), Address (add_null (AD.of_mval (heap_var, `Index (IdxDom.of_int (Cilfacade.ptrdiff_ikind ()) Z.zero, `NoOffset))))) ] ) | _ -> st end | Realloc { ptr = p; size }, _ -> (* Realloc shouldn't be passed non-dynamically allocated memory *) - check_invalid_mem_dealloc ctx f p; + check_invalid_mem_dealloc man f p; begin match lv with | Some lv -> - let p_rv = eval_rv ~ctx st p in + let p_rv = eval_rv ~man st p in let p_addr = match p_rv with | Address a -> a @@ -2756,18 +2756,18 @@ 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 st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) - let size_int = eval_int ~ctx st size in + let p_addr_get = get ~man st p_addr' None in (* implicitly includes join of malloc value (VD.bot) *) + let size_int = eval_int ~man st size in let heap_val:value = Blob (p_addr_get, size_int, ZeroInit.malloc) in (* copy old contents with new size *) - let heap_addr = AD.of_var (heap_var false ctx) in + let heap_addr = AD.of_var (heap_var false man) in let heap_addr' = if get_bool "sem.malloc.fail" then AD.join heap_addr AD.null_ptr else heap_addr in - let lv_addr = eval_lv ~ctx st lv in - set_many ~ctx st [ + let lv_addr = eval_lv ~man st lv in + set_many ~man st [ (heap_addr, TVoid [], heap_val); (lv_addr, Cilfacade.typeOfLval lv, Address heap_addr'); ] (* TODO: free (i.e. invalidate) old blob if successful? *) @@ -2776,21 +2776,21 @@ struct end | Free ptr, _ -> (* Free shouldn't be passed non-dynamically allocated memory *) - check_invalid_mem_dealloc ctx f ptr; + check_invalid_mem_dealloc man f ptr; st - | Assert { exp; refine; _ }, _ -> assert_fn ctx exp refine + | Assert { exp; refine; _ }, _ -> assert_fn man exp refine | Setjmp { env }, _ -> - let st' = match eval_rv ~ctx st env with + let st' = match eval_rv ~man 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 + let value = VD.JmpBuf (ValueDomain.JmpBufs.Bufs.singleton (Target (man.prev_node, man.control_context ())), false) in + let r = set ~man st jmp_buf (Cilfacade.typeOf env) value in if M.tracing then M.tracel "setjmp" "setting setjmp %a on %a -> %a" d_exp env D.pretty st D.pretty r; r | _ -> failwith "problem?!" in begin match lv with | Some lv -> - set ~ctx st' (eval_lv ~ctx st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt Z.zero)) + set ~man st' (eval_lv ~man st lv) (Cilfacade.typeOfLval lv) (Int (ID.of_int IInt Z.zero)) | None -> st' end | Longjmp {env; value}, _ -> @@ -2810,19 +2810,19 @@ 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 ~man man.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! *) + set ~man ~t_override:t man.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 ~ctx st x) (Cilfacade.typeOfLval x) result + set ~man st (eval_lv ~man st x) (Cilfacade.typeOfLval x) result | None -> st end | _, _ -> let st = - special_unknown_invalidate ctx f args + special_unknown_invalidate man f args (* * TODO: invalidate vars reachable via args * publish globals @@ -2835,7 +2835,7 @@ struct in 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 combine_st man (local_st : store) (fun_st : store) (tainted_lvs : AD.t) : store = AD.fold (fun addr (st: store) -> match addr with | Addr.Addr (v,o) when CPA.mem v fun_st.cpa -> @@ -2851,9 +2851,9 @@ struct | _ -> begin let address = AD.singleton addr in - let new_val = get ~ctx fun_st address None in + let new_val = get ~man fun_st address None in if M.tracing then M.trace "taintPC" "update val: %a" VD.pretty new_val; - let st' = set_savetop ~ctx st address lval_type new_val in + let st' = set_savetop ~man st address lval_type new_val in 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 *) @@ -2866,7 +2866,7 @@ struct | _ -> st ) tainted_lvs local_st - let combine_env ctx lval fexp f args fc au (f_ask: Queries.ask) = + let combine_env man lval fexp f args fc au (f_ask: Queries.ask) = let combine_one (st: D.t) (fun_st: D.t) = if M.tracing then M.tracel "combine" "%a\n%a" CPA.pretty st.cpa CPA.pretty fun_st.cpa; (* This function does miscellaneous things, but the main task was to give the @@ -2877,7 +2877,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_man man in let tainted = f_ask.f Q.MayBeTainted in if M.tracing then M.trace "taintPC" "combine for %s in base: tainted: %a" f.svar.vname AD.pretty tainted; if M.tracing then M.trace "taintPC" "combine base:\ncaller: %a\ncallee: %a" CPA.pretty st.cpa CPA.pretty fun_st.cpa; @@ -2900,7 +2900,7 @@ struct | Addr.Addr (v,_) -> not (CPA.mem v cpa_new) | _ -> false ) tainted in - let st_combined = combine_st ctx {st with cpa = cpa_caller'} fun_st tainted in + let st_combined = combine_st man {st with cpa = cpa_caller'} fun_st tainted in if M.tracing then M.trace "taintPC" "combined: %a" CPA.pretty st_combined.cpa; { fun_st with cpa = st_combined.cpa } in @@ -2912,20 +2912,20 @@ struct | Some n -> Node.find_fundec n | None -> failwith "callerfundec not found" in - let cpa' = project (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (Some p) nst.cpa callerFundec in + let cpa' = project (Queries.to_value_domain_ask (Analyses.ask_of_man man)) (Some p) nst.cpa callerFundec in if get_bool "sem.noreturn.dead_code" && Cil.hasAttribute "noreturn" f.svar.vattr then raise Deadcode; { nst with cpa = cpa'; weak = st.weak } (* keep weak from caller *) in - combine_one ctx.local au + combine_one man.local au - let combine_assign ctx (lval: lval option) fexp (f: fundec) (args: exp list) fc (after: D.t) (f_ask: Q.ask) : D.t = + let combine_assign man (lval: lval option) fexp (f: fundec) (args: exp list) fc (after: D.t) (f_ask: Q.ask) : D.t = let combine_one (st: D.t) (fun_st: D.t) = let return_var = return_var () in let return_val = if CPA.mem (return_varinfo ()) fun_st.cpa - then get ~ctx fun_st return_var None + then get ~man fun_st return_var None else VD.top () in @@ -2935,46 +2935,46 @@ struct | Some n -> Node.find_fundec n | None -> failwith "callerfundec not found" in - let return_val = project_val (Queries.to_value_domain_ask (Analyses.ask_of_ctx ctx)) (attributes_varinfo (return_varinfo ()) callerFundec) (Some p) return_val (is_privglob (return_varinfo ())) in + let return_val = project_val (Queries.to_value_domain_ask (Analyses.ask_of_man man)) (attributes_varinfo (return_varinfo ()) callerFundec) (Some p) return_val (is_privglob (return_varinfo ())) in match lval with | None -> st - | Some lval -> set_savetop ~ctx st (eval_lv ~ctx st lval) (Cilfacade.typeOfLval lval) return_val + | Some lval -> set_savetop ~man st (eval_lv ~man st lval) (Cilfacade.typeOfLval lval) return_val in - combine_one ctx.local after + combine_one man.local after - let threadenter ctx ~multiple (lval: lval option) (f: varinfo) (args: exp list): D.t list = + let threadenter man ~multiple (lval: lval option) (f: varinfo) (args: exp list): D.t list = match Cilfacade.find_varinfo_fundec f with | fd -> - [make_entry ~thread:true ctx fd args] + [make_entry ~thread:true man fd args] | exception Not_found -> (* Unknown functions *) - let st = special_unknown_invalidate ctx f args in + let st = special_unknown_invalidate man f args in [st] - let threadspawn ctx ~multiple (lval: lval option) (f: varinfo) (args: exp list) fctx: D.t = + let threadspawn man ~multiple (lval: lval option) (f: varinfo) (args: exp list) fman: D.t = begin match lval with | Some lval -> - begin match ThreadId.get_current (Analyses.ask_of_ctx fctx) with + begin match ThreadId.get_current (Analyses.ask_of_man fman) with | `Lifted tid -> - (* Cannot set here, because ctx isn't in multithreaded mode and set wouldn't side-effect if lval is global. *) - ctx.emit (Events.AssignSpawnedThread (lval, tid)) + (* Cannot set here, because man isn't in multithreaded mode and set wouldn't side-effect if lval is global. *) + man.emit (Events.AssignSpawnedThread (lval, tid)) | _ -> () end | None -> () end; - (* D.join ctx.local @@ *) - Priv.threadspawn (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) (priv_sideg ctx.sideg) ctx.local + (* D.join man.local @@ *) + Priv.threadspawn (Analyses.ask_of_man man) (priv_getg man.global) (priv_sideg man.sideg) man.local - let unassume (ctx: (D.t, _, _, _) ctx) e uuids = + let unassume (man: (D.t, _, _, _) man) e uuids = (* TODO: structural unassume instead of invariant hack *) let e_d = - let ctx_with_local ~single local = - (* The usual recursion trick for ctx. *) - (* Must change ctx used by ask to also use new st (not ctx.local), otherwise recursive EvalInt queries use outdated state. *) + let man_with_local ~single local = + (* The usual recursion trick for man. *) + (* Must change man used by ask to also use new st (not man.local), otherwise recursive EvalInt queries use outdated state. *) (* Note: query is just called on base, but not any other analyses. Potentially imprecise, but seems to be sufficient for now. *) - let rec ctx' ~querycache asked = - { ctx with + let rec man' ~querycache asked = + { man with ask = (fun (type a) (q: a Queries.t) -> query' ~querycache asked q) ; local } @@ -3010,57 +3010,57 @@ struct where base doesn't have the partial top local state. They are also needed for sensible eval behavior via [inv_exp] such that everything wouldn't be may escaped. *) - ctx.ask q + man.ask q | _ -> (* Other queries are not safe, because they would query the local value state instead of top. Therefore, these are answered only by base on the partial top local state. *) - query (ctx' ~querycache asked') q + query (man' ~querycache asked') q in Queries.Hashtbl.replace querycache anyq (Obj.repr r); r ) in let querycache = Queries.Hashtbl.create 13 in - ctx' ~querycache Queries.Set.empty + man' ~querycache Queries.Set.empty in let f st = (* TODO: start with empty vars because unassume may unassume values for pointed variables not in the invariant exp *) - let local: D.t = {ctx.local with cpa = CPA.bot ()} in - let octx = ctx_with_local ~single:false (D.join ctx.local st) in (* original ctx with non-top values *) + let local: D.t = {man.local with cpa = CPA.bot ()} in + let oman = man_with_local ~single:false (D.join man.local st) in (* original man with non-top values *) (* TODO: deduplicate with invariant *) - let ctx = ctx_with_local ~single:true local in + let man = man_with_local ~single:true local in let module UnassumeEval = struct module D = D module V = V module G = G - let ost = octx.local + let ost = oman.local let unop_ID = unop_ID let unop_FD = unop_FD - (* all evals happen in octx with non-top values *) - 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 evals happen in oman with non-top values *) + let eval_rv ~man st e = eval_rv ~man:oman ost e + let eval_rv_address ~man st e = eval_rv_address ~man:oman ost e + let eval_lv ~man st lv = eval_lv ~man:oman ost lv + let convert_offset ~man st o = convert_offset ~man:oman ost o - (* all updates happen in ctx with top values *) + (* all updates happen in man with top values *) let get_var = get_var - let get ~ctx st addrs exp = get ~ctx st addrs exp - 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 get ~man st addrs exp = get ~man st addrs exp + let set ~man st lval lval_type ?lval_raw value = set ~man ~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 = 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 st exp lv + let eval_rv_lval_refine ~man st exp lv = + (* new, use different man for eval_lv (for Mem): *) + eval_rv_base_lval ~eval_lv ~man st exp lv - (* don't meet with current octx values when propagating inverse operands down *) + (* don't meet with current oman values when propagating inverse operands down *) let id_meet_down ~old ~c = c let fd_meet_down ~old ~c = c @@ -3069,7 +3069,7 @@ struct in let module Unassume = BaseInvariant.Make (UnassumeEval) in try - Unassume.invariant ctx ctx.local e true + Unassume.invariant man man.local e true with Deadcode -> (* contradiction in unassume *) D.bot () in @@ -3095,47 +3095,47 @@ struct WideningTokenLifter.with_side_tokens (WideningTokenLifter.TS.of_list uuids) (fun () -> CPA.fold (fun x v acc -> let addr: AD.t = AD.of_mval (x, `NoOffset) in - set ~ctx ~invariant:false acc addr x.vtype v - ) e_d.cpa ctx.local + set ~man ~invariant:false acc addr x.vtype v + ) e_d.cpa man.local ) in - D.join ctx.local e_d' + D.join man.local e_d' - let event ctx e octx = - let ask = Analyses.ask_of_ctx ctx in - let st: store = ctx.local in + let event man e oman = + let ask = Analyses.ask_of_man man in + let st: store = man.local in match e with | 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" LockDomain.Addr.pretty addr; CommonPriv.lift_lock ask (fun st m -> - Priv.lock ask (priv_getg ctx.global) st m + Priv.lock ask (priv_getg man.global) st m ) st addr | Events.Unlock addr when ThreadFlag.has_ever_been_multi ask -> (* TODO: is this condition sound? *) WideningTokenLifter.with_local_side_tokens (fun () -> CommonPriv.lift_unlock ask (fun st m -> - Priv.unlock ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st m + Priv.unlock ask (priv_getg man.global) (priv_sideg man.sideg) st m ) st addr ) | Events.Escape escaped -> - Priv.escape ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st escaped + Priv.escape ask (priv_getg man.global) (priv_sideg man.sideg) st escaped | Events.EnterMultiThreaded -> - Priv.enter_multithreaded ask (priv_getg ctx.global) (priv_sideg ctx.sideg) st + Priv.enter_multithreaded ask (priv_getg man.global) (priv_sideg man.sideg) st | Events.AssignSpawnedThread (lval, tid) -> (* TODO: is this type right? *) - set ~ctx ctx.local (eval_lv ~ctx ctx.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) + set ~man man.local (eval_lv ~man man.local lval) (Cilfacade.typeOfLval lval) (Thread (ValueDomain.Threads.singleton tid)) | Events.Assert exp -> - assert_fn ctx exp true + assert_fn man exp true | Events.Unassume {exp; tokens} -> - Timing.wrap "base unassume" (unassume ctx exp) tokens + Timing.wrap "base unassume" (unassume man exp) tokens | Events.Longjmped {lval} -> begin match lval with | Some lval -> - let st' = assign ctx lval (Lval (Cil.var !longjmp_return)) in + let st' = assign man lval (Lval (Cil.var !longjmp_return)) in {st' with cpa = CPA.remove !longjmp_return st'.cpa} - | None -> ctx.local + | None -> man.local end | _ -> - ctx.local + man.local end module type MainSpec = sig diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index 52f0888d3f..19a9999ecf 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -17,18 +17,18 @@ sig val unop_ID: Cil.unop -> ID.t -> ID.t val unop_FD: Cil.unop -> FD.t -> 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 -> 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 eval_rv: man:(D.t, G.t, _, V.t) Analyses.man -> D.t -> exp -> VD.t + val eval_rv_address: man:(D.t, G.t, _, V.t) Analyses.man -> D.t -> exp -> VD.t + val eval_lv: man:(D.t, G.t, _, V.t) Analyses.man -> D.t -> lval -> AD.t + val convert_offset: man:(D.t, G.t, _, V.t) Analyses.man -> 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 - val set: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> AD.t -> typ -> ?lval_raw:lval -> VD.t -> D.t + val get_var: man:(D.t, G.t, _, V.t) Analyses.man -> D.t -> varinfo -> VD.t + val get: man:(D.t, G.t, _, V.t) Analyses.man -> D.t -> AD.t -> exp option -> VD.t + val set: man:(D.t, G.t, _, V.t) Analyses.man -> 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 - val eval_rv_lval_refine: ctx:(D.t, G.t, _, V.t) Analyses.ctx -> D.t -> exp -> lval -> VD.t + val eval_rv_lval_refine: man:(D.t, G.t, _, V.t) Analyses.man -> 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 @@ -54,12 +54,12 @@ struct VD.meet old_val new_val with Lattice.Uncomparable -> old_val - let refine_lv_fallback ctx st lval value tv = + let refine_lv_fallback man st lval value tv = if M.tracing then M.tracec "invariant" "Restricting %a with %a" d_lval lval VD.pretty value; - let addr = eval_lv ~ctx st lval in + let addr = eval_lv ~man 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) *) + let old_val = get ~man 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 = @@ -70,8 +70,8 @@ struct else old_val in - let state_with_excluded = set st addr t_lval value ~ctx in - let value = get ~ctx state_with_excluded addr None in + let state_with_excluded = set st addr t_lval value ~man in + let value = get ~man 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" VD.pretty new_val; (* make that address meet the invariant, i.e exclusion sets will be joined *) @@ -80,18 +80,18 @@ struct contra st ) else if VD.is_bot new_val - 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 *) + then set st addr t_lval value ~man (* no *_raw because this is not a real assignment *) + else set st addr t_lval new_val ~man (* 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 st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~ctx in + let refine_lv man st c x c' pretty exp = + let set' lval v st = set st (eval_lv ~man st lval) (Cilfacade.typeOfLval lval) ~lval_raw:lval v ~man 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 = get_var ~man st var in let old_val = map_oldval old_val var.vtype 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 offs = convert_offset ~man st o in + let new_val = VD.update_offset (Queries.to_value_domain_ask (Analyses.ask_of_man man)) 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 ( @@ -103,7 +103,7 @@ struct | Var _, _ | Mem _, _ -> (* For accesses via pointers, not yet *) - let old_val = eval_rv_lval_refine ~ctx st exp x in + let old_val = eval_rv_lval_refine ~man 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 @@ -112,7 +112,7 @@ struct set' x v st ) - let invariant_fallback ctx st exp tv = + let invariant_fallback man 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): [> `Refine of lval * VD.t | `NotUnderstood] = @@ -139,7 +139,7 @@ struct end | Address n -> begin if M.tracing then M.tracec "invariant" "Yes, %a is not %a" d_lval x AD.pretty n; - match eval_rv_address ~ctx st (Lval x) with + match eval_rv_address ~man st (Lval x) with | Address a when AD.is_definite n -> `Refine (x, Address (AD.diff a n)) | Top when AD.is_null n -> @@ -203,12 +203,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 ~man 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_statically_safe_cast t1 (Cilfacade.typeOf c1) && VD.is_statically_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) -> - begin match eval_rv ~ctx st (Lval x) with + begin match eval_rv ~man st (Lval x) with | Int v -> if VD.is_dynamically_safe_cast t1 (Cilfacade.typeOfLval x) (Int v) then derived_invariant (BinOp (op, Lval x, rval, typ)) tv @@ -233,7 +233,7 @@ struct in match derived_invariant exp tv with | `Refine (lval, value) -> - refine_lv_fallback ctx st lval value tv + refine_lv_fallback man st lval value tv | `NothingToRefine -> if M.tracing then M.traceu "invariant" "Nothing to refine."; st @@ -242,10 +242,10 @@ struct M.debug ~category:Analyzer "Invariant failed: expression \"%a\" not understood." d_exp exp; st - let invariant ctx st exp tv: D.t = + let invariant man st exp tv: D.t = let fallback reason st = if M.tracing then M.tracel "inv" "Can't handle %a.\n%t" d_plainexp exp reason; - invariant_fallback ctx st exp tv + invariant_fallback man 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). *) @@ -549,7 +549,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 ~man 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 @@ -703,7 +703,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 st c x c' pretty exp in + let update_lval c x c' pretty = refine_lv man 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" d_lval x VD.pretty c_typed d_type t; begin match c_typed with @@ -718,7 +718,7 @@ struct (* handle special calls *) begin match x, t with | (Var v, offs), TInt (ik, _) -> - let tmpSpecial = ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in + let tmpSpecial = man.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in if M.tracing then M.trace "invSpecial" "qry Result: %a" Queries.ML.pretty tmpSpecial; begin match tmpSpecial with | `Lifted (Abs (ik, xInt)) -> @@ -756,7 +756,7 @@ struct (* handle special calls *) begin match x, t with | (Var v, offs), TFloat (fk, _) -> - let tmpSpecial = ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in + let tmpSpecial = man.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in if M.tracing then M.trace "invSpecial" "qry Result: %a" Queries.ML.pretty tmpSpecial; begin match tmpSpecial with | `Lifted (Ceil (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_ceil (FD.cast_to ret_fk c))) xFloat st @@ -835,9 +835,9 @@ struct in inv_exp (Float ftv) exp st - let invariant ctx st exp tv = + let invariant man st exp tv = (* The computations that happen here are not computations that happen in the programs *) (* Any overflow during the forward evaluation will already have been flagged here *) GobRef.wrap AnalysisState.executing_speculative_computations true - @@ fun () -> invariant ctx st exp tv + @@ fun () -> invariant man st exp tv end diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 3afd758daa..a8696a1532 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -57,7 +57,7 @@ end let old_threadenter (type d) ask (st: d BaseDomain.basecomponents_t) = (* Copy-paste from Base make_entry *) 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 = if !earlyglobs || ThreadFlag.is_multi man.ask then CPA.filter (fun k v -> is_private man.ask man.local k) globals else globals in *) let new_cpa = globals in {st with cpa = new_cpa} @@ -1802,7 +1802,7 @@ struct let write_global ?invariant ask getg sideg st x v = time "write_global" (Priv.write_global ?invariant ask getg sideg st x) v let lock ask getg cpa m = time "lock" (Priv.lock ask getg cpa) m let unlock ask getg sideg st m = time "unlock" (Priv.unlock ask getg sideg st) m - let sync reason ctx = time "sync" (Priv.sync reason) ctx + let sync reason man = time "sync" (Priv.sync reason) man let escape ask getg sideg st escaped = time "escape" (Priv.escape ask getg sideg st) escaped let enter_multithreaded ask getg sideg st = time "enter_multithreaded" (Priv.enter_multithreaded ask getg sideg) st let threadenter ask st = time "threadenter" (Priv.threadenter ask) st diff --git a/src/analyses/callstring.ml b/src/analyses/callstring.ml index 391f5f6657..66c2773c59 100644 --- a/src/analyses/callstring.ml +++ b/src/analyses/callstring.ml @@ -13,7 +13,7 @@ module type CallstringType = sig include CilType.S val ana_name: string - val new_ele: fundec -> ('d,'g,'c,'v) ctx -> t option (* returns an element that should be pushed to the call string *) + val new_ele: fundec -> ('d,'g,'c,'v) man -> t option (* returns an element that should be pushed to the call string *) end (** Analysis with infinite call string or with limited call string (k-CFA, tracks the last k call stack elements). @@ -49,17 +49,17 @@ struct let startcontext () = CallString.empty - let context ctx fd _ = - let elem = CT.new_ele fd ctx in (* receive element that should be added to call string *) - CallString.push (ctx.context ()) elem + let context man fd _ = + let elem = CT.new_ele fd man in (* receive element that should be added to call string *) + CallString.push (man.context ()) elem end (* implementations of CallstringTypes*) module Callstring: CallstringType = struct include CilType.Fundec let ana_name = "string" - let new_ele f ctx = - let f' = Node.find_fundec ctx.node in + let new_ele f man = + let f' = Node.find_fundec man.node in if CilType.Fundec.equal f' dummyFunDec then None else Some f' @@ -68,8 +68,8 @@ end module Callsite: CallstringType = struct include CilType.Stmt let ana_name = "site" - let new_ele f ctx = - match ctx.prev_node with + let new_ele f man = + match man.prev_node with | Statement stmt -> Some stmt | _ -> None (* first statement is filtered *) end diff --git a/src/analyses/condVars.ml b/src/analyses/condVars.ml index 448e3a79e5..fbfb2199f2 100644 --- a/src/analyses/condVars.ml +++ b/src/analyses/condVars.ml @@ -63,8 +63,8 @@ struct (* >? is >>=, |? is >> *) let (>?) = Option.bind - let mayPointTo ctx exp = - let ad = ctx.ask (Queries.MayPointTo exp) in + let mayPointTo man exp = + let ad = man.ask (Queries.MayPointTo exp) in let a' = if Queries.AD.mem UnknownPtr ad then ( M.info ~category:Unsound "mayPointTo: query result for %a contains TOP!" d_exp exp; (* UNSOUND *) Queries.AD.remove UnknownPtr ad @@ -75,16 +75,16 @@ struct | _ -> None ) (Queries.AD.elements a') - let mustPointTo ctx exp = (* this is just to get Mval.Exp *) - match mayPointTo ctx exp with + let mustPointTo man exp = (* this is just to get Mval.Exp *) + match mayPointTo man exp with | [clval] -> Some clval | _ -> None (* queries *) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.CondVars e -> - let d = ctx.local in + let d = man.local in let rec of_expr tv = function | UnOp (LNot, e, t) when isIntegralType t -> of_expr (not tv) e | BinOp (Ne, e1, e2, t) when isIntegralType t -> of_expr (not tv) (BinOp (Eq, e1, e2, t)) @@ -93,7 +93,7 @@ struct | Lval lval -> Some (tv, lval) | _ -> None in - let of_lval (tv,lval) = Option.map (fun k -> tv, k) @@ mustPointTo ctx (AddrOf lval) in + let of_lval (tv,lval) = Option.map (fun k -> tv, k) @@ mustPointTo man (AddrOf lval) in let t tv e = if tv then e else UnOp (LNot, e, intType) in (* TODO: remove option? *) let f tv v = D.V.map (t tv) v |> fun v -> Some v in @@ -102,11 +102,11 @@ struct | _ -> Queries.Result.top q (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = + let assign man (lval:lval) (rval:exp) : D.t = (* remove all keys lval may point to, and all exprs that contain the variables (TODO precision) *) - let d = List.fold_left (fun d (v,o as k) -> D.remove k d |> D.remove_var v) ctx.local (mayPointTo ctx (AddrOf lval)) in + let d = List.fold_left (fun d (v,o as k) -> D.remove k d |> D.remove_var v) man.local (mayPointTo man (AddrOf lval)) in let save_expr lval expr = - match mustPointTo ctx (AddrOf lval) with + match mustPointTo man (AddrOf lval) with | Some clval -> if M.tracing then M.tracel "condvars" "CondVars: saving %a = %a" Mval.Exp.pretty clval d_exp expr; D.add clval (D.V.singleton expr) d (* if lval must point to clval, add expr *) @@ -117,11 +117,11 @@ struct | BinOp (op, _, _, _) when is_cmp op -> (* logical expression *) save_expr lval rval | Lval k -> (* var-eq for transitive closure *) - mustPointTo ctx (AddrOf k) >? flip D.get_elt d |> Option.map (save_expr lval) |? d + mustPointTo man (AddrOf k) >? flip D.get_elt d |> Option.map (save_expr lval) |? d | _ -> d - let branch ctx (exp:exp) (tv:bool) : D.t = - ctx.local + let branch man (exp:exp) (tv:bool) : D.t = + man.local (* possible solutions for functions: * 1. only intra-procedural <- we do this @@ -130,33 +130,33 @@ struct * 4. same, but also consider escaped vars *) - let body ctx (f:fundec) : D.t = - ctx.local + let body man (f:fundec) : D.t = + man.local - let return ctx (exp:exp option) (f:fundec) : D.t = - (* D.only_globals ctx.local *) - ctx.local + let return man (exp:exp option) (f:fundec) : D.t = + (* D.only_globals man.local *) + man.local - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - [ctx.local, D.bot ()] + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + [man.local, D.bot ()] - let combine_env ctx lval fexp f args fc au (f_ask: Queries.ask) = + let combine_env man lval fexp f args fc au (f_ask: Queries.ask) = (* combine caller's state with globals from callee *) (* TODO (precision): globals with only global vars are kept, the rest is lost -> collect which globals are assigned to *) - (* D.merge (fun k s1 s2 -> match s2 with Some ss2 when (fst k).vglob && D.only_global_exprs ss2 -> s2 | _ when (fst k).vglob -> None | _ -> s1) ctx.local au *) + (* D.merge (fun k s1 s2 -> match s2 with Some ss2 when (fst k).vglob && D.only_global_exprs ss2 -> s2 | _ when (fst k).vglob -> None | _ -> s1) man.local au *) let tainted = TaintPartialContexts.conv_varset (f_ask.f Queries.MayBeTainted) in - D.only_untainted ctx.local tainted (* tainted globals might have changed... *) + D.only_untainted man.local tainted (* tainted globals might have changed... *) - 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 combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + man.local - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = (* TODO: shouldn't there be some kind of invalidadte, depending on the effect of the special function? *) - ctx.local + man.local let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.bot ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.bot () end diff --git a/src/analyses/deadlock.ml b/src/analyses/deadlock.ml index e83b122fd9..333b015ad6 100644 --- a/src/analyses/deadlock.ml +++ b/src/analyses/deadlock.ml @@ -23,23 +23,23 @@ struct module G = MapDomain.MapBot (Lock) (MayLockEventPairs) - let side_lock_event_pair ctx ((before_node, _, _) as before) ((after_node, _, _) as after) = + let side_lock_event_pair man ((before_node, _, _) as before) ((after_node, _, _) as after) = if !AnalysisState.should_warn then - ctx.sideg before_node (G.singleton after_node (MayLockEventPairs.singleton (before, after))) + man.sideg before_node (G.singleton after_node (MayLockEventPairs.singleton (before, after))) - let part_access ctx: MCPAccess.A.t = - Obj.obj (ctx.ask (PartAccess Point)) + let part_access man: MCPAccess.A.t = + Obj.obj (man.ask (PartAccess Point)) - let add ctx ((l, _): LockDomain.AddrRW.t) = - let after: LockEvent.t = (l, ctx.prev_node, part_access ctx) in (* use octx for access to use locksets before event *) + let add man ((l, _): LockDomain.AddrRW.t) = + let after: LockEvent.t = (l, man.prev_node, part_access man) in (* use octx for access to use locksets before event *) D.iter (fun before -> - side_lock_event_pair ctx before after - ) ctx.local; - D.add after ctx.local + side_lock_event_pair man before after + ) man.local; + D.add after man.local - let remove ctx l = + let remove man l = let inLockAddrs (e, _, _) = Lock.equal l e in - D.filter (neg inLockAddrs) ctx.local + D.filter (neg inLockAddrs) man.local end include LocksetAnalysis.MakeMay (Arg) @@ -47,7 +47,7 @@ struct module G = Arg.G (* help type checker using explicit constraint *) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | WarnGlobal g -> let g: V.t = Obj.obj g in @@ -105,7 +105,7 @@ struct let new_path_visited_lock_event_pairs' = lock_event_pair :: path_visited_lock_event_pairs in iter_lock new_path_visited_locks new_path_visited_lock_event_pairs' to_lock ) lock_event_pairs - ) (ctx.global lock) + ) (man.global lock) end in diff --git a/src/analyses/expRelation.ml b/src/analyses/expRelation.ml index 39df650bc0..09a644f0f2 100644 --- a/src/analyses/expRelation.ml +++ b/src/analyses/expRelation.ml @@ -47,7 +47,7 @@ struct let isFloat e = Cilfacade.isFloatType (Cilfacade.typeOf e) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = let lvalsEq l1 l2 = CilType.Lval.equal l1 l2 in (* == would be wrong here *) match q with | Queries.EvalInt (BinOp (Eq, e1, e2, t)) when not (isFloat e1) && Basetype.CilExp.equal (canonize e1) (canonize e2) -> diff --git a/src/analyses/expsplit.ml b/src/analyses/expsplit.ml index 46ec4774e5..6fb2b547a9 100644 --- a/src/analyses/expsplit.ml +++ b/src/analyses/expsplit.ml @@ -21,83 +21,83 @@ struct include Analyses.DefaultSpec module P = IdentityP (D) - let emit_splits ctx d = + let emit_splits man d = D.iter (fun e _ -> - ctx.emit (UpdateExpSplit e) + man.emit (UpdateExpSplit e) ) d; d - let emit_splits_ctx ctx = - emit_splits ctx ctx.local + let emit_splits_ctx man = + emit_splits man man.local - let assign ctx (lval:lval) (rval:exp) = - emit_splits_ctx ctx + let assign man (lval:lval) (rval:exp) = + emit_splits_ctx man - let vdecl ctx (var:varinfo) = - emit_splits_ctx ctx + let vdecl man (var:varinfo) = + emit_splits_ctx man - let branch ctx (exp:exp) (tv:bool) = - emit_splits_ctx ctx + let branch man (exp:exp) (tv:bool) = + emit_splits_ctx man - let enter ctx (lval: lval option) (f:fundec) (args:exp list) = - [ctx.local, ctx.local] + let enter man (lval: lval option) (f:fundec) (args:exp list) = + [man.local, man.local] - let body ctx (f:fundec) = - emit_splits_ctx ctx + let body man (f:fundec) = + emit_splits_ctx man - let return ctx (exp:exp option) (f:fundec) = - emit_splits_ctx ctx + let return man (exp:exp option) (f:fundec) = + emit_splits_ctx man - let combine_env ctx lval fexp f args fc au f_ask = - let d = D.join ctx.local au in - emit_splits ctx d (* Update/preserve splits for globals in combined environment. *) + let combine_env man lval fexp f args fc au f_ask = + let d = D.join man.local au in + emit_splits man d (* Update/preserve splits for globals in combined environment. *) - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - emit_splits_ctx ctx (* Update/preserve splits over assigned variable. *) + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + emit_splits_ctx man (* Update/preserve splits over assigned variable. *) - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) = let d = match (LibraryFunctions.find f).special arglist, f.vname with | _, "__goblint_split_begin" -> let exp = List.hd arglist in let ik = Cilfacade.get_ikind_exp exp in (* TODO: something different for pointers, currently casts pointers to ints and loses precision (other than NULL) *) - D.add exp (ID.top_of ik) ctx.local (* split immediately follows *) + D.add exp (ID.top_of ik) man.local (* split immediately follows *) | _, "__goblint_split_end" -> let exp = List.hd arglist in - D.remove exp ctx.local + D.remove exp man.local | Setjmp { env }, _ -> Option.map_default (fun lval -> match GobConfig.get_string "ana.setjmp.split" with - | "none" -> ctx.local + | "none" -> man.local | "precise" -> let e = Lval lval in let ik = Cilfacade.get_ikind_exp e in - D.add e (ID.top_of ik) ctx.local + D.add e (ID.top_of ik) man.local | "coarse" -> let e = Lval lval in let e = BinOp (Eq, e, integer 0, intType) in - D.add e (ID.top_of IInt) ctx.local + D.add e (ID.top_of IInt) man.local | _ -> failwith "Invalid value for ana.setjmp.split" - ) ctx.local lval + ) man.local lval | _ -> - ctx.local + man.local in - emit_splits ctx d + emit_splits man d - let threadenter ctx ~multiple lval f args = [ctx.local] + let threadenter man ~multiple lval f args = [man.local] - let threadspawn ctx ~multiple lval f args fctx = - emit_splits_ctx ctx + let threadspawn man ~multiple lval f args fman = + emit_splits_ctx man - let event ctx (event: Events.t) octx = + let event man (event: Events.t) octx = match event with | UpdateExpSplit exp -> - let value = ctx.ask (EvalInt exp) in - D.add exp value ctx.local + let value = man.ask (EvalInt exp) in + D.add exp value man.local | Longjmped _ -> - emit_splits_ctx ctx + emit_splits_ctx man | _ -> - ctx.local + man.local end let () = diff --git a/src/analyses/extractPthread.ml b/src/analyses/extractPthread.ml index a61c54ab96..cd3fce184d 100644 --- a/src/analyses/extractPthread.ml +++ b/src/analyses/extractPthread.ml @@ -233,22 +233,22 @@ let promela_main : fun_name = "mainfun" (* assign tid: promela_main -> 0 *) let _ = Tbls.ThreadTidTbl.get promela_main -let fun_ctx ctx f = - let ctx_hash = - match PthreadDomain.Ctx.to_int ctx with +let fun_ctx man f = + let man_hash = + match PthreadDomain.Ctx.to_int man with | Some i -> i |> i64_to_int |> Tbls.CtxTbl.get |> string_of_int | None -> "TOP" in - f.vname ^ "_" ^ ctx_hash + f.vname ^ "_" ^ man_hash module Tasks = SetDomain.Make (Lattice.Prod (Queries.AD) (PthreadDomain.D)) module rec Env : sig type t - val get : (PthreadDomain.D.t, Tasks.t, PthreadDomain.D.t, _) ctx -> t + val get : (PthreadDomain.D.t, Tasks.t, PthreadDomain.D.t, _) man -> t val d : t -> PthreadDomain.D.t @@ -262,8 +262,8 @@ end = struct ; resource : Resource.t } - let get ctx = - let d : PthreadDomain.D.t = ctx.local in + let get man = + let d : PthreadDomain.D.t = man.local in let node = Option.get !MyCFG.current_node in let fundec = Node.find_fundec node in let thread_name = @@ -452,12 +452,12 @@ module Variables = struct (* all vars on rhs should be already registered, otherwise -> do not add this var *) - let rec all_vars_are_valid ctx = function + let rec all_vars_are_valid man = function | Const _ -> true | Lval l -> let open PthreadDomain in - let d = Env.d @@ Env.get ctx in + let d = Env.d @@ Env.get man in let tid = Int64.to_int @@ Option.get @@ Tid.to_int d.tid in l @@ -465,9 +465,9 @@ module Variables = struct |> Option.map @@ valid_var tid |> Option.default false | UnOp (_, e, _) -> - all_vars_are_valid ctx e + all_vars_are_valid man e | BinOp (_, a, b, _) -> - all_vars_are_valid ctx a && all_vars_are_valid ctx b + all_vars_are_valid man a && all_vars_are_valid man b | _ -> false end @@ -876,56 +876,56 @@ module Spec : Analyses.MCPSpec = struct module ExprEval = struct - let eval_ptr ctx exp = - ctx.ask (Queries.MayPointTo exp) + let eval_ptr man exp = + man.ask (Queries.MayPointTo exp) |> Queries.AD.remove UnknownPtr (* UNSOUND *) |> Queries.AD.to_var_may - let eval_var ctx exp = + let eval_var man exp = match exp with | Lval (Mem e, _) -> - eval_ptr ctx e + eval_ptr man e | Lval (Var v, _) -> [ v ] | _ -> - eval_ptr ctx exp + eval_ptr man exp - let eval_ptr_id ctx exp get = - List.map (get % Variable.show) @@ eval_ptr ctx exp + let eval_ptr_id man exp get = + List.map (get % Variable.show) @@ eval_ptr man exp - let eval_var_id ctx exp get = - List.map (get % Variable.show) @@ eval_var ctx exp + let eval_var_id man exp get = + List.map (get % Variable.show) @@ eval_var man exp end let name () = "extract-pthread" - let assign ctx (lval : lval) (rval : exp) : D.t = + let assign man (lval : lval) (rval : exp) : D.t = let should_ignore_assigns = GobConfig.get_bool "ana.extract-pthread.ignore_assign" in - if PthreadDomain.D.is_bot ctx.local || should_ignore_assigns - then ctx.local + if PthreadDomain.D.is_bot man.local || should_ignore_assigns + then man.local else if Option.is_none !MyCFG.current_node then ( (* it is global var assignment *) let var_opt = Variable.make_from_lval lval in - if Variables.all_vars_are_valid ctx rval + if Variables.all_vars_are_valid man rval (* TODO: handle the assignment of the global *) then Option.may (Variables.add (-1)) var_opt else Option.may (Variables.add_top (-1)) var_opt ; - ctx.local ) + man.local ) else - let env = Env.get ctx in + let env = Env.get man in let d = Env.d env in let tid = Int64.to_int @@ Option.get @@ Tid.to_int d.tid in let var_opt = Variable.make_from_lval lval in - if Option.is_none var_opt || (not @@ Variables.all_vars_are_valid ctx rval) + if Option.is_none var_opt || (not @@ Variables.all_vars_are_valid man rval) then ( (* set lhs var to TOP *) Option.may (Variables.add_top tid) var_opt ; - ctx.local ) + man.local ) else let var = Option.get var_opt in @@ -938,11 +938,11 @@ module Spec : Analyses.MCPSpec = struct { d with pred = Pred.of_node @@ Env.node env } - let branch ctx (exp : exp) (tv : bool) : D.t = - if PthreadDomain.D.is_bot ctx.local - then ctx.local + let branch man (exp : exp) (tv : bool) : D.t = + if PthreadDomain.D.is_bot man.local + then man.local else - let env = Env.get ctx in + let env = Env.get man in let d = Env.d env in let tid = Int64.to_int @@ Option.get @@ Tid.to_int d.tid in let is_valid_var = @@ -981,7 +981,7 @@ module Spec : Analyses.MCPSpec = struct Tbls.NodeTbl.get (if tv then then_stmt else else_stmt).sid in Edges.add ~dst:intermediate_node env (Action.Cond pred_str) ; - { ctx.local with pred = Pred.of_node intermediate_node } + { man.local with pred = Pred.of_node intermediate_node } | _ -> failwith "branch: current_node is not an If" in @@ -996,7 +996,7 @@ module Spec : Analyses.MCPSpec = struct when is_valid_var lhostA && is_valid_var lhostB -> add_action @@ pred_str op (var_str lhostA) (var_str lhostB) | _ -> - ctx.local + man.local in let handle_unop x tv = match x with @@ -1004,7 +1004,7 @@ module Spec : Analyses.MCPSpec = struct let pred = (if tv then "" else "!") ^ var_str lhost in add_action pred | _ -> - ctx.local + man.local in match exp with | BinOp (op, a, b, _) -> @@ -1014,26 +1014,26 @@ module Spec : Analyses.MCPSpec = struct | Const (CInt _) -> handle_unop exp tv | _ -> - ctx.local + man.local - let body ctx (f : fundec) : D.t = + let body man (f : fundec) : D.t = (* enter is not called for spawned threads -> initialize them here *) - let context_hash = Int64.of_int (if not !AnalysisState.global_initialization then ControlSpecC.hash (ctx.control_context ()) else 37) in - { ctx.local with ctx = Ctx.of_int context_hash } + let context_hash = Int64.of_int (if not !AnalysisState.global_initialization then ControlSpecC.hash (man.control_context ()) else 37) in + { man.local with ctx = Ctx.of_int context_hash } - let return ctx (exp : exp option) (f : fundec) : D.t = ctx.local + let return man (exp : exp option) (f : fundec) : D.t = man.local - let enter ctx (lval : lval option) (f : fundec) (args : exp list) : + let enter man (lval : lval option) (f : fundec) (args : exp list) : (D.t * D.t) list = (* on function calls (also for main); not called for spawned threads *) - let d_caller = ctx.local in + let d_caller = man.local in let d_callee = - if D.is_bot ctx.local - then ctx.local + if D.is_bot man.local + then man.local else - { ctx.local with + { man.local with pred = Pred.of_node (MyCFG.Function f) ; ctx = Ctx.top () } @@ -1041,14 +1041,14 @@ module Spec : Analyses.MCPSpec = struct (* set predecessor set to start node of function *) [ (d_caller, d_callee) ] - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local + let combine_env man lval fexp f args fc au f_ask = + man.local - let combine_assign ctx (lval : lval option) fexp (f : fundec) (args : exp list) fc (au : D.t) (f_ask: Queries.ask) : D.t = - if D.any_is_bot ctx.local || D.any_is_bot au - then ctx.local + let combine_assign man (lval : lval option) fexp (f : fundec) (args : exp list) fc (au : D.t) (f_ask: Queries.ask) : D.t = + if D.any_is_bot man.local || D.any_is_bot au + then man.local else - let d_caller = ctx.local in + let d_caller = man.local in let d_callee = au in (* check if the callee has some relevant edges, i.e. advanced from the entry point * if not, we generate no edge for the call and keep the predecessors from the caller *) @@ -1059,7 +1059,7 @@ module Spec : Analyses.MCPSpec = struct (* set current node as new predecessor, since something interesting happend during the call *) { d_callee with pred = d_caller.pred; ctx = d_caller.ctx } else - let env = Env.get ctx in + let env = Env.get man in (* write out edges with call to f coming from all predecessor nodes of the caller *) ( if Ctx.to_int d_callee.ctx <> None then @@ -1073,11 +1073,11 @@ module Spec : Analyses.MCPSpec = struct } - let special ctx (lval : lval option) (f : varinfo) (arglist : exp list) : D.t = - if D.any_is_bot ctx.local then - ctx.local + let special man (lval : lval option) (f : varinfo) (arglist : exp list) : D.t = + if D.any_is_bot man.local then + man.local else - let env = Env.get ctx in + let env = Env.get man in let d = Env.d env in let tid = Int64.to_int @@ Option.get @@ Tid.to_int d.tid in @@ -1110,7 +1110,7 @@ module Spec : Analyses.MCPSpec = struct match (LibraryFunctions.find f).special arglist', f.vname, arglist with | ThreadCreate { thread; start_routine = func; _ }, _, _ -> let funs_ad = - let ad = ctx.ask (Queries.ReachableFrom func) in + let ad = man.ask (Queries.ReachableFrom func) in Queries.AD.filter (function | Queries.AD.Addr.Addr mval -> @@ -1128,13 +1128,13 @@ module Spec : Analyses.MCPSpec = struct let tasks = let f_d:PthreadDomain.D.t = { tid = Tid.of_int @@ Int64.of_int tid - ; pred = Pred.of_node (ctx.prev_node) + ; pred = Pred.of_node (man.prev_node) ; ctx = Ctx.top () } in Tasks.singleton (funs_ad, f_d) in - ctx.sideg tasks_var tasks ; + man.sideg tasks_var tasks ; in let thread_create tid = let fun_name = Variable.show thread_fun in @@ -1180,20 +1180,20 @@ module Spec : Analyses.MCPSpec = struct add_actions @@ List.map thread_create - @@ ExprEval.eval_ptr_id ctx thread Tbls.ThreadTidTbl.get + @@ ExprEval.eval_ptr_id man thread Tbls.ThreadTidTbl.get | ThreadJoin { thread; ret_var = thread_ret }, _, _ -> add_actions @@ List.map (fun tid -> Action.ThreadJoin tid) - @@ ExprEval.eval_var_id ctx thread Tbls.ThreadTidTbl.get + @@ ExprEval.eval_var_id man thread Tbls.ThreadTidTbl.get | Lock { lock = mutex; _ }, _, _ -> add_actions @@ List.map (fun mid -> Action.MutexLock mid) - @@ ExprEval.eval_ptr_id ctx mutex Tbls.MutexMidTbl.get + @@ ExprEval.eval_ptr_id man mutex Tbls.MutexMidTbl.get | Unlock mutex, _, _ -> add_actions @@ List.map (fun mid -> Action.MutexUnlock mid) - @@ ExprEval.eval_ptr_id ctx mutex Tbls.MutexMidTbl.get + @@ ExprEval.eval_ptr_id man mutex Tbls.MutexMidTbl.get | ThreadExit _, _ , _ -> add_action Action.ThreadExit | Abort, _, _ -> @@ -1202,22 +1202,22 @@ module Spec : Analyses.MCPSpec = struct (* TODO: reentrant mutex handling *) add_actions @@ List.map (fun mid -> Action.MutexInit mid) - @@ ExprEval.eval_ptr_id ctx mutex Tbls.MutexMidTbl.get + @@ ExprEval.eval_ptr_id man mutex Tbls.MutexMidTbl.get | Unknown, "pthread_cond_init", [ cond_var; cond_var_attr ] -> add_actions @@ List.map (fun id -> Action.CondVarInit id) - @@ ExprEval.eval_ptr_id ctx cond_var Tbls.CondVarIdTbl.get + @@ ExprEval.eval_ptr_id man cond_var Tbls.CondVarIdTbl.get | Broadcast cond_var, _, _ -> add_actions @@ List.map (fun id -> Action.CondVarBroadcast id) - @@ ExprEval.eval_ptr_id ctx cond_var Tbls.CondVarIdTbl.get + @@ ExprEval.eval_ptr_id man cond_var Tbls.CondVarIdTbl.get | Signal cond_var, _, _ -> add_actions @@ List.map (fun id -> Action.CondVarSignal id) - @@ ExprEval.eval_ptr_id ctx cond_var Tbls.CondVarIdTbl.get + @@ ExprEval.eval_ptr_id man cond_var Tbls.CondVarIdTbl.get | Wait {cond = cond_var; mutex = mutex}, _, _ -> - let cond_vars = ExprEval.eval_ptr ctx cond_var in - let mutex_vars = ExprEval.eval_ptr ctx mutex in + let cond_vars = ExprEval.eval_ptr man cond_var in + let mutex_vars = ExprEval.eval_ptr man mutex in let cond_var_action (v, m) = let open Action in CondVarWait @@ -1228,7 +1228,7 @@ module Spec : Analyses.MCPSpec = struct add_actions @@ List.map cond_var_action @@ List.cartesian_product cond_vars mutex_vars - | _ -> ctx.local + | _ -> man.local let startstate v = let open D in @@ -1238,9 +1238,9 @@ module Spec : Analyses.MCPSpec = struct (Ctx.top ()) - let threadenter ctx ~multiple lval f args = - let d : D.t = ctx.local in - let tasks = ctx.global tasks_var in + let threadenter man ~multiple lval f args = + let d : D.t = man.local in + let tasks = man.global tasks_var in (* TODO: optimize finding *) let tasks_f = let var_in_ad ad f = Queries.AD.exists (function @@ -1254,7 +1254,7 @@ module Spec : Analyses.MCPSpec = struct [ { f_d with pred = d.pred } ] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.top () diff --git a/src/analyses/locksetAnalysis.ml b/src/analyses/locksetAnalysis.ml index c73bd4703e..e781307868 100644 --- a/src/analyses/locksetAnalysis.ml +++ b/src/analyses/locksetAnalysis.ml @@ -18,7 +18,7 @@ struct include Analyses.ValueContexts(D) let startstate v = D.empty () - let threadenter ctx ~multiple lval f args = [D.empty ()] + let threadenter man ~multiple lval f args = [D.empty ()] let exitstate v = D.empty () end @@ -29,8 +29,8 @@ sig module G: Lattice.S module V: SpecSysVar - val add: (D.t, G.t, D.t, V.t) ctx -> LockDomain.AddrRW.t -> D.t - val remove: (D.t, G.t, D.t, V.t) ctx -> ValueDomain.Addr.t -> D.t + val add: (D.t, G.t, D.t, V.t) man -> LockDomain.AddrRW.t -> D.t + val remove: (D.t, G.t, D.t, V.t) man -> ValueDomain.Addr.t -> D.t end module MakeMay (Arg: MayArg) = @@ -41,25 +41,25 @@ struct module G = Arg.G module V = Arg.V - let event ctx e octx = + let event man e oman = match e with | Events.Lock l -> - Arg.add ctx l (* add all locks, including blob and unknown *) + Arg.add man l (* add all locks, including blob and unknown *) | Events.Unlock UnknownPtr -> - ctx.local (* don't remove any locks, including unknown itself *) - | Events.Unlock Addr (v, _) when ctx.ask (IsMultiple v) -> - ctx.local (* don't remove non-unique lock *) + man.local (* don't remove any locks, including unknown itself *) + | Events.Unlock Addr (v, _) when man.ask (IsMultiple v) -> + man.local (* don't remove non-unique lock *) | Events.Unlock l -> - Arg.remove ctx l (* remove definite lock or none in parallel if ambiguous *) + Arg.remove man l (* remove definite lock or none in parallel if ambiguous *) | _ -> - ctx.local + man.local end module type MustArg = sig include MayArg - val remove_all: (D.t, _, D.t, _) ctx -> D.t + val remove_all: (D.t, _, D.t, _) man -> D.t end module MakeMust (Arg: MustArg) = @@ -70,18 +70,18 @@ struct module G = Arg.G module V = Arg.V - let event ctx e octx = + let event man e oman = match e with | Events.Lock (UnknownPtr, _) -> - ctx.local (* don't add unknown lock *) - | Events.Lock (Addr (v, _), _) when ctx.ask (IsMultiple v) -> - ctx.local (* don't add non-unique lock *) + man.local (* don't add unknown lock *) + | Events.Lock (Addr (v, _), _) when man.ask (IsMultiple v) -> + man.local (* don't add non-unique lock *) | Events.Lock l -> - Arg.add ctx l (* add definite lock or none in parallel if ambiguous *) + Arg.add man l (* add definite lock or none in parallel if ambiguous *) | Events.Unlock UnknownPtr -> - Arg.remove_all ctx (* remove all locks *) + Arg.remove_all man (* remove all locks *) | Events.Unlock l -> - Arg.remove ctx l (* remove definite lock or all in parallel if ambiguous (blob lock is never added) *) + Arg.remove man l (* remove definite lock or all in parallel if ambiguous (blob lock is never added) *) | _ -> - ctx.local + man.local end diff --git a/src/analyses/loopTermination.ml b/src/analyses/loopTermination.ml index 66a50c17b7..364151a189 100644 --- a/src/analyses/loopTermination.ml +++ b/src/analyses/loopTermination.ml @@ -8,10 +8,10 @@ open TerminationPreprocessing let loop_counters : stmt VarToStmt.t ref = ref VarToStmt.empty (** Checks whether a variable can be bounded. *) -let check_bounded ctx varinfo = +let check_bounded man varinfo = let open IntDomain.IntDomTuple in let exp = Lval (Var varinfo, NoOffset) in - match ctx.ask (EvalInt exp) with + match man.ask (EvalInt exp) with | `Top -> false | `Lifted v -> not (is_top_of (ikind v) v) | `Bot -> failwith "Loop counter variable is Bot." @@ -46,14 +46,14 @@ struct (** Recognizes a call of [__goblint_bounded] to check the EvalInt of the * respective loop counter variable at that position. *) - let special ctx (lval : lval option) (f : varinfo) (arglist : exp list) = + let special man (lval : lval option) (f : varinfo) (arglist : exp list) = if !AnalysisState.postsolving then match f.vname, arglist with "__goblint_bounded", [Lval (Var loop_counter, NoOffset)] -> (try let loop_statement = find_loop ~loop_counter in - let is_bounded = check_bounded ctx loop_counter in - ctx.sideg () (G.add (`Lifted loop_statement) is_bounded (ctx.global ())); + let is_bounded = check_bounded man loop_counter in + man.sideg () (G.add (`Lifted loop_statement) is_bounded (man.global ())); (* In case the loop is not bounded, a warning is created. *) if not (is_bounded) then ( M.warn ~loc:(M.Location.CilLocation (Cilfacade.get_stmtLoc loop_statement)) ~category:Termination "The program might not terminate! (Loop analysis)" @@ -64,21 +64,21 @@ struct | _ -> () else () - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.MustTermLoop loop_statement -> - let multithreaded = ctx.ask Queries.IsEverMultiThreaded in + let multithreaded = man.ask Queries.IsEverMultiThreaded in (not multithreaded) - && (match G.find_opt (`Lifted loop_statement) (ctx.global ()) with + && (match G.find_opt (`Lifted loop_statement) (man.global ()) with Some b -> b | None -> false) | Queries.MustTermAllLoops -> - let multithreaded = ctx.ask Queries.IsEverMultiThreaded in + let multithreaded = man.ask Queries.IsEverMultiThreaded in if multithreaded then ( M.warn ~category:Termination "The program might not terminate! (Multithreaded)"; false) else - G.for_all (fun _ term_info -> term_info) (ctx.global ()) + G.for_all (fun _ term_info -> term_info) (man.global ()) | _ -> Queries.Result.top q end diff --git a/src/analyses/loopfreeCallstring.ml b/src/analyses/loopfreeCallstring.ml index d9760e58a0..9226b0b142 100644 --- a/src/analyses/loopfreeCallstring.ml +++ b/src/analyses/loopfreeCallstring.ml @@ -43,7 +43,7 @@ struct append fd (FundecSet.empty ()) [] current let startcontext () = [] - let context ctx fd x = append fd (ctx.context ()) + let context man fd x = append fd (man.context ()) end let _ = MCP.register_analysis (module Spec : MCPSpec) diff --git a/src/analyses/mCP.ml b/src/analyses/mCP.ml index f2f36b1360..0420931ffd 100644 --- a/src/analyses/mCP.ml +++ b/src/analyses/mCP.ml @@ -83,15 +83,15 @@ struct check_deps !activated; activated := topo_sort_an !activated; begin - match get_string_list "ana.ctx_sens" with - | [] -> (* use values of "ana.ctx_insens" (blacklist) *) - let cont_inse = map' find_id @@ get_string_list "ana.ctx_insens" in - activated_ctx_sens := List.filter (fun (n, _) -> not (List.mem n cont_inse)) !activated; - | sens -> (* use values of "ana.ctx_sens" (whitelist) *) + match get_string_list "ana.man_sens" with + | [] -> (* use values of "ana.man_insens" (blacklist) *) + let cont_inse = map' find_id @@ get_string_list "ana.man_insens" in + activated_context_sens := List.filter (fun (n, _) -> not (List.mem n cont_inse)) !activated; + | sens -> (* use values of "ana.man_sens" (whitelist) *) let cont_sens = map' find_id @@ sens in - activated_ctx_sens := List.filter (fun (n, _) -> List.mem n cont_sens) !activated; + activated_context_sens := List.filter (fun (n, _) -> List.mem n cont_sens) !activated; end; - act_cont_sens := Set.of_list (List.map (fun (n,p) -> n) !activated_ctx_sens); + act_cont_sens := Set.of_list (List.map (fun (n,p) -> n) !activated_context_sens); activated_path_sens := List.filter (fun (n, _) -> List.mem n !path_sens) !activated; match marshal with | Some marshal -> @@ -147,16 +147,16 @@ struct f ((k,v::a')::a) b in f [] xs - let do_spawns ctx (xs:(varinfo * (lval option * exp list * bool)) list) = + let do_spawns man (xs:(varinfo * (lval option * exp list * bool)) list) = let spawn_one v d = - List.iter (fun (lval, args, multiple) -> ctx.spawn ~multiple lval v args) d + List.iter (fun (lval, args, multiple) -> man.spawn ~multiple lval v args) d in if get_bool "exp.single-threaded" then M.msg_final Error ~category:Unsound "Thread not spawned" else iter (uncurry spawn_one) @@ group_assoc_eq Basetype.Variables.equal xs - let do_sideg ctx (xs:(V.t * (WideningTokenLifter.TS.t * G.t)) list) = + let do_sideg man (xs:(V.t * (WideningTokenLifter.TS.t * G.t)) list) = let side_one v dts = let side_one_ts ts d = (* Do side effects with the tokens that were active at the time. @@ -164,7 +164,7 @@ struct let old_side_tokens = !WideningTokenLifter.side_tokens in WideningTokenLifter.side_tokens := ts; Fun.protect (fun () -> - ctx.sideg v @@ fold_left G.join (G.bot ()) d + man.sideg v @@ fold_left G.join (G.bot ()) d ) ~finally:(fun () -> WideningTokenLifter.side_tokens := old_side_tokens ) @@ -173,54 +173,54 @@ struct in iter (uncurry side_one) @@ group_assoc_eq V.equal xs - let rec do_splits ctx pv (xs:(int * (Obj.t * Events.t list)) list) emits = + let rec do_splits man pv (xs:(int * (Obj.t * Events.t list)) list) emits = let split_one n (d,emits') = let nv = assoc_replace (n,d) pv in (* Do split-specific emits before general emits. [emits] and [do_emits] are in reverse order. [emits'] is in normal order. *) - ctx.split (do_emits ctx (emits @ List.rev emits') nv false) [] + man.split (do_emits man (emits @ List.rev emits') nv false) [] in iter (uncurry split_one) xs - and do_emits ctx emits xs dead = - let octx = ctx in - let ctx_with_local ctx local' = - (* let rec ctx' = - { ctx with + and do_emits man emits xs dead = + let oman = man in + let man_with_local man local' = + (* let rec man' = + { man with local = local'; ask = ask - } - and ask q = query ctx' q - in - ctx' *) - {ctx with local = local'} + } + and ask q = query man' q + in + man' *) + {man with local = local'} in - let do_emit ctx = function + let do_emit man = function | Events.SplitBranch (exp, tv) -> - ctx_with_local ctx (branch ctx exp tv) + man_with_local man (branch man exp tv) | Events.Assign {lval; exp} -> - ctx_with_local ctx (assign ctx lval exp) + man_with_local man (assign man lval exp) | e -> let spawns = ref [] in let splits = ref [] in - let sides = ref [] in (* why do we need to collect these instead of calling ctx.sideg directly? *) + let sides = ref [] in (* why do we need to collect these instead of calling man.sideg directly? *) let emits = ref [] in - let ctx'' = outer_ctx "do_emits" ~spawns ~sides ~emits ctx in - let octx'' = outer_ctx "do_emits" ~spawns ~sides ~emits octx in + let man'' = outer_man "do_emits" ~spawns ~sides ~emits man in + let oman'' = outer_man "do_emits" ~spawns ~sides ~emits oman in let f post_all (n,(module S:MCPSpec),(d,od)) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "do_emits" ~splits ~post_all ctx'' n d in - let octx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "do_emits" ~splits ~post_all octx'' n od in - n, Obj.repr @@ S.event ctx' e octx' + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "do_emits" ~splits ~post_all man'' n d in + let oman' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "do_emits" ~splits ~post_all oman'' n od in + n, Obj.repr @@ S.event man' e oman' in - if M.tracing then M.traceli "event" "%a\n before: %a" Events.pretty e D.pretty ctx.local; - let d, q = map_deadcode f @@ spec_list2 ctx.local octx.local in + if M.tracing then M.traceli "event" "%a\n before: %a" Events.pretty e D.pretty man.local; + let d, q = map_deadcode f @@ spec_list2 man.local oman.local in if M.tracing then M.traceu "event" "%a\n after:%a" Events.pretty e D.pretty d; - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in - if q then raise Deadcode else ctx_with_local ctx d + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in + if q then raise Deadcode else man_with_local man d in if M.tracing then M.traceli "event" "do_emits:"; let emits = @@ -230,40 +230,40 @@ struct emits in (* [emits] is in reverse order. *) - let ctx' = List.fold_left do_emit (ctx_with_local ctx xs) (List.rev emits) in + let man' = List.fold_left do_emit (man_with_local man xs) (List.rev emits) in if M.tracing then M.traceu "event" ""; - ctx'.local + man'.local - and context ctx fd x = - let ctx'' = outer_ctx "context_computation" ctx in + and context man fd x = + let man'' = outer_man "context_computation" man in let x = spec_list x in filter_map (fun (n,(module S:MCPSpec),d) -> if Set.is_empty !act_cont_sens || not (Set.mem n !act_cont_sens) then (*n is insensitive*) None else - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "context_computation" ctx'' n d in - Some (n, Obj.repr @@ S.context ctx' fd (Obj.obj d)) + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "context_computation" man'' n d in + Some (n, Obj.repr @@ S.context man' fd (Obj.obj d)) ) x - and branch (ctx:(D.t, G.t, C.t, V.t) ctx) (e:exp) (tv:bool) = + and branch (man:(D.t, G.t, C.t, V.t) man) (e:exp) (tv:bool) = let spawns = ref [] in let splits = ref [] in - let sides = ref [] in (* why do we need to collect these instead of calling ctx.sideg directly? *) + let sides = ref [] in (* why do we need to collect these instead of calling man.sideg directly? *) let emits = ref [] in - let ctx'' = outer_ctx "branch" ~spawns ~sides ~emits ctx in + let man'' = outer_man "branch" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "branch" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.branch ctx' e tv + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "branch" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.branch man' e tv in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d (* Explicitly polymorphic type required here for recursive GADT call in ask. *) - and query': type a. querycache:Obj.t Queries.Hashtbl.t -> Queries.Set.t -> (D.t, G.t, C.t, V.t) ctx -> a Queries.t -> a Queries.result = fun ~querycache asked ctx q -> + and query': type a. querycache:Obj.t Queries.Hashtbl.t -> Queries.Set.t -> (D.t, G.t, C.t, V.t) man -> a Queries.t -> a Queries.result = fun ~querycache asked man q -> let anyq = Queries.Any q in if M.tracing then M.traceli "query" "query %a" Queries.Any.pretty anyq; let r = match Queries.Hashtbl.find_option querycache anyq with @@ -279,18 +279,18 @@ struct else let asked' = Queries.Set.add anyq asked in let sides = ref [] in - let ctx'' = outer_ctx "query" ~sides ctx in + let man'' = outer_man "query" ~sides man in let f ~q a (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "query" ctx'' n d in + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "query" man'' n d in (* sideg is discouraged in query, because they would bypass sides grouping in other transfer functions. See https://github.com/goblint/analyzer/pull/214. *) - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = - { ctx' with - ask = (fun (type b) (q: b Queries.t) -> query' ~querycache asked' ctx q) + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = + { man' with + ask = (fun (type b) (q: b Queries.t) -> query' ~querycache asked' man q) } in (* meet results so that precision from all analyses is combined *) - let res = S.query ctx' q in + let res = S.query man' q in if M.tracing then M.trace "queryanswers" "analysis %s query %a -> answer %a" (S.name ()) Queries.Any.pretty anyq Result.pretty res; Result.meet a @@ res in @@ -298,40 +298,40 @@ struct | Queries.WarnGlobal g -> (* WarnGlobal is special: it only goes to corresponding analysis and the argument variant is unlifted for it *) let (n, g): V.t = Obj.obj g in - f ~q:(WarnGlobal (Obj.repr g)) (Result.top ()) (n, spec n, assoc n ctx.local) + f ~q:(WarnGlobal (Obj.repr g)) (Result.top ()) (n, spec n, assoc n man.local) | Queries.InvariantGlobal g -> (* InvariantGlobal is special: it only goes to corresponding analysis and the argument variant is unlifted for it *) let (n, g): V.t = Obj.obj g in - f ~q:(InvariantGlobal (Obj.repr g)) (Result.top ()) (n, spec n, assoc n ctx.local) + f ~q:(InvariantGlobal (Obj.repr g)) (Result.top ()) (n, spec n, assoc n man.local) | Queries.YamlEntryGlobal (g, task) -> (* YamlEntryGlobal is special: it only goes to corresponding analysis and the argument variant is unlifted for it *) let (n, g): V.t = Obj.obj g in - f ~q:(YamlEntryGlobal (Obj.repr g, task)) (Result.top ()) (n, spec n, assoc n ctx.local) + f ~q:(YamlEntryGlobal (Obj.repr g, task)) (Result.top ()) (n, spec n, assoc n man.local) | Queries.PartAccess a -> - Obj.repr (access ctx a) + Obj.repr (access man a) | Queries.IterSysVars (vq, fi) -> (* IterSysVars is special: argument function is lifted for each analysis *) iter (fun ((n,(module S:MCPSpec),d) as t) -> let fi' x = fi (Obj.repr (v_of n x)) in let q' = Queries.IterSysVars (vq, fi') in f ~q:q' () t - ) @@ spec_list ctx.local + ) @@ spec_list man.local (* | EvalInt e -> (* TODO: only query others that actually respond to EvalInt *) (* 2x speed difference on SV-COMP nla-digbench-scaling/ps6-ll_valuebound5.c *) - f (Result.top ()) (!base_id, spec !base_id, assoc !base_id ctx.local) *) + f (Result.top ()) (!base_id, spec !base_id, assoc !base_id man.local) *) | Queries.DYojson -> - `Lifted (D.to_yojson ctx.local) + `Lifted (D.to_yojson man.local) | Queries.GasExhausted f -> if (get_int "ana.context.gas_value" >= 0) then (* There is a lifter above this that will answer it, save to ask *) - ctx.ask (Queries.GasExhausted f) + man.ask (Queries.GasExhausted f) else (* Abort to avoid infinite recursion *) false | _ -> - let r = fold_left (f ~q) (Result.top ()) @@ spec_list ctx.local in - do_sideg ctx !sides; + let r = fold_left (f ~q) (Result.top ()) @@ spec_list man.local in + do_sideg man !sides; Queries.Hashtbl.replace querycache anyq (Obj.repr r); r in @@ -341,19 +341,19 @@ struct ); r - and query: type a. (D.t, G.t, C.t, V.t) ctx -> a Queries.t -> a Queries.result = fun ctx q -> + and query: type a. (D.t, G.t, C.t, V.t) man -> a Queries.t -> a Queries.result = fun man q -> let querycache = Queries.Hashtbl.create 13 in - query' ~querycache Queries.Set.empty ctx q + query' ~querycache Queries.Set.empty man q - and access (ctx:(D.t, G.t, C.t, V.t) ctx) a: MCPAccess.A.t = - let ctx'' = outer_ctx "access" ctx in + and access (man:(D.t, G.t, C.t, V.t) man) a: MCPAccess.A.t = + let man'' = outer_man "access" man in let f (n, (module S: MCPSpec), d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "access" ctx'' n d in - (n, Obj.repr (S.access ctx' a)) + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "access" man'' n d in + (n, Obj.repr (S.access man' a)) in - BatList.map f (spec_list ctx.local) (* map without deadcode *) + BatList.map f (spec_list man.local) (* map without deadcode *) - and outer_ctx tfname ?spawns ?sides ?emits ctx = + and outer_man tfname ?spawns ?sides ?emits man = let spawn = match spawns with | Some spawns -> (fun ?(multiple=false) l v a -> spawns := (v,(l,a,multiple)) :: !spawns) | None -> (fun ?(multiple=false) v d -> failwith ("Cannot \"spawn\" in " ^ tfname ^ " context.")) @@ -368,183 +368,183 @@ struct in let querycache = Queries.Hashtbl.create 13 in (* TODO: make rec? *) - { ctx with - ask = (fun (type a) (q: a Queries.t) -> query' ~querycache Queries.Set.empty ctx q) + { man with + ask = (fun (type a) (q: a Queries.t) -> query' ~querycache Queries.Set.empty man q) ; emit ; spawn ; sideg } (* Explicitly polymorphic type required here for recursive call in branch. *) - and inner_ctx: type d g c v. string -> ?splits:(int * (Obj.t * Events.t list)) list ref -> ?post_all:(int * Obj.t) list -> (D.t, G.t, C.t, V.t) ctx -> int -> Obj.t -> (d, g, c, v) ctx = fun tfname ?splits ?(post_all=[]) ctx n d -> + and inner_man: type d g c v. string -> ?splits:(int * (Obj.t * Events.t list)) list ref -> ?post_all:(int * Obj.t) list -> (D.t, G.t, C.t, V.t) man -> int -> Obj.t -> (d, g, c, v) man = fun tfname ?splits ?(post_all=[]) man n d -> let split = match splits with | Some splits -> (fun d es -> splits := (n,(Obj.repr d,es)) :: !splits) | None -> (fun _ _ -> failwith ("Cannot \"split\" in " ^ tfname ^ " context.")) in - { ctx with + { man with local = Obj.obj d - ; context = (fun () -> ctx.context () |> assoc n |> Obj.obj) - ; global = (fun v -> ctx.global (v_of n v) |> g_to n |> Obj.obj) + ; context = (fun () -> man.context () |> assoc n |> Obj.obj) + ; global = (fun v -> man.global (v_of n v) |> g_to n |> Obj.obj) ; split - ; sideg = (fun v g -> ctx.sideg (v_of n v) (g_of n g)) + ; sideg = (fun v g -> man.sideg (v_of n v) (g_of n g)) } - and assign (ctx:(D.t, G.t, C.t, V.t) ctx) l e = + and assign (man:(D.t, G.t, C.t, V.t) man) l e = let spawns = ref [] in let splits = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "assign" ~spawns ~sides ~emits ctx in + let man'' = outer_man "assign" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "assign" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.assign ctx' l e + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "assign" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.assign man' l e in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let vdecl (ctx:(D.t, G.t, C.t, V.t) ctx) v = + let vdecl (man:(D.t, G.t, C.t, V.t) man) v = let spawns = ref [] in let splits = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "vdecl" ~spawns ~sides ~emits ctx in + let man'' = outer_man "vdecl" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "vdecl" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.vdecl ctx' v + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "vdecl" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.vdecl man' v in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let body (ctx:(D.t, G.t, C.t, V.t) ctx) f = + let body (man:(D.t, G.t, C.t, V.t) man) f = let spawns = ref [] in let splits = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "body" ~spawns ~sides ~emits ctx in + let man'' = outer_man "body" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "body" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.body ctx' f + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "body" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.body man' f in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let return (ctx:(D.t, G.t, C.t, V.t) ctx) e f = + let return (man:(D.t, G.t, C.t, V.t) man) e f = let spawns = ref [] in let splits = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "return" ~spawns ~sides ~emits ctx in + let man'' = outer_man "return" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "return" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.return ctx' e f + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "return" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.return man' e f in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let asm (ctx:(D.t, G.t, C.t, V.t) ctx) = + let asm (man:(D.t, G.t, C.t, V.t) man) = let spawns = ref [] in let splits = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "asm" ~spawns ~sides ~emits ctx in + let man'' = outer_man "asm" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "asm" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.asm ctx' + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "asm" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.asm man' in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let skip (ctx:(D.t, G.t, C.t, V.t) ctx) = + let skip (man:(D.t, G.t, C.t, V.t) man) = let spawns = ref [] in let splits = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "skip" ~spawns ~sides ~emits ctx in + let man'' = outer_man "skip" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "skip" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.skip ctx' + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "skip" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.skip man' in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let special (ctx:(D.t, G.t, C.t, V.t) ctx) r f a = + let special (man:(D.t, G.t, C.t, V.t) man) r f a = let spawns = ref [] in let splits = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "special" ~spawns ~sides ~emits ctx in + let man'' = outer_man "special" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "special" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.special ctx' r f a + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "special" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.special man' r f a in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let sync (ctx:(D.t, G.t, C.t, V.t) ctx) reason = + let sync (man:(D.t, G.t, C.t, V.t) man) reason = let spawns = ref [] in let splits = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "sync" ~spawns ~sides ~emits ctx in + let man'' = outer_man "sync" ~spawns ~sides ~emits man in let f post_all (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "sync" ~splits ~post_all ctx'' n d in - n, Obj.repr @@ S.sync ctx' reason + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "sync" ~splits ~post_all man'' n d in + n, Obj.repr @@ S.sync man' reason in - let d, q = map_deadcode f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; - do_splits ctx d !splits !emits; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; + do_splits man d !splits !emits; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let enter (ctx:(D.t, G.t, C.t, V.t) ctx) r f a = + let enter (man:(D.t, G.t, C.t, V.t) man) r f a = let spawns = ref [] in let sides = ref [] in - let ctx'' = outer_ctx "enter" ~spawns ~sides ctx in + let man'' = outer_man "enter" ~spawns ~sides man in let f (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "enter" ctx'' n d in - map (fun (c,d) -> ((n, Obj.repr c), (n, Obj.repr d))) @@ S.enter ctx' r f a + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "enter" man'' n d in + map (fun (c,d) -> ((n, Obj.repr c), (n, Obj.repr d))) @@ S.enter man' r f a in - let css = map f @@ spec_list ctx.local in - do_sideg ctx !sides; - do_spawns ctx !spawns; + let css = map f @@ spec_list man.local in + do_sideg man !sides; + do_spawns man !spawns; map (fun xs -> (topo_sort_an @@ map fst xs, topo_sort_an @@ map snd xs)) @@ n_cartesian_product css - let combine_env (ctx:(D.t, G.t, C.t, V.t) ctx) r fe f a fc fd f_ask = + let combine_env (man:(D.t, G.t, C.t, V.t) man) r fe f a fc fd f_ask = let spawns = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "combine_env" ~spawns ~sides ~emits ctx in + let man'' = outer_man "combine_env" ~spawns ~sides ~emits man in (* Like spec_list2 but for three lists. Tail recursion like map3_rev would have. Due to context-insensitivity, second list is optional and may only contain a subset of analyses in the same order, so some skipping needs to happen to align the three lists. @@ -560,20 +560,20 @@ struct | _, _, _ -> invalid_arg "MCP.spec_list3_rev_acc" in let f post_all (n,(module S:MCPSpec),(d,fc,fd)) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "combine_env" ~post_all ctx'' n d in - n, Obj.repr @@ S.combine_env ctx' r fe f a (Option.map Obj.obj fc) (Obj.obj fd) f_ask + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "combine_env" ~post_all man'' n d in + n, Obj.repr @@ S.combine_env man' r fe f a (Option.map Obj.obj fc) (Obj.obj fd) f_ask in - let d, q = map_deadcode f @@ List.rev @@ spec_list3_rev_acc [] ctx.local fc fd in - do_sideg ctx !sides; - do_spawns ctx !spawns; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ List.rev @@ spec_list3_rev_acc [] man.local fc fd in + do_sideg man !sides; + do_spawns man !spawns; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let combine_assign (ctx:(D.t, G.t, C.t, V.t) ctx) r fe f a fc fd f_ask = + let combine_assign (man:(D.t, G.t, C.t, V.t) man) r fe f a fc fd f_ask = let spawns = ref [] in let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "combine_assign" ~spawns ~sides ~emits ctx in + let man'' = outer_man "combine_assign" ~spawns ~sides ~emits man in (* Like spec_list2 but for three lists. Tail recursion like map3_rev would have. Due to context-insensitivity, second list is optional and may only contain a subset of analyses in the same order, so some skipping needs to happen to align the three lists. @@ -589,45 +589,45 @@ struct | _, _, _ -> invalid_arg "MCP.spec_list3_rev_acc" in let f post_all (n,(module S:MCPSpec),(d,fc,fd)) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "combine_assign" ~post_all ctx'' n d in - n, Obj.repr @@ S.combine_assign ctx' r fe f a (Option.map Obj.obj fc) (Obj.obj fd) f_ask + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "combine_assign" ~post_all man'' n d in + n, Obj.repr @@ S.combine_assign man' r fe f a (Option.map Obj.obj fc) (Obj.obj fd) f_ask in - let d, q = map_deadcode f @@ List.rev @@ spec_list3_rev_acc [] ctx.local fc fd in - do_sideg ctx !sides; - do_spawns ctx !spawns; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ List.rev @@ spec_list3_rev_acc [] man.local fc fd in + do_sideg man !sides; + do_spawns man !spawns; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let threadenter (ctx:(D.t, G.t, C.t, V.t) ctx) ~multiple lval f a = + let threadenter (man:(D.t, G.t, C.t, V.t) man) ~multiple lval f a = let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "threadenter" ~sides ~emits ctx in + let man'' = outer_man "threadenter" ~sides ~emits man in let f (n,(module S:MCPSpec),d) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "threadenter" ctx'' n d in - map (fun d -> (n, Obj.repr d)) @@ (S.threadenter ~multiple) ctx' lval f a + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "threadenter" man'' n d in + map (fun d -> (n, Obj.repr d)) @@ (S.threadenter ~multiple) man' lval f a in - let css = map f @@ spec_list ctx.local in - do_sideg ctx !sides; + let css = map f @@ spec_list man.local in + do_sideg man !sides; (* TODO: this do_emits is now different from everything else *) - map (fun d -> do_emits ctx !emits d false) @@ map topo_sort_an @@ n_cartesian_product css + map (fun d -> do_emits man !emits d false) @@ map topo_sort_an @@ n_cartesian_product css - let threadspawn (ctx:(D.t, G.t, C.t, V.t) ctx) ~multiple lval f a fctx = + let threadspawn (man:(D.t, G.t, C.t, V.t) man) ~multiple lval f a fman = let sides = ref [] in let emits = ref [] in - let ctx'' = outer_ctx "threadspawn" ~sides ~emits ctx in - let fctx'' = outer_ctx "threadspawn" ~sides ~emits fctx in + let man'' = outer_man "threadspawn" ~sides ~emits man in + let fman'' = outer_man "threadspawn" ~sides ~emits fman in let f post_all (n,(module S:MCPSpec),(d,fd)) = - let ctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "threadspawn" ~post_all ctx'' n d in - let fctx' : (S.D.t, S.G.t, S.C.t, S.V.t) ctx = inner_ctx "threadspawn" ~post_all fctx'' n fd in - n, Obj.repr @@ S.threadspawn ~multiple ctx' lval f a fctx' + let man' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "threadspawn" ~post_all man'' n d in + let fman' : (S.D.t, S.G.t, S.C.t, S.V.t) man = inner_man "threadspawn" ~post_all fman'' n fd in + n, Obj.repr @@ S.threadspawn ~multiple man' lval f a fman' in - let d, q = map_deadcode f @@ spec_list2 ctx.local fctx.local in - do_sideg ctx !sides; - let d = do_emits ctx !emits d q in + let d, q = map_deadcode f @@ spec_list2 man.local fman.local in + do_sideg man !sides; + let d = do_emits man !emits d q in if q then raise Deadcode else d - let event (ctx:(D.t, G.t, C.t, V.t) ctx) e _ = do_emits ctx [e] ctx.local false + let event (man:(D.t, G.t, C.t, V.t) man) e _ = do_emits man [e] man.local false (* Just to satisfy signature *) - let paths_as_set ctx = [ctx.local] + let paths_as_set man = [man.local] end diff --git a/src/analyses/mCPRegistry.ml b/src/analyses/mCPRegistry.ml index 43ccd690f2..991af6b6af 100644 --- a/src/analyses/mCPRegistry.ml +++ b/src/analyses/mCPRegistry.ml @@ -17,7 +17,7 @@ type spec_modules = { name : string ; path : (module DisjointDomain.Representative) } let activated : (int * spec_modules) list ref = ref [] -let activated_ctx_sens: (int * spec_modules) list ref = ref [] +let activated_context_sens: (int * spec_modules) list ref = ref [] let activated_path_sens: (int * spec_modules) list ref = ref [] let registered: (int, spec_modules) Hashtbl.t = Hashtbl.create 100 let registered_name: (string, int) Hashtbl.t = Hashtbl.create 100 @@ -437,7 +437,7 @@ end module ContextListSpec : DomainListPrintableSpec = struct let assoc_dom n = (find_spec n).cont - let domain_list () = List.map (fun (n,p) -> n, p.cont) !activated_ctx_sens + let domain_list () = List.map (fun (n,p) -> n, p.cont) !activated_context_sens end module VarListSpec : DomainListSysVarSpec = diff --git a/src/analyses/mHPAnalysis.ml b/src/analyses/mHPAnalysis.ml index e9c3364c9f..a44e5340ac 100644 --- a/src/analyses/mHPAnalysis.ml +++ b/src/analyses/mHPAnalysis.ml @@ -18,7 +18,7 @@ struct not (ConcDomain.ThreadSet.is_empty must_joined)) end - let access ctx _: MHP.t = MHP.current (Analyses.ask_of_ctx ctx) + let access man _: MHP.t = MHP.current (Analyses.ask_of_man man) end let _ = diff --git a/src/analyses/mallocFresh.ml b/src/analyses/mallocFresh.ml index 020046c678..c226d7e6ce 100644 --- a/src/analyses/mallocFresh.ml +++ b/src/analyses/mallocFresh.ml @@ -26,23 +26,23 @@ struct ) ad -> D.empty () | _ -> local - let assign ctx lval rval = - assign_lval (Analyses.ask_of_ctx ctx) lval ctx.local + let assign man lval rval = + assign_lval (Analyses.ask_of_man man) lval man.local - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local (* keep local as opposed to IdentitySpec *) + let combine_env man lval fexp f args fc au f_ask = + man.local (* keep local as opposed to IdentitySpec *) - let combine_assign ctx lval f fd args context f_local (f_ask: Queries.ask) = + let combine_assign man lval f fd args context f_local (f_ask: Queries.ask) = match lval with | None -> f_local - | Some lval -> assign_lval (Analyses.ask_of_ctx ctx) lval f_local + | Some lval -> assign_lval (Analyses.ask_of_man man) lval f_local - let special ctx lval f args = + let special man lval f args = let desc = LibraryFunctions.find f in let alloc_var on_stack = - match ctx.ask (AllocVar {on_stack = on_stack}) with - | `Lifted var -> D.add var ctx.local - | _ -> ctx.local + match man.ask (AllocVar {on_stack = on_stack}) with + | `Lifted var -> D.add var man.local + | _ -> man.local in match desc.special args with | Malloc _ @@ -51,13 +51,13 @@ struct | Alloca _ -> alloc_var true | _ -> match lval with - | None -> ctx.local - | Some lval -> assign_lval (Analyses.ask_of_ctx ctx) lval ctx.local + | None -> man.local + | Some lval -> assign_lval (Analyses.ask_of_man man) lval man.local - let threadenter ctx ~multiple lval f args = + let threadenter man ~multiple lval f args = [D.empty ()] - let threadspawn ctx ~multiple lval f args fctx = + let threadspawn man ~multiple lval f args fman = D.empty () module A = @@ -67,10 +67,10 @@ struct let may_race f1 f2 = not (f1 || f2) let should_print f = f end - let access ctx (a: Queries.access) = + let access man (a: Queries.access) = match a with | Memory {var_opt = Some v; _} -> - D.mem v ctx.local + D.mem v man.local | _ -> false end diff --git a/src/analyses/malloc_null.ml b/src/analyses/malloc_null.ml index 5e6225caac..07f798583e 100644 --- a/src/analyses/malloc_null.ml +++ b/src/analyses/malloc_null.ml @@ -145,78 +145,78 @@ struct *) (* One step tf-s *) - let assign ctx (lval:lval) (rval:exp) : D.t = - warn_deref_exp (Analyses.ask_of_ctx ctx) ctx.local (Lval lval) ; - warn_deref_exp (Analyses.ask_of_ctx ctx) ctx.local rval; - match get_concrete_exp rval ctx.global ctx.local, get_concrete_lval (Analyses.ask_of_ctx ctx) lval with - | Some rv, Some mval when might_be_null (Analyses.ask_of_ctx ctx) rv ctx.global ctx.local -> - D.add (Addr.of_mval mval) ctx.local - | _ -> ctx.local + let assign man (lval:lval) (rval:exp) : D.t = + warn_deref_exp (Analyses.ask_of_man man) man.local (Lval lval) ; + warn_deref_exp (Analyses.ask_of_man man) man.local rval; + match get_concrete_exp rval man.global man.local, get_concrete_lval (Analyses.ask_of_man man) lval with + | Some rv, Some mval when might_be_null (Analyses.ask_of_man man) rv man.global man.local -> + D.add (Addr.of_mval mval) man.local + | _ -> man.local - let branch ctx (exp:exp) (tv:bool) : D.t = - warn_deref_exp (Analyses.ask_of_ctx ctx) ctx.local exp; - ctx.local + let branch man (exp:exp) (tv:bool) : D.t = + warn_deref_exp (Analyses.ask_of_man man) man.local exp; + man.local - let body ctx (f:fundec) : D.t = - ctx.local + let body man (f:fundec) : D.t = + man.local let return_addr_ = ref Addr.NullPtr let return_addr () = !return_addr_ - let return ctx (exp:exp option) (f:fundec) : D.t = + let return man (exp:exp option) (f:fundec) : D.t = let remove_var x v = List.fold_right D.remove (to_addrs v) x in - let nst = List.fold_left remove_var ctx.local (f.slocals @ f.sformals) in + let nst = List.fold_left remove_var man.local (f.slocals @ f.sformals) in match exp with | Some ret -> - warn_deref_exp (Analyses.ask_of_ctx ctx) ctx.local ret; - begin match get_concrete_exp ret ctx.global ctx.local with - | Some ev when might_be_null (Analyses.ask_of_ctx ctx) ev ctx.global ctx.local -> + warn_deref_exp (Analyses.ask_of_man man) man.local ret; + begin match get_concrete_exp ret man.global man.local with + | Some ev when might_be_null (Analyses.ask_of_man man) ev man.global man.local -> D.add (return_addr ()) nst | _ -> nst end | None -> nst (* Function calls *) - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - let nst = remove_unreachable (Analyses.ask_of_ctx ctx) args ctx.local in - Option.iter (fun x -> warn_deref_exp (Analyses.ask_of_ctx ctx) ctx.local (Lval x)) lval; - List.iter (warn_deref_exp (Analyses.ask_of_ctx ctx) ctx.local) args; - [ctx.local,nst] + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let nst = remove_unreachable (Analyses.ask_of_man man) args man.local in + Option.iter (fun x -> warn_deref_exp (Analyses.ask_of_man man) man.local (Lval x)) lval; + List.iter (warn_deref_exp (Analyses.ask_of_man man) man.local) args; + [man.local,nst] - let combine_env ctx lval fexp f args fc au f_ask = - let cal_st = remove_unreachable (Analyses.ask_of_ctx ctx) args ctx.local in - D.union (D.remove (return_addr ()) au) (D.diff ctx.local cal_st) + let combine_env man lval fexp f args fc au f_ask = + let cal_st = remove_unreachable (Analyses.ask_of_man man) args man.local in + D.union (D.remove (return_addr ()) au) (D.diff man.local cal_st) - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = match lval, D.mem (return_addr ()) au with | Some lv, true -> - begin match get_concrete_lval (Analyses.ask_of_ctx ctx) lv with - | Some mval -> D.add (Addr.of_mval mval) ctx.local - | _ -> ctx.local + begin match get_concrete_lval (Analyses.ask_of_man man) lv with + | Some mval -> D.add (Addr.of_mval mval) man.local + | _ -> man.local end - | _ -> ctx.local + | _ -> man.local - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - Option.iter (fun x -> warn_deref_exp (Analyses.ask_of_ctx ctx) ctx.local (Lval x)) lval; - List.iter (warn_deref_exp (Analyses.ask_of_ctx ctx) ctx.local) arglist; + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + Option.iter (fun x -> warn_deref_exp (Analyses.ask_of_man man) man.local (Lval x)) lval; + List.iter (warn_deref_exp (Analyses.ask_of_man man) man.local) arglist; let desc = LibraryFunctions.find f in match desc.special arglist, lval with | Malloc _, Some lv -> begin - match get_concrete_lval (Analyses.ask_of_ctx ctx) lv with + match get_concrete_lval (Analyses.ask_of_man man) lv with | Some mval -> - ctx.split ctx.local [Events.SplitBranch ((Lval lv), true)]; - ctx.split (D.add (Addr.of_mval mval) ctx.local) [Events.SplitBranch ((Lval lv), false)]; + man.split man.local [Events.SplitBranch ((Lval lv), true)]; + man.split (D.add (Addr.of_mval mval) man.local) [Events.SplitBranch ((Lval lv), false)]; raise Analyses.Deadcode - | _ -> ctx.local + | _ -> man.local end - | _ -> ctx.local + | _ -> man.local let name () = "malloc_null" let startstate v = D.empty () - let threadenter ctx ~multiple lval f args = [D.empty ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.empty ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.empty () let init marshal = diff --git a/src/analyses/mayLocks.ml b/src/analyses/mayLocks.ml index 853005de87..13806ac59d 100644 --- a/src/analyses/mayLocks.ml +++ b/src/analyses/mayLocks.ml @@ -10,34 +10,34 @@ struct module G = DefaultSpec.G module V = DefaultSpec.V - let add ctx (l,r) = - if D.mem l ctx.local then + let add man (l,r) = + if D.mem l man.local then let default () = M.warn ~category:M.Category.Behavior.Undefined.double_locking "Acquiring a (possibly non-recursive) mutex that may be already held"; - ctx.local + man.local in match D.Addr.to_mval l with | Some (v,o) -> - (let mtype = ctx.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) in + (let mtype = man.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) in match mtype with - | `Lifted MutexAttrDomain.MutexKind.Recursive -> ctx.local + | `Lifted MutexAttrDomain.MutexKind.Recursive -> man.local | `Lifted MutexAttrDomain.MutexKind.NonRec -> M.warn ~category:M.Category.Behavior.Undefined.double_locking "Acquiring a non-recursive mutex that may be already held"; - ctx.local + man.local | _ -> default ()) | _ -> default () else - D.add l ctx.local + D.add l man.local - let remove ctx l = - if not (D.mem l ctx.local) then M.warn "Releasing a mutex that is definitely not held"; + let remove man l = + if not (D.mem l man.local) then M.warn "Releasing a mutex that is definitely not held"; match D.Addr.to_mval l with | Some (v,o) -> - (let mtype = ctx.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) in + (let mtype = man.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) in match mtype with - | `Lifted MutexAttrDomain.MutexKind.NonRec -> D.remove l ctx.local - | _ -> ctx.local (* we cannot remove them here *)) - | None -> ctx.local (* we cannot remove them here *) + | `Lifted MutexAttrDomain.MutexKind.NonRec -> D.remove l man.local + | _ -> man.local (* we cannot remove them here *)) + | None -> man.local (* we cannot remove them here *) end module Spec = @@ -47,16 +47,16 @@ struct let exitstate v = D.top () (* TODO: why? *) - let return ctx exp fundec = - if not (D.is_bot ctx.local) && ThreadReturn.is_current (Analyses.ask_of_ctx ctx) then M.warn "Exiting thread while still holding a mutex!"; - ctx.local + let return man exp fundec = + if not (D.is_bot man.local) && ThreadReturn.is_current (Analyses.ask_of_man man) then M.warn "Exiting thread while still holding a mutex!"; + man.local - let special ctx (lv:lval option) (f: varinfo) (args: exp list) = + let special man (lv:lval option) (f: varinfo) (args: exp list) = (match(LF.find f).special args with - | ThreadExit _ -> if not @@ D.is_bot ctx.local then M.warn "Exiting thread while still holding a mutex!" + | ThreadExit _ -> if not @@ D.is_bot man.local then M.warn "Exiting thread while still holding a mutex!" | _ -> ()) ; - ctx.local + man.local end let _ = diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 362800b7b4..7930b00103 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -20,13 +20,13 @@ struct module V = UnitV module G = WasMallocCalled - let context ctx _ d = d + let context man _ d = d - let must_be_single_threaded ~since_start ctx = - ctx.ask (Queries.MustBeSingleThreaded { since_start }) + let must_be_single_threaded ~since_start man = + man.ask (Queries.MustBeSingleThreaded { since_start }) - let was_malloc_called ctx = - ctx.global () + let was_malloc_called man = + man.global () (* HELPER FUNCTIONS *) let get_global_vars () = @@ -50,21 +50,21 @@ struct | (TNamed ({ttype = TComp (ci,_); _}, _)) -> ci.cstruct | _ -> false) - let get_reachable_mem_from_globals (global_vars:varinfo list) ctx = + let get_reachable_mem_from_globals (global_vars:varinfo list) man = global_vars |> List.map (fun v -> Lval (Var v, NoOffset)) |> List.filter_map (fun exp -> - match ctx.ask (Queries.MayPointTo exp) with + match man.ask (Queries.MayPointTo exp) with | a when not (Queries.AD.is_top a) && Queries.AD.cardinal a = 1 -> begin match List.hd @@ Queries.AD.elements a with - | Queries.AD.Addr.Addr (v, _) when (ctx.ask (Queries.IsHeapVar v)) && not (ctx.ask (Queries.IsMultiple v)) -> Some v + | Queries.AD.Addr.Addr (v, _) when (man.ask (Queries.IsHeapVar v)) && not (man.ask (Queries.IsMultiple v)) -> Some v | _ -> None end | _ -> None) - let rec get_reachable_mem_from_str_ptr_globals (global_struct_ptr_vars:varinfo list) ctx = + let rec get_reachable_mem_from_str_ptr_globals (global_struct_ptr_vars:varinfo list) man = let eval_value_of_heap_var heap_var = - match ctx.ask (Queries.EvalValue (Lval (Var heap_var, NoOffset))) with + match man.ask (Queries.EvalValue (Lval (Var heap_var, NoOffset))) with | a when not (Queries.VD.is_top a) -> begin match a with | Struct s -> @@ -75,7 +75,7 @@ struct let reachable_from_addr_set = Queries.AD.fold (fun addr acc -> match addr with - | Queries.AD.Addr.Addr (v, _) -> (v :: get_reachable_mem_from_str_ptr_globals [v] ctx) @ acc + | Queries.AD.Addr.Addr (v, _) -> (v :: get_reachable_mem_from_str_ptr_globals [v] man) @ acc | _ -> acc ) a [] in @@ -89,27 +89,27 @@ struct | _ -> [] in let get_pts_of_non_heap_ptr_var var = - match ctx.ask (Queries.MayPointTo (Lval (Var var, NoOffset))) with + match man.ask (Queries.MayPointTo (Lval (Var var, NoOffset))) with | a when not (Queries.AD.is_top a) && Queries.AD.cardinal a = 1 -> begin match List.hd @@ Queries.AD.elements a with - | Queries.AD.Addr.Addr (v, _) when (ctx.ask (Queries.IsHeapVar v)) && not (ctx.ask (Queries.IsMultiple v)) -> v :: (eval_value_of_heap_var v) - | Queries.AD.Addr.Addr (v, _) when not (ctx.ask (Queries.IsAllocVar v)) && isPointerType v.vtype -> get_reachable_mem_from_str_ptr_globals [v] ctx + | Queries.AD.Addr.Addr (v, _) when (man.ask (Queries.IsHeapVar v)) && not (man.ask (Queries.IsMultiple v)) -> v :: (eval_value_of_heap_var v) + | Queries.AD.Addr.Addr (v, _) when not (man.ask (Queries.IsAllocVar v)) && isPointerType v.vtype -> get_reachable_mem_from_str_ptr_globals [v] man | _ -> [] end | _ -> [] in global_struct_ptr_vars |> List.fold_left (fun acc var -> - if ctx.ask (Queries.IsHeapVar var) then (eval_value_of_heap_var var) @ acc - else if not (ctx.ask (Queries.IsAllocVar var)) && isPointerType var.vtype then (get_pts_of_non_heap_ptr_var var) @ acc + if man.ask (Queries.IsHeapVar var) then (eval_value_of_heap_var var) @ acc + else if not (man.ask (Queries.IsAllocVar var)) && isPointerType var.vtype then (get_pts_of_non_heap_ptr_var var) @ acc else acc ) [] - let get_reachable_mem_from_str_non_ptr_globals (global_struct_non_ptr_vars:varinfo list) ctx = + let get_reachable_mem_from_str_non_ptr_globals (global_struct_non_ptr_vars:varinfo list) man = global_struct_non_ptr_vars (* Filter out global struct vars that don't have pointer fields *) |> List.filter_map (fun v -> - match ctx.ask (Queries.EvalValue (Lval (Var v, NoOffset))) with + match man.ask (Queries.EvalValue (Lval (Var v, NoOffset))) with | a when not (Queries.VD.is_top a) -> begin match a with | Queries.VD.Struct s -> @@ -129,7 +129,7 @@ struct Queries.AD.fold (fun addr acc_addr -> match addr with | Queries.AD.Addr.Addr (v, _) -> - let reachable_from_v = Queries.AD.of_list (List.map (fun v -> Queries.AD.Addr.Addr (v, `NoOffset)) (get_reachable_mem_from_str_ptr_globals [v] ctx)) in + let reachable_from_v = Queries.AD.of_list (List.map (fun v -> Queries.AD.Addr.Addr (v, `NoOffset)) (get_reachable_mem_from_str_ptr_globals [v] man)) in Queries.AD.join (Queries.AD.add addr reachable_from_v) acc_addr | _ -> acc_addr ) a (Queries.AD.empty ()) @@ -140,29 +140,29 @@ struct reachable_from_fields @ acc_struct ) [] - let warn_for_multi_threaded_due_to_abort ctx = - let malloc_called = was_malloc_called ctx in - if not (must_be_single_threaded ctx ~since_start:true) && malloc_called then ( + let warn_for_multi_threaded_due_to_abort man = + let malloc_called = was_malloc_called man in + if not (must_be_single_threaded man ~since_start:true) && malloc_called then ( set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Program aborted while running in multi-threaded mode. A memory leak might occur" ) (* If [is_return] is set to [true], then a thread return occurred, else a thread exit *) - let warn_for_thread_return_or_exit ctx is_return = - if not (ToppedVarInfoSet.is_empty ctx.local) then ( + let warn_for_thread_return_or_exit man is_return = + if not (ToppedVarInfoSet.is_empty man.local) then ( set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; - let current_thread = ctx.ask (Queries.CurrentThreadId) in + let current_thread = man.ask (Queries.CurrentThreadId) in M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory may be leaked at thread %s for thread %a" (if is_return then "return" else "exit") ThreadIdDomain.ThreadLifted.pretty current_thread ) - let check_for_mem_leak ?(assert_exp_imprecise = false) ?(exp = None) ctx = - let allocated_mem = ctx.local in + let check_for_mem_leak ?(assert_exp_imprecise = false) ?(exp = None) man = + let allocated_mem = man.local in if not (D.is_empty allocated_mem) then - let reachable_mem_from_non_struct_globals = D.of_list (get_reachable_mem_from_globals (get_global_vars ()) ctx) in - let reachable_mem_from_struct_ptr_globals = D.of_list (get_reachable_mem_from_str_ptr_globals (get_global_struct_ptr_vars ()) ctx) in - let reachable_mem_from_struct_non_ptr_globals = D.of_list (get_reachable_mem_from_str_non_ptr_globals (get_global_struct_non_ptr_vars ()) ctx) in + let reachable_mem_from_non_struct_globals = D.of_list (get_reachable_mem_from_globals (get_global_vars ()) man) in + let reachable_mem_from_struct_ptr_globals = D.of_list (get_reachable_mem_from_str_ptr_globals (get_global_struct_ptr_vars ()) man) in + let reachable_mem_from_struct_non_ptr_globals = D.of_list (get_reachable_mem_from_str_non_ptr_globals (get_global_struct_non_ptr_vars ()) man) in let reachable_mem_from_struct_globals = D.join reachable_mem_from_struct_ptr_globals reachable_mem_from_struct_non_ptr_globals in let reachable_mem = D.join reachable_mem_from_non_struct_globals reachable_mem_from_struct_globals in (* Check and warn if there's unreachable allocated memory at program exit *) @@ -181,72 +181,72 @@ struct M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Memory leak detected for heap variables" (* TRANSFER FUNCTIONS *) - let return ctx (exp:exp option) (f:fundec) : D.t = + let return man (exp:exp option) (f:fundec) : D.t = (* Check for a valid-memcleanup and memtrack violation in a multi-threaded setting *) (* The check for multi-threadedness is to ensure that valid-memtrack and valid-memclenaup are treated separately for single-threaded programs *) - if (ctx.ask (Queries.MayBeThreadReturn) && not (must_be_single_threaded ctx ~since_start:true)) then ( - warn_for_thread_return_or_exit ctx true + if (man.ask (Queries.MayBeThreadReturn) && not (must_be_single_threaded man ~since_start:true)) then ( + warn_for_thread_return_or_exit man true ); (* Returning from "main" is one possible program exit => need to check for memory leaks *) if f.svar.vname = "main" then ( - check_for_mem_leak ctx; - if not (must_be_single_threaded ctx ~since_start:false) && was_malloc_called ctx then begin + check_for_mem_leak man; + if not (must_be_single_threaded man ~since_start:false) && was_malloc_called man then begin set_mem_safety_flag InvalidMemTrack; set_mem_safety_flag InvalidMemcleanup; M.warn ~category:(Behavior (Undefined MemoryLeak)) ~tags:[CWE 401] "Possible memory leak: Memory was allocated in a multithreaded program, but not all threads are joined." end ); - ctx.local + man.local - let special ctx (lval:lval option) (f:varinfo) (arglist:exp list) : D.t = - let state = ctx.local in + let special man (lval:lval option) (f:varinfo) (arglist:exp list) : D.t = + let state = man.local in let desc = LibraryFunctions.find f in match desc.special arglist with | Malloc _ | Calloc _ | Realloc _ -> - ctx.sideg () true; - begin match ctx.ask (Queries.AllocVar {on_stack = false}) with + man.sideg () true; + begin match man.ask (Queries.AllocVar {on_stack = false}) with | `Lifted var -> ToppedVarInfoSet.add var state | _ -> state end | Free ptr -> - begin match ctx.ask (Queries.MayPointTo ptr) with + begin match man.ask (Queries.MayPointTo ptr) with | ad when (not (Queries.AD.is_top ad)) && Queries.AD.cardinal ad = 1 -> (* Note: Need to always set "ana.malloc.unique_address_count" to a value > 0 *) begin match Queries.AD.choose ad with - | Queries.AD.Addr.Addr (v,_) when ctx.ask (Queries.IsAllocVar v) && ctx.ask (Queries.IsHeapVar v) && not @@ ctx.ask (Queries.IsMultiple v) -> - ToppedVarInfoSet.remove v ctx.local - | _ -> ctx.local + | Queries.AD.Addr.Addr (v,_) when man.ask (Queries.IsAllocVar v) && man.ask (Queries.IsHeapVar v) && not @@ man.ask (Queries.IsMultiple v) -> + ToppedVarInfoSet.remove v man.local + | _ -> man.local end - | _ -> ctx.local + | _ -> man.local end | Abort -> - check_for_mem_leak ctx; + check_for_mem_leak man; (* Upon a call to the "Abort" special function in the multi-threaded case, we give up and conservatively warn *) - warn_for_multi_threaded_due_to_abort ctx; + warn_for_multi_threaded_due_to_abort man; state | Assert { exp; _ } -> - begin match ctx.ask (Queries.EvalInt exp) with + begin match man.ask (Queries.EvalInt exp) with | a when Queries.ID.is_bot a -> M.warn ~category:Assert "assert expression %a is bottom" d_exp exp | a -> begin match Queries.ID.to_bool a with | Some true -> () | Some false -> (* If we know for sure that the expression in "assert" is false => need to check for memory leaks *) - warn_for_multi_threaded_due_to_abort ctx; - check_for_mem_leak ctx + warn_for_multi_threaded_due_to_abort man; + check_for_mem_leak man | None -> - warn_for_multi_threaded_due_to_abort ctx; - check_for_mem_leak ctx ~assert_exp_imprecise:true ~exp:(Some exp) + warn_for_multi_threaded_due_to_abort man; + check_for_mem_leak man ~assert_exp_imprecise:true ~exp:(Some exp) end end; state | ThreadExit _ -> - begin match ctx.ask (Queries.CurrentThreadId) with + begin match man.ask (Queries.CurrentThreadId) with | `Lifted tid -> - warn_for_thread_return_or_exit ctx false + warn_for_thread_return_or_exit man false | _ -> () end; state @@ -255,7 +255,7 @@ struct let startstate v = D.bot () let exitstate v = D.top () - let threadenter ctx ~multiple lval f args = [D.bot ()] + let threadenter man ~multiple lval f args = [D.bot ()] end let _ = diff --git a/src/analyses/memOutOfBounds.ml b/src/analyses/memOutOfBounds.ml index 914644a86e..296a990b80 100644 --- a/src/analyses/memOutOfBounds.ml +++ b/src/analyses/memOutOfBounds.ml @@ -22,7 +22,7 @@ struct module D = Lattice.Unit include Analyses.ValueContexts(D) - let context ctx _ _ = () + let context man _ _ = () let name () = "memOutOfBounds" @@ -69,21 +69,21 @@ struct in host_contains_a_ptr host || offset_contains_a_ptr offset - let points_to_alloc_only ctx ptr = - match ctx.ask (Queries.MayPointTo ptr) with + let points_to_alloc_only man ptr = + match man.ask (Queries.MayPointTo ptr) with | a when not (Queries.AD.is_top a)-> Queries.AD.for_all (function - | Addr (v, o) -> ctx.ask (Queries.IsAllocVar v) + | Addr (v, o) -> man.ask (Queries.IsAllocVar v) | _ -> false ) a | _ -> false - let get_size_of_ptr_target ctx ptr = - if points_to_alloc_only ctx ptr then + let get_size_of_ptr_target man ptr = + if points_to_alloc_only man ptr then (* Ask for BlobSize from the base address (the second component being set to true) in order to avoid BlobSize giving us bot *) - ctx.ask (Queries.BlobSize {exp = ptr; base_address = true}) + man.ask (Queries.BlobSize {exp = ptr; base_address = true}) else - match ctx.ask (Queries.MayPointTo ptr) with + match man.ask (Queries.MayPointTo ptr) with | a when not (Queries.AD.is_top a) -> let pts_list = Queries.AD.elements a in let pts_elems_to_sizes (addr: Queries.AD.elt) = @@ -96,7 +96,7 @@ struct begin match v.vtype with | TArray (item_typ, _, _) -> let item_typ_size_in_bytes = size_of_type_in_bytes item_typ in - begin match ctx.ask (Queries.EvalLength ptr) with + begin match man.ask (Queries.EvalLength ptr) with | `Lifted arr_len -> let arr_len_casted = ID.cast_to (Cilfacade.ptrdiff_ikind ()) arr_len in begin @@ -131,8 +131,8 @@ struct | TPtr (t, _) -> Some t | _ -> None - let eval_ptr_offset_in_binop ctx exp ptr_contents_typ = - let eval_offset = ctx.ask (Queries.EvalInt exp) in + let eval_ptr_offset_in_binop man exp ptr_contents_typ = + let eval_offset = man.ask (Queries.EvalInt exp) in let ptr_contents_typ_size_in_bytes = size_of_type_in_bytes ptr_contents_typ in match eval_offset with | `Lifted eo -> @@ -165,7 +165,7 @@ struct with IntDomain.ArithmeticOnIntegerBot _ -> ID.bot_of @@ Cilfacade.ptrdiff_ikind () end - let cil_offs_to_idx ctx typ offs = + let cil_offs_to_idx man typ offs = (* TODO: Some duplication with convert_offset in base.ml, unclear how to immediately get more reuse *) let rec convert_offset (ofs: offset) = match ofs with @@ -174,7 +174,7 @@ struct | Index (exp, ofs) when CilType.Exp.equal exp (Lazy.force Offset.Index.Exp.any) -> (* special offset added by convertToQueryLval *) `Index (ID.top (), convert_offset ofs) | Index (exp, ofs) -> - let i = match ctx.ask (Queries.EvalInt exp) with + let i = match man.ask (Queries.EvalInt exp) with | `Lifted x -> x | _ -> ID.top_of @@ Cilfacade.ptrdiff_ikind () in @@ -183,9 +183,9 @@ struct PreValueDomain.Offs.to_index (convert_offset offs) - let check_unknown_addr_deref ctx ptr = + let check_unknown_addr_deref man ptr = let may_contain_unknown_addr = - match ctx.ask (Queries.EvalValue ptr) with + match man.ask (Queries.EvalValue ptr) with | a when not (Queries.VD.is_top a) -> begin match a with | Address a -> ValueDomain.AD.may_be_unknown a @@ -199,8 +199,8 @@ struct M.warn ~category:(Behavior (Undefined Other)) "Pointer %a contains an unknown address. Invalid dereference may occur" d_exp ptr end - let ptr_only_has_str_addr ctx ptr = - match ctx.ask (Queries.EvalValue ptr) with + let ptr_only_has_str_addr man ptr = + match man.ask (Queries.EvalValue ptr) with | a when not (Queries.VD.is_top a) -> begin match a with | Address a -> ValueDomain.AD.for_all (fun addr -> match addr with | StrPtr _ -> true | _ -> false) a @@ -209,8 +209,8 @@ struct (* Intuition: if ptr evaluates to top, it could all sorts of things and not only string addresses *) | _ -> false - let rec get_addr_offs ctx ptr = - match ctx.ask (Queries.MayPointTo ptr) with + let rec get_addr_offs man ptr = + match man.ask (Queries.MayPointTo ptr) with | a when not (VDQ.AD.is_top a) -> let ptr_deref_type = get_ptr_deref_type @@ typeOf ptr in begin match ptr_deref_type with @@ -254,22 +254,22 @@ struct M.warn "Pointer %a has a points-to-set of top. An invalid memory access might occur" d_exp ptr; ID.top_of @@ Cilfacade.ptrdiff_ikind () - and check_lval_for_oob_access ctx ?(is_implicitly_derefed = false) lval = + and check_lval_for_oob_access man ?(is_implicitly_derefed = false) lval = (* If the lval does not contain a pointer or if it does contain a pointer, but only points to string addresses, then no need to WARN *) - if (not @@ lval_contains_a_ptr lval) || ptr_only_has_str_addr ctx (Lval lval) then () + if (not @@ lval_contains_a_ptr lval) || ptr_only_has_str_addr man (Lval lval) then () else (* If the lval doesn't indicate an explicit dereference, we still need to check for an implicit dereference *) (* An implicit dereference is, e.g., printf("%p", ptr), where ptr is a pointer *) match lval, is_implicitly_derefed with | (Var _, _), false -> () - | (Var v, _), true -> check_no_binop_deref ctx (Lval lval) + | (Var v, _), true -> check_no_binop_deref man (Lval lval) | (Mem e, o), _ -> let ptr_deref_type = get_ptr_deref_type @@ typeOf e in let offs_intdom = begin match ptr_deref_type with - | Some t -> cil_offs_to_idx ctx t o + | Some t -> cil_offs_to_idx man t o | None -> ID.bot_of @@ Cilfacade.ptrdiff_ikind () end in - let e_size = get_size_of_ptr_target ctx e in + let e_size = get_size_of_ptr_target man e in let () = begin match e_size with | `Top -> (set_mem_safety_flag InvalidDeref; @@ -300,20 +300,20 @@ struct end end in begin match e with - | Lval (Var v, _) as lval_exp -> check_no_binop_deref ctx lval_exp + | Lval (Var v, _) as lval_exp -> check_no_binop_deref man lval_exp | BinOp (binop, e1, e2, t) when binop = PlusPI || binop = MinusPI || binop = IndexPI -> - check_binop_exp ctx binop e1 e2 t; - check_exp_for_oob_access ctx ~is_implicitly_derefed e1; - check_exp_for_oob_access ctx ~is_implicitly_derefed e2 - | _ -> check_exp_for_oob_access ctx ~is_implicitly_derefed e + check_binop_exp man binop e1 e2 t; + check_exp_for_oob_access man ~is_implicitly_derefed e1; + check_exp_for_oob_access man ~is_implicitly_derefed e2 + | _ -> check_exp_for_oob_access man ~is_implicitly_derefed e end - and check_no_binop_deref ctx lval_exp = - check_unknown_addr_deref ctx lval_exp; + and check_no_binop_deref man lval_exp = + check_unknown_addr_deref man lval_exp; let behavior = Undefined MemoryOutOfBoundsAccess in let cwe_number = 823 in - let ptr_size = get_size_of_ptr_target ctx lval_exp in - let addr_offs = get_addr_offs ctx lval_exp in + let ptr_size = get_size_of_ptr_target man lval_exp in + let addr_offs = get_addr_offs man lval_exp in let ptr_type = typeOf lval_exp in let ptr_contents_type = get_ptr_deref_type ptr_type in match ptr_contents_type with @@ -341,7 +341,7 @@ struct end | _ -> M.error "Expression %a is not a pointer" d_exp lval_exp - and check_exp_for_oob_access ctx ?(is_implicitly_derefed = false) exp = + and check_exp_for_oob_access man ?(is_implicitly_derefed = false) exp = match exp with | Const _ | SizeOf _ @@ -353,20 +353,20 @@ struct | SizeOfE e | AlignOfE e | UnOp (_, e, _) - | CastE (_, e) -> check_exp_for_oob_access ctx ~is_implicitly_derefed e + | CastE (_, e) -> check_exp_for_oob_access man ~is_implicitly_derefed e | BinOp (bop, e1, e2, t) -> - check_exp_for_oob_access ctx ~is_implicitly_derefed e1; - check_exp_for_oob_access ctx ~is_implicitly_derefed e2 + check_exp_for_oob_access man ~is_implicitly_derefed e1; + check_exp_for_oob_access man ~is_implicitly_derefed e2 | Question (e1, e2, e3, _) -> - check_exp_for_oob_access ctx ~is_implicitly_derefed e1; - check_exp_for_oob_access ctx ~is_implicitly_derefed e2; - check_exp_for_oob_access ctx ~is_implicitly_derefed e3 + check_exp_for_oob_access man ~is_implicitly_derefed e1; + check_exp_for_oob_access man ~is_implicitly_derefed e2; + check_exp_for_oob_access man ~is_implicitly_derefed e3 | Lval lval | StartOf lval - | AddrOf lval -> check_lval_for_oob_access ctx ~is_implicitly_derefed lval + | AddrOf lval -> check_lval_for_oob_access man ~is_implicitly_derefed lval - and check_binop_exp ctx binop e1 e2 t = - check_unknown_addr_deref ctx e1; + and check_binop_exp man binop e1 e2 t = + check_unknown_addr_deref man e1; let binopexp = BinOp (binop, e1, e2, t) in let behavior = Undefined MemoryOutOfBoundsAccess in let cwe_number = 823 in @@ -374,13 +374,13 @@ struct | PlusPI | IndexPI | MinusPI -> - let ptr_size = get_size_of_ptr_target ctx e1 in - let addr_offs = get_addr_offs ctx e1 in + let ptr_size = get_size_of_ptr_target man e1 in + let addr_offs = get_addr_offs man e1 in let ptr_type = typeOf e1 in let ptr_contents_type = get_ptr_deref_type ptr_type in begin match ptr_contents_type with | Some t -> - let offset_size = eval_ptr_offset_in_binop ctx e2 t in + let offset_size = eval_ptr_offset_in_binop man e2 t in (* Make sure to add the address offset to the binop offset *) let offset_size_with_addr_size = match offset_size with | `Lifted os -> @@ -425,12 +425,12 @@ struct | _ -> () (* For memset() and memcpy() *) - let check_count ctx fun_name ptr n = + let check_count man fun_name ptr n = let (behavior:MessageCategory.behavior) = Undefined MemoryOutOfBoundsAccess in let cwe_number = 823 in - let ptr_size = get_size_of_ptr_target ctx ptr in - let eval_n = ctx.ask (Queries.EvalInt n) in - let addr_offs = get_addr_offs ctx ptr in + let ptr_size = get_size_of_ptr_target man ptr in + let eval_n = man.ask (Queries.EvalInt n) in + let addr_offs = get_addr_offs man ptr in match ptr_size, eval_n with | `Top, _ -> set_mem_safety_flag InvalidDeref; @@ -462,20 +462,20 @@ struct (* TRANSFER FUNCTIONS *) - let assign ctx (lval:lval) (rval:exp) : D.t = - check_lval_for_oob_access ctx lval; - check_exp_for_oob_access ctx rval; - ctx.local + let assign man (lval:lval) (rval:exp) : D.t = + check_lval_for_oob_access man lval; + check_exp_for_oob_access man rval; + man.local - let branch ctx (exp:exp) (tv:bool) : D.t = - check_exp_for_oob_access ctx exp; - ctx.local + let branch man (exp:exp) (tv:bool) : D.t = + check_exp_for_oob_access man exp; + man.local - let return ctx (exp:exp option) (f:fundec) : D.t = - Option.iter (fun x -> check_exp_for_oob_access ctx x) exp; - ctx.local + let return man (exp:exp option) (f:fundec) : D.t = + Option.iter (fun x -> check_exp_for_oob_access man x) exp; + man.local - let special ctx (lval:lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval:lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in let is_arg_implicitly_derefed arg = let read_shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Read; deep = false } arglist in @@ -484,23 +484,23 @@ struct let write_deep_args = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = true } arglist in List.mem arg read_shallow_args || List.mem arg read_deep_args || List.mem arg write_shallow_args || List.mem arg write_deep_args in - Option.iter (fun x -> check_lval_for_oob_access ctx x) lval; - List.iter (fun arg -> check_exp_for_oob_access ctx ~is_implicitly_derefed:(is_arg_implicitly_derefed arg) arg) arglist; + Option.iter (fun x -> check_lval_for_oob_access man x) lval; + List.iter (fun arg -> check_exp_for_oob_access man ~is_implicitly_derefed:(is_arg_implicitly_derefed arg) arg) arglist; (* Check calls to memset and memcpy for out-of-bounds-accesses *) match desc.special arglist with - | Memset { dest; ch; count; } -> check_count ctx f.vname dest count; + | Memset { dest; ch; count; } -> check_count man f.vname dest count; | Memcpy { dest; src; n = count; } -> - (check_count ctx f.vname src count; - check_count ctx f.vname dest count;) - | _ -> ctx.local + (check_count man f.vname src count; + check_count man f.vname dest count;) + | _ -> man.local - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - List.iter (fun arg -> check_exp_for_oob_access ctx arg) args; - [ctx.local, ctx.local] + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + List.iter (fun arg -> check_exp_for_oob_access man arg) args; + [man.local, man.local] - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask:Queries.ask) : D.t = - Option.iter (fun x -> check_lval_for_oob_access ctx x) lval; - ctx.local + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask:Queries.ask) : D.t = + Option.iter (fun x -> check_lval_for_oob_access man x) lval; + man.local let startstate v = () let exitstate v = () diff --git a/src/analyses/modifiedSinceSetjmp.ml b/src/analyses/modifiedSinceSetjmp.ml index 515f63cdb4..85d3180990 100644 --- a/src/analyses/modifiedSinceSetjmp.ml +++ b/src/analyses/modifiedSinceSetjmp.ml @@ -30,42 +30,42 @@ struct ) ls (VS.empty ()) (* transfer functions *) - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - [ctx.local, D.bot ()] (* enter with bot as opposed to IdentitySpec *) + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + [man.local, D.bot ()] (* enter with bot as opposed to IdentitySpec *) - let combine_env ctx lval fexp f args fc au (f_ask: Queries.ask) = + let combine_env man lval fexp f args fc au (f_ask: Queries.ask) = let taintedcallee = relevants_from_ad (f_ask.f Queries.MayBeTainted) in - add_to_all_defined taintedcallee ctx.local + add_to_all_defined taintedcallee man.local - 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 combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask:Queries.ask) : D.t = + man.local - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special arglist with | Setjmp _ -> - let entry = (ctx.prev_node, ctx.control_context ()) in - let v = D.find entry ctx.local in (* Will make bot binding explicit here *) + let entry = (man.prev_node, man.control_context ()) in + let v = D.find entry man.local in (* Will make bot binding explicit here *) (* LHS of setjmp not marked as tainted on purpose *) - D.add entry v ctx.local + D.add entry v man.local | _ -> - ctx.local + man.local let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] + let threadenter man ~multiple lval f args = [D.bot ()] let exitstate v = D.top () - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with - | Queries.MayBeModifiedSinceSetjmp entry -> D.find entry ctx.local + | Queries.MayBeModifiedSinceSetjmp entry -> D.find entry man.local | _ -> Queries.Result.top q - let event ctx (e: Events.t) octx = + let event man (e: Events.t) oman = match e with | Access {ad; kind = Write; _} -> - add_to_all_defined (relevants_from_ad ad) ctx.local + add_to_all_defined (relevants_from_ad ad) man.local | _ -> - ctx.local + man.local end let _ = diff --git a/src/analyses/mutexAnalysis.ml b/src/analyses/mutexAnalysis.ml index 3710d2db9c..824c36814f 100644 --- a/src/analyses/mutexAnalysis.ml +++ b/src/analyses/mutexAnalysis.ml @@ -119,13 +119,13 @@ struct let create_protected protected = `Lifted2 protected end - let add ctx ((addr, rw): AddrRW.t): D.t = + let add man ((addr, rw): AddrRW.t): D.t = match addr with | Addr ((v, o) as mv) -> - let (s, m) = ctx.local in + let (s, m) = man.local in let s' = MustLocksetRW.add_mval_rw (mv, rw) s in let m' = - match ctx.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) with + match man.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) with | `Lifted Recursive -> MustMultiplicity.increment mv m | `Lifted NonRec -> if MustLocksetRW.mem_mval mv s then @@ -136,23 +136,23 @@ struct (s', m') | NullPtr -> M.warn "locking NULL mutex"; - ctx.local + man.local | StrPtr _ - | UnknownPtr -> ctx.local + | UnknownPtr -> man.local - let remove' ctx ~warn (addr: Addr.t): D.t = + let remove' man ~warn (addr: Addr.t): D.t = match addr with | StrPtr _ - | UnknownPtr -> ctx.local + | UnknownPtr -> man.local | NullPtr -> if warn then M.warn "unlocking NULL mutex"; - ctx.local + man.local | Addr mv -> - let (s, m) = ctx.local in + let (s, m) = man.local in if warn && not (MustLocksetRW.mem_mval mv s) then M.warn "unlocking mutex (%a) which may not be held" Mval.pretty mv; - if MutexTypeAnalysis.must_be_recursive ctx mv then ( + if MutexTypeAnalysis.must_be_recursive man mv then ( let (m', rmed) = MustMultiplicity.decrement mv m in if rmed then (* TODO: don't repeat the same semantic_equal checks *) @@ -166,10 +166,10 @@ struct let remove = remove' ~warn:true - let remove_all ctx: D.t = + let remove_all man: D.t = (* Mutexes.iter (fun m -> - ctx.emit (MustUnlock m) - ) (D.export_locks ctx.local); *) + man.emit (MustUnlock m) + ) (D.export_locks man.local); *) (* TODO: used to have remove_nonspecial, which kept v.vname.[0] = '{' variables *) M.warn "unlocking unknown mutex which may not be held"; D.empty () @@ -196,17 +196,17 @@ struct num_mutexes := 0; sum_protected := 0 - let query (ctx: (D.t, _, _, V.t) ctx) (type a) (q: a Queries.t): a Queries.result = - let ls, m = ctx.local in + let query (man: (D.t, _, _, V.t) man) (type a) (q: a Queries.t): a Queries.result = + let ls, m = man.local in (* get the set of mutexes protecting the variable v in the given mode *) - let protecting ~write mode v = GProtecting.get ~write mode (G.protecting (ctx.global (V.protecting v))) in + let protecting ~write mode v = GProtecting.get ~write mode (G.protecting (man.global (V.protecting v))) in match q with | Queries.MayBePublic _ when MustLocksetRW.is_all ls -> false | Queries.MayBePublic {global=v; write; protection} -> let held_locks = MustLocksetRW.to_must_lockset (MustLocksetRW.filter snd ls) in let protecting = protecting ~write protection v in (* TODO: unsound in 29/24, why did we do this before? *) - (* if Mutexes.mem verifier_atomic (Lockset.export_locks ctx.local) then + (* if Mutexes.mem verifier_atomic (Lockset.export_locks man.local) then false else *) MustLockset.disjoint held_locks protecting @@ -215,7 +215,7 @@ struct let held_locks = MustLockset.remove without_mutex (MustLocksetRW.to_must_lockset ls) in let protecting = protecting ~write protection v in (* TODO: unsound in 29/24, why did we do this before? *) - (* if Mutexes.mem verifier_atomic (Lockset.export_locks (Lockset.remove (without_mutex, true) ctx.local)) then + (* if Mutexes.mem verifier_atomic (Lockset.export_locks (Lockset.remove (without_mutex, true) man.local)) then false else *) MustLockset.disjoint held_locks protecting @@ -235,7 +235,7 @@ struct let held_locks = MustLocksetRW.to_must_lockset (MustLocksetRW.filter snd ls) in MustLockset.mem (LF.verifier_atomic_var, `NoOffset) held_locks (* TODO: Mval.of_var *) | Queries.MustProtectedVars {mutex; write} -> - let protected = GProtected.get ~write Strong (G.protected (ctx.global (V.protected mutex))) in + let protected = GProtected.get ~write Strong (G.protected (man.global (V.protected mutex))) in VarSet.fold (fun v acc -> Queries.VS.add v acc ) protected (Queries.VS.empty ()) @@ -246,13 +246,13 @@ struct begin match g with | `Left g' -> (* protecting *) if GobConfig.get_bool "dbg.print_protection" then ( - let protecting = GProtecting.get ~write:false Strong (G.protecting (ctx.global g)) in (* readwrite protecting *) + let protecting = GProtecting.get ~write:false Strong (G.protecting (man.global g)) in (* readwrite protecting *) let s = MustLockset.cardinal protecting in M.info_noloc ~category:Race "Variable %a read-write protected by %d mutex(es): %a" CilType.Varinfo.pretty g' s MustLockset.pretty protecting ) | `Right m -> (* protected *) if GobConfig.get_bool "dbg.print_protection" then ( - let protected = GProtected.get ~write:false Strong (G.protected (ctx.global g)) in (* readwrite protected *) + let protected = GProtected.get ~write:false Strong (G.protected (man.global g)) in (* readwrite protected *) let s = VarSet.cardinal protected in max_protected := max !max_protected s; sum_protected := !sum_protected + s; @@ -279,21 +279,21 @@ struct let should_print ls = not (is_empty ls) end - let access ctx (a: Queries.access) = - fst ctx.local + let access man (a: Queries.access) = + fst man.local - let event (ctx: (D.t, _, _, V.t) ctx) e (octx: (D.t, _, _, _) ctx) = + let event (man: (D.t, _, _, V.t) man) e (oman: (D.t, _, _, _) man) = match e with - | Events.Access {exp; ad; kind; _} when ThreadFlag.has_ever_been_multi (Analyses.ask_of_ctx ctx) -> (* threadflag query in post-threadspawn ctx *) - let is_recovered_to_st = not (ThreadFlag.is_currently_multi (Analyses.ask_of_ctx ctx)) in - (* must use original (pre-assign, etc) ctx queries *) + | Events.Access {exp; ad; kind; _} when ThreadFlag.has_ever_been_multi (Analyses.ask_of_man man) -> (* threadflag query in post-threadspawn man *) + let is_recovered_to_st = not (ThreadFlag.is_currently_multi (Analyses.ask_of_man man)) in + (* must use original (pre-assign, etc) man queries *) let old_access var_opt = - (* TODO: this used to use ctx instead of octx, why? *) + (* TODO: this used to use man instead of oman, why? *) (*privatization*) match var_opt with | Some v -> - if not (MustLocksetRW.is_all (fst octx.local)) then - let locks = MustLocksetRW.to_must_lockset (MustLocksetRW.filter snd (fst octx.local)) in + if not (MustLocksetRW.is_all (fst oman.local)) then + let locks = MustLocksetRW.to_must_lockset (MustLocksetRW.filter snd (fst oman.local)) in let write = match kind with | Write | Free -> true | Read -> false @@ -301,23 +301,23 @@ struct | Spawn -> false (* TODO: nonsense? *) in let s = GProtecting.make ~write ~recovered:is_recovered_to_st locks in - ctx.sideg (V.protecting v) (G.create_protecting s); + man.sideg (V.protecting v) (G.create_protecting s); if !AnalysisState.postsolving then ( - let protecting mode = GProtecting.get ~write mode (G.protecting (ctx.global (V.protecting v))) in + let protecting mode = GProtecting.get ~write mode (G.protecting (man.global (V.protecting v))) in let held_strong = protecting Strong in let held_weak = protecting Weak in let vs = VarSet.singleton v in let protected = G.create_protected @@ GProtected.make ~write vs in - MustLockset.iter (fun ml -> ctx.sideg (V.protected ml) protected) held_strong; + MustLockset.iter (fun ml -> man.sideg (V.protected ml) protected) held_strong; (* If the mutex set here is top, it is actually not accessed *) if is_recovered_to_st && not @@ MustLockset.is_all held_weak then - MustLockset.iter (fun ml -> ctx.sideg (V.protected ml) protected) held_weak; + MustLockset.iter (fun ml -> man.sideg (V.protected ml) protected) held_weak; ) | None -> M.info ~category:Unsound "Write to unknown address: privatization is unsound." in let module AD = Queries.AD in - let has_escaped g = octx.ask (Queries.MayEscape g) in + let has_escaped g = oman.ask (Queries.MayEscape g) in let on_ad ad = let f = function | AD.Addr.Addr (g,_) when g.vglob || has_escaped g -> old_access (Some g) @@ -333,7 +333,7 @@ struct | ad -> (* the case where the points-to set is non top and contains unknown values *) (* now we need to access all fields that might be pointed to: is this correct? *) - begin match octx.ask (ReachableUkTypes exp) with + begin match oman.ask (ReachableUkTypes exp) with | ts when Queries.TS.is_top ts -> () | ts -> @@ -348,9 +348,9 @@ struct (* | _ -> old_access None None *) (* TODO: what about this case? *) end; - ctx.local + man.local | _ -> - event ctx e octx (* delegate to must lockset analysis *) + event man e oman (* delegate to must lockset analysis *) let finalize () = if GobConfig.get_bool "dbg.print_protection" then ( diff --git a/src/analyses/mutexEventsAnalysis.ml b/src/analyses/mutexEventsAnalysis.ml index 5ea0afc809..0e318aad8b 100644 --- a/src/analyses/mutexEventsAnalysis.ml +++ b/src/analyses/mutexEventsAnalysis.ml @@ -17,7 +17,7 @@ struct let eval_exp_addr (a: Queries.ask) exp = a.f (Queries.MayPointTo exp) - let lock ctx rw may_fail nonzero_return_when_aquired a lv_opt arg = + let lock man rw may_fail nonzero_return_when_aquired a lv_opt arg = let compute_refine_split (e: Addr.t) = match e with | Addr a -> let arg_e = AddrOf (PreValueDomain.Mval.to_cil a) in @@ -31,57 +31,57 @@ struct match lv_opt with | None -> Queries.AD.iter (fun e -> - ctx.split () (Events.Lock (e, rw) :: compute_refine_split e) + man.split () (Events.Lock (e, rw) :: compute_refine_split e) ) (eval_exp_addr a arg); if may_fail then - ctx.split () []; + man.split () []; raise Analyses.Deadcode | Some lv -> let sb = Events.SplitBranch (Lval lv, nonzero_return_when_aquired) in Queries.AD.iter (fun e -> - ctx.split () (sb :: Events.Lock (e, rw) :: compute_refine_split e); + man.split () (sb :: Events.Lock (e, rw) :: compute_refine_split e); ) (eval_exp_addr a arg); if may_fail then ( let fail_exp = if nonzero_return_when_aquired then Lval lv else BinOp(Gt, Lval lv, zero, intType) in - ctx.split () [Events.SplitBranch (fail_exp, not nonzero_return_when_aquired)] + man.split () [Events.SplitBranch (fail_exp, not nonzero_return_when_aquired)] ); raise Analyses.Deadcode - let return ctx exp fundec : D.t = + let return man exp fundec : D.t = (* deprecated but still valid SV-COMP convention for atomic block *) if get_bool "ana.sv-comp.functions" && String.starts_with fundec.svar.vname ~prefix:"__VERIFIER_atomic_" then - ctx.emit (Events.Unlock (LockDomain.Addr.of_var LF.verifier_atomic_var)) + man.emit (Events.Unlock (LockDomain.Addr.of_var LF.verifier_atomic_var)) - let body ctx f : D.t = + let body man f : D.t = (* deprecated but still valid SV-COMP convention for atomic block *) if get_bool "ana.sv-comp.functions" && String.starts_with f.svar.vname ~prefix:"__VERIFIER_atomic_" then - ctx.emit (Events.Lock (LockDomain.Addr.of_var LF.verifier_atomic_var, true)) + man.emit (Events.Lock (LockDomain.Addr.of_var LF.verifier_atomic_var, true)) - let special (ctx: (unit, _, _, _) ctx) lv f arglist : D.t = + let special (man: (unit, _, _, _) man) lv f arglist : D.t = let remove_rw x = x in let unlock arg remove_fn = Queries.AD.iter (fun e -> - ctx.split () [Events.Unlock (remove_fn e)] - ) (eval_exp_addr (Analyses.ask_of_ctx ctx) arg); + man.split () [Events.Unlock (remove_fn e)] + ) (eval_exp_addr (Analyses.ask_of_man man) arg); raise Analyses.Deadcode in let desc = LF.find f in match desc.special arglist with | Lock { lock = arg; try_ = failing; write = rw; return_on_success = nonzero_return_when_aquired } -> - lock ctx rw failing nonzero_return_when_aquired (Analyses.ask_of_ctx ctx) lv arg + lock man rw failing nonzero_return_when_aquired (Analyses.ask_of_man man) lv arg | Unlock arg -> unlock arg remove_rw | Wait { mutex = m_arg; _} | TimedWait { mutex = m_arg; _} -> (* mutex is unlocked while waiting but relocked when returns *) (* emit unlock-lock events for privatization *) - let ms = eval_exp_addr (Analyses.ask_of_ctx ctx) m_arg in + let ms = eval_exp_addr (Analyses.ask_of_man man) m_arg in Queries.AD.iter (fun m -> (* unlock-lock each possible mutex as a split to be dependent *) (* otherwise may-point-to {a, b} might unlock a, but relock b *) - ctx.split () [Events.Unlock m; Events.Lock (m, true)]; + man.split () [Events.Unlock m; Events.Lock (m, true)]; ) ms; raise Deadcode (* splits cover all cases *) | _ -> diff --git a/src/analyses/mutexGhosts.ml b/src/analyses/mutexGhosts.ml index 3deec3ef59..98fd33d621 100644 --- a/src/analyses/mutexGhosts.ml +++ b/src/analyses/mutexGhosts.ml @@ -66,70 +66,70 @@ struct | Addr mv when LockDomain.Mval.is_definite mv -> Some (LockDomain.MustLock.of_mval mv) | _ -> None - let event ctx e octx = + let event man e oman = let verifier_atomic_addr = LockDomain.Addr.of_var LibraryFunctions.verifier_atomic_var in begin match e with | Events.Lock (l, _) when not (LockDomain.Addr.equal l verifier_atomic_addr) -> - ctx.sideg (V.node ctx.prev_node) (G.create_node (Locked.singleton l, Unlocked.bot (), MultiThread.bot ())); + man.sideg (V.node man.prev_node) (G.create_node (Locked.singleton l, Unlocked.bot (), MultiThread.bot ())); if !AnalysisState.postsolving then ( - ctx.sideg V.update (G.create_update (NodeSet.singleton ctx.prev_node)); - let (locked, _, _) = G.node (ctx.global (V.node ctx.prev_node)) in + man.sideg V.update (G.create_update (NodeSet.singleton man.prev_node)); + let (locked, _, _) = G.node (man.global (V.node man.prev_node)) in if Locked.cardinal locked > 1 then ( Locked.iter (fun lock -> Option.iter (fun lock -> - ctx.sideg (V.lock lock) (G.create_lock true) + man.sideg (V.lock lock) (G.create_lock true) ) (mustlock_of_addr lock) ) locked ); ) | Events.Unlock l when not (LockDomain.Addr.equal l verifier_atomic_addr) -> - ctx.sideg (V.node ctx.prev_node) (G.create_node (Locked.bot (), Unlocked.singleton l, MultiThread.bot ())); + man.sideg (V.node man.prev_node) (G.create_node (Locked.bot (), Unlocked.singleton l, MultiThread.bot ())); if !AnalysisState.postsolving then ( - ctx.sideg V.update (G.create_update (NodeSet.singleton ctx.prev_node)); - let (_, unlocked, _) = G.node (ctx.global (V.node ctx.prev_node)) in + man.sideg V.update (G.create_update (NodeSet.singleton man.prev_node)); + let (_, unlocked, _) = G.node (man.global (V.node man.prev_node)) in if Locked.cardinal unlocked > 1 then ( Locked.iter (fun lock -> Option.iter (fun lock -> - ctx.sideg (V.lock lock) (G.create_lock true) + man.sideg (V.lock lock) (G.create_lock true) ) (mustlock_of_addr lock) ) unlocked ); ) | Events.EnterMultiThreaded -> - ctx.sideg (V.node ctx.prev_node) (G.create_node (Locked.bot (), Unlocked.bot (), true)); + man.sideg (V.node man.prev_node) (G.create_node (Locked.bot (), Unlocked.bot (), true)); if !AnalysisState.postsolving then - ctx.sideg V.update (G.create_update (NodeSet.singleton ctx.prev_node)); + man.sideg V.update (G.create_update (NodeSet.singleton man.prev_node)); | _ -> () end; - ctx.local + man.local - let threadspawn ctx ~multiple lval f args octx = - ctx.sideg V.threadcreate (G.create_threadcreate (NodeSet.singleton ctx.node)); - ctx.local + let threadspawn man ~multiple lval f args oman = + man.sideg V.threadcreate (G.create_threadcreate (NodeSet.singleton man.node)); + man.local - let ghost_var_available ctx = function - | WitnessGhost.Var.Locked ((v, o) as lock) -> not (Offset.Z.contains_index o) && not (G.lock (ctx.global (V.lock lock))) + let ghost_var_available man = function + | WitnessGhost.Var.Locked ((v, o) as lock) -> not (Offset.Z.contains_index o) && not (G.lock (man.global (V.lock lock))) | Multithreaded -> true - let ghost_var_available ctx v = - WitnessGhost.enabled () && ghost_var_available ctx v + let ghost_var_available man v = + WitnessGhost.enabled () && ghost_var_available man v module VariableSet = Set.Make (YamlWitnessType.GhostInstrumentation.Variable) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with - | GhostVarAvailable v -> ghost_var_available ctx v + | GhostVarAvailable v -> ghost_var_available man v | YamlEntryGlobal (g, task) -> let g: V.t = Obj.obj g in begin match g with | `Right true when YamlWitness.entry_type_enabled YamlWitnessType.GhostInstrumentation.entry_type -> - let nodes = G.update (ctx.global g) in + let nodes = G.update (man.global g) in let (variables, location_updates) = NodeSet.fold (fun node (variables, location_updates) -> - let (locked, unlocked, multithread) = G.node (ctx.global (V.node node)) in + let (locked, unlocked, multithread) = G.node (man.global (V.node node)) in let variables' = Locked.fold (fun l acc -> match mustlock_of_addr l with - | Some l when ghost_var_available ctx (Locked l) -> + | Some l when ghost_var_available man (Locked l) -> let variable = WitnessGhost.variable' (Locked l) in VariableSet.add variable acc | _ -> @@ -139,7 +139,7 @@ struct let updates = Locked.fold (fun l acc -> match mustlock_of_addr l with - | Some l when ghost_var_available ctx (Locked l) -> + | Some l when ghost_var_available man (Locked l) -> let update = WitnessGhost.update' (Locked l) GoblintCil.one in update :: acc | _ -> @@ -149,7 +149,7 @@ struct let updates = Unlocked.fold (fun l acc -> match mustlock_of_addr l with - | Some l when ghost_var_available ctx (Locked l) -> + | Some l when ghost_var_available man (Locked l) -> let update = WitnessGhost.update' (Locked l) GoblintCil.zero in update :: acc | _ -> @@ -158,7 +158,7 @@ struct in let (variables', updates) = if not (GobConfig.get_bool "exp.earlyglobs") && multithread then ( - if ghost_var_available ctx Multithreaded then ( + if ghost_var_available man Multithreaded then ( let variable = WitnessGhost.variable' Multithreaded in let update = WitnessGhost.update' Multithreaded GoblintCil.one in let variables' = VariableSet.add variable variables' in @@ -183,7 +183,7 @@ struct | `Middle _ -> Queries.Result.top q | `Right _ -> Queries.Result.top q end - | InvariantGlobalNodes -> (G.threadcreate (ctx.global V.threadcreate): NodeSet.t) + | InvariantGlobalNodes -> (G.threadcreate (man.global V.threadcreate): NodeSet.t) | _ -> Queries.Result.top q end diff --git a/src/analyses/mutexTypeAnalysis.ml b/src/analyses/mutexTypeAnalysis.ml index 4a993bbd7d..06d1b1ff6e 100644 --- a/src/analyses/mutexTypeAnalysis.ml +++ b/src/analyses/mutexTypeAnalysis.ml @@ -24,7 +24,7 @@ struct module O = Offset.Unit (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = + let assign man (lval:lval) (rval:exp) : D.t = match lval with | (Var v, o) -> (* There's no way to use the PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP etc for accesses via pointers *) @@ -35,8 +35,8 @@ struct | Const (CInt (c, _, _)) -> MAttr.of_int c | _ -> `Top) in - ctx.sideg (v,o) kind; - ctx.local + man.sideg (v,o) kind; + man.local | Field ({fname = "__sig"; _}, NoOffset) when ValueDomain.Compound.is_mutex_type t -> (* OSX *) let kind: MAttr.t = match Cil.constFold true rval with | Const (CInt (c, _, _)) -> @@ -48,42 +48,42 @@ struct end | _ -> `Top in - ctx.sideg (v,o) kind; - ctx.local + man.sideg (v,o) kind; + man.local | Index (i,o') -> let o'' = O.of_offs (`Index (i, `NoOffset)) in helper (O.add_offset o o'') (Cilfacade.typeOffset t (Index (i,NoOffset))) o' | Field (f,o') -> let o'' = O.of_offs (`Field (f, `NoOffset)) in helper (O.add_offset o o'') (Cilfacade.typeOffset t (Field (f,NoOffset))) o' - | NoOffset -> ctx.local + | NoOffset -> man.local in helper `NoOffset v.vtype o - | _ -> ctx.local + | _ -> man.local - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LF.find f in match desc.special arglist with | MutexInit {mutex = mutex; attr = attr} -> - let attr = ctx.ask (Queries.EvalMutexAttr attr) in - let mutexes = ctx.ask (Queries.MayPointTo mutex) in + let attr = man.ask (Queries.EvalMutexAttr attr) in + let mutexes = man.ask (Queries.MayPointTo mutex) in (* It is correct to iter over these sets here, as mutexes need to be intialized before being used, and an analysis that detects usage before initialization is a different analysis. *) Queries.AD.iter (function addr -> match addr with - | Queries.AD.Addr.Addr (v,o) -> ctx.sideg (v,O.of_offs o) attr + | Queries.AD.Addr.Addr (v,o) -> man.sideg (v,O.of_offs o) attr | _ -> () ) mutexes; - ctx.local - | _ -> ctx.local + man.local + | _ -> man.local - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with - | Queries.MutexType (v,o) -> (ctx.global (v,o):MutexAttrDomain.t) + | Queries.MutexType (v,o) -> (man.global (v,o):MutexAttrDomain.t) | _ -> Queries.Result.top q end -let must_be_recursive ctx (v,o) = - ctx.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) = `Lifted MutexAttrDomain.MutexKind.Recursive +let must_be_recursive man (v,o) = + man.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) = `Lifted MutexAttrDomain.MutexKind.Recursive let _ = MCP.register_analysis (module Spec : MCPSpec) diff --git a/src/analyses/poisonVariables.ml b/src/analyses/poisonVariables.ml index e8a4a9a404..1b0c159dc0 100644 --- a/src/analyses/poisonVariables.ml +++ b/src/analyses/poisonVariables.ml @@ -26,26 +26,26 @@ struct (* transfer functions *) - let return ctx (exp:exp option) (f:fundec) : D.t = + let return man (exp:exp option) (f:fundec) : D.t = (* remove locals, except ones which need to be weakly updated*) - if D.is_top ctx.local then - ctx.local + if D.is_top man.local then + man.local else ( let locals = f.sformals @ f.slocals in D.filter (fun v -> not (List.exists (fun local -> - CilType.Varinfo.equal v local && not (ctx.ask (Queries.IsMultiple local)) + CilType.Varinfo.equal v local && not (man.ask (Queries.IsMultiple local)) ) locals) - ) ctx.local + ) man.local ) - let enter ctx (_:lval option) (_:fundec) (args:exp list) : (D.t * D.t) list = - if VS.is_empty ctx.local then - [ctx.local,ctx.local] + let enter man (_:lval option) (_:fundec) (args:exp list) : (D.t * D.t) list = + if VS.is_empty man.local then + [man.local,man.local] else ( - let reachable_from_args = List.fold (fun ad e -> Queries.AD.join ad (ctx.ask (ReachableFrom e))) (Queries.AD.empty ()) args in - if Queries.AD.is_top reachable_from_args || VS.is_top ctx.local then - [ctx.local, ctx.local] + let reachable_from_args = List.fold (fun ad e -> Queries.AD.join ad (man.ask (ReachableFrom e))) (Queries.AD.empty ()) args in + if Queries.AD.is_top reachable_from_args || VS.is_top man.local then + [man.local, man.local] else let reachable_vars = let get_vars addr vs = @@ -55,53 +55,53 @@ struct in Queries.AD.fold get_vars reachable_from_args (VS.empty ()) in - [VS.diff ctx.local reachable_vars, VS.inter reachable_vars ctx.local] + [VS.diff man.local reachable_vars, VS.inter reachable_vars man.local] ) - let combine_env ctx lval fexp f args fc au f_ask = - VS.join au ctx.local + let combine_env man lval fexp f args fc au f_ask = + VS.join au man.local let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] + let threadenter man ~multiple lval f args = [D.bot ()] let exitstate v = D.top () - let event ctx e octx = + let event man e oman = match e with | Events.Longjmped {lval} -> - let modified_locals = ctx.ask (MayBeModifiedSinceSetjmp (ctx.prev_node, ctx.control_context ())) in + let modified_locals = man.ask (MayBeModifiedSinceSetjmp (man.prev_node, man.control_context ())) in let modified_locals = match lval with | Some (Var v, NoOffset) -> Queries.VS.remove v modified_locals | _ -> modified_locals (* Does usually not really occur, if it does, this is sound *) in - let (_, longjmp_nodes) = ctx.ask ActiveJumpBuf in + let (_, longjmp_nodes) = man.ask ActiveJumpBuf in JmpBufDomain.NodeSet.iter (fun longjmp_node -> if Queries.VS.is_top modified_locals then - 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 + 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 man.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 + 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 man.prev_node Queries.VS.pretty modified_locals ) longjmp_nodes; - D.join modified_locals ctx.local + D.join modified_locals man.local | Access {ad; kind = Read; _} -> (* TODO: what about AD with both known and unknown pointers? *) begin match ad with - | ad when Queries.AD.is_top ad && not (VS.is_empty octx.local) -> + | ad when Queries.AD.is_top ad && not (VS.is_empty oman.local) -> M.warn ~category:(Behavior (Undefined Other)) "reading unknown memory location, may be tainted!" | ad -> (* Use original access state instead of current with removed written vars. *) - Queries.AD.iter (check_mval octx.local) ad + Queries.AD.iter (check_mval oman.local) ad end; - ctx.local + man.local | Access {ad; kind = Write; _} -> (* TODO: what about AD with both known and unknown pointers? *) begin match ad with | ad when Queries.AD.is_top ad -> - ctx.local + man.local | ad -> Queries.AD.fold (fun addr vs -> rem_mval vs addr - ) ad ctx.local + ) ad man.local end - | _ -> ctx.local + | _ -> man.local end diff --git a/src/analyses/pthreadSignals.ml b/src/analyses/pthreadSignals.ml index 68c2bf4f34..98f53ee0fd 100644 --- a/src/analyses/pthreadSignals.ml +++ b/src/analyses/pthreadSignals.ml @@ -22,18 +22,18 @@ struct (* transfer functions *) - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LF.find f in match desc.special arglist with | Signal cond | Broadcast cond -> - let mhp = G.singleton @@ MHP.current (Analyses.ask_of_ctx ctx) in - let publish_one a = ctx.sideg a mhp in - let possible_vars = possible_vinfos (Analyses.ask_of_ctx ctx) cond in + let mhp = G.singleton @@ MHP.current (Analyses.ask_of_man man) in + let publish_one a = man.sideg a mhp in + let possible_vars = possible_vinfos (Analyses.ask_of_man man) cond in List.iter publish_one possible_vars; - ctx.local + man.local | Wait {cond = cond; _} -> - let current_mhp = MHP.current (Analyses.ask_of_ctx ctx) in + let current_mhp = MHP.current (Analyses.ask_of_man man) in let module Signalled = struct type signalled = Never | NotConcurrently | PossiblySignalled @@ -45,7 +45,7 @@ struct | Never, Never -> Never let can_be_signalled a = - let signalling_tids = ctx.global a in + let signalling_tids = man.global a in if G.is_top signalling_tids then PossiblySignalled else if G.is_empty signalling_tids then @@ -57,23 +57,23 @@ struct end in let open Signalled in - let add_if_singleton conds = match conds with | [a] -> Signals.add (ValueDomain.Addr.of_var a) ctx.local | _ -> ctx.local in - let conds = possible_vinfos (Analyses.ask_of_ctx ctx) cond in + let add_if_singleton conds = match conds with | [a] -> Signals.add (ValueDomain.Addr.of_var a) man.local | _ -> man.local in + let conds = possible_vinfos (Analyses.ask_of_man man) cond in (match List.fold_left (fun acc cond -> can_be_signalled cond ||| acc) Never conds with | PossiblySignalled -> add_if_singleton conds | NotConcurrently -> - (M.warn ~category:Deadcode "The condition variable(s) pointed to by %a are never signalled concurrently, succeeding code is live due to spurious wakeups only!" Basetype.CilExp.pretty cond; ctx.local) + (M.warn ~category:Deadcode "The condition variable(s) pointed to by %a are never signalled concurrently, succeeding code is live due to spurious wakeups only!" Basetype.CilExp.pretty cond; man.local) | Never -> - (M.warn ~category:Deadcode "The condition variable(s) pointed to by %a are never signalled, succeeding code is live due to spurious wakeups only!" Basetype.CilExp.pretty cond; ctx.local) + (M.warn ~category:Deadcode "The condition variable(s) pointed to by %a are never signalled, succeeding code is live due to spurious wakeups only!" Basetype.CilExp.pretty cond; man.local) ) | TimedWait _ -> (* Time could simply have elapsed *) - ctx.local - | _ -> ctx.local + man.local + | _ -> man.local let startstate v = Signals.empty () - let threadenter ctx ~multiple lval f args = [ctx.local] + let threadenter man ~multiple lval f args = [man.local] let exitstate v = Signals.empty () end diff --git a/src/analyses/ptranalAnalysis.ml b/src/analyses/ptranalAnalysis.ml index 6991b5ea22..0d7f4dd228 100644 --- a/src/analyses/ptranalAnalysis.ml +++ b/src/analyses/ptranalAnalysis.ml @@ -13,7 +13,7 @@ struct let name () = "ptranal" - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.EvalFunvar (Lval (Mem e, _)) -> let funs = Ptranal.resolve_exp e in diff --git a/src/analyses/raceAnalysis.ml b/src/analyses/raceAnalysis.ml index 2f6611d467..263506b4fb 100644 --- a/src/analyses/raceAnalysis.ml +++ b/src/analyses/raceAnalysis.ml @@ -217,24 +217,24 @@ struct vulnerable := 0; unsafe := 0 - let side_vars ctx memo = + let side_vars man memo = match memo with | (`Var v, _) -> if !AnalysisState.should_warn then - ctx.sideg (V.vars v) (G.create_vars (MemoSet.singleton memo)) + man.sideg (V.vars v) (G.create_vars (MemoSet.singleton memo)) | _ -> () - let side_access ctx acc ((memoroot, offset) as memo) = + let side_access man acc ((memoroot, offset) as memo) = if !AnalysisState.should_warn then - ctx.sideg (V.access memoroot) (G.create_access (OffsetTrie.singleton offset (`Lifted (Access.AS.singleton acc)))); - side_vars ctx memo + man.sideg (V.access memoroot) (G.create_access (OffsetTrie.singleton offset (`Lifted (Access.AS.singleton acc)))); + side_vars man memo (** Side-effect empty access set for prefix-type_suffix race checking. *) - let side_access_empty ctx ((memoroot, offset) as memo) = + let side_access_empty man ((memoroot, offset) as memo) = if !AnalysisState.should_warn then - ctx.sideg (V.access memoroot) (G.create_access (OffsetTrie.singleton offset (`Lifted (Access.AS.empty ())))); - side_vars ctx memo + man.sideg (V.access memoroot) (G.create_access (OffsetTrie.singleton offset (`Lifted (Access.AS.empty ())))); + side_vars man memo (** Get immediate type_suffix memo. *) let type_suffix_memo ((root, offset) : Access.Memo.t) : Access.Memo.t option = @@ -247,30 +247,30 @@ struct | `Type (TSArray (ts, _, _)), `Index ((), offset') -> Some (`Type ts, offset') (* (int[])[*] -> int *) | _, `Index ((), offset') -> None (* TODO: why indexing on non-array? *) - let rec find_type_suffix' ctx ((root, offset) as memo : Access.Memo.t) : Access.AS.t = - let trie = G.access (ctx.global (V.access root)) in + let rec find_type_suffix' man ((root, offset) as memo : Access.Memo.t) : Access.AS.t = + let trie = G.access (man.global (V.access root)) in let accs = match OffsetTrie.find offset trie with | `Lifted accs -> accs | `Bot -> Access.AS.empty () in - let type_suffix = find_type_suffix ctx memo in + let type_suffix = find_type_suffix man memo in Access.AS.union accs type_suffix (** Find accesses from all type_suffixes transitively. *) - and find_type_suffix ctx (memo : Access.Memo.t) : Access.AS.t = + and find_type_suffix man (memo : Access.Memo.t) : Access.AS.t = match type_suffix_memo memo with - | Some type_suffix_memo -> find_type_suffix' ctx type_suffix_memo + | Some type_suffix_memo -> find_type_suffix' man type_suffix_memo | None -> Access.AS.empty () - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | WarnGlobal g -> let g: V.t = Obj.obj g in begin match g with | `Left g' -> (* accesses *) (* Logs.debug "WarnGlobal %a" Access.MemoRoot.pretty g'; *) - let trie = G.access (ctx.global g) in + let trie = G.access (man.global g) in (** Distribute access to contained fields. *) let rec distribute_inner offset (accs, children) ~prefix ~type_suffix_prefix = let accs = @@ -278,7 +278,7 @@ struct | `Lifted accs -> accs | `Bot -> Access.AS.empty () in - let type_suffix = find_type_suffix ctx (g', offset) in + let type_suffix = find_type_suffix man (g', offset) in if not (Access.AS.is_empty accs) || (not (Access.AS.is_empty prefix) && not (Access.AS.is_empty type_suffix)) then ( let memo = (g', offset) in let mem_loc_str = GobPretty.sprint Access.Memo.pretty memo in @@ -299,29 +299,29 @@ struct | IterSysVars (Global g, vf) -> MemoSet.iter (fun v -> vf (Obj.repr (V.access v)) - ) (G.vars (ctx.global (V.vars g))) + ) (G.vars (man.global (V.vars g))) | _ -> Queries.Result.top q - let event ctx e octx = + let event man e oman = match e with - | Events.Access {exp; ad; kind; reach} when ThreadFlag.is_currently_multi (Analyses.ask_of_ctx ctx) -> (* threadflag query in post-threadspawn ctx *) - (* must use original (pre-assign, etc) ctx queries *) + | Events.Access {exp; ad; kind; reach} when ThreadFlag.is_currently_multi (Analyses.ask_of_man man) -> (* threadflag query in post-threadspawn man *) + (* must use original (pre-assign, etc) man queries *) let conf = 110 in let module AD = Queries.AD in let part_access (vo:varinfo option): MCPAccess.A.t = (*partitions & locks*) - Obj.obj (octx.ask (PartAccess (Memory {exp; var_opt=vo; kind}))) + Obj.obj (oman.ask (PartAccess (Memory {exp; var_opt=vo; kind}))) in let node = Option.get !Node.current_node in let add_access conf voffs = let acc = part_access (Option.map fst voffs) in - Access.add ~side:(side_access octx {conf; kind; node; exp; acc}) ~side_empty:(side_access_empty octx) exp voffs; + Access.add ~side:(side_access oman {conf; kind; node; exp; acc}) ~side_empty:(side_access_empty oman) exp voffs; in let add_access_struct conf ci = let acc = part_access None in - Access.add_one ~side:(side_access octx {conf; kind; node; exp; acc}) (`Type (TSComp (ci.cstruct, ci.cname, [])), `NoOffset) + Access.add_one ~side:(side_access oman {conf; kind; node; exp; acc}) (`Type (TSComp (ci.cstruct, ci.cname, [])), `NoOffset) in - let has_escaped g = octx.ask (Queries.MayEscape g) in + let has_escaped g = oman.ask (Queries.MayEscape g) in (* The following function adds accesses to the lval-set ls -- this is the common case if we have a sound points-to set. *) let on_ad ad includes_uk = @@ -345,7 +345,7 @@ struct (* the case where the points-to set is non top and contains unknown values *) let includes_uk = ref false in (* now we need to access all fields that might be pointed to: is this correct? *) - begin match octx.ask (ReachableUkTypes exp) with + begin match oman.ask (ReachableUkTypes exp) with | ts when Queries.TS.is_top ts -> includes_uk := true | ts -> @@ -362,23 +362,23 @@ struct (* | _ -> add_access (conf - 60) None *) (* TODO: what about this case? *) end; - ctx.local + man.local | _ -> - ctx.local + man.local - let special ctx (lvalOpt: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lvalOpt: lval option) (f:varinfo) (arglist:exp list) : D.t = (* perform shallow and deep invalidate according to Library descriptors *) let desc = LibraryFunctions.find f in - if List.mem LibraryDesc.ThreadUnsafe desc.attrs && ThreadFlag.is_currently_multi (Analyses.ask_of_ctx ctx) then ( + if List.mem LibraryDesc.ThreadUnsafe desc.attrs && ThreadFlag.is_currently_multi (Analyses.ask_of_man man) then ( let exp = Lval (Var f, NoOffset) in let conf = 110 in let kind = AccessKind.Call in let node = Option.get !Node.current_node in let vo = Some f in - let acc = Obj.obj (ctx.ask (PartAccess (Memory {exp; var_opt=vo; kind}))) in - side_access ctx {conf; kind; node; exp; acc} ((`Var f), `NoOffset) ; + let acc = Obj.obj (man.ask (PartAccess (Memory {exp; var_opt=vo; kind}))) in + side_access man {conf; kind; node; exp; acc} ((`Var f), `NoOffset) ; ); - ctx.local + man.local let finalize () = let total = !safe + !unsafe + !vulnerable in diff --git a/src/analyses/region.ml b/src/analyses/region.ml index e53dded304..7cc8d34111 100644 --- a/src/analyses/region.ml +++ b/src/analyses/region.ml @@ -42,20 +42,20 @@ struct | `Top -> false | `Bot -> true - let get_region ctx e = - let regpart = ctx.global () in - if is_bullet e regpart ctx.local then + let get_region man e = + let regpart = man.global () in + if is_bullet e regpart man.local then None else - Some (regions e regpart ctx.local) + Some (regions e regpart man.local) (* queries *) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.Regions e -> - let regpart = ctx.global () in - if is_bullet e regpart ctx.local then Queries.Result.bot q (* TODO: remove bot *) else - let ls = List.fold_right Queries.LS.add (regions e regpart ctx.local) (Queries.LS.empty ()) in + let regpart = man.global () in + if is_bullet e regpart man.local then Queries.Result.bot q (* TODO: remove bot *) else + let ls = List.fold_right Queries.LS.add (regions e regpart man.local) (Queries.LS.empty ()) in ls | _ -> Queries.Result.top q @@ -76,7 +76,7 @@ struct | Some r when Lvals.is_empty r -> false | _ -> true end - let access ctx (a: Queries.access) = + let access man (a: Queries.access) = match a with | Point -> Some (Lvals.empty ()) @@ -84,30 +84,30 @@ struct (* TODO: remove regions that cannot be reached from the var*) (* forget specific indices *) (* TODO: If indices are topped, could they not be collected in the first place? *) - Option.map (Lvals.of_list % List.map (Tuple2.map2 Offset.Exp.top_indices)) (get_region ctx e) + Option.map (Lvals.of_list % List.map (Tuple2.map2 Offset.Exp.top_indices)) (get_region man e) (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - match ctx.local with + let assign man (lval:lval) (rval:exp) : D.t = + match man.local with | `Lifted reg -> - let old_regpart = ctx.global () in + let old_regpart = man.global () in let regpart, reg = Reg.assign lval rval (old_regpart, reg) in if not (RegPart.leq regpart old_regpart) then - ctx.sideg () regpart; + man.sideg () regpart; `Lifted reg | x -> x - let branch ctx (exp:exp) (tv:bool) : D.t = - ctx.local + let branch man (exp:exp) (tv:bool) : D.t = + man.local - let body ctx (f:fundec) : D.t = - ctx.local + let body man (f:fundec) : D.t = + man.local - let return ctx (exp:exp option) (f:fundec) : D.t = + let return man (exp:exp option) (f:fundec) : D.t = let locals = f.sformals @ f.slocals in - match ctx.local with + match man.local with | `Lifted reg -> - let old_regpart = ctx.global () in + let old_regpart = man.global () in let regpart, reg = match exp with | Some exp -> Reg.assign (ReturnUtil.return_lval ()) exp (old_regpart, reg) @@ -115,74 +115,74 @@ struct in let regpart, reg = Reg.kill_vars locals (Reg.remove_vars locals (regpart, reg)) in if not (RegPart.leq regpart old_regpart) then - ctx.sideg () regpart; + man.sideg () regpart; `Lifted reg | x -> x - let enter ctx (lval: lval option) (fundec:fundec) (args:exp list) : (D.t * D.t) list = + let enter man (lval: lval option) (fundec:fundec) (args:exp list) : (D.t * D.t) list = let rec fold_right2 f xs ys r = match xs, ys with | x::xs, y::ys -> f x y (fold_right2 f xs ys r) | _ -> r in - match ctx.local with + match man.local with | `Lifted reg -> let f x r reg = Reg.assign (var x) r reg in - let old_regpart = ctx.global () in + let old_regpart = man.global () in let regpart, reg = fold_right2 f fundec.sformals args (old_regpart,reg) in if not (RegPart.leq regpart old_regpart) then - ctx.sideg () regpart; - [ctx.local, `Lifted reg] + man.sideg () regpart; + [man.local, `Lifted reg] | x -> [x,x] - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local + let combine_env man lval fexp f args fc au f_ask = + man.local - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = match au with | `Lifted reg -> begin - let old_regpart = ctx.global () in + let old_regpart = man.global () in let regpart, reg = match lval with | None -> (old_regpart, reg) | Some lval -> Reg.assign lval (AddrOf (ReturnUtil.return_lval ())) (old_regpart, reg) in let regpart, reg = Reg.remove_vars [ReturnUtil.return_varinfo ()] (regpart, reg) in if not (RegPart.leq regpart old_regpart) then - ctx.sideg () regpart; + man.sideg () regpart; `Lifted reg end | _ -> au - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special arglist with | Malloc _ | Calloc _ | Realloc _ | Alloca _ -> begin - match ctx.local, lval with + match man.local, lval with | `Lifted reg, Some lv -> - let old_regpart = ctx.global () in + let old_regpart = man.global () in (* TODO: should realloc use arg region if failed/in-place? *) let regpart, reg = Reg.assign_bullet lv (old_regpart, reg) in if not (RegPart.leq regpart old_regpart) then - ctx.sideg () regpart; + man.sideg () regpart; `Lifted reg - | _ -> ctx.local + | _ -> man.local end | _ -> - ctx.local + man.local let startstate v = `Lifted (RegMap.bot ()) - let threadenter ctx ~multiple lval f args = + let threadenter man ~multiple lval f args = [`Lifted (RegMap.bot ())] - let threadspawn ctx ~multiple lval f args fctx = - match ctx.local with + let threadspawn man ~multiple lval f args fman = + match man.local with | `Lifted reg -> - let old_regpart = ctx.global () in + let old_regpart = man.global () in let regpart, reg = List.fold_right Reg.assign_escape args (old_regpart, reg) in if not (RegPart.leq regpart old_regpart) then - ctx.sideg () regpart; + man.sideg () regpart; `Lifted reg | x -> x diff --git a/src/analyses/stackTrace.ml b/src/analyses/stackTrace.ml index 56656c0639..8e6149d802 100644 --- a/src/analyses/stackTrace.ml +++ b/src/analyses/stackTrace.ml @@ -13,14 +13,14 @@ struct (* transfer functions *) - let body ctx (f:fundec) : D.t = - if f.svar.vname = "__goblint_dummy_init" then ctx.local else D.push f.svar ctx.local + let body man (f:fundec) : D.t = + if f.svar.vname = "__goblint_dummy_init" then man.local else D.push f.svar man.local - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local (* keep local as opposed to IdentitySpec *) + let combine_env man lval fexp f args fc au f_ask = + man.local (* keep local as opposed to IdentitySpec *) let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] + let threadenter man ~multiple lval f args = [D.bot ()] let exitstate v = D.top () end @@ -34,17 +34,17 @@ struct (* transfer functions *) - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - [ctx.local, D.push !Goblint_tracing.current_loc ctx.local] + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + [man.local, D.push !Goblint_tracing.current_loc man.local] - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local (* keep local as opposed to IdentitySpec *) + let combine_env man lval fexp f args fc au f_ask = + man.local (* keep local as opposed to IdentitySpec *) let startstate v = D.bot () let exitstate v = D.top () - let threadenter ctx ~multiple lval f args = - [D.push !Goblint_tracing.current_loc ctx.local] + let threadenter man ~multiple lval f args = + [D.push !Goblint_tracing.current_loc man.local] end diff --git a/src/analyses/symbLocks.ml b/src/analyses/symbLocks.ml index ab116c525d..0850fac317 100644 --- a/src/analyses/symbLocks.ml +++ b/src/analyses/symbLocks.ml @@ -27,12 +27,12 @@ struct let name () = "symb_locks" let startstate v = D.top () - let threadenter ctx ~multiple lval f args = [D.top ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.top ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.top () - let branch ctx exp tv = ctx.local - let body ctx f = ctx.local + let branch man exp tv = man.local + let body man f = man.local let invalidate_exp ask exp st = D.filter (fun e -> not (VarEq.may_change ask exp e)) st @@ -40,14 +40,14 @@ struct let invalidate_lval ask lv st = invalidate_exp ask (mkAddrOf lv) st - let assign ctx lval rval = invalidate_lval (Analyses.ask_of_ctx ctx) lval ctx.local + let assign man lval rval = invalidate_lval (Analyses.ask_of_man man) lval man.local - let return ctx exp fundec = - List.fold_right D.remove_var (fundec.sformals@fundec.slocals) ctx.local + let return man exp fundec = + List.fold_right D.remove_var (fundec.sformals@fundec.slocals) man.local - let enter ctx lval f args = [(ctx.local,ctx.local)] - let combine_env ctx lval fexp f args fc au f_ask = au - let combine_assign ctx lval fexp f args fc st2 f_ask = ctx.local + let enter man lval f args = [(man.local,man.local)] + let combine_env man lval fexp f args fc au f_ask = au + let combine_assign man lval fexp f args fc st2 f_ask = man.local let get_locks e st = let add_perel x xs = @@ -82,24 +82,24 @@ struct | Some (_, i, e) -> D.fold (lock_index i e) slocks (PS.empty ()) | _ -> PS.empty () - let special ctx lval f arglist = + let special man lval f arglist = let desc = LF.find f in match desc.special arglist, f.vname with | Lock { lock; _ }, _ -> - D.add (Analyses.ask_of_ctx ctx) lock ctx.local + D.add (Analyses.ask_of_man man) lock man.local | Unlock lock, _ -> - D.remove (Analyses.ask_of_ctx ctx) lock ctx.local + D.remove (Analyses.ask_of_man man) lock man.local | _, _ -> let st = match lval with - | Some lv -> invalidate_lval (Analyses.ask_of_ctx ctx) lv ctx.local - | None -> ctx.local + | Some lv -> invalidate_lval (Analyses.ask_of_man man) lv man.local + | None -> man.local in let write_args = LibraryDesc.Accesses.find_kind desc.accs Write arglist in (* TODO: why doesn't invalidate_exp involve any reachable for deep write? *) - List.fold_left (fun st e -> invalidate_exp (Analyses.ask_of_ctx ctx) e st) st write_args + List.fold_left (fun st e -> invalidate_exp (Analyses.ask_of_man man) e st) st write_args module A = @@ -125,7 +125,7 @@ struct let should_print lp = not (is_empty lp) end - let add_per_element_access ctx e rw = + let add_per_element_access man e rw = (* Per-element returns a triple of exps, first are the "element" pointers, in the second and third positions are the respectively access and mutex. Access and mutex expressions have exactly the given "elements" as "prefixes". @@ -160,14 +160,14 @@ struct xs in let do_perel e xs = - match get_all_locks (Analyses.ask_of_ctx ctx) e ctx.local with + match get_all_locks (Analyses.ask_of_man man) e man.local with | a when not (PS.is_top a || PS.is_empty a) -> PS.fold one_perelem a xs | _ -> xs in let do_lockstep e xs = - match same_unknown_index (Analyses.ask_of_ctx ctx) e ctx.local with + match same_unknown_index (Analyses.ask_of_man man) e man.local with | a when not (PS.is_top a || PS.is_empty a) -> PS.fold one_lockstep a xs @@ -175,11 +175,11 @@ struct in let matching_exps = Queries.ES.meet - (match ctx.ask (Queries.EqualSet e) with + (match man.ask (Queries.EqualSet e) with | es when not (Queries.ES.is_top es || Queries.ES.is_empty es) -> Queries.ES.add e es | _ -> Queries.ES.singleton e) - (match ctx.ask (Queries.Regions e) with + (match man.ask (Queries.Regions e) with | ls when not (Queries.LS.is_top ls || Queries.LS.is_empty ls) -> let add_exp x xs = try Queries.ES.add (Mval.Exp.to_cil_exp x) xs @@ -192,12 +192,12 @@ struct Queries.ES.fold do_lockstep matching_exps (Queries.ES.fold do_perel matching_exps (A.empty ())) - let access ctx (a: Queries.access) = + let access man (a: Queries.access) = match a with | Point -> A.empty () | Memory {exp = e; _} -> - add_per_element_access ctx e false + add_per_element_access man e false end let _ = diff --git a/src/analyses/taintPartialContexts.ml b/src/analyses/taintPartialContexts.ml index 917a6d1644..789c783ca3 100644 --- a/src/analyses/taintPartialContexts.ml +++ b/src/analyses/taintPartialContexts.ml @@ -16,23 +16,23 @@ struct module D = AD (* Add Lval or any Lval which it may point to to the set *) - let taint_lval ctx (lval:lval) : D.t = - D.union (ctx.ask (Queries.MayPointTo (AddrOf lval))) ctx.local + let taint_lval man (lval:lval) : D.t = + D.union (man.ask (Queries.MayPointTo (AddrOf lval))) man.local (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - taint_lval ctx lval + let assign man (lval:lval) (rval:exp) : D.t = + taint_lval man lval - let return ctx (exp:exp option) (f:fundec) : D.t = + let return man (exp:exp option) (f:fundec) : D.t = (* remove locals, except ones which need to be weakly updated*) - let d = ctx.local in + let d = man.local in let d_return = if D.is_top d then d else let locals = f.sformals @ f.slocals in D.filter (function - | AD.Addr.Addr (v,_) -> not (List.exists (fun local -> CilType.Varinfo.equal v local && not (ctx.ask (Queries.IsMultiple local))) locals) + | AD.Addr.Addr (v,_) -> not (List.exists (fun local -> CilType.Varinfo.equal v local && not (man.ask (Queries.IsMultiple local))) locals) | _ -> false ) d in @@ -40,25 +40,25 @@ struct d_return - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = (* Entering a function, all globals count as untainted *) - [ctx.local, (D.bot ())] + [man.local, (D.bot ())] - let combine_env ctx lval fexp f args fc au f_ask = - if M.tracing then M.trace "taintPC" "combine for %s in TaintPC: tainted: in function: %a before call: %a" f.svar.vname D.pretty au D.pretty ctx.local; - D.union ctx.local au + let combine_env man lval fexp f args fc au f_ask = + if M.tracing then M.trace "taintPC" "combine for %s in TaintPC: tainted: in function: %a before call: %a" f.svar.vname D.pretty au D.pretty man.local; + D.union man.local au - let combine_assign ctx (lvalOpt:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + let combine_assign man (lvalOpt:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = match lvalOpt with - | Some lv -> taint_lval ctx lv - | None -> ctx.local + | Some lv -> taint_lval man lv + | None -> man.local - let special ctx (lvalOpt: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lvalOpt: lval option) (f:varinfo) (arglist:exp list) : D.t = (* perform shallow and deep invalidate according to Library descriptors *) let d = match lvalOpt with - | Some lv -> taint_lval ctx lv - | None -> ctx.local + | Some lv -> taint_lval man lv + | None -> man.local in let desc = LibraryFunctions.find f in let shallow_addrs = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = false } arglist in @@ -77,24 +77,24 @@ struct deep_addrs in (* TODO: should one handle ad with unknown pointers separately like in (all) other analyses? *) - let d = List.fold_left (fun accD addr -> D.union accD (ctx.ask (Queries.MayPointTo addr))) d shallow_addrs + let d = List.fold_left (fun accD addr -> D.union accD (man.ask (Queries.MayPointTo addr))) d shallow_addrs in - let d = List.fold_left (fun accD addr -> D.union accD (ctx.ask (Queries.ReachableFrom addr))) d deep_addrs + let d = List.fold_left (fun accD addr -> D.union accD (man.ask (Queries.ReachableFrom addr))) d deep_addrs in d let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = + let threadenter man ~multiple lval f args = [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = + let threadspawn man ~multiple lval f args fman = match lval with - | Some lv -> taint_lval ctx lv - | None -> ctx.local + | Some lv -> taint_lval man lv + | None -> man.local let exitstate v = D.top () - let query ctx (type a) (q: a Queries.t) : a Queries.result = + let query man (type a) (q: a Queries.t) : a Queries.result = match q with - | MayBeTainted -> (ctx.local : Queries.AD.t) + | MayBeTainted -> (man.local : Queries.AD.t) | _ -> Queries.Result.top q end diff --git a/src/analyses/threadAnalysis.ml b/src/analyses/threadAnalysis.ml index 435e1a6afe..8be2bf9315 100644 --- a/src/analyses/threadAnalysis.ml +++ b/src/analyses/threadAnalysis.ml @@ -22,19 +22,19 @@ struct module P = IdentityP (D) (* transfer functions *) - let handle_thread_return ctx (exp: exp option) = - let tid = ThreadId.get_current (Analyses.ask_of_ctx ctx) in + let handle_thread_return man (exp: exp option) = + let tid = ThreadId.get_current (Analyses.ask_of_man man) in match tid with - | `Lifted tid -> ctx.sideg tid (false, TS.bot (), not (D.is_empty ctx.local)) + | `Lifted tid -> man.sideg tid (false, TS.bot (), not (D.is_empty man.local)) | _ -> () - let return ctx (exp:exp option) _ : D.t = - if ctx.ask Queries.MayBeThreadReturn then - handle_thread_return ctx exp; - ctx.local + let return man (exp:exp option) _ : D.t = + if man.ask Queries.MayBeThreadReturn then + handle_thread_return man exp; + man.local - let rec is_not_unique ctx tid = - let (rep, parents, _) = ctx.global tid in + let rec is_not_unique man tid = + let (rep, parents, _) = man.global tid in if rep then true (* repeatedly created *) else ( @@ -45,71 +45,71 @@ struct (* created by single thread *) let parent = TS.choose parents in (* created by itself thread-recursively or by a thread that is itself multiply created *) - T.equal tid parent || is_not_unique ctx parent (* equal check needed to avoid infinte self-recursion *) + T.equal tid parent || is_not_unique man parent (* equal check needed to avoid infinte self-recursion *) ) else false (* no ancestors, starting thread *) ) - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special arglist with | ThreadJoin { thread = id; ret_var } -> (* TODO: generalize ThreadJoin like ThreadCreate *) - (let has_clean_exit tid = not (BatTuple.Tuple3.third (ctx.global tid)) in - let tids = ctx.ask (Queries.EvalThread id) in + (let has_clean_exit tid = not (BatTuple.Tuple3.third (man.global tid)) in + let tids = man.ask (Queries.EvalThread id) in let join_thread s tid = - if has_clean_exit tid && not (is_not_unique ctx tid) then + if has_clean_exit tid && not (is_not_unique man tid) then D.remove tid s else s in if TS.is_top tids - then ctx.local + then man.local else match TS.elements tids with - | [t] -> join_thread ctx.local t (* single thread *) - | _ -> ctx.local (* if several possible threads are may-joined, none are must-joined *)) + | [t] -> join_thread man.local t (* single thread *) + | _ -> man.local (* if several possible threads are may-joined, none are must-joined *)) | ThreadExit { ret_val } -> - handle_thread_return ctx (Some ret_val); - ctx.local - | _ -> ctx.local + handle_thread_return man (Some ret_val); + man.local + | _ -> man.local - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.MustBeUniqueThread -> begin - let tid = ThreadId.get_current (Analyses.ask_of_ctx ctx) in + let tid = ThreadId.get_current (Analyses.ask_of_man man) in match tid with - | `Lifted tid -> not (is_not_unique ctx tid) + | `Lifted tid -> not (is_not_unique man tid) | _ -> false end | Queries.MustBeSingleThreaded {since_start = false} -> begin - let tid = ThreadId.get_current (Analyses.ask_of_ctx ctx) in + let tid = ThreadId.get_current (Analyses.ask_of_man man) in match tid with | `Lifted tid when T.is_main tid -> (* This analysis cannot tell if we are back in single-threaded mode or never left it. *) - D.is_empty ctx.local + D.is_empty man.local | _ -> false end | _ -> Queries.Result.top q let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = - (* ctx is of creator, side-effects to denote non-uniqueness are performed in threadspawn *) + let threadenter man ~multiple lval f args = + (* man is of creator, side-effects to denote non-uniqueness are performed in threadspawn *) [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = - let creator = ThreadId.get_current (Analyses.ask_of_ctx ctx) in - let tid = ThreadId.get_current_unlift (Analyses.ask_of_ctx fctx) in - let repeated = D.mem tid ctx.local in + let threadspawn man ~multiple lval f args fman = + let creator = ThreadId.get_current (Analyses.ask_of_man man) in + let tid = ThreadId.get_current_unlift (Analyses.ask_of_man fman) in + let repeated = D.mem tid man.local in let eff = match creator with | `Lifted ctid -> (repeated || multiple, TS.singleton ctid, false) | `Top -> (true, TS.bot (), false) | `Bot -> (multiple, TS.bot (), false) in - ctx.sideg tid eff; - D.join ctx.local (D.singleton tid) + man.sideg tid eff; + D.join man.local (D.singleton tid) let exitstate v = D.bot () end diff --git a/src/analyses/threadEscape.ml b/src/analyses/threadEscape.ml index 4311e72558..2bf67f4bb9 100644 --- a/src/analyses/threadEscape.ml +++ b/src/analyses/threadEscape.ml @@ -53,30 +53,30 @@ struct if M.tracing then M.tracel "escape" "mpt %a: %a" d_exp e AD.pretty ad; D.empty () - let thread_id ctx = - ctx.ask Queries.CurrentThreadId + let thread_id man = + man.ask Queries.CurrentThreadId (** Emit an escape event: Only necessary when code has ever been multithreaded, or when about to go multithreaded. *) - let emit_escape_event ctx escaped = + let emit_escape_event man escaped = (* avoid emitting unnecessary event *) if not (D.is_empty escaped) then - ctx.emit (Events.Escape escaped) + man.emit (Events.Escape escaped) (** Side effect escapes: In contrast to the emitting the event, side-effecting is necessary in single threaded mode, since we rely on escape status in Base for passing locals reachable via globals *) - let side_effect_escape ctx escaped threadid = + let side_effect_escape man escaped threadid = let threadid = G.singleton threadid in D.iter (fun v -> - ctx.sideg v threadid) escaped + man.sideg v threadid) escaped (* queries *) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.MayEscape v -> - let threads = ctx.global v in + let threads = man.global v in if ThreadIdSet.is_empty threads then false else begin @@ -85,7 +85,7 @@ struct (* if our own (unique) thread is started here, that is not a problem *) false | `Lifted tid -> - let threads = ctx.ask Queries.CreatedThreads in + let threads = man.ask Queries.CreatedThreads in let not_started = MHP.definitely_not_started (current, threads) tid in let possibly_started = not not_started in possibly_started @@ -98,7 +98,7 @@ struct | `Top -> true | `Bot -> false in - match ctx.ask Queries.CurrentThreadId with + match man.ask Queries.CurrentThreadId with | `Lifted current -> let possibly_started = ThreadIdSet.exists (other_possibly_started current) threads in if possibly_started then @@ -111,7 +111,7 @@ struct true else (* Check whether current unique thread has escaped the variable *) - D.mem v ctx.local + D.mem v man.local | `Top -> true | `Bot -> @@ -120,76 +120,76 @@ struct end | _ -> Queries.Result.top q - let escape_rval ctx ask (rval:exp) = + let escape_rval man ask (rval:exp) = let escaped = reachable ask rval in let escaped = D.filter (fun v -> not v.vglob) escaped in - let thread_id = thread_id ctx in - side_effect_escape ctx escaped thread_id; + let thread_id = thread_id man in + side_effect_escape man escaped thread_id; if ThreadFlag.has_ever_been_multi ask then (* avoid emitting unnecessary event *) - emit_escape_event ctx escaped; + emit_escape_event man escaped; escaped (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - let ask = Analyses.ask_of_ctx ctx in + let assign man (lval:lval) (rval:exp) : D.t = + let ask = Analyses.ask_of_man man in let vs = mpt ask (AddrOf lval) in if D.exists (fun v -> v.vglob || has_escaped ask v) vs then ( - let escaped = escape_rval ctx ask rval in - D.join ctx.local escaped + let escaped = escape_rval man ask rval in + D.join man.local escaped ) else begin - ctx.local + man.local end - let combine_assign ctx (lval:lval option) (fexp:exp) f args fc au f_ask : D.t = - let ask = Analyses.ask_of_ctx ctx in + let combine_assign man (lval:lval option) (fexp:exp) f args fc au f_ask : D.t = + let ask = Analyses.ask_of_man man in match lval with | Some lval when D.exists (fun v -> v.vglob || has_escaped ask v) (mpt ask (AddrOf lval)) -> let rval = Lval (ReturnUtil.return_lval ()) in - let escaped = escape_rval ctx f_ask rval in (* Using f_ask because the return value is only accessible in the context of that function at this point *) - D.join ctx.local escaped - | _ -> ctx.local + let escaped = escape_rval man f_ask rval in (* Using f_ask because the return value is only accessible in the context of that function at this point *) + D.join man.local escaped + | _ -> man.local - let special ctx (lval: lval option) (f:varinfo) (args:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (args:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special args, f.vname, args with | Globalize ptr, _, _ -> - let escaped = escape_rval ctx (Analyses.ask_of_ctx ctx) ptr in - D.join ctx.local escaped + let escaped = escape_rval man (Analyses.ask_of_man man) ptr in + D.join man.local escaped | _, "pthread_setspecific" , [key; pt_value] -> - let escaped = escape_rval ctx (Analyses.ask_of_ctx ctx) pt_value in - D.join ctx.local escaped - | _ -> ctx.local + let escaped = escape_rval man (Analyses.ask_of_man man) pt_value in + D.join man.local escaped + | _ -> man.local let startstate v = D.bot () let exitstate v = D.bot () - let threadenter ctx ~multiple lval f args = + let threadenter man ~multiple lval f args = [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = - D.join ctx.local @@ + let threadspawn man ~multiple lval f args fman = + D.join man.local @@ match args with | [ptc_arg] -> - (* not reusing fctx.local to avoid unnecessarily early join of extra *) - let escaped = reachable (Analyses.ask_of_ctx ctx) ptc_arg in + (* not reusing fman.local to avoid unnecessarily early join of extra *) + let escaped = reachable (Analyses.ask_of_man man) ptc_arg in let escaped = D.filter (fun v -> not v.vglob) escaped in if M.tracing then M.tracel "escape" "%a: %a" d_exp ptc_arg D.pretty escaped; - let thread_id = thread_id ctx in - emit_escape_event ctx escaped; - side_effect_escape ctx escaped thread_id; + let thread_id = thread_id man in + emit_escape_event man escaped; + side_effect_escape man escaped thread_id; escaped | _ -> D.bot () - let event ctx e octx = + let event man e oman = match e with | Events.EnterMultiThreaded -> - let escaped = ctx.local in - let thread_id = thread_id ctx in - emit_escape_event ctx escaped; - side_effect_escape ctx escaped thread_id; - ctx.local - | _ -> ctx.local + let escaped = man.local in + let thread_id = thread_id man in + emit_escape_event man escaped; + side_effect_escape man escaped thread_id; + man.local + | _ -> man.local end let _ = diff --git a/src/analyses/threadFlag.ml b/src/analyses/threadFlag.ml index e1efcaaba5..1e0ff7db9f 100644 --- a/src/analyses/threadFlag.ml +++ b/src/analyses/threadFlag.ml @@ -35,21 +35,21 @@ struct let create_tid v = Flag.get_multi () - let return ctx exp fundec = + let return man exp fundec = match fundec.svar.vname with | "__goblint_dummy_init" -> (* TODO: is this necessary? *) - Flag.join ctx.local (Flag.get_main ()) + Flag.join man.local (Flag.get_main ()) | _ -> - ctx.local + man.local - let query ctx (type a) (x: a Queries.t): a Queries.result = + let query man (type a) (x: a Queries.t): a Queries.result = match x with - | Queries.MustBeSingleThreaded _ -> not (Flag.is_multi ctx.local) (* If this analysis can tell, it is the case since the start *) - | Queries.MustBeUniqueThread -> not (Flag.is_not_main ctx.local) - | Queries.IsEverMultiThreaded -> (ctx.global () : bool) (* requires annotation to compile *) + | Queries.MustBeSingleThreaded _ -> not (Flag.is_multi man.local) (* If this analysis can tell, it is the case since the start *) + | Queries.MustBeUniqueThread -> not (Flag.is_not_main man.local) + | Queries.IsEverMultiThreaded -> (man.global () : bool) (* requires annotation to compile *) (* This used to be in base but also commented out. *) - (* | Queries.MayBePublic _ -> Flag.is_multi ctx.local *) + (* | Queries.MayBePublic _ -> Flag.is_multi man.local *) | _ -> Queries.Result.top x module A = @@ -59,19 +59,19 @@ struct let may_race m1 m2 = m1 && m2 (* kill access when single threaded *) let should_print m = not m end - let access ctx _ = - is_currently_multi (Analyses.ask_of_ctx ctx) + let access man _ = + is_currently_multi (Analyses.ask_of_man man) - let threadenter ctx ~multiple lval f args = - if not (has_ever_been_multi (Analyses.ask_of_ctx ctx)) then - ctx.emit Events.EnterMultiThreaded; + let threadenter man ~multiple lval f args = + if not (has_ever_been_multi (Analyses.ask_of_man man)) then + man.emit Events.EnterMultiThreaded; [create_tid f] - let threadspawn ctx ~multiple lval f args fctx = - ctx.sideg () true; - if not (has_ever_been_multi (Analyses.ask_of_ctx ctx)) then - ctx.emit Events.EnterMultiThreaded; - D.join ctx.local (Flag.get_main ()) + let threadspawn man ~multiple lval f args fman = + man.sideg () true; + if not (has_ever_been_multi (Analyses.ask_of_man man)) then + man.emit Events.EnterMultiThreaded; + D.join man.local (Flag.get_main ()) end let _ = diff --git a/src/analyses/threadId.ml b/src/analyses/threadId.ml index 80bab1ebf9..53d070a056 100644 --- a/src/analyses/threadId.ml +++ b/src/analyses/threadId.ml @@ -60,7 +60,7 @@ struct let name () = "threadid" - let context ctx fd ((n,current,td) as d) = + let context man fd ((n,current,td) as d) = if GobConfig.get_bool "ana.thread.context.create-edges" then d else @@ -85,15 +85,15 @@ struct | _ -> [`Lifted (Thread.threadinit v ~multiple:true)] - let is_unique ctx = - ctx.ask Queries.MustBeUniqueThread + let is_unique man = + man.ask Queries.MustBeUniqueThread - let enter ctx lval f args = - let (n, current, (td, _)) = ctx.local in - [ctx.local, (n, current, (td,TD.bot ()))] + let enter man lval f args = + let (n, current, (td, _)) = man.local in + [man.local, (n, current, (td,TD.bot ()))] - let combine_env ctx lval fexp f args fc ((n,current,(_, au_ftd)) as au) f_ask = - let (_, _, (td, ftd)) = ctx.local in + let combine_env man lval fexp f args fc ((n,current,(_, au_ftd)) as au) f_ask = + let (_, _, (td, ftd)) = man.local in if not (GobConfig.get_bool "ana.thread.context.create-edges") then (n,current,(TD.join td au_ftd, TD.join ftd au_ftd)) else @@ -104,23 +104,23 @@ struct | `Lifted current -> BatOption.map_default (ConcDomain.ThreadSet.of_list) (ConcDomain.ThreadSet.top ()) (Thread.created current td) | _ -> ConcDomain.ThreadSet.top () - let query (ctx: (D.t, _, _, _) ctx) (type a) (x: a Queries.t): a Queries.result = + let query (man: (D.t, _, _, _) man) (type a) (x: a Queries.t): a Queries.result = match x with - | Queries.CurrentThreadId -> Tuple3.second ctx.local - | Queries.CreatedThreads -> created ctx.local + | Queries.CurrentThreadId -> Tuple3.second man.local + | Queries.CreatedThreads -> created man.local | Queries.MustBeUniqueThread -> - begin match Tuple3.second ctx.local with + begin match Tuple3.second man.local with | `Lifted tid -> Thread.is_unique tid | _ -> Queries.MustBool.top () end | Queries.MustBeSingleThreaded {since_start} -> - begin match Tuple3.second ctx.local with + begin match Tuple3.second man.local with | `Lifted tid when Thread.is_main tid -> - let created = created ctx.local in + let created = created man.local in if since_start then ConcDomain.ThreadSet.is_empty created - else if ctx.ask Queries.ThreadsJoinedCleanly then - let joined = ctx.ask Queries.MustJoinedThreads in + else if man.ask Queries.ThreadsJoinedCleanly then + let joined = man.ask Queries.MustJoinedThreads in ConcDomain.ThreadSet.is_empty (ConcDomain.ThreadSet.diff created joined) else false @@ -138,28 +138,28 @@ struct let should_print = Option.is_some end - let access ctx _ = - if is_unique ctx then - let tid = Tuple3.second ctx.local in + let access man _ = + if is_unique man then + let tid = Tuple3.second man.local in Some tid else None (** get the node that identifies the current context, possibly that of a wrapper function *) - let indexed_node_for_ctx ctx = - match ctx.ask Queries.ThreadCreateIndexedNode with + let indexed_node_for_man man = + match man.ask Queries.ThreadCreateIndexedNode with | `Lifted node, count when WrapperFunctionAnalysis.ThreadCreateUniqueCount.is_top count -> node, None | `Lifted node, count -> node, Some count - | (`Bot | `Top), _ -> ctx.prev_node, None + | (`Bot | `Top), _ -> man.prev_node, None - let threadenter ctx ~multiple lval f args:D.t list = - let n, i = indexed_node_for_ctx ctx in - let+ tid = create_tid ~multiple ctx.local (n, i) f in + let threadenter man ~multiple lval f args:D.t list = + let n, i = indexed_node_for_man man in + let+ tid = create_tid ~multiple man.local (n, i) f in (`Lifted (f, n, i), tid, (TD.bot (), TD.bot ())) - let threadspawn ctx ~multiple lval f args fctx = - let (current_n, current, (td,tdl)) = ctx.local in - let v, n, i = match fctx.local with `Lifted vni, _, _ -> vni | _ -> failwith "ThreadId.threadspawn" in + let threadspawn man ~multiple lval f args fman = + let (current_n, current, (td,tdl)) = man.local in + let v, n, i = match fman.local with `Lifted vni, _, _ -> vni | _ -> failwith "ThreadId.threadspawn" in (current_n, current, (Thread.threadspawn ~multiple td n i v, Thread.threadspawn ~multiple tdl n i v)) type marshal = (Thread.t,unit) Hashtbl.t (* TODO: don't use polymorphic Hashtbl *) diff --git a/src/analyses/threadJoins.ml b/src/analyses/threadJoins.ml index eddbe184da..354c40072a 100644 --- a/src/analyses/threadJoins.ml +++ b/src/analyses/threadJoins.ml @@ -28,43 +28,43 @@ struct end (* transfer functions *) - let threadreturn ctx = - match ctx.ask CurrentThreadId with + let threadreturn man = + match man.ask CurrentThreadId with | `Lifted tid -> - let (j,joined_clean) = ctx.local in + let (j,joined_clean) = man.local in (* the current thread has been exited cleanly if all joined threads where exited cleanly, and all created threads are joined *) - let created = ctx.ask Queries.CreatedThreads in + let created = man.ask Queries.CreatedThreads in let clean = TIDs.subset created j in - ctx.sideg tid (j, joined_clean && clean) + man.sideg tid (j, joined_clean && clean) | _ -> () (* correct? *) - let return ctx (exp:exp option) (f:fundec) : D.t = - if ThreadReturn.is_current (Analyses.ask_of_ctx ctx) then threadreturn ctx; - ctx.local + let return man (exp:exp option) (f:fundec) : D.t = + if ThreadReturn.is_current (Analyses.ask_of_man man) then threadreturn man; + man.local - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in match desc.special arglist, f.vname with - | ThreadExit _, _ -> threadreturn ctx; ctx.local + | ThreadExit _, _ -> threadreturn man; man.local | ThreadJoin { thread = id; ret_var }, _ -> - let threads = ctx.ask (Queries.EvalThread id) in + let threads = man.ask (Queries.EvalThread id) in if TIDs.is_top threads then - ctx.local + man.local else ( (* all elements are known *) let threads = TIDs.elements threads in match threads with | [tid] when TID.is_unique tid-> - let (local_joined, local_clean) = ctx.local in - let (other_joined, other_clean) = ctx.global tid in + let (local_joined, local_clean) = man.local in + let (other_joined, other_clean) = man.global tid in (MustTIDs.union (MustTIDs.add tid local_joined) other_joined, local_clean && other_clean) - | _ -> ctx.local (* if multiple possible thread ids are joined, none of them is must joined *) + | _ -> man.local (* if multiple possible thread ids are joined, none of them is must joined *) (* Possible improvement: Do the intersection first, things that are must joined in all possibly joined threads are must-joined *) ) | Unknown, "__goblint_assume_join" -> let id = List.hd arglist in - let threads = ctx.ask (Queries.EvalThread id) in + let threads = man.ask (Queries.EvalThread id) in if TIDs.is_top threads then ( M.info ~category:Unsound "Unknown thread ID assume-joined, assuming ALL threads must-joined."; (MustTIDs.bot(), true) (* consider everything joined, MustTIDs is reversed so bot is All threads *) @@ -75,33 +75,33 @@ struct if List.compare_length_with threads 1 > 0 then M.info ~category:Unsound "Ambiguous thread ID assume-joined, assuming all of those threads must-joined."; List.fold_left (fun (joined, clean) tid -> - let (other_joined, other_clean) = ctx.global tid in + let (other_joined, other_clean) = man.global tid in (MustTIDs.union (MustTIDs.add tid joined) other_joined, clean && other_clean) - ) (ctx.local) threads + ) (man.local) threads ) - | _, _ -> ctx.local + | _, _ -> man.local - let threadspawn ctx ~multiple lval f args fctx = - if D.is_bot ctx.local then ( (* bot is All threads *) + let threadspawn man ~multiple lval f args fman = + if D.is_bot man.local then ( (* bot is All threads *) M.info ~category:Imprecise "Thread created while ALL threads must-joined, continuing with no threads joined."; D.top () (* top is no threads *) ) else - match ThreadId.get_current (Analyses.ask_of_ctx fctx) with + match ThreadId.get_current (Analyses.ask_of_man fman) with | `Lifted tid -> - let (j, clean) = ctx.local in + let (j, clean) = man.local in (MustTIDs.remove tid j, clean) | _ -> - ctx.local + man.local - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with - | Queries.MustJoinedThreads -> (fst ctx.local:ConcDomain.MustThreadSet.t) (* type annotation needed to avoid "would escape the scope of its equation" *) - | Queries.ThreadsJoinedCleanly -> (snd ctx.local:bool) + | Queries.MustJoinedThreads -> (fst man.local:ConcDomain.MustThreadSet.t) (* type annotation needed to avoid "would escape the scope of its equation" *) + | Queries.ThreadsJoinedCleanly -> (snd man.local:bool) | _ -> Queries.Result.top q - let combine_env ctx lval fexp f args fc au f_ask = - let (caller_joined, local_clean) = ctx.local in + let combine_env man lval fexp f args fc au f_ask = + let (caller_joined, local_clean) = man.local in let (callee_joined, callee_clean) = au in (MustTIDs.union caller_joined callee_joined, local_clean && callee_clean) diff --git a/src/analyses/threadReturn.ml b/src/analyses/threadReturn.ml index d72e2586e8..c557be40e6 100644 --- a/src/analyses/threadReturn.ml +++ b/src/analyses/threadReturn.ml @@ -17,23 +17,23 @@ struct (* transfer functions *) - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = if !AnalysisState.global_initialization then (* We are inside enter_with inside a startfun, and thus the current function retruning is the main function *) - [ctx.local, true] + [man.local, true] else - [ctx.local, false] + [man.local, false] - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local (* keep local as opposed to IdentitySpec *) + let combine_env man lval fexp f args fc au f_ask = + man.local (* keep local as opposed to IdentitySpec *) let startstate v = true - let threadenter ctx ~multiple lval f args = [true] + let threadenter man ~multiple lval f args = [true] let exitstate v = D.top () - let query (ctx: (D.t, _, _, _) ctx) (type a) (x: a Queries.t): a Queries.result = + let query (man: (D.t, _, _, _) man) (type a) (x: a Queries.t): a Queries.result = match x with - | Queries.MayBeThreadReturn -> ctx.local + | Queries.MayBeThreadReturn -> man.local | _ -> Queries.Result.top x end diff --git a/src/analyses/tmpSpecial.ml b/src/analyses/tmpSpecial.ml index 78056e3857..fd2b6f71e3 100644 --- a/src/analyses/tmpSpecial.ml +++ b/src/analyses/tmpSpecial.ml @@ -21,22 +21,22 @@ struct D.filter (fun _ (ml, deps) -> (Deps.for_all (fun arg -> not (VarEq.may_change ask exp_w arg)) deps)) st (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = + let assign man (lval:lval) (rval:exp) : D.t = if M.tracing then M.tracel "tmpSpecial" "assignment of %a" d_lval lval; (* Invalidate all entrys from the map that are possibly written by the assignment *) - invalidate (Analyses.ask_of_ctx ctx) (mkAddrOf lval) ctx.local + invalidate (Analyses.ask_of_man man) (mkAddrOf lval) man.local - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = (* For now we only track relationships intraprocedurally. *) - [ctx.local, D.bot ()] + [man.local, D.bot ()] - let combine ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) f_ask : D.t = + let combine man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) f_ask : D.t = (* For now we only track relationships intraprocedurally. *) D.bot () - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - let d = ctx.local in - let ask = Analyses.ask_of_ctx ctx in + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let d = man.local in + let ask = Analyses.ask_of_man man in (* Just dbg prints *) (if M.tracing then @@ -55,7 +55,7 @@ struct (* same for lval assignment of the call*) let d = match lval with - | Some lv -> invalidate ask (mkAddrOf lv) ctx.local + | Some lv -> invalidate ask (mkAddrOf lv) man.local | None -> d in @@ -77,16 +77,16 @@ struct d - let query ctx (type a) (q: a Queries.t) : a Queries.result = + let query man (type a) (q: a Queries.t) : a Queries.result = match q with - | TmpSpecial lv -> let ml = fst (D.find lv ctx.local) in + | TmpSpecial lv -> let ml = fst (D.find lv man.local) in if ML.is_bot ml then Queries.Result.top q else ml | _ -> Queries.Result.top q let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.bot ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.bot () end diff --git a/src/analyses/tutorials/constants.ml b/src/analyses/tutorials/constants.ml index 0c7d801df7..5a5a8f7051 100644 --- a/src/analyses/tutorials/constants.ml +++ b/src/analyses/tutorials/constants.ml @@ -49,29 +49,29 @@ struct | _ -> I.top () (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = + let assign man (lval:lval) (rval:exp) : D.t = match get_local lval with - | Some loc -> D.add loc (eval ctx.local rval) ctx.local - | None -> ctx.local + | Some loc -> D.add loc (eval man.local rval) man.local + | None -> man.local - let branch ctx (exp:exp) (tv:bool) : D.t = - let v = eval ctx.local exp in + let branch man (exp:exp) (tv:bool) : D.t = + let v = eval man.local exp in match I.to_bool v with | Some b when b <> tv -> raise Deadcode (* if the expression evaluates to not tv, the tv branch is not reachable *) - | _ -> ctx.local + | _ -> man.local - let body ctx (f:fundec) : D.t = + let body man (f:fundec) : D.t = (* Initialize locals to top *) - List.fold_left (fun m l -> D.add l (I.top ()) m) ctx.local f.slocals + List.fold_left (fun m l -> D.add l (I.top ()) m) man.local f.slocals - let return ctx (exp:exp option) (f:fundec) : D.t = + let return man (exp:exp option) (f:fundec) : D.t = (* Do nothing, as we are not interested in return values for now. *) - ctx.local + man.local - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = (* Set the formal int arguments to top *) let callee_state = List.fold_left (fun m l -> D.add l (I.top ()) m) (D.bot ()) f.sformals in - [(ctx.local, callee_state)] + [(man.local, callee_state)] let set_local_int_lval_top (state: D.t) (lval: lval option) = match lval with @@ -82,18 +82,18 @@ struct ) |_ -> state - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local (* keep local as opposed to IdentitySpec *) + let combine_env man lval fexp f args fc au f_ask = + man.local (* keep local as opposed to IdentitySpec *) - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask): D.t = + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask): D.t = (* If we have a function call with assignment x = f (e1, ... , ek) with a local int variable x on the left, we set it to top *) - set_local_int_lval_top ctx.local lval + set_local_int_lval_top man.local lval - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = (* When calling a special function, and assign the result to some local int variable, we also set it to top. *) - set_local_int_lval_top ctx.local lval + set_local_int_lval_top man.local lval let startstate v = D.bot () let exitstate v = D.top () (* TODO: why is this different from startstate? *) diff --git a/src/analyses/tutorials/signs.ml b/src/analyses/tutorials/signs.ml index 28f7e0acdc..a605bb3910 100644 --- a/src/analyses/tutorials/signs.ml +++ b/src/analyses/tutorials/signs.ml @@ -66,8 +66,8 @@ struct (* Transfer functions: we only implement assignments here. * You can leave this code alone... *) - let assign ctx (lval:lval) (rval:exp) : D.t = - let d = ctx.local in + let assign man (lval:lval) (rval:exp) : D.t = + let d = man.local in match lval with | (Var x, NoOffset) when not x.vaddrof -> D.add x (eval d rval) d | _ -> D.top () @@ -81,10 +81,10 @@ struct (* We should now provide this information to Goblint. Assertions are integer expressions, * so we implement here a response to EvalInt queries. * You should definitely leave this alone... *) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = let open Queries in match q with - | EvalInt e when assert_holds ctx.local e -> + | EvalInt e when assert_holds man.local e -> let ik = Cilfacade.get_ikind_exp e in ID.of_bool ik true | _ -> Result.top q diff --git a/src/analyses/tutorials/taint.ml b/src/analyses/tutorials/taint.ml index f62a5a4722..6f341618cc 100644 --- a/src/analyses/tutorials/taint.ml +++ b/src/analyses/tutorials/taint.ml @@ -28,7 +28,7 @@ struct module C = Printable.Unit (* We are context insensitive in this analysis *) - let context ctx _ _ = () + let context man _ _ = () let startcontext () = () @@ -58,8 +58,8 @@ struct (* transfer functions *) (** Handles assignment of [rval] to [lval]. *) - let assign ctx (lval:lval) (rval:exp) : D.t = - let state = ctx.local in + let assign man (lval:lval) (rval:exp) : D.t = + let state = man.local in match lval with | Var v,_ -> (* TODO: Check whether rval is tainted, handle assignment to v accordingly *) @@ -67,19 +67,19 @@ struct | _ -> state (** Handles conditional branching yielding truth value [tv]. *) - let branch ctx (exp:exp) (tv:bool) : D.t = + let branch man (exp:exp) (tv:bool) : D.t = (* Nothing needs to be done *) - ctx.local + man.local (** Handles going from start node of function [f] into the function body of [f]. Meant to handle e.g. initializiation of local variables. *) - let body ctx (f:fundec) : D.t = + let body man (f:fundec) : D.t = (* Nothing needs to be done here, as the (non-formals) locals are initally untainted *) - ctx.local + man.local (** Handles the [return] statement, i.e. "return exp" or "return", in function [f]. *) - let return ctx (exp:exp option) (f:fundec) : D.t = - let state = ctx.local in + let return man (exp:exp option) (f:fundec) : D.t = + let state = man.local in match exp with | Some e -> (* TODO: Record whether a tainted value was returned. *) @@ -91,8 +91,8 @@ struct [enter] returns a caller state, and the initial state of the callee. In [enter], the caller state can usually be returned unchanged, as [combine_env] and [combine_assign] (below) will compute the caller state after the function call, given the return state of the callee. *) - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - let caller_state = ctx.local in + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let caller_state = man.local in (* Create list of (formal, actual_exp)*) let zipped = List.combine f.sformals args in (* TODO: For the initial callee_state, collect formal parameters where the actual is tainted. *) @@ -108,31 +108,31 @@ struct (** For a function call "lval = f(args)" or "f(args)", computes the global environment state of the caller after the call. Argument [callee_local] is the state of [f] at its return node. *) - let combine_env ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask: Queries.ask): D.t = + let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask: Queries.ask): D.t = (* Nothing needs to be done *) - ctx.local + man.local (** For a function call "lval = f(args)" or "f(args)", computes the state of the caller after assigning the return value from the call. Argument [callee_local] is the state of [f] at its return node. *) - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask: Queries.ask): D.t = - let caller_state = ctx.local in + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask: Queries.ask): D.t = + let caller_state = man.local in (* TODO: Record whether lval was tainted. *) caller_state (** For a call to a _special_ function f "lval = f(args)" or "f(args)", computes the caller state after the function call. For this analysis, source and sink functions will be considered _special_ and have to be treated here. *) - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - let caller_state = ctx.local in + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let caller_state = man.local in (* TODO: Check if f is a sink / source and handle it appropriately *) (* To warn about a potential issue in the code, use M.warn. *) caller_state (* You may leave these alone *) let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.top ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.top ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.top () end diff --git a/src/analyses/tutorials/unitAnalysis.ml b/src/analyses/tutorials/unitAnalysis.ml index 225767f010..23c336bfa1 100644 --- a/src/analyses/tutorials/unitAnalysis.ml +++ b/src/analyses/tutorials/unitAnalysis.ml @@ -14,34 +14,34 @@ struct module C = Printable.Unit (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - ctx.local + let assign man (lval:lval) (rval:exp) : D.t = + man.local - let branch ctx (exp:exp) (tv:bool) : D.t = - ctx.local + let branch man (exp:exp) (tv:bool) : D.t = + man.local - let body ctx (f:fundec) : D.t = - ctx.local + let body man (f:fundec) : D.t = + man.local - let return ctx (exp:exp option) (f:fundec) : D.t = - ctx.local + let return man (exp:exp option) (f:fundec) : D.t = + man.local - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - [ctx.local, ctx.local] + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + [man.local, man.local] - let combine_env ctx lval fexp f args fc au f_ask = + let combine_env man 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 combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + man.local - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - ctx.local + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + man.local let startcontext () = () let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.top ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.top ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.top () end diff --git a/src/analyses/unassumeAnalysis.ml b/src/analyses/unassumeAnalysis.ml index 1b430e651a..fe1c4809cd 100644 --- a/src/analyses/unassumeAnalysis.ml +++ b/src/analyses/unassumeAnalysis.ml @@ -248,39 +248,39 @@ struct | Error (`Msg e) -> M.error_noloc ~category:Witness "couldn't parse entry: %s" e ) yaml_entries - let emit_unassume ctx = - let es = NH.find_all invs ctx.node in + let emit_unassume man = + let es = NH.find_all invs man.node in let es = D.fold (fun pre acc -> - match NH.find_option pre_invs ctx.node with + match NH.find_option pre_invs man.node with | Some eh -> EH.find_all eh pre @ acc | None -> acc - ) ctx.local es + ) man.local es in match es with | x :: xs -> let e = List.fold_left (fun a {exp = b; _} -> Cil.(BinOp (LAnd, a, b, intType))) x.exp xs in M.info ~category:Witness "unassume invariant: %a" CilType.Exp.pretty e; if not !AnalysisState.postsolving then ( - if not (GobConfig.get_bool "ana.unassume.precheck" && Queries.ID.to_bool (ctx.ask (EvalInt e)) = Some false) then ( + if not (GobConfig.get_bool "ana.unassume.precheck" && Queries.ID.to_bool (man.ask (EvalInt e)) = Some false) then ( let tokens = x.token :: List.map (fun {token; _} -> token) xs in - ctx.emit (Unassume {exp = e; tokens}); + man.emit (Unassume {exp = e; tokens}); List.iter WideningTokenLifter.add tokens ) ); - ctx.local + man.local | [] -> - ctx.local + man.local - let assign ctx lv e = - emit_unassume ctx + let assign man lv e = + emit_unassume man - let branch ctx e tv = - emit_unassume ctx + let branch man e tv = + emit_unassume man - let body ctx fd = + let body man fd = let pres = FH.find_all fun_pres fd in let st = List.fold_left (fun acc pre -> - let v = ctx.ask (EvalInt pre) in + let v = man.ask (EvalInt pre) in (* M.debug ~category:Witness "%a precondition %a evaluated to %a" CilType.Fundec.pretty fd CilType.Exp.pretty pre Queries.ID.pretty v; *) if Queries.ID.to_bool v = Some true then D.add pre acc @@ -289,25 +289,25 @@ struct ) (D.empty ()) pres in - emit_unassume {ctx with local = st} (* doesn't query, so no need to redefine ask *) + emit_unassume {man with local = st} (* doesn't query, so no need to redefine ask *) - let asm ctx = - emit_unassume ctx + let asm man = + emit_unassume man - let skip ctx = - emit_unassume ctx + let skip man = + emit_unassume man - let special ctx lv f args = - emit_unassume ctx + let special man lv f args = + emit_unassume man - let enter ctx lv f args = - [(ctx.local, D.empty ())] + let enter man lv f args = + [(man.local, D.empty ())] - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local (* not here because isn't final transfer function on edge *) + let combine_env man lval fexp f args fc au f_ask = + man.local (* not here because isn't final transfer function on edge *) - let combine_assign ctx lv fe f args fc fd f_ask = - emit_unassume ctx + let combine_assign man lv fe f args fc fd f_ask = + emit_unassume man (* not in sync, query, entry, threadenter because they aren't final transfer function on edge *) (* not in vdecl, return, threadspawn because unnecessary targets for invariants? *) diff --git a/src/analyses/uninit.ml b/src/analyses/uninit.ml index 8c217cda4e..a8689d9e8b 100644 --- a/src/analyses/uninit.ml +++ b/src/analyses/uninit.ml @@ -25,8 +25,8 @@ struct let name () = "uninit" let startstate v : D.t = D.empty () - let threadenter ctx ~multiple lval f args = [D.empty ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.empty ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v : D.t = D.empty () let access_address (ask: Queries.ask) write lv = @@ -219,48 +219,48 @@ struct (* Transfer functions *) - let assign ctx (lval:lval) (rval:exp) : trans_out = - ignore (is_expr_initd (Analyses.ask_of_ctx ctx) rval ctx.local); - init_lval (Analyses.ask_of_ctx ctx) lval ctx.local + let assign man (lval:lval) (rval:exp) : trans_out = + ignore (is_expr_initd (Analyses.ask_of_man man) rval man.local); + init_lval (Analyses.ask_of_man man) lval man.local - let branch ctx (exp:exp) (tv:bool) : trans_out = - ignore (is_expr_initd (Analyses.ask_of_ctx ctx) exp ctx.local); - ctx.local + let branch man (exp:exp) (tv:bool) : trans_out = + ignore (is_expr_initd (Analyses.ask_of_man man) exp man.local); + man.local - let body ctx (f:fundec) : trans_out = + let body man (f:fundec) : trans_out = let add_var st v = List.fold_right D.add (to_addrs v) st in - List.fold_left add_var ctx.local f.slocals + List.fold_left add_var man.local f.slocals - let return ctx (exp:exp option) (f:fundec) : trans_out = + let return man (exp:exp option) (f:fundec) : trans_out = let remove_var x v = List.fold_right D.remove (to_addrs v) x in - let nst = List.fold_left remove_var ctx.local (f.slocals @ f.sformals) in + let nst = List.fold_left remove_var man.local (f.slocals @ f.sformals) in match exp with - | Some exp -> ignore (is_expr_initd (Analyses.ask_of_ctx ctx) exp ctx.local); nst + | Some exp -> ignore (is_expr_initd (Analyses.ask_of_man man) exp man.local); nst | _ -> nst - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - let nst = remove_unreachable (Analyses.ask_of_ctx ctx) args ctx.local in - [ctx.local, nst] + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let nst = remove_unreachable (Analyses.ask_of_man man) args man.local in + [man.local, nst] - let combine_env ctx lval fexp f args fc au f_ask = - ignore (List.map (fun x -> is_expr_initd (Analyses.ask_of_ctx ctx) x ctx.local) args); - let cal_st = remove_unreachable (Analyses.ask_of_ctx ctx) args ctx.local in - D.union au (D.diff ctx.local cal_st) + let combine_env man lval fexp f args fc au f_ask = + ignore (List.map (fun x -> is_expr_initd (Analyses.ask_of_man man) x man.local) args); + let cal_st = remove_unreachable (Analyses.ask_of_man man) args man.local in + D.union au (D.diff man.local cal_st) - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : trans_out = + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : trans_out = match lval with - | None -> ctx.local - | Some lv -> init_lval (Analyses.ask_of_ctx ctx) lv ctx.local + | None -> man.local + | Some lv -> init_lval (Analyses.ask_of_man man) lv man.local - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = match lval with - | Some lv -> init_lval (Analyses.ask_of_ctx ctx) lv ctx.local - | _ -> ctx.local + | Some lv -> init_lval (Analyses.ask_of_man man) lv man.local + | _ -> man.local - (* let fork ctx (lval: lval option) (f : varinfo) (args : exp list) : (varinfo * D.t) list = + (* let fork man (lval: lval option) (f : varinfo) (args : exp list) : (varinfo * D.t) list = [] (* thats wrong: should be [None, top ()] *)*) end diff --git a/src/analyses/useAfterFree.ml b/src/analyses/useAfterFree.ml index 6aa3e1e84c..32a095a13c 100644 --- a/src/analyses/useAfterFree.ml +++ b/src/analyses/useAfterFree.ml @@ -25,16 +25,16 @@ struct (* HELPER FUNCTIONS *) - let get_current_threadid ctx = - ctx.ask Queries.CurrentThreadId + let get_current_threadid man = + man.ask Queries.CurrentThreadId - let get_joined_threads ctx = - ctx.ask Queries.MustJoinedThreads + let get_joined_threads man = + man.ask Queries.MustJoinedThreads - let warn_for_multi_threaded_access ctx ?(is_double_free = false) (heap_var:varinfo) behavior cwe_number = - let freeing_threads = ctx.global heap_var in + let warn_for_multi_threaded_access man ?(is_double_free = false) (heap_var:varinfo) behavior cwe_number = + let freeing_threads = man.global heap_var in (* If we're single-threaded or there are no threads freeing the memory, we have nothing to WARN about *) - if ctx.ask (Queries.MustBeSingleThreaded { since_start = true }) || G.is_empty freeing_threads then () + if man.ask (Queries.MustBeSingleThreaded { since_start = true }) || G.is_empty freeing_threads then () else begin let other_possibly_started current tid joined_threads = match tid with @@ -42,7 +42,7 @@ struct (* if our own (unique) thread is started here, that is not a problem *) false | `Lifted tid -> - let created_threads = ctx.ask Queries.CreatedThreads in + let created_threads = man.ask Queries.CreatedThreads in let not_started = MHP.definitely_not_started (current, created_threads) tid in let possibly_started = not not_started in (* If [current] is possibly running together with [tid], but is also joined before the free() in [tid], then no need to WARN *) @@ -59,7 +59,7 @@ struct | `Bot -> false in let bug_name = if is_double_free then "Double Free" else "Use After Free" in - match get_current_threadid ctx with + match get_current_threadid man with | `Lifted current -> let possibly_started = G.exists (other_possibly_started current) freeing_threads in if possibly_started then begin @@ -73,7 +73,7 @@ struct if is_double_free then set_mem_safety_flag InvalidFree else set_mem_safety_flag InvalidDeref; M.warn ~category:(Behavior behavior) ~tags:[CWE cwe_number] "Current thread is not unique and a %s might occur for heap variable %a" bug_name CilType.Varinfo.pretty heap_var end - else if HeapVars.mem heap_var (snd ctx.local) then begin + else if HeapVars.mem heap_var (snd man.local) then begin if is_double_free then set_mem_safety_flag InvalidFree else set_mem_safety_flag InvalidDeref; M.warn ~category:(Behavior behavior) ~tags:[CWE cwe_number] "%s might occur in current unique thread %a for heap variable %a" bug_name ThreadIdDomain.Thread.pretty current CilType.Varinfo.pretty heap_var end @@ -85,19 +85,19 @@ struct M.warn ~category:MessageCategory.Analyzer "CurrentThreadId is bottom" end - let rec warn_lval_might_contain_freed ?(is_implicitly_derefed = false) ?(is_double_free = false) (transfer_fn_name:string) ctx (lval:lval) = + let rec warn_lval_might_contain_freed ?(is_implicitly_derefed = false) ?(is_double_free = false) (transfer_fn_name:string) man (lval:lval) = match is_implicitly_derefed, is_double_free, lval with (* If we're not checking for a double-free and there's no deref happening, then there's no need to check for an invalid deref or an invalid free *) | false, false, (Var _, NoOffset) -> () | _ -> - let state = ctx.local in + let state = man.local in let undefined_behavior = if is_double_free then Undefined DoubleFree else Undefined UseAfterFree in let cwe_number = if is_double_free then 415 else 416 in let rec offset_might_contain_freed offset = match offset with | NoOffset -> () | Field (f, o) -> offset_might_contain_freed o - | Index (e, o) -> warn_exp_might_contain_freed transfer_fn_name ctx e; offset_might_contain_freed o + | Index (e, o) -> warn_exp_might_contain_freed transfer_fn_name man e; offset_might_contain_freed o in let (lval_host, o) = lval in offset_might_contain_freed o; (* Check the lval's offset *) let lval_to_query = @@ -105,7 +105,7 @@ struct | Var _ -> Lval lval | Mem _ -> mkAddrOf lval (* Take the lval's address if its lhost is of the form *p, where p is a ptr *) in - begin match ctx.ask (Queries.MayPointTo lval_to_query) with + begin match man.ask (Queries.MayPointTo lval_to_query) with | ad when not (Queries.AD.is_top ad) -> let warn_for_heap_var v = if HeapVars.mem v (snd state) then begin @@ -116,18 +116,18 @@ struct let pointed_to_heap_vars = Queries.AD.fold (fun addr vars -> match addr with - | Queries.AD.Addr.Addr (v,_) when ctx.ask (Queries.IsAllocVar v) -> v :: vars + | Queries.AD.Addr.Addr (v,_) when man.ask (Queries.IsAllocVar v) -> v :: vars | _ -> vars ) ad [] in (* Warn for all heap vars that the lval possibly points to *) List.iter warn_for_heap_var pointed_to_heap_vars; (* Warn for a potential multi-threaded UAF for all heap vars that the lval possibly points to *) - List.iter (fun heap_var -> warn_for_multi_threaded_access ctx ~is_double_free heap_var undefined_behavior cwe_number) pointed_to_heap_vars + List.iter (fun heap_var -> warn_for_multi_threaded_access man ~is_double_free heap_var undefined_behavior cwe_number) pointed_to_heap_vars | _ -> () end - and warn_exp_might_contain_freed ?(is_implicitly_derefed = false) ?(is_double_free = false) (transfer_fn_name:string) ctx (exp:exp) = + and warn_exp_might_contain_freed ?(is_implicitly_derefed = false) ?(is_double_free = false) (transfer_fn_name:string) man (exp:exp) = match exp with (* Base recursion cases *) | Const _ @@ -141,53 +141,53 @@ struct | SizeOfE e | AlignOfE e | UnOp (_, e, _) - | CastE (_, e) -> warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name ctx e + | CastE (_, e) -> warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name man e | BinOp (_, e1, e2, _) -> - warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name ctx e1; - warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name ctx e2 + warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name man e1; + warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name man e2 | Question (e1, e2, e3, _) -> - warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name ctx e1; - warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name ctx e2; - warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name ctx e3 + warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name man e1; + warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name man e2; + warn_exp_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name man e3 (* Lval cases (need [warn_lval_might_contain_freed] for them) *) | Lval lval | StartOf lval - | AddrOf lval -> warn_lval_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name ctx lval + | AddrOf lval -> warn_lval_might_contain_freed ~is_implicitly_derefed ~is_double_free transfer_fn_name man lval - let side_effect_mem_free ctx freed_heap_vars threadid joined_threads = + let side_effect_mem_free man freed_heap_vars threadid joined_threads = let side_effect_globals_to_heap_var heap_var = - let current_globals = ctx.global heap_var in + let current_globals = man.global heap_var in let globals_to_side_effect = G.add threadid joined_threads current_globals in - ctx.sideg heap_var globals_to_side_effect + man.sideg heap_var globals_to_side_effect in HeapVars.iter side_effect_globals_to_heap_var freed_heap_vars (* TRANSFER FUNCTIONS *) - let assign ctx (lval:lval) (rval:exp) : D.t = - warn_lval_might_contain_freed "assign" ctx lval; - warn_exp_might_contain_freed "assign" ctx rval; - ctx.local + let assign man (lval:lval) (rval:exp) : D.t = + warn_lval_might_contain_freed "assign" man lval; + warn_exp_might_contain_freed "assign" man rval; + man.local - let branch ctx (exp:exp) (tv:bool) : D.t = - warn_exp_might_contain_freed "branch" ctx exp; - ctx.local + let branch man (exp:exp) (tv:bool) : D.t = + warn_exp_might_contain_freed "branch" man exp; + man.local - let return ctx (exp:exp option) (f:fundec) : D.t = - Option.iter (fun x -> warn_exp_might_contain_freed "return" ctx x) exp; - ctx.local + let return man (exp:exp option) (f:fundec) : D.t = + Option.iter (fun x -> warn_exp_might_contain_freed "return" man x) exp; + man.local - let enter ctx (lval:lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - let caller_state = ctx.local in - List.iter (fun arg -> warn_exp_might_contain_freed "enter" ctx arg) args; + let enter man (lval:lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let caller_state = man.local in + List.iter (fun arg -> warn_exp_might_contain_freed "enter" man arg) args; (* TODO: The 2nd component of the callee state needs to contain only the heap vars from the caller state which are reachable from: *) (* * Global program variables *) (* * The callee arguments *) [caller_state, (AllocaVars.empty (), snd caller_state)] - let combine_env ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask:Queries.ask) : D.t = - let (caller_stack_state, caller_heap_state) = ctx.local in + let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask:Queries.ask) : D.t = + let (caller_stack_state, caller_heap_state) = man.local in let callee_stack_state = fst callee_local in let callee_heap_state = snd callee_local in (* Put all alloca()-vars together with all freed() vars in the caller's second component *) @@ -195,12 +195,12 @@ struct let callee_combined_state = HeapVars.join callee_stack_state callee_heap_state in (caller_stack_state, HeapVars.join caller_heap_state callee_combined_state) - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask: Queries.ask): D.t = - Option.iter (fun x -> warn_lval_might_contain_freed "enter" ctx x) lval; - ctx.local + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (callee_local:D.t) (f_ask: Queries.ask): D.t = + Option.iter (fun x -> warn_lval_might_contain_freed "enter" man x) lval; + man.local - let special ctx (lval:lval option) (f:varinfo) (arglist:exp list) : D.t = - let state = ctx.local in + let special man (lval:lval option) (f:varinfo) (arglist:exp list) : D.t = + let state = man.local in let desc = LibraryFunctions.find f in let is_arg_implicitly_derefed arg = let read_shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Read; deep = false } arglist in @@ -209,28 +209,28 @@ struct let write_deep_args = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = true } arglist in List.mem arg read_shallow_args || List.mem arg read_deep_args || List.mem arg write_shallow_args || List.mem arg write_deep_args in - Option.iter (fun x -> warn_lval_might_contain_freed ("special: " ^ f.vname) ctx x) lval; - List.iter (fun arg -> warn_exp_might_contain_freed ~is_implicitly_derefed:(is_arg_implicitly_derefed arg) ~is_double_free:(match desc.special arglist with Free _ -> true | _ -> false) ("special: " ^ f.vname) ctx arg) arglist; + Option.iter (fun x -> warn_lval_might_contain_freed ("special: " ^ f.vname) man x) lval; + List.iter (fun arg -> warn_exp_might_contain_freed ~is_implicitly_derefed:(is_arg_implicitly_derefed arg) ~is_double_free:(match desc.special arglist with Free _ -> true | _ -> false) ("special: " ^ f.vname) man arg) arglist; match desc.special arglist with | Free ptr -> - begin match ctx.ask (Queries.MayPointTo ptr) with + begin match man.ask (Queries.MayPointTo ptr) with | ad when not (Queries.AD.is_top ad) -> let pointed_to_heap_vars = Queries.AD.fold (fun addr state -> match addr with - | Queries.AD.Addr.Addr (var,_) when ctx.ask (Queries.IsAllocVar var) && ctx.ask (Queries.IsHeapVar var) -> HeapVars.add var state + | Queries.AD.Addr.Addr (var,_) when man.ask (Queries.IsAllocVar var) && man.ask (Queries.IsHeapVar var) -> HeapVars.add var state | _ -> state ) ad (HeapVars.empty ()) in (* Side-effect the tid that's freeing all the heap vars collected here *) - side_effect_mem_free ctx pointed_to_heap_vars (get_current_threadid ctx) (get_joined_threads ctx); + side_effect_mem_free man pointed_to_heap_vars (get_current_threadid man) (get_joined_threads man); (* Add all heap vars, which ptr points to, to the state *) (fst state, HeapVars.join (snd state) pointed_to_heap_vars) | _ -> state end | Alloca _ -> (* Create fresh heap var for the alloca() call *) - begin match ctx.ask (Queries.AllocVar {on_stack = true}) with + begin match man.ask (Queries.AllocVar {on_stack = true}) with | `Lifted v -> (AllocaVars.add v (fst state), snd state) | _ -> state end diff --git a/src/analyses/varEq.ml b/src/analyses/varEq.ml index b220afc0d9..20d09f38d4 100644 --- a/src/analyses/varEq.ml +++ b/src/analyses/varEq.ml @@ -41,8 +41,8 @@ struct let name () = "var_eq" let startstate v = D.top () - let threadenter ctx ~multiple lval f args = [D.top ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.top ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.top () let typ_equal = CilType.Typ.equal (* TODO: Used to have equality checking, which ignores attributes. Is that needed? *) @@ -395,47 +395,47 @@ struct (* Probably ok as is. *) - let body ctx f = ctx.local + let body man f = man.local (* Branch could be improved to set invariants like base tries to do. *) - let branch ctx exp tv = ctx.local + let branch man exp tv = man.local (* Just remove things that go out of scope. *) - let return ctx exp fundec = - let rm v = remove (Analyses.ask_of_ctx ctx) (Var v,NoOffset) in - List.fold_right rm (fundec.sformals@fundec.slocals) ctx.local + let return man exp fundec = + let rm v = remove (Analyses.ask_of_man man) (Var v,NoOffset) in + List.fold_right rm (fundec.sformals@fundec.slocals) man.local (* removes all equalities with lval and then tries to make a new one: lval=rval *) - let assign ctx (lval:lval) (rval:exp) : D.t = + let assign man (lval:lval) (rval:exp) : D.t = let rval = constFold true (stripCasts rval) in - add_eq (Analyses.ask_of_ctx ctx) lval rval ctx.local + add_eq (Analyses.ask_of_man man) lval rval man.local (* First assign arguments to parameters. Then join it with reachables, to get rid of equalities that are not reachable. *) - let enter ctx lval f args = + let enter man lval f args = let rec fold_left2 f r xs ys = match xs, ys with | x::xs, y::ys -> fold_left2 f (f r x y) xs ys | _ -> r in let assign_one_param st lv exp = - let rm = remove (Analyses.ask_of_ctx ctx) (Var lv, NoOffset) st in - add_eq (Analyses.ask_of_ctx ctx) (Var lv, NoOffset) exp rm + let rm = remove (Analyses.ask_of_man man) (Var lv, NoOffset) st in + add_eq (Analyses.ask_of_man man) (Var lv, NoOffset) exp rm in let nst = - try fold_left2 assign_one_param ctx.local f.sformals args + try fold_left2 assign_one_param man.local f.sformals args with SetDomain.Unsupported _ -> (* ignore varargs fr now *) D.top () in - match D.is_bot ctx.local with + match D.is_bot man.local with | true -> raise Analyses.Deadcode - | false -> [ctx.local,nst] + | false -> [man.local,nst] - let combine_env ctx lval fexp f args fc au (f_ask: Queries.ask) = + let combine_env man lval fexp f args fc au (f_ask: Queries.ask) = let tainted = f_ask.f Queries.MayBeTainted in let d_local = (* if we are multithreaded, we run the risk, that some mutex protected variables got unlocked, so in this case caller state goes to top TODO: !!Unsound, this analysis does not handle this case -> regtest 63 08!! *) - if Queries.AD.is_top tainted || not (ctx.ask (Queries.MustBeSingleThreaded {since_start = true})) then + if Queries.AD.is_top tainted || not (man.ask (Queries.MustBeSingleThreaded {since_start = true})) then D.top () else let taint_exp = @@ -443,17 +443,17 @@ struct |> List.map Addr.Mval.to_cil_exp |> Queries.ES.of_list in - D.filter (fun exp -> not (Queries.ES.mem exp taint_exp)) ctx.local + D.filter (fun exp -> not (Queries.ES.mem exp taint_exp)) man.local in let d = D.meet au d_local in - match D.is_bot ctx.local with + match D.is_bot man.local with | true -> raise Analyses.Deadcode | false -> d - let combine_assign ctx lval fexp f args fc st2 (f_ask : Queries.ask) = + let combine_assign man lval fexp f args fc st2 (f_ask : Queries.ask) = match lval with - | Some lval -> remove (Analyses.ask_of_ctx ctx) lval ctx.local - | None -> ctx.local + | Some lval -> remove (Analyses.ask_of_man man) lval man.local + | None -> man.local let remove_reachable ~deep ask es st = let rs = reachables ~deep ask es in @@ -468,7 +468,7 @@ struct | _ -> st ) rs st - let unknown_fn ctx lval f args = + let unknown_fn man lval f args = let desc = LF.find f in let shallow_args = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = false } args in let deep_args = LibraryDesc.Accesses.find desc.accs { kind = Write; deep = true } args in @@ -477,29 +477,29 @@ struct | Some l -> mkAddrOf l :: shallow_args | None -> shallow_args in - match D.is_bot ctx.local with + match D.is_bot man.local with | true -> raise Analyses.Deadcode | false -> - let ask = Analyses.ask_of_ctx ctx in - ctx.local + let ask = Analyses.ask_of_man man in + man.local |> remove_reachable ~deep:false ask shallow_args |> remove_reachable ~deep:true ask deep_args (* remove all variables that are reachable from arguments *) - let special ctx lval f args = + let special man lval f args = let desc = LibraryFunctions.find f in match desc.special args with | Identity e -> begin match lval with - | Some x -> assign ctx x e - | None -> unknown_fn ctx lval f args + | Some x -> assign man x e + | None -> unknown_fn man lval f args end | ThreadCreate { arg; _ } -> - begin match D.is_bot ctx.local with + begin match D.is_bot man.local with | true -> raise Analyses.Deadcode - | false -> remove_reachable ~deep:true (Analyses.ask_of_ctx ctx) [arg] ctx.local + | false -> remove_reachable ~deep:true (Analyses.ask_of_man man) [arg] man.local end - | _ -> unknown_fn ctx lval f args + | _ -> unknown_fn man lval f args (* query stuff *) let eq_set (e:exp) s = @@ -554,20 +554,20 @@ struct r - let query ctx (type a) (x: a Queries.t): a Queries.result = + let query man (type a) (x: a Queries.t): a Queries.result = match x with - | Queries.EvalInt (BinOp (Eq, e1, e2, t)) when query_exp_equal (Analyses.ask_of_ctx ctx) e1 e2 ctx.global ctx.local -> + | Queries.EvalInt (BinOp (Eq, e1, e2, t)) when query_exp_equal (Analyses.ask_of_man man) e1 e2 man.global man.local -> Queries.ID.of_bool (Cilfacade.get_ikind t) true | Queries.EqualSet e -> - let r = eq_set_clos e ctx.local in + let r = eq_set_clos e man.local in if M.tracing then M.tracel "var_eq" "equalset %a = %a" d_plainexp e Queries.ES.pretty r; r | Queries.Invariant context when GobConfig.get_bool "ana.var_eq.invariant.enabled" && GobConfig.get_bool "witness.invariant.exact" -> (* only exact equalities here *) - let scope = Node.find_fundec ctx.node in - D.invariant ~scope ctx.local + let scope = Node.find_fundec man.node in + D.invariant ~scope man.local | _ -> Queries.Result.top x - let event ctx e octx = + let event man e oman = match e with | Events.Unassume {exp; _} -> (* Unassume must forget equalities, @@ -576,19 +576,19 @@ struct Basetype.CilExp.get_vars exp |> List.map Cil.var |> List.fold_left (fun st lv -> - remove (Analyses.ask_of_ctx ctx) lv st - ) ctx.local + remove (Analyses.ask_of_man man) lv st + ) man.local | Events.Escape vars -> if EscapeDomain.EscapedVars.is_top vars then D.top () else - let ask = Analyses.ask_of_ctx ctx in + let ask = Analyses.ask_of_man man in let remove_var st v = remove ask (Cil.var v) st in - List.fold_left remove_var ctx.local (EscapeDomain.EscapedVars.elements vars) + List.fold_left remove_var man.local (EscapeDomain.EscapedVars.elements vars) | _ -> - ctx.local + man.local end let _ = diff --git a/src/analyses/vla.ml b/src/analyses/vla.ml index aca4fdead8..28a485f5d4 100644 --- a/src/analyses/vla.ml +++ b/src/analyses/vla.ml @@ -10,27 +10,27 @@ struct let name () = "vla" module D = BoolDomain.MayBool - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - [ctx.local, false] + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + [man.local, false] - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local (* keep local as opposed to IdentitySpec *) + let combine_env man lval fexp f args fc au f_ask = + man.local (* keep local as opposed to IdentitySpec *) - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = match (LibraryFunctions.find f).special arglist with | Setjmp _ -> (* Checking if this within the scope of an identifier of variably modified type *) - if ctx.local then + if man.local then M.warn ~category:(Behavior (Undefined Other)) "setjmp called within the scope of a variably modified type. If a call to longjmp is made after this scope is left, the behavior is undefined."; - ctx.local + man.local | _ -> - ctx.local + man.local - let vdecl ctx (v:varinfo) : D.t = - ctx.local || Cilfacade.isVLAType v.vtype + let vdecl man (v:varinfo) : D.t = + man.local || Cilfacade.isVLAType v.vtype let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.top ()] + let threadenter man ~multiple lval f args = [D.top ()] let exitstate v = D.top () end diff --git a/src/analyses/wrapperFunctionAnalysis.ml b/src/analyses/wrapperFunctionAnalysis.ml index 32ca234e70..b450452a62 100644 --- a/src/analyses/wrapperFunctionAnalysis.ml +++ b/src/analyses/wrapperFunctionAnalysis.ml @@ -26,12 +26,12 @@ module SpecBase (UniqueCount : Lattice.S with type t = int) (WrapperArgs : Wrapp struct include IdentitySpec - (* Use the previous CFG node (ctx.prev_node) for identifying calls to (wrapper) functions. + (* Use the previous CFG node (man.prev_node) for identifying calls to (wrapper) functions. For one, this is the node that typically contains the call as its statement. - Additionally, it distinguishes two calls that share the next CFG node (ctx.node), e.g.: + Additionally, it distinguishes two calls that share the next CFG node (man.node), e.g.: if (cond) { x = malloc(1); } else { x = malloc(2); } Introduce a function for this to keep things consistent. *) - let node_for_ctx ctx = ctx.prev_node + let node_for_man man = man.prev_node module NodeFlatLattice = struct @@ -63,40 +63,40 @@ struct (* transfer functions *) - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - let wrapper_node, counter = ctx.local in + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + let wrapper_node, counter = man.local in let new_wrapper_node = if Hashtbl.mem wrappers f.svar.vname then match wrapper_node with (* if an interesting callee is called by an interesting caller, then we remember the caller context *) | `Lifted _ -> wrapper_node (* if an interesting callee is called by an uninteresting caller, then we remember the callee context *) - | _ -> `Lifted (node_for_ctx ctx) + | _ -> `Lifted (node_for_man man) else NodeFlatLattice.top () (* if an uninteresting callee is called, then we forget what was called before *) in let callee = (new_wrapper_node, counter) in - [(ctx.local, callee)] + [(man.local, callee)] - let combine_env ctx lval fexp f args fc (_, counter) f_ask = + let combine_env man lval fexp f args fc (_, counter) f_ask = (* Keep (potentially higher) counter from callee and keep wrapper node from caller *) - let lnode, _ = ctx.local in + let lnode, _ = man.local in (lnode, counter) - let add_unique_call_ctx ctx = - let wrapper_node, counter = ctx.local in + let add_unique_call_man man = + let wrapper_node, counter = man.local in wrapper_node, (* track the unique ID per call to the wrapper function, not to the wrapped function *) add_unique_call counter - (match wrapper_node with `Lifted node -> node | _ -> node_for_ctx ctx) + (match wrapper_node with `Lifted node -> node | _ -> node_for_man man) - let special (ctx: (D.t, G.t, C.t, V.t) ctx) (lval: lval option) (f: varinfo) (arglist:exp list) : D.t = + let special (man: (D.t, G.t, C.t, V.t) man) (lval: lval option) (f: varinfo) (arglist:exp list) : D.t = let desc = LibraryFunctions.find f in - if WrapperArgs.is_wrapped @@ desc.special arglist then add_unique_call_ctx ctx else ctx.local + if WrapperArgs.is_wrapped @@ desc.special arglist then add_unique_call_man man else man.local let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = + let threadenter man ~multiple lval f args = (* The new thread receives a fresh counter *) [D.bot ()] @@ -152,16 +152,16 @@ module MallocWrapper : MCPSpec = struct let name () = "mallocWrapper" - let query (ctx: (D.t, G.t, C.t, V.t) ctx) (type a) (q: a Q.t): a Q.result = - let wrapper_node, counter = ctx.local in + let query (man: (D.t, G.t, C.t, V.t) man) (type a) (q: a Q.t): a Q.result = + let wrapper_node, counter = man.local in match q with | Q.AllocVar {on_stack = on_stack} -> let node = match wrapper_node with | `Lifted wrapper_node -> wrapper_node - | _ -> node_for_ctx ctx + | _ -> node_for_man man in let count = UniqueCallCounter.find (`Lifted node) counter in - let var = NodeVarinfoMap.to_varinfo (ctx.ask Q.CurrentThreadId, node, count) in + let var = NodeVarinfoMap.to_varinfo (man.ask Q.CurrentThreadId, node, count) in var.vdecl <- UpdateCil.getLoc node; (* TODO: does this do anything bad for incremental? *) if on_stack then var.vattr <- addAttribute (Attr ("stack_alloca", [])) var.vattr; (* If the call was for stack allocation, add an attr to mark the heap var *) `Lifted var @@ -171,7 +171,7 @@ module MallocWrapper : MCPSpec = struct NodeVarinfoMap.mem_varinfo v | Q.IsMultiple v -> begin match NodeVarinfoMap.from_varinfo v with - | Some (_, _, c) -> UniqueCount.is_top c || not (ctx.ask Q.MustBeUniqueThread) + | Some (_, _, c) -> UniqueCount.is_top c || not (man.ask Q.MustBeUniqueThread) | None -> false end | _ -> Queries.Result.top q @@ -203,13 +203,13 @@ module ThreadCreateWrapper : MCPSpec = struct let name () = "threadCreateWrapper" - let query (ctx: (D.t, G.t, C.t, V.t) ctx) (type a) (q: a Q.t): a Q.result = + let query (man: (D.t, G.t, C.t, V.t) man) (type a) (q: a Q.t): a Q.result = match q with | Q.ThreadCreateIndexedNode -> - let wrapper_node, counter = ctx.local in + let wrapper_node, counter = man.local in let node = match wrapper_node with | `Lifted wrapper_node -> wrapper_node - | _ -> node_for_ctx ctx + | _ -> node_for_man man in let count = UniqueCallCounter.find (`Lifted node) counter in `Lifted node, count diff --git a/src/cdomains/apron/sharedFunctions.apron.ml b/src/cdomains/apron/sharedFunctions.apron.ml index b9d93bfd99..112e327530 100644 --- a/src/cdomains/apron/sharedFunctions.apron.ml +++ b/src/cdomains/apron/sharedFunctions.apron.ml @@ -143,7 +143,7 @@ struct might be able to be represented by means of 2 var equalities This simplification happens during a time, when there are temporary variables a#in and a#out part of the expression, - but are not represented in the ctx, thus queries may result in top for these variables. Wrapping this in speculative + but are not represented in the man, thus queries may result in top for these variables. Wrapping this in speculative mode is a stop-gap measure to avoid flagging overflows. We however should address simplification in a more generally useful way. outside of the apron-related expression conversion. *) diff --git a/src/domains/events.ml b/src/domains/events.ml index cf12900c98..cc4af83819 100644 --- a/src/domains/events.ml +++ b/src/domains/events.ml @@ -11,7 +11,7 @@ type t = | SplitBranch of exp * bool (** Used to simulate old branch-based split. *) | AssignSpawnedThread of lval * ThreadIdDomain.Thread.t (** Assign spawned thread's ID to lval. *) | Access of {exp: CilType.Exp.t; ad: Queries.AD.t; kind: AccessKind.t; reach: bool} - | Assign of {lval: CilType.Lval.t; exp: CilType.Exp.t} (** Used to simulate old [ctx.assign]. *) (* TODO: unused *) + | Assign of {lval: CilType.Lval.t; exp: CilType.Exp.t} (** Used to simulate old [man.assign]. *) (* TODO: unused *) | UpdateExpSplit of exp (** Used by expsplit analysis to evaluate [exp] on post-state. *) | Assert of exp | Unassume of {exp: CilType.Exp.t; tokens: WideningToken.t list} diff --git a/src/domains/queries.ml b/src/domains/queries.ml index fee44a6b24..f43cd77eca 100644 --- a/src/domains/queries.ml +++ b/src/domains/queries.ml @@ -137,9 +137,9 @@ type _ t = type 'a result = 'a -(** Container for explicitly polymorphic [ctx.ask] function out of [ctx]. - To be used when passing entire [ctx] around seems inappropriate. - Use [Analyses.ask_of_ctx] to convert [ctx] to [ask]. *) +(** Container for explicitly polymorphic [man.ask] function out of [man]. + To be used when passing entire [man] around seems inappropriate. + Use [Analyses.ask_of_man] to convert [man] to [ask]. *) (* Must be in a singleton record due to second-order polymorphism. See https://ocaml.org/manual/polymorphism.html#s%3Ahigher-rank-poly. *) type ask = { f: 'a. 'a t -> 'a result } [@@unboxed] diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index ab41335944..985f013ede 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -143,23 +143,13 @@ struct end -(* Experiment to reduce the number of arguments on transfer functions and allow - sub-analyses. The list sub contains the current local states of analyses in - the same order as written in the dependencies list (in MCP). - - The foreign states when calling special_fn or enter are joined if the foreign - analysis tries to be path-sensitive in these functions. First try to only - depend on simple analyses. - - It is not clear if we need pre-states, post-states or both on foreign analyses. -*) -type ('d,'g,'c,'v) ctx = +type ('d,'g,'c,'v) man = { ask : 'a. 'a Queries.t -> 'a Queries.result (* Inlined Queries.ask *) ; emit : Events.t -> unit ; node : MyCFG.node ; prev_node: MyCFG.node - ; control_context : unit -> ControlSpecC.t (** top-level Control Spec context, raises [Ctx_failure] if missing *) - ; context : unit -> 'c (** current Spec context, raises [Ctx_failure] if missing *) + ; control_context : unit -> ControlSpecC.t (** top-level Control Spec context, raises [Man_failure] if missing *) + ; context : unit -> 'c (** current Spec context, raises [Man_failure] if missing *) ; edge : MyCFG.edge ; local : 'd ; global : 'v -> 'g @@ -168,13 +158,13 @@ type ('d,'g,'c,'v) ctx = ; sideg : 'v -> 'g -> unit } -exception Ctx_failure of string -(** Failure from ctx, e.g. global initializer *) +exception Man_failure of string +(** Failure from man, e.g. global initializer *) -let ctx_failwith s = raise (Ctx_failure s) (* TODO: use everywhere in ctx *) +let man_failwith s = raise (Man_failure s) (* TODO: use everywhere in man *) -(** Convert [ctx] to [Queries.ask]. *) -let ask_of_ctx ctx: Queries.ask = { Queries.f = ctx.ask } +(** Convert [man] to [Queries.ask]. *) +let ask_of_man man: Queries.ask = { Queries.f = man.ask } module type Spec = @@ -205,48 +195,48 @@ sig val morphstate : varinfo -> D.t -> D.t val exitstate : varinfo -> D.t - val context: (D.t, G.t, C.t, V.t) ctx -> fundec -> D.t -> C.t + val context: (D.t, G.t, C.t, V.t) man -> fundec -> D.t -> C.t val startcontext: unit -> C.t - val sync : (D.t, G.t, C.t, V.t) ctx -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t - val query : (D.t, G.t, C.t, V.t) ctx -> 'a Queries.t -> 'a Queries.result + val sync : (D.t, G.t, C.t, V.t) man -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t + val query : (D.t, G.t, C.t, V.t) man -> 'a Queries.t -> 'a Queries.result (** A transfer function which handles the assignment of a rval to a lval, i.e., it handles program points of the form "lval = rval;" *) - val assign: (D.t, G.t, C.t, V.t) ctx -> lval -> exp -> D.t + val assign: (D.t, G.t, C.t, V.t) man -> lval -> exp -> D.t (** A transfer function used for declaring local variables. By default only for variable-length arrays (VLAs). *) - val vdecl : (D.t, G.t, C.t, V.t) ctx -> varinfo -> D.t + val vdecl : (D.t, G.t, C.t, V.t) man -> varinfo -> D.t (** A transfer function which handles conditional branching yielding the truth value passed as a boolean argument *) - val branch: (D.t, G.t, C.t, V.t) ctx -> exp -> bool -> D.t + val branch: (D.t, G.t, C.t, V.t) man -> exp -> bool -> D.t (** A transfer function which handles going from the start node of a function (fundec) into its function body. Meant to handle, e.g., initialization of local variables *) - val body : (D.t, G.t, C.t, V.t) ctx -> fundec -> D.t + val body : (D.t, G.t, C.t, V.t) man -> fundec -> D.t (** A transfer function which handles the return statement, i.e., "return exp" or "return" in the passed function (fundec) *) - val return: (D.t, G.t, C.t, V.t) ctx -> exp option -> fundec -> D.t + val return: (D.t, G.t, C.t, V.t) man -> exp option -> fundec -> D.t (** A transfer function meant to handle inline assembler program points *) - val asm : (D.t, G.t, C.t, V.t) ctx -> D.t + val asm : (D.t, G.t, C.t, V.t) man -> D.t (** A transfer function which works as the identity function, i.e., it skips and does nothing. Used for empty loops. *) - val skip : (D.t, G.t, C.t, V.t) ctx -> D.t + val skip : (D.t, G.t, C.t, V.t) man -> D.t (** A transfer function which, for a call to a {e special} function f "lval = f(args)" or "f(args)", computes the caller state after the function call *) - val special : (D.t, G.t, C.t, V.t) ctx -> lval option -> varinfo -> exp list -> D.t + val special : (D.t, G.t, C.t, V.t) man -> lval option -> varinfo -> exp list -> D.t (** For a function call "lval = f(args)" or "f(args)", [enter] returns a caller state, and the initial state of the callee. In [enter], the caller state can usually be returned unchanged, as [combine_env] and [combine_assign] (below) will compute the caller state after the function call, given the return state of the callee *) - val enter : (D.t, G.t, C.t, V.t) ctx -> lval option -> fundec -> exp list -> (D.t * D.t) list + val enter : (D.t, G.t, C.t, V.t) man -> lval option -> fundec -> exp list -> (D.t * D.t) list (* Combine is split into two steps: *) @@ -254,24 +244,24 @@ sig between local state (first component from enter) and function return. This shouldn't yet assign to the lval. *) - val combine_env : (D.t, G.t, C.t, V.t) ctx -> lval option -> exp -> fundec -> exp list -> C.t option -> D.t -> Queries.ask -> D.t + val combine_env : (D.t, G.t, C.t, V.t) man -> lval option -> exp -> fundec -> exp list -> C.t option -> D.t -> Queries.ask -> D.t (** Combine return value assignment to local state (result from combine_env) and function return. This should only assign to the lval. *) - val combine_assign : (D.t, G.t, C.t, V.t) ctx -> lval option -> exp -> fundec -> exp list -> C.t option -> D.t -> Queries.ask -> D.t + val combine_assign : (D.t, G.t, C.t, V.t) man -> lval option -> exp -> fundec -> exp list -> C.t option -> D.t -> Queries.ask -> D.t (* Paths as sets: I know this is ugly! *) - val paths_as_set : (D.t, G.t, C.t, V.t) ctx -> D.t list + val paths_as_set : (D.t, G.t, C.t, V.t) man -> D.t list (** Returns initial state for created thread. *) - val threadenter : (D.t, G.t, C.t, V.t) ctx -> multiple:bool -> lval option -> varinfo -> exp list -> D.t list + val threadenter : (D.t, G.t, C.t, V.t) man -> multiple:bool -> lval option -> varinfo -> exp list -> D.t list (** Updates the local state of the creator thread using initial state of created thread. *) - val threadspawn : (D.t, G.t, C.t, V.t) ctx -> multiple:bool -> lval option -> varinfo -> exp list -> (D.t, G.t, C.t, V.t) ctx -> D.t + val threadspawn : (D.t, G.t, C.t, V.t) man -> multiple:bool -> lval option -> varinfo -> exp list -> (D.t, G.t, C.t, V.t) man -> D.t - val event : (D.t, G.t, C.t, V.t) ctx -> Events.t -> (D.t, G.t, C.t, V.t) ctx -> D.t + val event : (D.t, G.t, C.t, V.t) man -> Events.t -> (D.t, G.t, C.t, V.t) man -> D.t end module type Spec2Spec = functor (S: Spec) -> Spec @@ -288,7 +278,7 @@ sig include Spec module A: MCPA - val access: (D.t, G.t, C.t, V.t) ctx -> Queries.access -> A.t + val access: (D.t, G.t, C.t, V.t) man -> Queries.access -> A.t end type increment_data = { @@ -357,7 +347,7 @@ struct (* no inits nor finalize -- only analyses like Mutex, Base, ... need these to do postprocessing or other imperative hacks. *) - let vdecl ctx _ = ctx.local + let vdecl man _ = man.local let asm x = M.msg_final Info ~category:Unsound "ASM ignored"; @@ -369,18 +359,18 @@ struct let query _ (type a) (q: a Queries.t) = Queries.Result.top q (* Don't know anything --- most will want to redefine this. *) - let event ctx _ _ = ctx.local + let event man _ _ = man.local let morphstate v d = d (* Only for those who track thread IDs. *) - let sync ctx _ = ctx.local + let sync man _ = man.local (* Most domains do not have a global part. *) - let context ctx fd x = x + let context man fd x = x (* Everything is context sensitive --- override in MCP and maybe elsewhere*) - let paths_as_set ctx = [ctx.local] + let paths_as_set man = [man.local] module A = UnitA let access _ _ = () @@ -390,39 +380,39 @@ end module IdentitySpec = struct include DefaultSpec - let assign ctx (lval:lval) (rval:exp) = - ctx.local + let assign man (lval:lval) (rval:exp) = + man.local - let branch ctx (exp:exp) (tv:bool) = - ctx.local + let branch man (exp:exp) (tv:bool) = + man.local - let body ctx (f:fundec) = - ctx.local + let body man (f:fundec) = + man.local - let return ctx (exp:exp option) (f:fundec) = - ctx.local + let return man (exp:exp option) (f:fundec) = + man.local - let enter ctx (lval: lval option) (f:fundec) (args:exp list) = - [ctx.local, ctx.local] + let enter man (lval: lval option) (f:fundec) (args:exp list) = + [man.local, man.local] - let combine_env ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = au - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - ctx.local + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + man.local - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) = - ctx.local + let special man (lval: lval option) (f:varinfo) (arglist:exp list) = + man.local - let threadenter ctx ~multiple lval f args = [ctx.local] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [man.local] + let threadspawn man ~multiple lval f args fman = man.local end module IdentityUnitContextsSpec = struct include IdentitySpec module C = Printable.Unit - let context ctx _ _ = () + let context man _ _ = () let startcontext () = () end diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index fb4b5081e8..18a7f5191a 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -38,24 +38,24 @@ struct 1. S.V -> S.G -- used for Spec 2. fundec -> set of S.C -- used for IterSysVars Node *) - let sync ctx = - match ctx.prev_node, Cfg.prev ctx.prev_node with + let sync man = + match man.prev_node, Cfg.prev man.prev_node with | _, _ :: _ :: _ -> (* Join in CFG. *) - S.sync ctx `Join + S.sync man `Join | FunctionEntry f, _ -> (* Function entry, also needs sync because partial contexts joined by solver, see 00-sanity/35-join-contexts. *) - S.sync ctx (`JoinCall f) - | _, _ -> S.sync ctx `Normal + S.sync man (`JoinCall f) + | _, _ -> S.sync man `Normal let side_context sideg f c = if !AnalysisState.postsolving then sideg (GVar.contexts f) (G.create_contexts (G.CSet.singleton c)) - let common_ctx var edge prev_node pval (getl:lv -> ld) sidel getg sideg : (D.t, S.G.t, S.C.t, S.V.t) ctx * D.t list ref * (lval option * varinfo * exp list * D.t * bool) list ref = + let common_man var edge prev_node pval (getl:lv -> ld) sidel getg sideg : (D.t, S.G.t, S.C.t, S.V.t) man * D.t list ref * (lval option * varinfo * exp list * D.t * bool) list ref = let r = ref [] in let spawns = ref [] in (* now watch this ... *) - let rec ctx = - { ask = (fun (type a) (q: a Queries.t) -> S.query ctx q) + let rec man = + { ask = (fun (type a) (q: a Queries.t) -> S.query man q) ; emit = (fun _ -> failwith "emit outside MCP") ; node = fst var ; prev_node = prev_node @@ -69,14 +69,14 @@ struct ; sideg = (fun g d -> sideg (GVar.spec g) (G.create_spec d)) } and spawn ?(multiple=false) lval f args = - (* TODO: adjust ctx node/edge? *) + (* TODO: adjust man node/edge? *) (* TODO: don't repeat for all paths that spawn same *) - let ds = S.threadenter ~multiple ctx lval f args in + let ds = S.threadenter ~multiple man lval f args in List.iter (fun d -> spawns := (lval, f, args, d, multiple) :: !spawns; match Cilfacade.find_varinfo_fundec f with | fd -> - let c = S.context ctx fd d in + let c = S.context man fd d in sidel (FunctionEntry fd, c) d; ignore (getl (Function fd, c)) | exception Not_found -> @@ -86,142 +86,142 @@ struct ) ds in (* ... nice, right! *) - let pval = sync ctx in - { ctx with local = pval }, r, spawns + let pval = sync man in + { man with local = pval }, r, spawns let rec bigsqcup = function | [] -> D.bot () | [x] -> x | x::xs -> D.join x (bigsqcup xs) - let thread_spawns ctx d spawns = + let thread_spawns man d spawns = if List.is_empty spawns then d else - let rec ctx' = - { ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query ctx' q) + let rec man' = + { man with + ask = (fun (type a) (q: a Queries.t) -> S.query man' q) ; local = d } in (* TODO: don't forget path dependencies *) let one_spawn (lval, f, args, fd, multiple) = - let rec fctx = - { ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query fctx q) + let rec fman = + { man with + ask = (fun (type a) (q: a Queries.t) -> S.query fman q) ; local = fd } in - S.threadspawn ctx' ~multiple lval f args fctx + S.threadspawn man' ~multiple lval f args fman in bigsqcup (List.map one_spawn spawns) - let common_join ctx d splits spawns = - thread_spawns ctx (bigsqcup (d :: splits)) spawns + let common_join man d splits spawns = + thread_spawns man (bigsqcup (d :: splits)) spawns - let common_joins ctx ds splits spawns = common_join ctx (bigsqcup ds) splits spawns + let common_joins man ds splits spawns = common_join man (bigsqcup ds) splits spawns let tf_assign var edge prev_node lv e getl sidel getg sideg d = - let ctx, r, spawns = common_ctx var edge prev_node d getl sidel getg sideg in - let d = S.assign ctx lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join ctx d !r !spawns + let man, r, spawns = common_man var edge prev_node d getl sidel getg sideg in + let d = S.assign man lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join man d !r !spawns let tf_vdecl var edge prev_node v getl sidel getg sideg d = - let ctx, r, spawns = common_ctx var edge prev_node d getl sidel getg sideg in - let d = S.vdecl ctx v in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join ctx d !r !spawns + let man, r, spawns = common_man var edge prev_node d getl sidel getg sideg in + let d = S.vdecl man v in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join man d !r !spawns - let normal_return r fd ctx sideg = - let spawning_return = S.return ctx r fd in - let nval = S.sync { ctx with local = spawning_return } `Return in + let normal_return r fd man sideg = + let spawning_return = S.return man r fd in + let nval = S.sync { man with local = spawning_return } `Return in nval - let toplevel_kernel_return r fd ctx sideg = - let st = if fd.svar.vname = MyCFG.dummy_func.svar.vname then ctx.local else S.return ctx r fd in - let spawning_return = S.return {ctx with local = st} None MyCFG.dummy_func in - let nval = S.sync { ctx with local = spawning_return } `Return in + let toplevel_kernel_return r fd man sideg = + let st = if fd.svar.vname = MyCFG.dummy_func.svar.vname then man.local else S.return man r fd in + let spawning_return = S.return {man with local = st} None MyCFG.dummy_func in + let nval = S.sync { man with local = spawning_return } `Return in nval let tf_ret var edge prev_node ret fd getl sidel getg sideg d = - let ctx, r, spawns = common_ctx var edge prev_node d getl sidel getg sideg in + let man, r, spawns = common_man var edge prev_node d getl sidel getg sideg in let d = (* Force transfer function to be evaluated before dereferencing in common_join argument. *) if (CilType.Fundec.equal fd MyCFG.dummy_func || List.mem fd.svar.vname (get_string_list "mainfun")) && get_bool "kernel" - then toplevel_kernel_return ret fd ctx sideg - else normal_return ret fd ctx sideg + then toplevel_kernel_return ret fd man sideg + else normal_return ret fd man sideg in - common_join ctx d !r !spawns + common_join man d !r !spawns let tf_entry var edge prev_node fd getl sidel getg sideg d = (* Side effect function context here instead of at sidel to FunctionEntry, because otherwise context for main functions (entrystates) will be missing or pruned during postsolving. *) let c: unit -> S.C.t = snd var |> Obj.obj in side_context sideg fd (c ()); - let ctx, r, spawns = common_ctx var edge prev_node d getl sidel getg sideg in - let d = S.body ctx fd in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join ctx d !r !spawns + let man, r, spawns = common_man var edge prev_node d getl sidel getg sideg in + let d = S.body man fd in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join man d !r !spawns let tf_test var edge prev_node e tv getl sidel getg sideg d = - let ctx, r, spawns = common_ctx var edge prev_node d getl sidel getg sideg in - let d = S.branch ctx e tv in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join ctx d !r !spawns + let man, r, spawns = common_man var edge prev_node d getl sidel getg sideg in + let d = S.branch man e tv in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join man d !r !spawns - let tf_normal_call ctx lv e (f:fundec) args getl sidel getg sideg = + let tf_normal_call man lv e (f:fundec) args getl sidel getg sideg = let combine (cd, fc, fd) = if M.tracing then M.traceli "combine" "local: %a" S.D.pretty cd; if M.tracing then M.trace "combine" "function: %a" S.D.pretty fd; - let rec cd_ctx = - { ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query cd_ctx q); + let rec cd_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S.query cd_man q); local = cd; } in - let fd_ctx = - (* Inner scope to prevent unsynced fd_ctx from being used. *) + let fd_man = + (* Inner scope to prevent unsynced fd_man from being used. *) (* Extra sync in case function has multiple returns. Each `Return sync is done before joining, so joined value may be unsound. - Since sync is normally done before tf (in common_ctx), simulate it here for fd. *) + Since sync is normally done before tf (in common_man), simulate it here for fd. *) (* TODO: don't do this extra sync here *) - let rec sync_ctx = - { ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query sync_ctx q); + let rec sync_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S.query sync_man q); local = fd; prev_node = Function f; } in - (* TODO: more accurate ctx? *) - let synced = sync sync_ctx in - let rec fd_ctx = - { sync_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query fd_ctx q); + (* TODO: more accurate man? *) + let synced = sync sync_man in + let rec fd_man = + { sync_man with + ask = (fun (type a) (q: a Queries.t) -> S.query fd_man q); local = synced; } in - fd_ctx + fd_man in let r = List.fold_left (fun acc fd1 -> - let rec fd1_ctx = - { fd_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query fd1_ctx q); + let rec fd1_man = + { fd_man with + ask = (fun (type a) (q: a Queries.t) -> S.query fd1_man q); local = fd1; } in - let combine_enved = S.combine_env cd_ctx lv e f args fc fd1_ctx.local (Analyses.ask_of_ctx fd1_ctx) in - let rec combine_assign_ctx = - { cd_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query combine_assign_ctx q); + let combine_enved = S.combine_env cd_man lv e f args fc fd1_man.local (Analyses.ask_of_man fd1_man) in + let rec combine_assign_man = + { cd_man with + ask = (fun (type a) (q: a Queries.t) -> S.query combine_assign_man q); local = combine_enved; } in - S.D.join acc (S.combine_assign combine_assign_ctx lv e f args fc fd1_ctx.local (Analyses.ask_of_ctx fd1_ctx)) - ) (S.D.bot ()) (S.paths_as_set fd_ctx) + S.D.join acc (S.combine_assign combine_assign_man lv e f args fc fd1_man.local (Analyses.ask_of_man fd1_man)) + ) (S.D.bot ()) (S.paths_as_set fd_man) in if M.tracing then M.traceu "combine" "combined local: %a" S.D.pretty r; r in - let paths = S.enter ctx lv f args in - let paths = List.map (fun (c,v) -> (c, S.context ctx f v, v)) paths in + let paths = S.enter man lv f args in + let paths = List.map (fun (c,v) -> (c, S.context man f v, v)) paths in List.iter (fun (c,fc,v) -> if not (S.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; let paths = List.map (fun (c,fc,v) -> (c, fc, if S.D.is_bot v then v else getl (Function f, fc))) paths in (* Don't filter bot paths, otherwise LongjmpLifter is not called. *) @@ -233,10 +233,10 @@ struct if M.tracing then M.traceu "combine" "combined: %a" S.D.pretty r; r - let tf_special_call ctx lv f args = S.special ctx lv f args + let tf_special_call man lv f args = S.special man lv f args let tf_proc var edge prev_node lv e args getl sidel getg sideg d = - let ctx, r, spawns = common_ctx var edge prev_node d getl sidel getg sideg in + let man, r, spawns = common_man var edge prev_node d getl sidel getg sideg in let functions = match e with | Lval (Var v, NoOffset) -> @@ -245,7 +245,7 @@ struct [v] | _ -> (* Depends on base for query. *) - let ad = ctx.ask (Queries.EvalFunvar e) in + let ad = man.ask (Queries.EvalFunvar e) in Queries.AD.to_var_may ad (* TODO: don't convert, handle UnknownPtr below *) in let one_function f = @@ -259,11 +259,11 @@ struct begin Some (match Cilfacade.find_varinfo_fundec f with | fd when LibraryFunctions.use_special f.vname -> M.info ~category:Analyzer "Using special for defined function %s" f.vname; - tf_special_call ctx lv f args + tf_special_call man lv f args | fd -> - tf_normal_call ctx lv e fd args getl sidel getg sideg + tf_normal_call man lv e fd args getl sidel getg sideg | exception Not_found -> - tf_special_call ctx lv f args) + tf_special_call man lv f args) end else begin let geq = if var_arg then ">=" else "" in @@ -275,22 +275,22 @@ struct None in let funs = List.filter_map one_function functions in - if [] = funs && not (S.D.is_bot ctx.local) then begin + if [] = funs && not (S.D.is_bot man.local) then begin M.msg_final Warning ~category:Unsound ~tags:[Category Call] "No suitable function to call"; M.warn ~category:Unsound ~tags:[Category Call] "No suitable function to be called at call site. Continuing with state before call."; d (* because LevelSliceLifter *) end else - common_joins ctx funs !r !spawns + common_joins man funs !r !spawns let tf_asm var edge prev_node getl sidel getg sideg d = - let ctx, r, spawns = common_ctx var edge prev_node d getl sidel getg sideg in - let d = S.asm ctx in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join ctx d !r !spawns + let man, r, spawns = common_man var edge prev_node d getl sidel getg sideg in + let d = S.asm man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join man d !r !spawns let tf_skip var edge prev_node getl sidel getg sideg d = - let ctx, r, spawns = common_ctx var edge prev_node d getl sidel getg sideg in - let d = S.skip ctx in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join ctx d !r !spawns + let man, r, spawns = common_man var edge prev_node d getl sidel getg sideg in + let d = S.skip man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join man d !r !spawns let tf var getl sidel getg sideg prev_node edge d = begin match edge with @@ -382,13 +382,13 @@ struct let iter_vars getl getg vq fl fg = (* vars for Spec *) - let rec ctx = - { ask = (fun (type a) (q: a Queries.t) -> S.query ctx q) + let rec man = + { ask = (fun (type a) (q: a Queries.t) -> S.query man q) ; emit = (fun _ -> failwith "Cannot \"emit\" in query context.") ; node = MyCFG.dummy_node (* TODO maybe ask should take a node (which could be used here) instead of a location *) ; prev_node = MyCFG.dummy_node - ; control_context = (fun () -> ctx_failwith "No context in query context.") - ; context = (fun () -> ctx_failwith "No context in query context.") + ; control_context = (fun () -> man_failwith "No context in query context.") + ; context = (fun () -> man_failwith "No context in query context.") ; edge = MyCFG.Skip ; local = S.startstate Cil.dummyFunDec.svar (* bot and top both silently raise and catch Deadcode in DeadcodeLifter *) ; global = (fun g -> G.spec (getg (GVar.spec g))) @@ -398,7 +398,7 @@ struct } in let f v = fg (GVar.spec (Obj.obj v)) in - S.query ctx (IterSysVars (vq, f)); + S.query man (IterSysVars (vq, f)); (* node vars for locals *) match vq with diff --git a/src/framework/control.ml b/src/framework/control.ml index 2566939817..0e4a8b1b5d 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -254,7 +254,7 @@ struct in (* add extern variables to local state *) - let do_extern_inits ctx (file : file) : Spec.D.t = + let do_extern_inits man (file : file) : Spec.D.t = let module VS = Set.Make (Basetype.Variables) in let add_glob s = function GVar (v,_,_) -> VS.add v s @@ -262,7 +262,7 @@ struct in let vars = foldGlobals file add_glob VS.empty in let set_bad v st = - Spec.assign {ctx with local = st} (var v) MyCFG.unknown_exp + Spec.assign {man with local = st} (var v) MyCFG.unknown_exp in let is_std = function | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) @@ -295,13 +295,13 @@ struct (* analyze cil's global-inits function to get a starting state *) let do_global_inits (file: file) : Spec.D.t * fundec list = - let ctx = + let man = { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) ; emit = (fun _ -> failwith "Cannot \"emit\" in global initializer context.") ; node = MyCFG.dummy_node ; prev_node = MyCFG.dummy_node - ; control_context = (fun () -> ctx_failwith "Global initializers have no context.") - ; context = (fun () -> ctx_failwith "Global initializers have no context.") + ; control_context = (fun () -> man_failwith "Global initializers have no context.") + ; context = (fun () -> man_failwith "Global initializers have no context.") ; edge = MyCFG.Skip ; local = Spec.D.top () ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) @@ -322,7 +322,7 @@ struct match edge with | MyCFG.Entry func -> if M.tracing then M.trace "global_inits" "Entry %a" d_lval (var func.svar); - Spec.body {ctx with local = st} func + Spec.body {man with local = st} func | MyCFG.Assign (lval,exp) -> if M.tracing then M.trace "global_inits" "Assign %a = %a" d_lval lval d_exp exp; begin match lval, exp with @@ -331,14 +331,14 @@ struct (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) | _ -> () end; - let res = Spec.assign {ctx with local = st} lval exp in + let res = Spec.assign {man with local = st} lval exp in (* Needed for privatizations (e.g. None) that do not side immediately *) - let res' = Spec.sync {ctx with local = res} `Normal in + let res' = Spec.sync {man with local = res} `Normal in if M.tracing then M.trace "global_inits" "\t\t -> state:%a" Spec.D.pretty res; res' | _ -> failwith "Unsupported global initializer edge" in - let with_externs = do_extern_inits ctx file in + let with_externs = do_extern_inits man file in (*if (get_bool "dbg.verbose") then Printf.printf "Number of init. edges : %d\nWorking:" (List.length edges); *) let old_loc = !Goblint_tracing.current_loc in let result : Spec.D.t = List.fold_left transfer_func with_externs edges in @@ -401,12 +401,12 @@ struct let enter_with st fd = let st = st fd.svar in - let ctx = + let man = { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) ; emit = (fun _ -> failwith "Cannot \"emit\" in enter_with context.") ; node = MyCFG.dummy_node ; prev_node = MyCFG.dummy_node - ; control_context = (fun () -> ctx_failwith "enter_with has no control_context.") + ; control_context = (fun () -> man_failwith "enter_with has no control_context.") ; context = Spec.startcontext ; edge = MyCFG.Skip ; local = st @@ -417,7 +417,7 @@ struct } in let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in - let ents = Spec.enter ctx None fd args in + let ents = Spec.enter man None fd args in List.map (fun (_,s) -> fd, s) ents in @@ -433,13 +433,13 @@ struct let exitvars = List.map (enter_with Spec.exitstate) exitfuns in let otherstate st v = - let ctx = + let man = { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) ; emit = (fun _ -> failwith "Cannot \"emit\" in otherstate context.") ; node = MyCFG.dummy_node ; prev_node = MyCFG.dummy_node - ; control_context = (fun () -> ctx_failwith "enter_func has no context.") - ; context = (fun () -> ctx_failwith "enter_func has no context.") + ; control_context = (fun () -> man_failwith "enter_func has no context.") + ; context = (fun () -> man_failwith "enter_func has no context.") ; edge = MyCFG.Skip ; local = st ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) @@ -449,7 +449,7 @@ struct } in (* TODO: don't hd *) - List.hd (Spec.threadenter ctx ~multiple:false None v []) + List.hd (Spec.threadenter man ~multiple:false None v []) (* TODO: do threadspawn to mainfuns? *) in let prestartstate = Spec.startstate MyCFG.dummy_func.svar in (* like in do_extern_inits *) @@ -460,12 +460,12 @@ struct AnalysisState.global_initialization := false; - let ctx e = + let man e = { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) ; emit = (fun _ -> failwith "Cannot \"emit\" in enter_with context.") ; node = MyCFG.dummy_node ; prev_node = MyCFG.dummy_node - ; control_context = (fun () -> ctx_failwith "enter_with has no control_context.") + ; control_context = (fun () -> man_failwith "enter_with has no control_context.") ; context = Spec.startcontext ; edge = MyCFG.Skip ; local = e @@ -477,12 +477,12 @@ struct in let startvars' = if get_bool "exp.forward" then - List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (ctx e) n e)) startvars + List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (man e) n e)) startvars else - List.map (fun (n,e) -> (MyCFG.Function n, Spec.context (ctx e) n e)) startvars + List.map (fun (n,e) -> (MyCFG.Function n, Spec.context (man e) n e)) startvars in - let entrystates = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (ctx e) n e), e) startvars in + let entrystates = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (man e) n e), e) startvars in let entrystates_global = GHT.to_list gh in let uncalled_dead = ref 0 in diff --git a/src/framework/resultQuery.ml b/src/framework/resultQuery.ml index c676c41c14..ea4a75f40a 100644 --- a/src/framework/resultQuery.ml +++ b/src/framework/resultQuery.ml @@ -7,9 +7,9 @@ struct open SpecSys let ask_local (gh: EQSys.G.t GHT.t) (lvar:EQSys.LVar.t) local = - (* build a ctx for using the query system *) - let rec ctx = - { ask = (fun (type a) (q: a Queries.t) -> Spec.query ctx q) + (* build a man for using the query system *) + let rec man = + { ask = (fun (type a) (q: a Queries.t) -> Spec.query man q) ; emit = (fun _ -> failwith "Cannot \"emit\" in witness context.") ; node = fst lvar ; prev_node = MyCFG.dummy_node @@ -23,17 +23,17 @@ struct ; sideg = (fun v g -> failwith "Cannot \"sideg\" in witness context.") } in - Spec.query ctx + Spec.query man let ask_local_node (gh: EQSys.G.t GHT.t) (n: Node.t) local = - (* build a ctx for using the query system *) - let rec ctx = - { ask = (fun (type a) (q: a Queries.t) -> Spec.query ctx q) + (* build a man for using the query system *) + let rec man = + { ask = (fun (type a) (q: a Queries.t) -> Spec.query man q) ; emit = (fun _ -> failwith "Cannot \"emit\" in witness context.") ; node = n ; prev_node = MyCFG.dummy_node - ; control_context = (fun () -> ctx_failwith "No context in witness context.") - ; context = (fun () -> ctx_failwith "No context in witness context.") + ; control_context = (fun () -> man_failwith "No context in witness context.") + ; context = (fun () -> man_failwith "No context in witness context.") ; edge = MyCFG.Skip ; local = local ; global = (fun g -> try EQSys.G.spec (GHT.find gh (EQSys.GVar.spec g)) with Not_found -> Spec.G.bot ()) (* TODO: how can be missing? *) @@ -42,18 +42,18 @@ struct ; sideg = (fun v g -> failwith "Cannot \"sideg\" in witness context.") } in - Spec.query ctx + Spec.query man let ask_global (gh: EQSys.G.t GHT.t) = (* copied from Control for WarnGlobal *) - (* build a ctx for using the query system *) - let rec ctx = - { ask = (fun (type a) (q: a Queries.t) -> Spec.query ctx q) + (* build a man for using the query system *) + let rec man = + { ask = (fun (type a) (q: a Queries.t) -> Spec.query man q) ; emit = (fun _ -> failwith "Cannot \"emit\" in query context.") ; node = MyCFG.dummy_node (* TODO maybe ask should take a node (which could be used here) instead of a location *) ; prev_node = MyCFG.dummy_node - ; control_context = (fun () -> ctx_failwith "No context in query context.") - ; context = (fun () -> ctx_failwith "No context in query context.") + ; control_context = (fun () -> man_failwith "No context in query context.") + ; context = (fun () -> man_failwith "No context in query context.") ; edge = MyCFG.Skip ; local = Spec.startstate GoblintCil.dummyFunDec.svar (* bot and top both silently raise and catch Deadcode in DeadcodeLifter *) (* TODO: is this startstate bad? *) ; global = (fun v -> EQSys.G.spec (try GHT.find gh (EQSys.GVar.spec v) with Not_found -> EQSys.G.bot ())) (* TODO: how can be missing? *) @@ -62,7 +62,7 @@ struct ; sideg = (fun v g -> failwith "Cannot \"split\" in query context.") } in - Spec.query ctx + Spec.query man end diff --git a/src/lifters/contextGasLifter.ml b/src/lifters/contextGasLifter.ml index 75bd9f7641..dc1a9e1565 100644 --- a/src/lifters/contextGasLifter.ml +++ b/src/lifters/contextGasLifter.ml @@ -42,8 +42,8 @@ struct let of_elt (x, _) = of_elt x end - (* returns context gas value of the given ctx *) - let cg_val ctx = snd ctx.local + (* returns context gas value of the given man *) + let cg_val man = snd man.local type marshal = S.marshal let init = S.init @@ -56,47 +56,47 @@ struct let exitstate v = S.exitstate v, Gas.startgas () let morphstate v (d,i) = S.morphstate v d, i - let conv (ctx:(D.t,G.t,C.t,V.t) ctx): (S.D.t,G.t,S.C.t,V.t)ctx = - {ctx with local = fst ctx.local - ; split = (fun d es -> ctx.split (d, cg_val ctx) es) - ; context = (fun () -> match ctx.context () with Some c -> c | None -> ctx_failwith "no context (contextGas = 0)")} + let conv (man:(D.t,G.t,C.t,V.t) man): (S.D.t,G.t,S.C.t,V.t) man = + {man with local = fst man.local + ; split = (fun d es -> man.split (d, cg_val man) es) + ; context = (fun () -> match man.context () with Some c -> c | None -> man_failwith "no context (contextGas = 0)")} - let context ctx fd (d,i) = + let context man fd (d,i) = (* only keep context if the context gas is greater zero *) if Gas.is_exhausted fd i then None else - Some (S.context (conv ctx) fd d) + Some (S.context (conv man) fd d) - let enter ctx r f args = - let liftmap_tup = List.map (fun (x,y) -> (x, cg_val ctx), (y, Gas.callee_gas f (cg_val ctx))) in - liftmap_tup (S.enter (conv ctx) r f args) + let enter man r f args = + let liftmap_tup = List.map (fun (x,y) -> (x, cg_val man), (y, Gas.callee_gas f (cg_val man))) in + liftmap_tup (S.enter (conv man) r f args) - let threadenter ctx ~multiple lval f args = - let liftmap d = List.map (fun (x) -> (x, Gas.thread_gas f (cg_val ctx))) d in - liftmap (S.threadenter (conv ctx) ~multiple lval f args) + let threadenter man ~multiple lval f args = + let liftmap d = List.map (fun (x) -> (x, Gas.thread_gas f (cg_val man))) d in + liftmap (S.threadenter (conv man) ~multiple lval f args) - let query ctx (type a) (q: a Queries.t):a Queries.result = + let query man (type a) (q: a Queries.t):a Queries.result = match q with | Queries.GasExhausted f -> - let (d,i) = ctx.local in + let (d,i) = man.local in Gas.is_exhausted f i - | _ -> S.query (conv ctx) q - - let sync ctx reason = S.sync (conv ctx) reason, cg_val ctx - let assign ctx lval expr = S.assign (conv ctx) lval expr, cg_val ctx - let vdecl ctx v = S.vdecl (conv ctx) v, cg_val ctx - let body ctx fundec = S.body (conv ctx) fundec, cg_val ctx - let branch ctx e tv = S.branch (conv ctx) e tv, cg_val ctx - let return ctx r f = S.return (conv ctx) r f, cg_val ctx - let asm ctx = S.asm (conv ctx), cg_val ctx - let skip ctx = S.skip (conv ctx), cg_val ctx - let special ctx r f args = S.special (conv ctx) r f args, cg_val ctx - let combine_env ctx r fe f args fc es f_ask = S.combine_env (conv ctx) r fe f args (Option.bind fc Fun.id) (fst es) f_ask, cg_val ctx - let combine_assign ctx r fe f args fc es f_ask = S.combine_assign (conv ctx) r fe f args (Option.bind fc Fun.id) (fst es) f_ask, cg_val ctx - let paths_as_set ctx = List.map (fun (x) -> (x, cg_val ctx)) @@ S.paths_as_set (conv ctx) - let threadspawn ctx ~multiple lval f args fctx = S.threadspawn (conv ctx) ~multiple lval f args (conv fctx), cg_val ctx - let event ctx e octx = S.event (conv ctx) e (conv octx), cg_val ctx + | _ -> S.query (conv man) q + + let sync man reason = S.sync (conv man) reason, cg_val man + let assign man lval expr = S.assign (conv man) lval expr, cg_val man + let vdecl man v = S.vdecl (conv man) v, cg_val man + let body man fundec = S.body (conv man) fundec, cg_val man + let branch man e tv = S.branch (conv man) e tv, cg_val man + let return man r f = S.return (conv man) r f, cg_val man + let asm man = S.asm (conv man), cg_val man + let skip man = S.skip (conv man), cg_val man + let special man r f args = S.special (conv man) r f args, cg_val man + let combine_env man r fe f args fc es f_ask = S.combine_env (conv man) r fe f args (Option.bind fc Fun.id) (fst es) f_ask, cg_val man + let combine_assign man r fe f args fc es f_ask = S.combine_assign (conv man) r fe f args (Option.bind fc Fun.id) (fst es) f_ask, cg_val man + let paths_as_set man = List.map (fun (x) -> (x, cg_val man)) @@ S.paths_as_set (conv man) + let threadspawn man ~multiple lval f args fman = S.threadspawn (conv man) ~multiple lval f args (conv fman), cg_val man + let event man e oman = S.event (conv man) e (conv oman), cg_val man end let get_gas_lifter () = diff --git a/src/lifters/longjmpLifter.ml b/src/lifters/longjmpLifter.ml index a093f8c703..c392499ef6 100644 --- a/src/lifters/longjmpLifter.ml +++ b/src/lifters/longjmpLifter.ml @@ -42,19 +42,19 @@ struct | x -> BatPrintf.fprintf f "%a" printXml x end - let conv (ctx: (_, G.t, _, V.t) ctx): (_, S.G.t, _, S.V.t) ctx = - { ctx with - global = (fun v -> G.s (ctx.global (V.s v))); - sideg = (fun v g -> ctx.sideg (V.s v) (G.create_s g)); + let conv (man: (_, G.t, _, V.t) man): (_, S.G.t, _, S.V.t) man = + { man with + global = (fun v -> G.s (man.global (V.s v))); + sideg = (fun v g -> man.sideg (V.s v) (G.create_s g)); } - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | WarnGlobal g -> let g: V.t = Obj.obj g in begin match g with | `Left g -> - S.query (conv ctx) (WarnGlobal (Obj.repr g)) + S.query (conv man) (WarnGlobal (Obj.repr g)) | _ -> Queries.Result.top q end @@ -62,7 +62,7 @@ struct let g: V.t = Obj.obj g in begin match g with | `Left g -> - S.query (conv ctx) (InvariantGlobal (Obj.repr g)) + S.query (conv man) (InvariantGlobal (Obj.repr g)) | _ -> Queries.Result.top q end @@ -70,89 +70,89 @@ struct let g: V.t = Obj.obj g in begin match g with | `Left g -> - S.query (conv ctx) (YamlEntryGlobal (Obj.repr g, task)) + S.query (conv man) (YamlEntryGlobal (Obj.repr g, task)) | _ -> Queries.Result.top q end | IterSysVars (vq, vf) -> (* vars for S *) let vf' x = vf (Obj.repr (V.s (Obj.obj x))) in - S.query (conv ctx) (IterSysVars (vq, vf')); + S.query (conv man) (IterSysVars (vq, vf')); (* TODO: vars? *) | _ -> - S.query (conv ctx) q + S.query (conv man) q - let branch ctx = S.branch (conv ctx) - let assign ctx = S.assign (conv ctx) - let vdecl ctx = S.vdecl (conv ctx) - let enter ctx = S.enter (conv ctx) - let paths_as_set ctx = S.paths_as_set (conv ctx) - let body ctx = S.body (conv ctx) - let return ctx = S.return (conv ctx) - let context ctx = S.context (conv ctx) + let branch man = S.branch (conv man) + let assign man = S.assign (conv man) + let vdecl man = S.vdecl (conv man) + let enter man = S.enter (conv man) + let paths_as_set man = S.paths_as_set (conv man) + let body man = S.body (conv man) + let return man = S.return (conv man) + let context man = S.context (conv man) - let combine_env ctx lv e f args fc fd f_ask = - let conv_ctx = conv ctx in - let current_fundec = Node.find_fundec ctx.node in + let combine_env man lv e f args fc fd f_ask = + let conv_man = conv man in + let current_fundec = Node.find_fundec man.node in let handle_longjmp (cd, fc, longfd) = (* This is called per-path. *) - let rec cd_ctx = - { conv_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query cd_ctx q); + let rec cd_man = + { conv_man with + ask = (fun (type a) (q: a Queries.t) -> S.query cd_man q); local = cd; } in - let longfd_ctx = - (* Inner scope to prevent unsynced longfd_ctx from being used. *) + let longfd_man = + (* Inner scope to prevent unsynced longfd_man from being used. *) (* Extra sync like with normal combine. *) - let rec sync_ctx = - { conv_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query sync_ctx q); + let rec sync_man = + { conv_man with + ask = (fun (type a) (q: a Queries.t) -> S.query sync_man q); local = longfd; prev_node = Function f; } in - let synced = S.sync sync_ctx `Join in - let rec longfd_ctx = - { sync_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query longfd_ctx q); + let synced = S.sync sync_man `Join in + let rec longfd_man = + { sync_man with + ask = (fun (type a) (q: a Queries.t) -> S.query longfd_man q); local = synced; } in - longfd_ctx + longfd_man in let combined = lazy ( (* does not depend on target, do at most once *) (* Globals are non-problematic here, as they are always carried around without any issues! *) (* A combine call is mostly needed to ensure locals have appropriate values. *) (* Using f from called function on purpose here! Needed? *) - S.combine_env cd_ctx None e f args fc longfd_ctx.local (Analyses.ask_of_ctx longfd_ctx) (* no lval because longjmp return skips return value assignment *) + S.combine_env cd_man None e f args fc longfd_man.local (Analyses.ask_of_man longfd_man) (* no lval because longjmp return skips return value assignment *) ) in let returned = lazy ( (* does not depend on target, do at most once *) - let rec combined_ctx = - { cd_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query combined_ctx q); + let rec combined_man = + { cd_man with + ask = (fun (type a) (q: a Queries.t) -> S.query combined_man q); local = Lazy.force combined; } in - S.return combined_ctx None current_fundec + S.return combined_man None current_fundec ) in - let (active_targets, _) = longfd_ctx.ask ActiveJumpBuf in - let valid_targets = cd_ctx.ask ValidLongJmp in + let (active_targets, _) = longfd_man.ask ActiveJumpBuf in + let valid_targets = cd_man.ask ValidLongJmp in let handle_target target = match target with | JmpBufDomain.BufferEntryOrTop.AllTargets -> () (* The warning is already emitted at the point where the longjmp happens *) | Target (target_node, target_context) -> let target_fundec = Node.find_fundec target_node in - if CilType.Fundec.equal target_fundec current_fundec && ControlSpecC.equal target_context (ctx.control_context ()) then ( + if CilType.Fundec.equal target_fundec current_fundec && ControlSpecC.equal target_context (man.control_context ()) then ( if M.tracing then Messages.tracel "longjmp" "Fun: Potentially from same context, side-effect to %a" Node.pretty target_node; - ctx.sideg (V.longjmpto (target_node, ctx.context ())) (G.create_local (Lazy.force combined)) + man.sideg (V.longjmpto (target_node, man.context ())) (G.create_local (Lazy.force combined)) (* No need to propagate this outwards here, the set of valid longjumps is part of the context, we can never have the same context setting the longjmp multiple times *) ) (* Appropriate setjmp is not in current function & current context *) else if JmpBufDomain.JmpBufSet.mem target valid_targets then - ctx.sideg (V.longjmpret (current_fundec, ctx.context ())) (G.create_local (Lazy.force returned)) + man.sideg (V.longjmpret (current_fundec, man.context ())) (G.create_local (Lazy.force returned)) else (* It actually is not handled here but was propagated here spuriously, we already warned at the location where this issue is caused *) (* As the validlongjumps inside the callee is a a superset of the ones inside the caller *) @@ -161,60 +161,60 @@ struct JmpBufDomain.JmpBufSet.iter handle_target active_targets in if M.tracing then M.tracel "longjmp" "longfd getg %a" CilType.Fundec.pretty f; - let longfd = G.local (ctx.global (V.longjmpret (f, Option.get fc))) in + let longfd = G.local (man.global (V.longjmpret (f, Option.get fc))) in if M.tracing then M.tracel "longjmp" "longfd %a" D.pretty longfd; if not (D.is_bot longfd) then - handle_longjmp (ctx.local, fc, longfd); - S.combine_env (conv_ctx) lv e f args fc fd f_ask + handle_longjmp (man.local, fc, longfd); + S.combine_env (conv_man) lv e f args fc fd f_ask - let combine_assign ctx lv e f args fc fd f_ask = - S.combine_assign (conv ctx) lv e f args fc fd f_ask + let combine_assign man lv e f args fc fd f_ask = + S.combine_assign (conv man) lv e f args fc fd f_ask - let special ctx lv f args = - let conv_ctx = conv ctx in + let special man lv f args = + let conv_man = conv man in match (LibraryFunctions.find f).special args with | Setjmp {env} -> (* Handling of returning for the first time *) - let normal_return = S.special conv_ctx lv f args in - let jmp_return = G.local (ctx.global (V.longjmpto (ctx.prev_node, ctx.context ()))) in + let normal_return = S.special conv_man lv f args in + let jmp_return = G.local (man.global (V.longjmpto (man.prev_node, man.context ()))) in if S.D.is_bot jmp_return then normal_return else ( - let rec jmp_ctx = - { conv_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query jmp_ctx q); + let rec jmp_man = + { conv_man with + ask = (fun (type a) (q: a Queries.t) -> S.query jmp_man q); local = jmp_return; } in - let longjmped = S.event jmp_ctx (Events.Longjmped {lval=lv}) jmp_ctx in + let longjmped = S.event jmp_man (Events.Longjmped {lval=lv}) jmp_man in S.D.join normal_return longjmped ) | Longjmp {env; value} -> - let current_fundec = Node.find_fundec ctx.node in + let current_fundec = Node.find_fundec man.node in let handle_path path = ( - let rec path_ctx = - { conv_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query path_ctx q); + let rec path_man = + { conv_man with + ask = (fun (type a) (q: a Queries.t) -> S.query path_man q); local = path; } in let specialed = lazy ( (* does not depend on target, do at most once *) - S.special path_ctx lv f args + S.special path_man lv f args ) in let returned = lazy ( (* does not depend on target, do at most once *) - let rec specialed_ctx = - { path_ctx with - ask = (fun (type a) (q: a Queries.t) -> S.query specialed_ctx q); + let rec specialed_man = + { path_man with + ask = (fun (type a) (q: a Queries.t) -> S.query specialed_man q); local = Lazy.force specialed; } in - S.return specialed_ctx None current_fundec + S.return specialed_man None current_fundec ) in - (* Eval `env` again to avoid having to construct bespoke ctx to ask *) - let targets = path_ctx.ask (EvalJumpBuf env) in - let valid_targets = path_ctx.ask ValidLongJmp in + (* Eval `env` again to avoid having to construct bespoke man to ask *) + let targets = path_man.ask (EvalJumpBuf env) in + let valid_targets = path_man.ask ValidLongJmp in if M.tracing then Messages.tracel "longjmp" "Jumping to %a" JmpBufDomain.JmpBufSet.pretty targets; let handle_target target = match target with | JmpBufDomain.BufferEntryOrTop.AllTargets -> @@ -222,13 +222,13 @@ struct M.msg_final Error ~category:Unsound ~tags:[Category Imprecise; Category Call] "Longjmp to unknown target ignored" | Target (target_node, target_context) -> let target_fundec = Node.find_fundec target_node in - if CilType.Fundec.equal target_fundec current_fundec && ControlSpecC.equal target_context (ctx.control_context ()) then ( + if CilType.Fundec.equal target_fundec current_fundec && ControlSpecC.equal target_context (man.control_context ()) then ( if M.tracing then Messages.tracel "longjmp" "Potentially from same context, side-effect to %a" Node.pretty target_node; - ctx.sideg (V.longjmpto (target_node, ctx.context ())) (G.create_local (Lazy.force specialed)) + man.sideg (V.longjmpto (target_node, man.context ())) (G.create_local (Lazy.force specialed)) ) else if JmpBufDomain.JmpBufSet.mem target valid_targets then ( - if M.tracing then Messages.tracel "longjmp" "Longjmp to somewhere else, side-effect to %i" (S.C.hash (ctx.context ())); - ctx.sideg (V.longjmpret (current_fundec, ctx.context ())) (G.create_local (Lazy.force returned)) + if M.tracing then Messages.tracel "longjmp" "Longjmp to somewhere else, side-effect to %i" (S.C.hash (man.context ())); + man.sideg (V.longjmpret (current_fundec, man.context ())) (G.create_local (Lazy.force returned)) ) else M.warn ~category:(Behavior (Undefined Other)) "Longjmp to potentially invalid target! (Target %a in Function %a which may have already returned or is in a different thread)" Node.pretty target_node CilType.Fundec.pretty target_fundec @@ -239,17 +239,17 @@ struct JmpBufDomain.JmpBufSet.iter handle_target targets ) in - List.iter handle_path (S.paths_as_set conv_ctx); + List.iter handle_path (S.paths_as_set conv_man); if !AnalysisState.should_warn && List.mem "termination" @@ get_string_list "ana.activated" then ( AnalysisState.svcomp_may_not_terminate := true; M.warn ~category:Termination "The program might not terminate! (Longjmp)" ); S.D.bot () - | _ -> S.special conv_ctx lv f args - let threadenter ctx = S.threadenter (conv ctx) - let threadspawn ctx ~multiple lv f args fctx = S.threadspawn (conv ctx) ~multiple lv f args (conv fctx) - let sync ctx = S.sync (conv ctx) - let skip ctx = S.skip (conv ctx) - let asm ctx = S.asm (conv ctx) - let event ctx e octx = S.event (conv ctx) e (conv octx) + | _ -> S.special conv_man lv f args + let threadenter man = S.threadenter (conv man) + let threadspawn man ~multiple lv f args fman = S.threadspawn (conv man) ~multiple lv f args (conv fman) + let sync man = S.sync (conv man) + let skip man = S.skip (conv man) + let asm man = S.asm (conv man) + let event man e oman = S.event (conv man) e (conv oman) end diff --git a/src/lifters/recursionTermLifter.ml b/src/lifters/recursionTermLifter.ml index 37522305b9..f694ecb1e2 100644 --- a/src/lifters/recursionTermLifter.ml +++ b/src/lifters/recursionTermLifter.ml @@ -55,13 +55,13 @@ struct let name () = "RecursionTermLifter (" ^ S.name () ^ ")" - let conv (ctx: (_, G.t, _, V.t) ctx): (_, S.G.t, _, S.V.t) ctx = - { ctx with - global = (fun v -> G.spec (ctx.global (V.spec v))); - sideg = (fun v g -> ctx.sideg (V.spec v) (G.create_spec g)); + let conv (man: (_, G.t, _, V.t) man): (_, S.G.t, _, S.V.t) man = + { man with + global = (fun v -> G.spec (man.global (V.spec v))); + sideg = (fun v g -> man.sideg (V.spec v) (G.create_spec g)); } - let cycleDetection ctx call = + let cycleDetection man call = let module LH = Hashtbl.Make (Printable.Prod (CilType.Fundec) (S.C)) in let module LS = Set.Make (Printable.Prod (CilType.Fundec) (S.C)) in (* find all cycles/SCCs *) @@ -78,7 +78,7 @@ struct LH.replace global_visited_calls call (); let new_path_visited_calls = LS.add call path_visited_calls in let gvar = V.call call in - let callers = G.callers (ctx.global gvar) in + let callers = G.callers (man.global gvar) in CallerSet.iter (fun to_call -> iter_call new_path_visited_calls to_call ) callers; @@ -86,23 +86,23 @@ struct in iter_call LS.empty call - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | WarnGlobal v -> (* check result of loop analysis *) - if not (ctx.ask Queries.MustTermAllLoops) then + if not (man.ask Queries.MustTermAllLoops) then AnalysisState.svcomp_may_not_terminate := true; let v: V.t = Obj.obj v in begin match v with | `Left v' -> - S.query (conv ctx) (WarnGlobal (Obj.repr v')) - | `Right call -> cycleDetection ctx call (* Note: to make it more efficient, one could only execute the cycle detection in case the loop analysis returns true, because otherwise the program will probably not terminate anyway*) + S.query (conv man) (WarnGlobal (Obj.repr v')) + | `Right call -> cycleDetection man call (* Note: to make it more efficient, one could only execute the cycle detection in case the loop analysis returns true, because otherwise the program will probably not terminate anyway*) end | InvariantGlobal v -> let v: V.t = Obj.obj v in begin match v with | `Left v -> - S.query (conv ctx) (InvariantGlobal (Obj.repr v)) + S.query (conv man) (InvariantGlobal (Obj.repr v)) | `Right v -> Queries.Result.top q end @@ -110,44 +110,44 @@ struct let v: V.t = Obj.obj v in begin match v with | `Left v -> - S.query (conv ctx) (YamlEntryGlobal (Obj.repr v, task)) + S.query (conv man) (YamlEntryGlobal (Obj.repr v, task)) | `Right v -> Queries.Result.top q end - | _ -> S.query (conv ctx) q + | _ -> S.query (conv man) q - let branch ctx = S.branch (conv ctx) - let assign ctx = S.assign (conv ctx) - let vdecl ctx = S.vdecl (conv ctx) + let branch man = S.branch (conv man) + let assign man = S.assign (conv man) + let vdecl man = S.vdecl (conv man) let record_call sideg callee caller = sideg (V.call callee) (G.create_singleton_caller caller) - let enter ctx = S.enter (conv ctx) - let context ctx = S.context (conv ctx) - let paths_as_set ctx = S.paths_as_set (conv ctx) - let body ctx = S.body (conv ctx) - let return ctx = S.return (conv ctx) - let combine_env ctx r fe f args fc es f_ask = + let enter man = S.enter (conv man) + let context man = S.context (conv man) + let paths_as_set man = S.paths_as_set (conv man) + let body man = S.body (conv man) + let return man = S.return (conv man) + let combine_env man r fe f args fc es f_ask = if !AnalysisState.postsolving then ( - let c_r: S.C.t = ctx.context () in (* Caller context *) - let nodeF = ctx.node in + let c_r: S.C.t = man.context () in (* Caller context *) + let nodeF = man.node in let fd_r : fundec = Node.find_fundec nodeF in (* Caller fundec *) let caller: (fundec * S.C.t) = (fd_r, c_r) in let c_e: S.C.t = Option.get fc in (* Callee context *) let fd_e : fundec = f in (* Callee fundec *) let callee = (fd_e, c_e) in - record_call ctx.sideg callee caller + record_call man.sideg callee caller ); - S.combine_env (conv ctx) r fe f args fc es f_ask - - let combine_assign ctx = S.combine_assign (conv ctx) - let special ctx = S.special (conv ctx) - let threadenter ctx = S.threadenter (conv ctx) - let threadspawn ctx ~multiple lv f args fctx = S.threadspawn (conv ctx) ~multiple lv f args (conv fctx) - let sync ctx = S.sync (conv ctx) - let skip ctx = S.skip (conv ctx) - let asm ctx = S.asm (conv ctx) - let event ctx e octx = S.event (conv ctx) e (conv octx) + S.combine_env (conv man) r fe f args fc es f_ask + + let combine_assign man = S.combine_assign (conv man) + let special man = S.special (conv man) + let threadenter man = S.threadenter (conv man) + let threadspawn man ~multiple lv f args fman = S.threadspawn (conv man) ~multiple lv f args (conv fman) + let sync man = S.sync (conv man) + let skip man = S.skip (conv man) + let asm man = S.asm (conv man) + let event man e oman = S.event (conv man) e (conv oman) end diff --git a/src/lifters/specLifters.ml b/src/lifters/specLifters.ml index 39c7799395..45102d0056 100644 --- a/src/lifters/specLifters.ml +++ b/src/lifters/specLifters.ml @@ -38,64 +38,64 @@ struct let exitstate v = D.lift (S.exitstate v) let morphstate v d = D.lift (S.morphstate v (D.unlift d)) - let conv ctx = - { ctx with local = D.unlift ctx.local - ; split = (fun d es -> ctx.split (D.lift d) es ) + let conv man = + { man with local = D.unlift man.local + ; split = (fun d es -> man.split (D.lift d) es ) } - let context ctx fd = S.context (conv ctx) fd % D.unlift + let context man fd = S.context (conv man) fd % D.unlift let startcontext () = S.startcontext () - let sync ctx reason = - D.lift @@ S.sync (conv ctx) reason + let sync man reason = + D.lift @@ S.sync (conv man) reason - let query ctx = - S.query (conv ctx) + let query man = + S.query (conv man) - let assign ctx lv e = - D.lift @@ S.assign (conv ctx) lv e + let assign man lv e = + D.lift @@ S.assign (conv man) lv e - let vdecl ctx v = - D.lift @@ S.vdecl (conv ctx) v + let vdecl man v = + D.lift @@ S.vdecl (conv man) v - let branch ctx e tv = - D.lift @@ S.branch (conv ctx) e tv + let branch man e tv = + D.lift @@ S.branch (conv man) e tv - let body ctx f = - D.lift @@ S.body (conv ctx) f + let body man f = + D.lift @@ S.body (conv man) f - let return ctx r f = - D.lift @@ S.return (conv ctx) r f + let return man r f = + D.lift @@ S.return (conv man) r f - let asm ctx = - D.lift @@ S.asm (conv ctx) + let asm man = + D.lift @@ S.asm (conv man) - let skip ctx = - D.lift @@ S.skip (conv ctx) + let skip man = + D.lift @@ S.skip (conv man) - let enter ctx r f args = - List.map (fun (x,y) -> D.lift x, D.lift y) @@ S.enter (conv ctx) r f args + let enter man r f args = + List.map (fun (x,y) -> D.lift x, D.lift y) @@ S.enter (conv man) r f args - let special ctx r f args = - D.lift @@ S.special (conv ctx) r f args + let special man r f args = + D.lift @@ S.special (conv man) r f args - let combine_env ctx r fe f args fc es f_ask = - D.lift @@ S.combine_env (conv ctx) r fe f args fc (D.unlift es) f_ask + let combine_env man r fe f args fc es f_ask = + D.lift @@ S.combine_env (conv man) r fe f args fc (D.unlift es) f_ask - let combine_assign ctx r fe f args fc es f_ask = - D.lift @@ S.combine_assign (conv ctx) r fe f args fc (D.unlift es) f_ask + let combine_assign man r fe f args fc es f_ask = + D.lift @@ S.combine_assign (conv man) r fe f args fc (D.unlift es) f_ask - let threadenter ctx ~multiple lval f args = - List.map D.lift @@ S.threadenter (conv ctx) ~multiple lval f args + let threadenter man ~multiple lval f args = + List.map D.lift @@ S.threadenter (conv man) ~multiple lval f args - let threadspawn ctx ~multiple lval f args fctx = - D.lift @@ S.threadspawn (conv ctx) ~multiple lval f args (conv fctx) + let threadspawn man ~multiple lval f args fman = + D.lift @@ S.threadspawn (conv man) ~multiple lval f args (conv fman) - let paths_as_set ctx = - List.map (fun x -> D.lift x) @@ S.paths_as_set (conv ctx) + let paths_as_set man = + List.map (fun x -> D.lift x) @@ S.paths_as_set (conv man) - let event ctx e octx = - D.lift @@ S.event (conv ctx) e (conv octx) + let event man e oman = + D.lift @@ S.event (conv man) e (conv oman) end (** Lifts a [Spec] so that the context is [Hashcons]d. *) @@ -121,63 +121,63 @@ struct let exitstate = S.exitstate let morphstate = S.morphstate - let conv ctx = - { ctx with context = (fun () -> C.unlift (ctx.context ())) } + let conv man = + { man with context = (fun () -> C.unlift (man.context ())) } - let context ctx fd = C.lift % S.context (conv ctx) fd + let context man fd = C.lift % S.context (conv man) fd let startcontext () = C.lift @@ S.startcontext () - let sync ctx reason = - S.sync (conv ctx) reason + let sync man reason = + S.sync (conv man) reason - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.IterPrevVars f -> let g i (n, c, j) e = f i (n, Obj.repr (C.lift (Obj.obj c)), j) e in - S.query (conv ctx) (Queries.IterPrevVars g) - | _ -> S.query (conv ctx) q + S.query (conv man) (Queries.IterPrevVars g) + | _ -> S.query (conv man) q - let assign ctx lv e = - S.assign (conv ctx) lv e + let assign man lv e = + S.assign (conv man) lv e - let vdecl ctx v = - S.vdecl (conv ctx) v + let vdecl man v = + S.vdecl (conv man) v - let branch ctx e tv = - S.branch (conv ctx) e tv + let branch man e tv = + S.branch (conv man) e tv - let body ctx f = - S.body (conv ctx) f + let body man f = + S.body (conv man) f - let return ctx r f = - S.return (conv ctx) r f + let return man r f = + S.return (conv man) r f - let asm ctx = - S.asm (conv ctx) + let asm man = + S.asm (conv man) - let skip ctx = - S.skip (conv ctx) + let skip man = + S.skip (conv man) - let enter ctx r f args = - S.enter (conv ctx) r f args + let enter man r f args = + S.enter (conv man) r f args - let special ctx r f args = - S.special (conv ctx) r f args + let special man r f args = + S.special (conv man) r f args - let combine_env ctx r fe f args fc es f_ask = - S.combine_env (conv ctx) r fe f args (Option.map C.unlift fc) es f_ask + let combine_env man r fe f args fc es f_ask = + S.combine_env (conv man) r fe f args (Option.map C.unlift fc) es f_ask - let combine_assign ctx r fe f args fc es f_ask = - S.combine_assign (conv ctx) r fe f args (Option.map C.unlift fc) es f_ask + let combine_assign man r fe f args fc es f_ask = + S.combine_assign (conv man) r fe f args (Option.map C.unlift fc) es f_ask - let threadenter ctx ~multiple lval f args = - S.threadenter (conv ctx) ~multiple lval f args + let threadenter man ~multiple lval f args = + S.threadenter (conv man) ~multiple lval f args - let threadspawn ctx ~multiple lval f args fctx = - S.threadspawn (conv ctx) ~multiple lval f args (conv fctx) + let threadspawn man ~multiple lval f args fman = + S.threadspawn (conv man) ~multiple lval f args (conv fman) - let paths_as_set ctx = S.paths_as_set (conv ctx) - let event ctx e octx = S.event (conv ctx) e (conv octx) + let paths_as_set man = S.paths_as_set (conv man) + let event man e oman = S.event (conv man) e (conv oman) end (* see option ana.opt.equal *) @@ -221,40 +221,40 @@ struct let exitstate v = (S.exitstate v, !start_level) let morphstate v (d,l) = (S.morphstate v d, l) - let conv ctx = - { ctx with local = fst ctx.local - ; split = (fun d es -> ctx.split (d, snd ctx.local) es ) + let conv man = + { man with local = fst man.local + ; split = (fun d es -> man.split (d, snd man.local) es ) } - let context ctx fd (d,_) = S.context (conv ctx) fd d + let context man fd (d,_) = S.context (conv man) fd d let startcontext () = S.startcontext () - let lift_fun ctx f g h = - f @@ h (g (conv ctx)) + let lift_fun man f g h = + f @@ h (g (conv man)) - let enter' ctx r f args = - let liftmap = List.map (fun (x,y) -> (x, snd ctx.local), (y, snd ctx.local)) in - lift_fun ctx liftmap S.enter ((|>) args % (|>) f % (|>) r) + let enter' man r f args = + let liftmap = List.map (fun (x,y) -> (x, snd man.local), (y, snd man.local)) in + lift_fun man liftmap S.enter ((|>) args % (|>) f % (|>) r) - let lift ctx d = (d, snd ctx.local) + let lift man d = (d, snd man.local) let lift_start_level d = (d, !start_level) - let sync ctx reason = lift_fun ctx (lift ctx) S.sync ((|>) reason) - let query' ctx (type a) (q: a Queries.t): a Queries.result = - lift_fun ctx identity S.query (fun x -> x q) - let assign ctx lv e = lift_fun ctx (lift ctx) S.assign ((|>) e % (|>) lv) - let vdecl ctx v = lift_fun ctx (lift ctx) S.vdecl ((|>) v) - let branch ctx e tv = lift_fun ctx (lift ctx) S.branch ((|>) tv % (|>) e) - let body ctx f = lift_fun ctx (lift ctx) S.body ((|>) f) - let return ctx r f = lift_fun ctx (lift ctx) S.return ((|>) f % (|>) r) - let asm ctx = lift_fun ctx (lift ctx) S.asm identity - let skip ctx = lift_fun ctx (lift ctx) S.skip identity - let special ctx r f args = lift_fun ctx (lift ctx) S.special ((|>) args % (|>) f % (|>) r) - let combine_env' ctx r fe f args fc es f_ask = lift_fun ctx (lift ctx) S.combine_env (fun p -> p r fe f args fc (fst es) f_ask) - let combine_assign' ctx r fe f args fc es f_ask = lift_fun ctx (lift ctx) S.combine_assign (fun p -> p r fe f args fc (fst es) f_ask) - - let threadenter ctx ~multiple lval f args = lift_fun ctx (List.map lift_start_level) (S.threadenter ~multiple) ((|>) args % (|>) f % (|>) lval) - let threadspawn ctx ~multiple lval f args fctx = lift_fun ctx (lift ctx) (S.threadspawn ~multiple) ((|>) (conv fctx) % (|>) args % (|>) f % (|>) lval) + let sync man reason = lift_fun man (lift man) S.sync ((|>) reason) + let query' man (type a) (q: a Queries.t): a Queries.result = + lift_fun man identity S.query (fun x -> x q) + let assign man lv e = lift_fun man (lift man) S.assign ((|>) e % (|>) lv) + let vdecl man v = lift_fun man (lift man) S.vdecl ((|>) v) + let branch man e tv = lift_fun man (lift man) S.branch ((|>) tv % (|>) e) + let body man f = lift_fun man (lift man) S.body ((|>) f) + let return man r f = lift_fun man (lift man) S.return ((|>) f % (|>) r) + let asm man = lift_fun man (lift man) S.asm identity + let skip man = lift_fun man (lift man) S.skip identity + let special man r f args = lift_fun man (lift man) S.special ((|>) args % (|>) f % (|>) r) + let combine_env' man r fe f args fc es f_ask = lift_fun man (lift man) S.combine_env (fun p -> p r fe f args fc (fst es) f_ask) + let combine_assign' man r fe f args fc es f_ask = lift_fun man (lift man) S.combine_assign (fun p -> p r fe f args fc (fst es) f_ask) + + let threadenter man ~multiple lval f args = lift_fun man (List.map lift_start_level) (S.threadenter ~multiple) ((|>) args % (|>) f % (|>) lval) + let threadspawn man ~multiple lval f args fman = lift_fun man (lift man) (S.threadspawn ~multiple) ((|>) (conv fman) % (|>) args % (|>) f % (|>) lval) let leq0 = function | `Top -> false @@ -269,47 +269,47 @@ struct | `Lifted x -> `Lifted (Int64.add x 1L) | x -> x - let paths_as_set ctx = - let liftmap = List.map (fun x -> (x, snd ctx.local)) in - lift_fun ctx liftmap S.paths_as_set (Fun.id) + let paths_as_set man = + let liftmap = List.map (fun x -> (x, snd man.local)) in + lift_fun man liftmap S.paths_as_set (Fun.id) - let event ctx e octx = - lift_fun ctx (lift ctx) S.event ((|>) (conv octx) % (|>) e) + let event man e oman = + lift_fun man (lift man) S.event ((|>) (conv oman) % (|>) e) - let enter ctx r f args = - let (d,l) = ctx.local in + let enter man r f args = + let (d,l) = man.local in if leq0 l then - [ctx.local, D.bot ()] + [man.local, D.bot ()] else - enter' {ctx with local=(d, sub1 l)} r f args + enter' {man with local=(d, sub1 l)} r f args - let combine_env ctx r fe f args fc es f_ask = - let (d,l) = ctx.local in + let combine_env man r fe f args fc es f_ask = + let (d,l) = man.local in let l = add1 l in if leq0 l then (d, l) else - let d',_ = combine_env' ctx r fe f args fc es f_ask in + let d',_ = combine_env' man r fe f args fc es f_ask in (d', l) - let combine_assign ctx r fe f args fc es f_ask = - let (d,l) = ctx.local in + let combine_assign man r fe f args fc es f_ask = + let (d,l) = man.local in (* No need to add1 here, already done in combine_env. *) if leq0 l then (d, l) else - let d',_ = combine_assign' ctx r fe f args fc es f_ask in + let d',_ = combine_assign' man r fe f args fc es f_ask in (d', l) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.EvalFunvar e -> - let (d,l) = ctx.local in + let (d,l) = man.local in if leq0 l then Queries.AD.empty () else - query' ctx (Queries.EvalFunvar e) - | q -> query' ctx q + query' man (Queries.EvalFunvar e) + | q -> query' man q end @@ -379,33 +379,33 @@ struct let morphstate v (d,m) = S.morphstate v d, m - let conv ctx = - { ctx with local = fst ctx.local - ; split = (fun d es -> ctx.split (d, snd ctx.local) es ) + let conv man = + { man with local = fst man.local + ; split = (fun d es -> man.split (d, snd man.local) es ) } - let context ctx fd (d,m) = S.context (conv ctx) fd d (* just the child analysis' context *) + let context man fd (d,m) = S.context (conv man) fd d (* just the child analysis' context *) - let lift_fun ctx f g = g (f (conv ctx)), snd ctx.local + let lift_fun man f g = g (f (conv man)), snd man.local - let sync ctx reason = lift_fun ctx S.sync ((|>) reason) - let query ctx = S.query (conv ctx) - let assign ctx lv e = lift_fun ctx S.assign ((|>) e % (|>) lv) - let vdecl ctx v = lift_fun ctx S.vdecl ((|>) v) - let branch ctx e tv = lift_fun ctx S.branch ((|>) tv % (|>) e) - let body ctx f = lift_fun ctx S.body ((|>) f) - let return ctx r f = lift_fun ctx S.return ((|>) f % (|>) r) - let asm ctx = lift_fun ctx S.asm identity - let skip ctx = lift_fun ctx S.skip identity - let special ctx r f args = lift_fun ctx S.special ((|>) args % (|>) f % (|>) r) + let sync man reason = lift_fun man S.sync ((|>) reason) + let query man = S.query (conv man) + let assign man lv e = lift_fun man S.assign ((|>) e % (|>) lv) + let vdecl man v = lift_fun man S.vdecl ((|>) v) + let branch man e tv = lift_fun man S.branch ((|>) tv % (|>) e) + let body man f = lift_fun man S.body ((|>) f) + let return man r f = lift_fun man S.return ((|>) f % (|>) r) + let asm man = lift_fun man S.asm identity + let skip man = lift_fun man S.skip identity + let special man r f args = lift_fun man S.special ((|>) args % (|>) f % (|>) r) - let event ctx e octx = lift_fun ctx S.event ((|>) (conv octx) % (|>) e) + let event man e oman = lift_fun man S.event ((|>) (conv oman) % (|>) e) - let threadenter ctx ~multiple lval f args = S.threadenter (conv ctx) ~multiple lval f args |> List.map (fun d -> (d, snd ctx.local)) - let threadspawn ctx ~multiple lval f args fctx = lift_fun ctx (S.threadspawn ~multiple) ((|>) (conv fctx) % (|>) args % (|>) f % (|>) lval) + let threadenter man ~multiple lval f args = S.threadenter (conv man) ~multiple lval f args |> List.map (fun d -> (d, snd man.local)) + let threadspawn man ~multiple lval f args fman = lift_fun man (S.threadspawn ~multiple) ((|>) (conv fman) % (|>) args % (|>) f % (|>) lval) - let enter ctx r f args = - let m = snd ctx.local in + let enter man r f args = + let m = snd man.local in let d' v_cur = if ContextUtil.should_keep ~isAttr:GobContext ~keepOption:"ana.context.widen" ~keepAttr:"widen" ~removeAttr:"no-widen" f then ( let v_old = M.find f.svar m in (* S.D.bot () if not found *) @@ -416,15 +416,15 @@ struct else v_cur, m in - S.enter (conv ctx) r f args + S.enter (conv man) r f args |> List.map (fun (c,v) -> (c,m), d' v) (* c: caller, v: callee *) - let paths_as_set ctx = - let m = snd ctx.local in - S.paths_as_set (conv ctx) |> List.map (fun v -> (v,m)) + let paths_as_set man = + let m = snd man.local in + S.paths_as_set (conv man) |> List.map (fun v -> (v,m)) - let combine_env ctx r fe f args fc es f_ask = lift_fun ctx S.combine_env (fun p -> p r fe f args fc (fst es) f_ask) - let combine_assign ctx r fe f args fc es f_ask = lift_fun ctx S.combine_assign (fun p -> p r fe f args fc (fst es) f_ask) + let combine_env man r fe f args fc es f_ask = lift_fun man S.combine_env (fun p -> p r fe f args fc (fst es) f_ask) + let combine_assign man r fe f args fc es f_ask = lift_fun man S.combine_assign (fun p -> p r fe f args fc (fst es) f_ask) end @@ -461,44 +461,44 @@ struct let morphstate v d = try `Lifted (S.morphstate v (D.unlift d)) with Deadcode -> d - let conv ctx = - { ctx with local = D.unlift ctx.local - ; split = (fun d es -> ctx.split (D.lift d) es ) + let conv man = + { man with local = D.unlift man.local + ; split = (fun d es -> man.split (D.lift d) es ) } - let context ctx fd = S.context (conv ctx) fd % D.unlift + let context man fd = S.context (conv man) fd % D.unlift - let lift_fun ctx f g h b = - try f @@ h (g (conv ctx)) + let lift_fun man f g h b = + try f @@ h (g (conv man)) with Deadcode -> b - let sync ctx reason = lift_fun ctx D.lift S.sync ((|>) reason) `Bot + let sync man reason = lift_fun man D.lift S.sync ((|>) reason) `Bot - let enter ctx r f args = + let enter man r f args = let liftmap = List.map (fun (x,y) -> D.lift x, D.lift y) in - lift_fun ctx liftmap S.enter ((|>) args % (|>) f % (|>) r) [] + lift_fun man liftmap S.enter ((|>) args % (|>) f % (|>) r) [] - let paths_as_set ctx = + let paths_as_set man = let liftmap = List.map (fun x -> D.lift x) in - lift_fun ctx liftmap S.paths_as_set (Fun.id) [D.bot ()] (* One dead path instead of none, such that combine_env gets called for functions with dead normal return (and thus longjmpy returns can be correctly handled by lifter). *) - - let query ctx (type a) (q: a Queries.t): a Queries.result = - lift_fun ctx identity S.query (fun (x) -> x q) (Queries.Result.bot q) - let assign ctx lv e = lift_fun ctx D.lift S.assign ((|>) e % (|>) lv) `Bot - let vdecl ctx v = lift_fun ctx D.lift S.vdecl ((|>) v) `Bot - let branch ctx e tv = lift_fun ctx D.lift S.branch ((|>) tv % (|>) e) `Bot - let body ctx f = lift_fun ctx D.lift S.body ((|>) f) `Bot - let return ctx r f = lift_fun ctx D.lift S.return ((|>) f % (|>) r) `Bot - let asm ctx = lift_fun ctx D.lift S.asm identity `Bot - let skip ctx = lift_fun ctx D.lift S.skip identity `Bot - let special ctx r f args = lift_fun ctx D.lift S.special ((|>) args % (|>) f % (|>) r) `Bot - let combine_env ctx r fe f args fc es f_ask = lift_fun ctx D.lift S.combine_env (fun p -> p r fe f args fc (D.unlift es) f_ask) `Bot - let combine_assign ctx r fe f args fc es f_ask = lift_fun ctx D.lift S.combine_assign (fun p -> p r fe f args fc (D.unlift es) f_ask) `Bot - - let threadenter ctx ~multiple lval f args = lift_fun ctx (List.map D.lift) (S.threadenter ~multiple) ((|>) args % (|>) f % (|>) lval) [] - let threadspawn ctx ~multiple lval f args fctx = lift_fun ctx D.lift (S.threadspawn ~multiple) ((|>) (conv fctx) % (|>) args % (|>) f % (|>) lval) `Bot - - let event (ctx:(D.t,G.t,C.t,V.t) ctx) (e:Events.t) (octx:(D.t,G.t,C.t,V.t) ctx):D.t = lift_fun ctx D.lift S.event ((|>) (conv octx) % (|>) e) `Bot + lift_fun man liftmap S.paths_as_set (Fun.id) [D.bot ()] (* One dead path instead of none, such that combine_env gets called for functions with dead normal return (and thus longjmpy returns can be correctly handled by lifter). *) + + let query man (type a) (q: a Queries.t): a Queries.result = + lift_fun man identity S.query (fun (x) -> x q) (Queries.Result.bot q) + let assign man lv e = lift_fun man D.lift S.assign ((|>) e % (|>) lv) `Bot + let vdecl man v = lift_fun man D.lift S.vdecl ((|>) v) `Bot + let branch man e tv = lift_fun man D.lift S.branch ((|>) tv % (|>) e) `Bot + let body man f = lift_fun man D.lift S.body ((|>) f) `Bot + let return man r f = lift_fun man D.lift S.return ((|>) f % (|>) r) `Bot + let asm man = lift_fun man D.lift S.asm identity `Bot + let skip man = lift_fun man D.lift S.skip identity `Bot + let special man r f args = lift_fun man D.lift S.special ((|>) args % (|>) f % (|>) r) `Bot + let combine_env man r fe f args fc es f_ask = lift_fun man D.lift S.combine_env (fun p -> p r fe f args fc (D.unlift es) f_ask) `Bot + let combine_assign man r fe f args fc es f_ask = lift_fun man D.lift S.combine_assign (fun p -> p r fe f args fc (D.unlift es) f_ask) `Bot + + let threadenter man ~multiple lval f args = lift_fun man (List.map D.lift) (S.threadenter ~multiple) ((|>) args % (|>) f % (|>) lval) [] + let threadspawn man ~multiple lval f args fman = lift_fun man D.lift (S.threadspawn ~multiple) ((|>) (conv fman) % (|>) args % (|>) f % (|>) lval) `Bot + + let event (man:(D.t,G.t,C.t,V.t) man) (e:Events.t) (oman:(D.t,G.t,C.t,V.t) man):D.t = lift_fun man D.lift S.event ((|>) (conv oman) % (|>) e) `Bot end @@ -545,81 +545,81 @@ struct let startstate v = D.singleton (Spec.startstate v) let morphstate v d = D.map (Spec.morphstate v) d - let conv ctx x = - let rec ctx' = { ctx with ask = (fun (type a) (q: a Queries.t) -> Spec.query ctx' q) + let conv man x = + let rec man' = { man with ask = (fun (type a) (q: a Queries.t) -> Spec.query man' q) ; local = x - ; split = (ctx.split % D.singleton) } + ; split = (man.split % D.singleton) } in - ctx' + man' - let context ctx fd l = + let context man fd l = if D.cardinal l <> 1 then failwith "PathSensitive2.context must be called with a singleton set." else let x = D.choose l in - Spec.context (conv ctx x) fd x + Spec.context (conv man x) fd x - let map ctx f g = + let map man f g = let h x xs = - try D.add (g (f (conv ctx x))) xs + try D.add (g (f (conv man x))) xs with Deadcode -> xs in - let d = D.fold h ctx.local (D.empty ()) in + let d = D.fold h man.local (D.empty ()) in if D.is_bot d then raise Deadcode else d - let fold' ctx f g h a = + let fold' man f g h a = let k x a = - try h a @@ g @@ f @@ conv ctx x + try h a @@ g @@ f @@ conv man x with Deadcode -> a in - D.fold k ctx.local a - - let assign ctx l e = map ctx Spec.assign (fun h -> h l e ) - let vdecl ctx v = map ctx Spec.vdecl (fun h -> h v) - let body ctx f = map ctx Spec.body (fun h -> h f ) - let return ctx e f = map ctx Spec.return (fun h -> h e f ) - let branch ctx e tv = map ctx Spec.branch (fun h -> h e tv) - let asm ctx = map ctx Spec.asm identity - let skip ctx = map ctx Spec.skip identity - let special ctx l f a = map ctx Spec.special (fun h -> h l f a) - - let event ctx e octx = - let fd1 = D.choose octx.local in - map ctx Spec.event (fun h -> h e (conv octx fd1)) - - let threadenter ctx ~multiple lval f args = + D.fold k man.local a + + let assign man l e = map man Spec.assign (fun h -> h l e ) + let vdecl man v = map man Spec.vdecl (fun h -> h v) + let body man f = map man Spec.body (fun h -> h f ) + let return man e f = map man Spec.return (fun h -> h e f ) + let branch man e tv = map man Spec.branch (fun h -> h e tv) + let asm man = map man Spec.asm identity + let skip man = map man Spec.skip identity + let special man l f a = map man Spec.special (fun h -> h l f a) + + let event man e oman = + let fd1 = D.choose oman.local in + map man Spec.event (fun h -> h e (conv oman fd1)) + + let threadenter man ~multiple lval f args = let g xs ys = (List.map (fun y -> D.singleton y) ys) @ xs in - fold' ctx (Spec.threadenter ~multiple) (fun h -> h lval f args) g [] + fold' man (Spec.threadenter ~multiple) (fun h -> h lval f args) g [] - let threadspawn ctx ~multiple lval f args fctx = - let fd1 = D.choose fctx.local in - map ctx (Spec.threadspawn ~multiple) (fun h -> h lval f args (conv fctx fd1)) + let threadspawn man ~multiple lval f args fman = + let fd1 = D.choose fman.local in + map man (Spec.threadspawn ~multiple) (fun h -> h lval f args (conv fman fd1)) - let sync ctx reason = map ctx Spec.sync (fun h -> h reason) + let sync man reason = map man Spec.sync (fun h -> h reason) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = (* TODO: handle Invariant path like PathSensitive3? *) (* join results so that they are sound for all paths *) let module Result = (val Queries.Result.lattice q) in - fold' ctx Spec.query identity (fun x f -> Result.join x (f q)) (Result.bot ()) + fold' man Spec.query identity (fun x f -> Result.join x (f q)) (Result.bot ()) - let enter ctx l f a = + let enter man l f a = let g xs ys = (List.map (fun (x,y) -> D.singleton x, D.singleton y) ys) @ xs in - fold' ctx Spec.enter (fun h -> h l f a) g [] + fold' man Spec.enter (fun h -> h l f a) g [] - let paths_as_set ctx = + let paths_as_set man = (* Path-sensitivity is only here, not below! *) - let elems = D.elements ctx.local in + let elems = D.elements man.local in List.map (D.singleton) elems - let combine_env ctx l fe f a fc d f_ask = - assert (D.cardinal ctx.local = 1); - let cd = D.choose ctx.local in + let combine_env man l fe f a fc d f_ask = + assert (D.cardinal man.local = 1); + let cd = D.choose man.local in let k x y = if M.tracing then M.traceli "combine" "function: %a" Spec.D.pretty x; try - let r = Spec.combine_env (conv ctx cd) l fe f a fc x f_ask in + let r = Spec.combine_env (conv man cd) l fe f a fc x f_ask in if M.tracing then M.traceu "combine" "combined function: %a" Spec.D.pretty r; D.add r y with Deadcode -> @@ -629,13 +629,13 @@ struct let d = D.fold k d (D.bot ()) in if D.is_bot d then raise Deadcode else d - let combine_assign ctx l fe f a fc d f_ask = - assert (D.cardinal ctx.local = 1); - let cd = D.choose ctx.local in + let combine_assign man l fe f a fc d f_ask = + assert (D.cardinal man.local = 1); + let cd = D.choose man.local in let k x y = if M.tracing then M.traceli "combine" "function: %a" Spec.D.pretty x; try - let r = Spec.combine_assign (conv ctx cd) l fe f a fc x f_ask in + let r = Spec.combine_assign (conv man cd) l fe f a fc x f_ask in if M.tracing then M.traceu "combine" "combined function: %a" Spec.D.pretty r; D.add r y with Deadcode -> @@ -699,21 +699,21 @@ struct init marshal; AnalysisState.unsound_both_branches_dead := Some false - let conv (ctx: (_, G.t, _, V.t) ctx): (_, S.G.t, _, S.V.t) ctx = - { ctx with - global = (fun v -> G.s (ctx.global (V.s v))); - sideg = (fun v g -> ctx.sideg (V.s v) (G.create_s g)); + let conv (man: (_, G.t, _, V.t) man): (_, S.G.t, _, S.V.t) man = + { man with + global = (fun v -> G.s (man.global (V.s v))); + sideg = (fun v g -> man.sideg (V.s v) (G.create_s g)); } - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | WarnGlobal g -> let g: V.t = Obj.obj g in begin match g with | `Left g -> - S.query (conv ctx) (WarnGlobal (Obj.repr g)) + S.query (conv man) (WarnGlobal (Obj.repr g)) | `Right g -> - let em = G.node (ctx.global (V.node g)) in + let em = G.node (man.global (V.node g)) in EM.iter (fun exp tv -> match tv with | `Lifted tv -> @@ -733,7 +733,7 @@ struct let g: V.t = Obj.obj g in begin match g with | `Left g -> - S.query (conv ctx) (InvariantGlobal (Obj.repr g)) + S.query (conv man) (InvariantGlobal (Obj.repr g)) | `Right g -> Queries.Result.top q end @@ -741,14 +741,14 @@ struct let g: V.t = Obj.obj g in begin match g with | `Left g -> - S.query (conv ctx) (YamlEntryGlobal (Obj.repr g, task)) + S.query (conv man) (YamlEntryGlobal (Obj.repr g, task)) | `Right g -> Queries.Result.top q end | IterSysVars (vq, vf) -> (* vars for S *) let vf' x = vf (Obj.repr (V.s (Obj.obj x))) in - S.query (conv ctx) (IterSysVars (vq, vf')); + S.query (conv man) (IterSysVars (vq, vf')); (* node vars for dead branches *) begin match vq with @@ -758,42 +758,42 @@ struct () end | _ -> - S.query (conv ctx) q + S.query (conv man) q - let branch ctx = S.branch (conv ctx) - let context ctx = S.context (conv ctx) + let branch man = S.branch (conv man) + let context man = S.context (conv man) - let branch ctx exp tv = + let branch man exp tv = if !AnalysisState.postsolving then ( try - let r = branch ctx exp tv in + let r = branch man exp tv in (* branch is live *) - ctx.sideg (V.node ctx.prev_node) (G.create_node (EM.singleton exp (`Lifted tv))); (* record expression with reached tv *) + man.sideg (V.node man.prev_node) (G.create_node (EM.singleton exp (`Lifted tv))); (* record expression with reached tv *) r with Deadcode -> (* branch is dead *) - ctx.sideg (V.node ctx.prev_node) (G.create_node (EM.singleton exp `Bot)); (* record expression without reached tv *) + man.sideg (V.node man.prev_node) (G.create_node (EM.singleton exp `Bot)); (* record expression without reached tv *) raise Deadcode ) else ( - ctx.sideg (V.node ctx.prev_node) (G.create_node (EM.bot ())); (* create global variable during solving, to allow postsolving leq hack to pass verify *) - branch ctx exp tv + man.sideg (V.node man.prev_node) (G.create_node (EM.bot ())); (* create global variable during solving, to allow postsolving leq hack to pass verify *) + branch man exp tv ) - let assign ctx = S.assign (conv ctx) - let vdecl ctx = S.vdecl (conv ctx) - let enter ctx = S.enter (conv ctx) - let paths_as_set ctx = S.paths_as_set (conv ctx) - let body ctx = S.body (conv ctx) - let return ctx = S.return (conv ctx) - let combine_env ctx = S.combine_env (conv ctx) - let combine_assign ctx = S.combine_assign (conv ctx) - let special ctx = S.special (conv ctx) - let threadenter ctx = S.threadenter (conv ctx) - let threadspawn ctx ~multiple lv f args fctx = S.threadspawn (conv ctx) ~multiple lv f args (conv fctx) - let sync ctx = S.sync (conv ctx) - let skip ctx = S.skip (conv ctx) - let asm ctx = S.asm (conv ctx) - let event ctx e octx = S.event (conv ctx) e (conv octx) + let assign man = S.assign (conv man) + let vdecl man = S.vdecl (conv man) + let enter man = S.enter (conv man) + let paths_as_set man = S.paths_as_set (conv man) + let body man = S.body (conv man) + let return man = S.return (conv man) + let combine_env man = S.combine_env (conv man) + let combine_assign man = S.combine_assign (conv man) + let special man = S.special (conv man) + let threadenter man = S.threadenter (conv man) + let threadspawn man ~multiple lv f args fman = S.threadspawn (conv man) ~multiple lv f args (conv fman) + let sync man = S.sync (conv man) + let skip man = S.skip (conv man) + let asm man = S.asm (conv man) + let event man e oman = S.event (conv man) e (conv oman) end diff --git a/src/lifters/wideningTokenLifter.ml b/src/lifters/wideningTokenLifter.ml index 634468a9ca..0ba069328a 100644 --- a/src/lifters/wideningTokenLifter.ml +++ b/src/lifters/wideningTokenLifter.ml @@ -125,25 +125,25 @@ struct let exitstate v = (S.exitstate v, TS.bot ()) let morphstate v (d, t) = (S.morphstate v d, t) - let conv (ctx: (D.t, G.t, C.t, V.t) ctx): (S.D.t, S.G.t, S.C.t, S.V.t) ctx = - { ctx with local = D.unlift ctx.local - ; split = (fun d es -> ctx.split (d, snd ctx.local) es) (* Split keeps local widening tokens. *) - ; global = (fun g -> G.unlift (ctx.global g)) - ; sideg = (fun v g -> ctx.sideg v (g, !side_tokens)) (* Using side_tokens for side effect. *) + let conv (man: (D.t, G.t, C.t, V.t) man): (S.D.t, S.G.t, S.C.t, S.V.t) man = + { man with local = D.unlift man.local + ; split = (fun d es -> man.split (d, snd man.local) es) (* Split keeps local widening tokens. *) + ; global = (fun g -> G.unlift (man.global g)) + ; sideg = (fun v g -> man.sideg v (g, !side_tokens)) (* Using side_tokens for side effect. *) } - let context ctx fd = S.context (conv ctx) fd % D.unlift + let context man fd = S.context (conv man) fd % D.unlift let startcontext () = S.startcontext () - let lift_fun ctx f g h = - let new_tokens = ref (snd ctx.local) in (* New tokens not yet used during this transfer function, such that it is deterministic. *) + let lift_fun man f g h = + let new_tokens = ref (snd man.local) in (* New tokens not yet used during this transfer function, such that it is deterministic. *) let old_add = !add_ref in let old_local_tokens = !local_tokens in add_ref := (fun t -> new_tokens := TS.add t !new_tokens); - local_tokens := snd ctx.local; + local_tokens := snd man.local; let d = Fun.protect (fun () -> - h (g (conv ctx)) + h (g (conv man)) ) ~finally:(fun () -> local_tokens := old_local_tokens; add_ref := old_add @@ -156,30 +156,30 @@ struct let lift' d ts = (d, ts) - let paths_as_set ctx = + let paths_as_set man = let liftmap l ts = List.map (fun x -> (x, ts)) l in - lift_fun ctx liftmap S.paths_as_set (Fun.id) + lift_fun man liftmap S.paths_as_set (Fun.id) - let sync ctx reason = lift_fun ctx lift' S.sync ((|>) reason) + let sync man reason = lift_fun man lift' S.sync ((|>) reason) - let enter ctx r f args = + let enter man r f args = let liftmap l ts = List.map (fun (x,y) -> (x, ts), (y, ts)) l in - lift_fun ctx liftmap S.enter ((|>) args % (|>) f % (|>) r) - - let query ctx (type a) (q: a Queries.t): a Queries.result = - lift_fun ctx Fun.const S.query (fun (x) -> x q) - let assign ctx lv e = lift_fun ctx lift' S.assign ((|>) e % (|>) lv) - let vdecl ctx v = lift_fun ctx lift' S.vdecl ((|>) v) - let branch ctx e tv = lift_fun ctx lift' S.branch ((|>) tv % (|>) e) - let body ctx f = lift_fun ctx lift' S.body ((|>) f) - let return ctx r f = lift_fun ctx lift' S.return ((|>) f % (|>) r) - let asm ctx = lift_fun ctx lift' S.asm identity - let skip ctx = lift_fun ctx lift' S.skip identity - let special ctx r f args = lift_fun ctx lift' S.special ((|>) args % (|>) f % (|>) r) - let combine_env ctx r fe f args fc es f_ask = lift_fun ctx lift' S.combine_env (fun p -> p r fe f args fc (D.unlift es) f_ask) (* TODO: use tokens from es *) - let combine_assign ctx r fe f args fc es f_ask = lift_fun ctx lift' S.combine_assign (fun p -> p r fe f args fc (D.unlift es) f_ask) (* TODO: use tokens from es *) - - let threadenter ctx ~multiple lval f args = lift_fun ctx (fun l ts -> List.map (Fun.flip lift' ts) l) (S.threadenter ~multiple) ((|>) args % (|>) f % (|>) lval ) - let threadspawn ctx ~multiple lval f args fctx = lift_fun ctx lift' (S.threadspawn ~multiple) ((|>) (conv fctx) % (|>) args % (|>) f % (|>) lval) - let event ctx e octx = lift_fun ctx lift' S.event ((|>) (conv octx) % (|>) e) + lift_fun man liftmap S.enter ((|>) args % (|>) f % (|>) r) + + let query man (type a) (q: a Queries.t): a Queries.result = + lift_fun man Fun.const S.query (fun (x) -> x q) + let assign man lv e = lift_fun man lift' S.assign ((|>) e % (|>) lv) + let vdecl man v = lift_fun man lift' S.vdecl ((|>) v) + let branch man e tv = lift_fun man lift' S.branch ((|>) tv % (|>) e) + let body man f = lift_fun man lift' S.body ((|>) f) + let return man r f = lift_fun man lift' S.return ((|>) f % (|>) r) + let asm man = lift_fun man lift' S.asm identity + let skip man = lift_fun man lift' S.skip identity + let special man r f args = lift_fun man lift' S.special ((|>) args % (|>) f % (|>) r) + let combine_env man r fe f args fc es f_ask = lift_fun man lift' S.combine_env (fun p -> p r fe f args fc (D.unlift es) f_ask) (* TODO: use tokens from es *) + let combine_assign man r fe f args fc es f_ask = lift_fun man lift' S.combine_assign (fun p -> p r fe f args fc (D.unlift es) f_ask) (* TODO: use tokens from es *) + + let threadenter man ~multiple lval f args = lift_fun man (fun l ts -> List.map (Fun.flip lift' ts) l) (S.threadenter ~multiple) ((|>) args % (|>) f % (|>) lval ) + let threadspawn man ~multiple lval f args fman = lift_fun man lift' (S.threadspawn ~multiple) ((|>) (conv fman) % (|>) args % (|>) f % (|>) lval) + let event man e oman = lift_fun man lift' S.event ((|>) (conv oman) % (|>) e) end diff --git a/src/witness/observerAnalysis.ml b/src/witness/observerAnalysis.ml index 490a51021a..533d1c5d58 100644 --- a/src/witness/observerAnalysis.ml +++ b/src/witness/observerAnalysis.ml @@ -44,40 +44,40 @@ struct end | _ -> d - let step_ctx ctx = step ctx.local ctx.prev_node ctx.node + let step_man man = step man.local man.prev_node man.node (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - step_ctx ctx + let assign man (lval:lval) (rval:exp) : D.t = + step_man man - let vdecl ctx (_:varinfo) : D.t = - step_ctx ctx + let vdecl man (_:varinfo) : D.t = + step_man man - let branch ctx (exp:exp) (tv:bool) : D.t = - step_ctx ctx + let branch man (exp:exp) (tv:bool) : D.t = + step_man man - let body ctx (f:fundec) : D.t = - step_ctx ctx + let body man (f:fundec) : D.t = + step_man man - let return ctx (exp:exp option) (f:fundec) : D.t = - step_ctx ctx + let return man (exp:exp option) (f:fundec) : D.t = + step_man man - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - (* ctx.local doesn't matter here? *) - [ctx.local, step ctx.local ctx.prev_node (FunctionEntry f)] + let enter man (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = + (* man.local doesn't matter here? *) + [man.local, step man.local man.prev_node (FunctionEntry f)] - let combine_env ctx lval fexp f args fc au f_ask = - ctx.local (* Don't yet consider call edge done before assign. *) + let combine_env man lval fexp f args fc au f_ask = + man.local (* Don't yet consider call edge done before assign. *) - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = - step au (Function f) ctx.node (* Consider call edge done after entire call-assign. *) + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = + step au (Function f) man.node (* Consider call edge done after entire call-assign. *) - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - step_ctx ctx + let special man (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = + step_man man let startstate v = `Lifted Automaton.initial - let threadenter ctx ~multiple lval f args = [D.top ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local + let threadenter man ~multiple lval f args = [D.top ()] + let threadspawn man ~multiple lval f args fman = man.local let exitstate v = D.top () end diff --git a/src/witness/witnessConstraints.ml b/src/witness/witnessConstraints.ml index e361dbaa54..dc492fdabb 100644 --- a/src/witness/witnessConstraints.ml +++ b/src/witness/witnessConstraints.ml @@ -117,111 +117,111 @@ struct | exception Not_found -> M.debug ~category:Witness ~tags:[Category Analyzer] "PathSensitive3 sync predecessor not found"; R.bot () - let step_ctx ctx x e = + let step_man man x e = try - step ctx.prev_node (ctx.context ()) x e (snd ctx.local) - with Ctx_failure _ -> + step man.prev_node (man.context ()) x e (snd man.local) + with Man_failure _ -> R.bot () - let step_ctx_edge ctx x = step_ctx ctx x (CFGEdge ctx.edge) - let step_ctx_inlined_edge ctx x = step_ctx ctx x (InlinedEdge ctx.edge) + let step_man_edge man x = step_man man x (CFGEdge man.edge) + let step_man_inlined_edge man x = step_man man x (InlinedEdge man.edge) let nosync x = Sync.singleton x (SyncSet.singleton x) - let conv ctx x = - let rec ctx' = - { ctx with + let conv man x = + let rec man' = + { man with local = x; - ask = (fun (type a) (q: a Queries.t) -> Spec.query ctx' q); + ask = (fun (type a) (q: a Queries.t) -> Spec.query man' q); split; } and split y es = - let yr = step_ctx_edge ctx x in - ctx.split (Dom.singleton y yr, Sync.bot ()) es + let yr = step_man_edge man x in + man.split (Dom.singleton y yr, Sync.bot ()) es in - ctx' + man' - let context ctx fd (l, _) = + let context man fd (l, _) = if Dom.cardinal l <> 1 then failwith "PathSensitive3.context must be called with a singleton set." else let x = Dom.choose_key l in - Spec.context (conv ctx x) fd @@ x + Spec.context (conv man x) fd @@ x let startcontext = Spec.startcontext - let map ctx f g = + let map man f g = (* we now use Sync for every tf such that threadspawn after tf could look up state before tf *) let h x (xs, sync) = try - let x' = g (f (conv ctx x)) in - (Dom.add x' (step_ctx_edge ctx x) xs, Sync.add x' (SyncSet.singleton x) sync) + let x' = g (f (conv man x)) in + (Dom.add x' (step_man_edge man x) xs, Sync.add x' (SyncSet.singleton x) sync) with Deadcode -> (xs, sync) in - let d = Dom.fold_keys h (fst ctx.local) (Dom.empty (), Sync.bot ()) in + let d = Dom.fold_keys h (fst man.local) (Dom.empty (), Sync.bot ()) in if Dom.is_bot (fst d) then raise Deadcode else d (* TODO???? *) - let map_event ctx e = + let map_event man e = (* we now use Sync for every tf such that threadspawn after tf could look up state before tf *) let h x (xs, sync) = try - let x' = Spec.event (conv ctx x) e (conv ctx x) in - (Dom.add x' (step_ctx_edge ctx x) xs, Sync.add x' (SyncSet.singleton x) sync) + let x' = Spec.event (conv man x) e (conv man x) in + (Dom.add x' (step_man_edge man x) xs, Sync.add x' (SyncSet.singleton x) sync) with Deadcode -> (xs, sync) in - let d = Dom.fold_keys h (fst ctx.local) (Dom.empty (), Sync.bot ()) in + let d = Dom.fold_keys h (fst man.local) (Dom.empty (), Sync.bot ()) in if Dom.is_bot (fst d) then raise Deadcode else d - let fold' ctx f g h a = + let fold' man f g h a = let k x a = - try h a x @@ g @@ f @@ conv ctx x + try h a x @@ g @@ f @@ conv man x with Deadcode -> a in - Dom.fold_keys k (fst ctx.local) a + Dom.fold_keys k (fst man.local) a - let fold'' ctx f g h a = + let fold'' man f g h a = let k x r a = - try h a x r @@ g @@ f @@ conv ctx x + try h a x r @@ g @@ f @@ conv man x with Deadcode -> a in - Dom.fold k (fst ctx.local) a - - let assign ctx l e = map ctx Spec.assign (fun h -> h l e ) - let vdecl ctx v = map ctx Spec.vdecl (fun h -> h v) - let body ctx f = map ctx Spec.body (fun h -> h f ) - let return ctx e f = map ctx Spec.return (fun h -> h e f ) - let branch ctx e tv = map ctx Spec.branch (fun h -> h e tv) - let asm ctx = map ctx Spec.asm identity - let skip ctx = map ctx Spec.skip identity - let special ctx l f a = map ctx Spec.special (fun h -> h l f a) - let event ctx e octx = map_event ctx e (* TODO: ???? *) - - let paths_as_set ctx = - let (a,b) = ctx.local in + Dom.fold k (fst man.local) a + + let assign man l e = map man Spec.assign (fun h -> h l e ) + let vdecl man v = map man Spec.vdecl (fun h -> h v) + let body man f = map man Spec.body (fun h -> h f ) + let return man e f = map man Spec.return (fun h -> h e f ) + let branch man e tv = map man Spec.branch (fun h -> h e tv) + let asm man = map man Spec.asm identity + let skip man = map man Spec.skip identity + let special man l f a = map man Spec.special (fun h -> h l f a) + let event man e oman = map_event man e (* TODO: ???? *) + + let paths_as_set man = + let (a,b) = man.local in let r = Dom.bindings a in List.map (fun (x,v) -> (Dom.singleton x v, b)) r - let threadenter ctx ~multiple lval f args = + let threadenter man ~multiple lval f args = let g xs x' ys = let ys' = List.map (fun y -> - let yr = step ctx.prev_node (ctx.context ()) x' (ThreadEntry (lval, f, args)) (nosync x') in (* threadenter called on before-sync state *) + let yr = step man.prev_node (man.context ()) x' (ThreadEntry (lval, f, args)) (nosync x') in (* threadenter called on before-sync state *) (Dom.singleton y yr, Sync.bot ()) ) ys in ys' @ xs in - fold' ctx (Spec.threadenter ~multiple) (fun h -> h lval f args) g [] - let threadspawn ctx ~multiple lval f args fctx = - let fd1 = Dom.choose_key (fst fctx.local) in - map ctx (Spec.threadspawn ~multiple) (fun h -> h lval f args (conv fctx fd1)) + fold' man (Spec.threadenter ~multiple) (fun h -> h lval f args) g [] + let threadspawn man ~multiple lval f args fman = + let fd1 = Dom.choose_key (fst fman.local) in + map man (Spec.threadspawn ~multiple) (fun h -> h lval f args (conv fman fd1)) - let sync ctx reason = - fold'' ctx Spec.sync (fun h -> h reason) (fun (a, async) x r a' -> + let sync man reason = + fold'' man Spec.sync (fun h -> h reason) (fun (a, async) x r a' -> (Dom.add a' r a, Sync.add a' (SyncSet.singleton x) async) ) (Dom.empty (), Sync.bot ()) - let query ctx (type a) (q: a Queries.t): a Queries.result = + let query man (type a) (q: a Queries.t): a Queries.result = match q with | Queries.IterPrevVars f -> if M.tracing then M.tracei "witness" "IterPrevVars"; @@ -234,35 +234,35 @@ struct f (I.to_int x) (n, Obj.repr c, I.to_int j) e ) r; if M.tracing then M.traceu "witness" "" (* unindent! *) - ) (fst ctx.local); + ) (fst man.local); (* check that sync mappings don't leak into solution (except Function) *) (* TODO: disabled because we now use and leave Sync for every tf, such that threadspawn after tf could look up state before tf *) - (* begin match ctx.node with + (* begin match man.node with | Function _ -> () (* returns post-sync in FromSpec *) - | _ -> assert (Sync.is_bot (snd ctx.local)); + | _ -> assert (Sync.is_bot (snd man.local)); end; *) if M.tracing then M.traceu "witness" ""; () | Queries.IterVars f -> Dom.iter (fun x r -> f (I.to_int x) - ) (fst ctx.local); + ) (fst man.local); () | Queries.PathQuery (i, q) -> (* TODO: optimize indexing, using inner hashcons somehow? *) (* let (d, _) = List.at (S.elements s) i in *) - let (d, _) = List.find (fun (x, _) -> I.to_int x = i) (Dom.bindings (fst ctx.local)) in - Spec.query (conv ctx d) q + let (d, _) = List.find (fun (x, _) -> I.to_int x = i) (Dom.bindings (fst man.local)) in + Spec.query (conv man d) q | Queries.Invariant ({path=Some i; _} as c) -> (* TODO: optimize indexing, using inner hashcons somehow? *) (* let (d, _) = List.at (S.elements s) i in *) - let (d, _) = List.find (fun (x, _) -> I.to_int x = i) (Dom.bindings (fst ctx.local)) in - Spec.query (conv ctx d) (Invariant c) + let (d, _) = List.find (fun (x, _) -> I.to_int x = i) (Dom.bindings (fst man.local)) in + Spec.query (conv man d) (Invariant c) | _ -> (* join results so that they are sound for all paths *) let module Result = (val Queries.Result.lattice q) in - fold' ctx Spec.query identity (fun x _ f -> Result.join x (f q)) (Result.bot ()) + fold' man Spec.query identity (fun x _ f -> Result.join x (f q)) (Result.bot ()) let should_inline f = (* (* inline __VERIFIER_error because Control requires the corresponding FunctionEntry node *) @@ -270,20 +270,20 @@ struct (* TODO: don't inline __VERIFIER functions for CPAchecker, but inlining needed for WP *) true - let enter ctx l f a = + let enter man l f a = let g xs x' ys = let ys' = List.map (fun (x,y) -> (* R.bot () isn't right here? doesn't actually matter? *) let yr = if should_inline f then - step_ctx ctx x' (InlineEntry (l, f, a)) + step_man man x' (InlineEntry (l, f, a)) else R.bot () in (* keep left syncs so combine gets them for no-inline case *) (* must lookup and short-circuit because enter may modify first in pair (e.g. abortUnless) *) let syncs = - match Sync.find x' (snd ctx.local) with + match Sync.find x' (snd man.local) with | syncs -> syncs | exception Not_found -> M.debug ~category:Witness ~tags:[Category Analyzer] "PathSensitive3 sync predecessor not found"; @@ -294,37 +294,37 @@ struct in ys' @ xs in - fold' ctx Spec.enter (fun h -> h l f a) g [] + fold' man Spec.enter (fun h -> h l f a) g [] - let combine_env ctx l fe f a fc d f_ask = + let combine_env man l fe f a fc d f_ask = (* Don't yet consider call edge done before assign. *) - assert (Dom.cardinal (fst ctx.local) = 1); - let (cd, cdr) = Dom.choose (fst ctx.local) in + assert (Dom.cardinal (fst man.local) = 1); + let (cd, cdr) = Dom.choose (fst man.local) in let k x (y, sync) = try - let x' = Spec.combine_env (conv ctx cd) l fe f a fc x f_ask in - (Dom.add x' cdr y, Sync.add x' (Sync.find cd (snd ctx.local)) sync) (* keep predecessors and sync from ctx, sync required for step_ctx_inlined_edge in combine_assign *) + let x' = Spec.combine_env (conv man cd) l fe f a fc x f_ask in + (Dom.add x' cdr y, Sync.add x' (Sync.find cd (snd man.local)) sync) (* keep predecessors and sync from man, sync required for step_man_inlined_edge in combine_assign *) with Deadcode -> (y, sync) in let d = Dom.fold_keys k (fst d) (Dom.bot (), Sync.bot ()) in if Dom.is_bot (fst d) then raise Deadcode else d - let combine_assign ctx l fe f a fc d f_ask = + let combine_assign man l fe f a fc d f_ask = (* Consider call edge done after entire call-assign. *) - assert (Dom.cardinal (fst ctx.local) = 1); - let cd = Dom.choose_key (fst ctx.local) in + assert (Dom.cardinal (fst man.local) = 1); + let cd = Dom.choose_key (fst man.local) in let k x (y, sync) = let r = if should_inline f then (* returns already post-sync in FromSpec *) let returnr = step (Function f) (Option.get fc) x (InlineReturn (l, f, a)) (nosync x) in (* fc should be Some outside of MCP *) - let procr = step_ctx_inlined_edge ctx cd in + let procr = step_man_inlined_edge man cd in R.join procr returnr else - step_ctx_edge ctx cd + step_man_edge man cd in try - let x' = Spec.combine_assign (conv ctx cd) l fe f a fc x f_ask in + let x' = Spec.combine_assign (conv man cd) l fe f a fc x f_ask in (Dom.add x' r y, Sync.add x' (SyncSet.singleton x) sync) with Deadcode -> (y, sync) in diff --git a/src/witness/z3/violationZ3.z3.ml b/src/witness/z3/violationZ3.z3.ml index d004320ad3..53ac756d17 100644 --- a/src/witness/z3/violationZ3.z3.ml +++ b/src/witness/z3/violationZ3.z3.ml @@ -16,7 +16,7 @@ struct (* ("smt.core.minimize", "true"); *) (* ("sat.core.minimize", "true"); *) ] - let ctx = mk_context cfg + let man = mk_context cfg type var = varinfo @@ -40,43 +40,43 @@ struct let get_const m x = match VarMap.find_opt x m with | Some x -> x - | None -> Arithmetic.Integer.mk_const_s ctx (get_name x) - let sort = Arithmetic.Integer.mk_sort ctx + | None -> Arithmetic.Integer.mk_const_s man (get_name x) + let sort = Arithmetic.Integer.mk_sort man let freshen env x = - VarMap.add x (Expr.mk_fresh_const ctx (get_name x) sort) env + VarMap.add x (Expr.mk_fresh_const man (get_name x) sort) env end let bool_to_int expr = - Boolean.mk_ite ctx expr (Arithmetic.Integer.mk_numeral_i ctx 1) (Arithmetic.Integer.mk_numeral_i ctx 0) + Boolean.mk_ite man expr (Arithmetic.Integer.mk_numeral_i man 1) (Arithmetic.Integer.mk_numeral_i man 0) let int_to_bool expr = - Boolean.mk_distinct ctx [expr; Arithmetic.Integer.mk_numeral_i ctx 0] + Boolean.mk_distinct man [expr; Arithmetic.Integer.mk_numeral_i man 0] let rec exp_to_expr env = function | Const (CInt (i, _, _)) -> - Arithmetic.Integer.mk_numeral_s ctx (Z.to_string i) + Arithmetic.Integer.mk_numeral_s man (Z.to_string i) | Lval (Var v, NoOffset) -> Env.get_const env v | BinOp (PlusA, e1, e2, TInt _) -> - Arithmetic.mk_add ctx [exp_to_expr env e1; exp_to_expr env e2] + Arithmetic.mk_add man [exp_to_expr env e1; exp_to_expr env e2] | BinOp (MinusA, e1, e2, TInt _) -> - Arithmetic.mk_sub ctx [exp_to_expr env e1; exp_to_expr env e2] + Arithmetic.mk_sub man [exp_to_expr env e1; exp_to_expr env e2] | BinOp (Mult, e1, e2, TInt _) -> - Arithmetic.mk_mul ctx [exp_to_expr env e1; exp_to_expr env e2] + Arithmetic.mk_mul man [exp_to_expr env e1; exp_to_expr env e2] | BinOp (Eq, e1, e2, TInt _) -> - bool_to_int (Boolean.mk_eq ctx (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Boolean.mk_eq man (exp_to_expr env e1) (exp_to_expr env e2)) | BinOp (Ne, e1, e2, TInt _) -> - bool_to_int (Boolean.mk_distinct ctx [exp_to_expr env e1; exp_to_expr env e2]) + bool_to_int (Boolean.mk_distinct man [exp_to_expr env e1; exp_to_expr env e2]) | BinOp (Gt, e1, e2, TInt _) -> - bool_to_int (Arithmetic.mk_gt ctx (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Arithmetic.mk_gt man (exp_to_expr env e1) (exp_to_expr env e2)) | BinOp (Lt, e1, e2, TInt _) -> - bool_to_int (Arithmetic.mk_lt ctx (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Arithmetic.mk_lt man (exp_to_expr env e1) (exp_to_expr env e2)) | BinOp (Ge, e1, e2, TInt _) -> - bool_to_int (Arithmetic.mk_ge ctx (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Arithmetic.mk_ge man (exp_to_expr env e1) (exp_to_expr env e2)) | BinOp (Le, e1, e2, TInt _) -> - bool_to_int (Arithmetic.mk_le ctx (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Arithmetic.mk_le man (exp_to_expr env e1) (exp_to_expr env e2)) | UnOp (LNot, e, TInt _) -> - bool_to_int (Boolean.mk_not ctx (int_to_bool (exp_to_expr env e))) + bool_to_int (Boolean.mk_not man (int_to_bool (exp_to_expr env e))) | e -> failwith @@ GobPretty.sprintf "exp_to_expr: %a" Cil.d_exp e @@ -86,11 +86,11 @@ struct let wp_assert env (from_node, (edge: MyARG.inline_edge), _) = match edge with | MyARG.CFGEdge (MyCFG.Assign ((Var v, NoOffset), e)) -> let env' = Env.freshen env v in - (env', [Boolean.mk_eq ctx (Env.get_const env v) (exp_to_expr env' e)]) + (env', [Boolean.mk_eq man (Env.get_const env v) (exp_to_expr env' e)]) | MyARG.CFGEdge (MyCFG.Test (e, true)) -> - (env, [Boolean.mk_distinct ctx [exp_to_expr env e; Arithmetic.Integer.mk_numeral_i ctx 0]]) + (env, [Boolean.mk_distinct man [exp_to_expr env e; Arithmetic.Integer.mk_numeral_i man 0]]) | MyARG.CFGEdge (MyCFG.Test (e, false)) -> - (env, [Boolean.mk_eq ctx (exp_to_expr env e) (Arithmetic.Integer.mk_numeral_i ctx 0)]) + (env, [Boolean.mk_eq man (exp_to_expr env e) (Arithmetic.Integer.mk_numeral_i man 0)]) | MyARG.CFGEdge (MyCFG.Entry fd) -> let env' = List.fold_left (fun acc formal -> Env.freshen acc formal @@ -98,7 +98,7 @@ struct in let eqs = List.mapi (fun i formal -> let arg_vname = get_arg_vname i in - Boolean.mk_eq ctx (Env.get_const env formal) (Env.get_const env' arg_vname) + Boolean.mk_eq man (Env.get_const env formal) (Env.get_const env' arg_vname) ) fd.sformals in (env', eqs) @@ -110,7 +110,7 @@ struct in let eqs = List.mapi (fun i arg -> let arg_vname = get_arg_vname i in - Boolean.mk_eq ctx (Env.get_const env arg_vname) (exp_to_expr env' arg) + Boolean.mk_eq man (Env.get_const env arg_vname) (exp_to_expr env' arg) ) args in (env', eqs) @@ -118,14 +118,14 @@ struct (env, []) | MyARG.CFGEdge (MyCFG.Ret (Some e, fd)) -> let env' = Env.freshen env return_vname in - (env', [Boolean.mk_eq ctx (Env.get_const env return_vname) (exp_to_expr env' e)]) + (env', [Boolean.mk_eq man (Env.get_const env return_vname) (exp_to_expr env' e)]) | MyARG.InlineReturn (None, _, _) -> (env, []) | MyARG.InlineReturn (Some (Var v, NoOffset), _, _) -> let env' = Env.freshen env v in - (env', [Boolean.mk_eq ctx (Env.get_const env v) (Env.get_const env' return_vname)]) + (env', [Boolean.mk_eq man (Env.get_const env v) (Env.get_const env' return_vname)]) | _ -> - (* (env, Boolean.mk_true ctx) *) + (* (env, Boolean.mk_true man) *) failwith @@ GobPretty.sprintf "wp_assert: %a" MyARG.pretty_inline_edge edge let const_get_symbol (expr: Expr.expr): Symbol.symbol = @@ -140,7 +140,7 @@ struct | Unknown let wp_path path = - let solver = Solver.mk_simple_solver ctx in + let solver = Solver.mk_simple_solver man in let rec iter_wp revpath i env = match revpath with | [] -> Feasible | step :: revpath' -> @@ -149,14 +149,14 @@ struct | [] -> iter_wp revpath' (i - 1) env' | [expr] -> do_assert revpath' i env' expr | exprs -> - let expr = Boolean.mk_and ctx exprs in + let expr = Boolean.mk_and man exprs in do_assert revpath' i env' expr end and do_assert revpath' i env' expr = Logs.debug "%d: %s" i (Expr.to_string expr); - let track_const = Boolean.mk_const ctx (Symbol.mk_int ctx i) in + let track_const = Boolean.mk_const man (Symbol.mk_int man i) in Solver.assert_and_track solver expr track_const; let status = Solver.check solver [] in From 197e804746da4f58d31574ecee2736a8fd5962da Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 18 Dec 2024 15:14:29 +0100 Subject: [PATCH 2/8] Ignore rename --- .git-blame-ignore-revs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index d0b623a8e4..0aa6cec831 100644 --- a/.git-blame-ignore-revs +++ b/.git-blame-ignore-revs @@ -37,3 +37,6 @@ c3e2cc848479ae86de5542b6ab0e75a74e9cf8c9 # Fix LibraryFunctions.invalidate_actions indentation 5662024232f32fe74dd25c9317dee4436ecb212d + +# Rename ctx -> man +0c155e68607fede6fab17704a9a7aee38df5408e From e559cb62e113ee6b3d62969b6c7268931433eb6a Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Wed, 18 Dec 2024 15:22:29 +0100 Subject: [PATCH 3/8] Brainfart --- src/analyses/mCP.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analyses/mCP.ml b/src/analyses/mCP.ml index 0420931ffd..b972195bad 100644 --- a/src/analyses/mCP.ml +++ b/src/analyses/mCP.ml @@ -83,11 +83,11 @@ struct check_deps !activated; activated := topo_sort_an !activated; begin - match get_string_list "ana.man_sens" with - | [] -> (* use values of "ana.man_insens" (blacklist) *) - let cont_inse = map' find_id @@ get_string_list "ana.man_insens" in + match get_string_list "ana.ctx_sens" with + | [] -> (* use values of "ana.ctx_insens" (blacklist) *) + let cont_inse = map' find_id @@ get_string_list "ana.ctx_insens" in activated_context_sens := List.filter (fun (n, _) -> not (List.mem n cont_inse)) !activated; - | sens -> (* use values of "ana.man_sens" (whitelist) *) + | sens -> (* use values of "ana.ctx_sens" (whitelist) *) let cont_sens = map' find_id @@ sens in activated_context_sens := List.filter (fun (n, _) -> List.mem n cont_sens) !activated; end; From 1b8d70ac5f1d97d78681929a8442bceec265fcfd Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 19 Dec 2024 10:00:59 +0100 Subject: [PATCH 4/8] extractPthread: Change accidentally changed name back --- src/analyses/extractPthread.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/analyses/extractPthread.ml b/src/analyses/extractPthread.ml index cd3fce184d..d31243ae70 100644 --- a/src/analyses/extractPthread.ml +++ b/src/analyses/extractPthread.ml @@ -233,15 +233,15 @@ let promela_main : fun_name = "mainfun" (* assign tid: promela_main -> 0 *) let _ = Tbls.ThreadTidTbl.get promela_main -let fun_ctx man f = - let man_hash = - match PthreadDomain.Ctx.to_int man with +let fun_ctx ctx f = + let ctx_hash = + match PthreadDomain.Ctx.to_int ctx with | Some i -> i |> i64_to_int |> Tbls.CtxTbl.get |> string_of_int | None -> "TOP" in - f.vname ^ "_" ^ man_hash + f.vname ^ "_" ^ ctx_hash module Tasks = SetDomain.Make (Lattice.Prod (Queries.AD) (PthreadDomain.D)) From 196bf69699086405534e6284577f3679a597c3b9 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 19 Dec 2024 10:01:38 +0100 Subject: [PATCH 5/8] Fix `sync` timing call Co-authored-by: Simmo Saan --- src/analyses/basePriv.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index a8696a1532..0caf45f08d 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -1802,7 +1802,7 @@ struct let write_global ?invariant ask getg sideg st x v = time "write_global" (Priv.write_global ?invariant ask getg sideg st x) v let lock ask getg cpa m = time "lock" (Priv.lock ask getg cpa) m let unlock ask getg sideg st m = time "unlock" (Priv.unlock ask getg sideg st) m - let sync reason man = time "sync" (Priv.sync reason) man + let sync ask getg sideg st reason = time "sync" (Priv.sync ask getg sideg st) reason let escape ask getg sideg st escaped = time "escape" (Priv.escape ask getg sideg st) escaped let enter_multithreaded ask getg sideg st = time "enter_multithreaded" (Priv.enter_multithreaded ask getg sideg) st let threadenter ask st = time "threadenter" (Priv.threadenter ask) st From 72110456b2add644df9cc6e1412876123053d744 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 19 Dec 2024 10:02:51 +0100 Subject: [PATCH 6/8] Z3: Change accidentally changed things back to `ctx` --- src/witness/z3/violationZ3.z3.ml | 56 ++++++++++++++++---------------- 1 file changed, 28 insertions(+), 28 deletions(-) diff --git a/src/witness/z3/violationZ3.z3.ml b/src/witness/z3/violationZ3.z3.ml index 53ac756d17..d004320ad3 100644 --- a/src/witness/z3/violationZ3.z3.ml +++ b/src/witness/z3/violationZ3.z3.ml @@ -16,7 +16,7 @@ struct (* ("smt.core.minimize", "true"); *) (* ("sat.core.minimize", "true"); *) ] - let man = mk_context cfg + let ctx = mk_context cfg type var = varinfo @@ -40,43 +40,43 @@ struct let get_const m x = match VarMap.find_opt x m with | Some x -> x - | None -> Arithmetic.Integer.mk_const_s man (get_name x) - let sort = Arithmetic.Integer.mk_sort man + | None -> Arithmetic.Integer.mk_const_s ctx (get_name x) + let sort = Arithmetic.Integer.mk_sort ctx let freshen env x = - VarMap.add x (Expr.mk_fresh_const man (get_name x) sort) env + VarMap.add x (Expr.mk_fresh_const ctx (get_name x) sort) env end let bool_to_int expr = - Boolean.mk_ite man expr (Arithmetic.Integer.mk_numeral_i man 1) (Arithmetic.Integer.mk_numeral_i man 0) + Boolean.mk_ite ctx expr (Arithmetic.Integer.mk_numeral_i ctx 1) (Arithmetic.Integer.mk_numeral_i ctx 0) let int_to_bool expr = - Boolean.mk_distinct man [expr; Arithmetic.Integer.mk_numeral_i man 0] + Boolean.mk_distinct ctx [expr; Arithmetic.Integer.mk_numeral_i ctx 0] let rec exp_to_expr env = function | Const (CInt (i, _, _)) -> - Arithmetic.Integer.mk_numeral_s man (Z.to_string i) + Arithmetic.Integer.mk_numeral_s ctx (Z.to_string i) | Lval (Var v, NoOffset) -> Env.get_const env v | BinOp (PlusA, e1, e2, TInt _) -> - Arithmetic.mk_add man [exp_to_expr env e1; exp_to_expr env e2] + Arithmetic.mk_add ctx [exp_to_expr env e1; exp_to_expr env e2] | BinOp (MinusA, e1, e2, TInt _) -> - Arithmetic.mk_sub man [exp_to_expr env e1; exp_to_expr env e2] + Arithmetic.mk_sub ctx [exp_to_expr env e1; exp_to_expr env e2] | BinOp (Mult, e1, e2, TInt _) -> - Arithmetic.mk_mul man [exp_to_expr env e1; exp_to_expr env e2] + Arithmetic.mk_mul ctx [exp_to_expr env e1; exp_to_expr env e2] | BinOp (Eq, e1, e2, TInt _) -> - bool_to_int (Boolean.mk_eq man (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Boolean.mk_eq ctx (exp_to_expr env e1) (exp_to_expr env e2)) | BinOp (Ne, e1, e2, TInt _) -> - bool_to_int (Boolean.mk_distinct man [exp_to_expr env e1; exp_to_expr env e2]) + bool_to_int (Boolean.mk_distinct ctx [exp_to_expr env e1; exp_to_expr env e2]) | BinOp (Gt, e1, e2, TInt _) -> - bool_to_int (Arithmetic.mk_gt man (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Arithmetic.mk_gt ctx (exp_to_expr env e1) (exp_to_expr env e2)) | BinOp (Lt, e1, e2, TInt _) -> - bool_to_int (Arithmetic.mk_lt man (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Arithmetic.mk_lt ctx (exp_to_expr env e1) (exp_to_expr env e2)) | BinOp (Ge, e1, e2, TInt _) -> - bool_to_int (Arithmetic.mk_ge man (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Arithmetic.mk_ge ctx (exp_to_expr env e1) (exp_to_expr env e2)) | BinOp (Le, e1, e2, TInt _) -> - bool_to_int (Arithmetic.mk_le man (exp_to_expr env e1) (exp_to_expr env e2)) + bool_to_int (Arithmetic.mk_le ctx (exp_to_expr env e1) (exp_to_expr env e2)) | UnOp (LNot, e, TInt _) -> - bool_to_int (Boolean.mk_not man (int_to_bool (exp_to_expr env e))) + bool_to_int (Boolean.mk_not ctx (int_to_bool (exp_to_expr env e))) | e -> failwith @@ GobPretty.sprintf "exp_to_expr: %a" Cil.d_exp e @@ -86,11 +86,11 @@ struct let wp_assert env (from_node, (edge: MyARG.inline_edge), _) = match edge with | MyARG.CFGEdge (MyCFG.Assign ((Var v, NoOffset), e)) -> let env' = Env.freshen env v in - (env', [Boolean.mk_eq man (Env.get_const env v) (exp_to_expr env' e)]) + (env', [Boolean.mk_eq ctx (Env.get_const env v) (exp_to_expr env' e)]) | MyARG.CFGEdge (MyCFG.Test (e, true)) -> - (env, [Boolean.mk_distinct man [exp_to_expr env e; Arithmetic.Integer.mk_numeral_i man 0]]) + (env, [Boolean.mk_distinct ctx [exp_to_expr env e; Arithmetic.Integer.mk_numeral_i ctx 0]]) | MyARG.CFGEdge (MyCFG.Test (e, false)) -> - (env, [Boolean.mk_eq man (exp_to_expr env e) (Arithmetic.Integer.mk_numeral_i man 0)]) + (env, [Boolean.mk_eq ctx (exp_to_expr env e) (Arithmetic.Integer.mk_numeral_i ctx 0)]) | MyARG.CFGEdge (MyCFG.Entry fd) -> let env' = List.fold_left (fun acc formal -> Env.freshen acc formal @@ -98,7 +98,7 @@ struct in let eqs = List.mapi (fun i formal -> let arg_vname = get_arg_vname i in - Boolean.mk_eq man (Env.get_const env formal) (Env.get_const env' arg_vname) + Boolean.mk_eq ctx (Env.get_const env formal) (Env.get_const env' arg_vname) ) fd.sformals in (env', eqs) @@ -110,7 +110,7 @@ struct in let eqs = List.mapi (fun i arg -> let arg_vname = get_arg_vname i in - Boolean.mk_eq man (Env.get_const env arg_vname) (exp_to_expr env' arg) + Boolean.mk_eq ctx (Env.get_const env arg_vname) (exp_to_expr env' arg) ) args in (env', eqs) @@ -118,14 +118,14 @@ struct (env, []) | MyARG.CFGEdge (MyCFG.Ret (Some e, fd)) -> let env' = Env.freshen env return_vname in - (env', [Boolean.mk_eq man (Env.get_const env return_vname) (exp_to_expr env' e)]) + (env', [Boolean.mk_eq ctx (Env.get_const env return_vname) (exp_to_expr env' e)]) | MyARG.InlineReturn (None, _, _) -> (env, []) | MyARG.InlineReturn (Some (Var v, NoOffset), _, _) -> let env' = Env.freshen env v in - (env', [Boolean.mk_eq man (Env.get_const env v) (Env.get_const env' return_vname)]) + (env', [Boolean.mk_eq ctx (Env.get_const env v) (Env.get_const env' return_vname)]) | _ -> - (* (env, Boolean.mk_true man) *) + (* (env, Boolean.mk_true ctx) *) failwith @@ GobPretty.sprintf "wp_assert: %a" MyARG.pretty_inline_edge edge let const_get_symbol (expr: Expr.expr): Symbol.symbol = @@ -140,7 +140,7 @@ struct | Unknown let wp_path path = - let solver = Solver.mk_simple_solver man in + let solver = Solver.mk_simple_solver ctx in let rec iter_wp revpath i env = match revpath with | [] -> Feasible | step :: revpath' -> @@ -149,14 +149,14 @@ struct | [] -> iter_wp revpath' (i - 1) env' | [expr] -> do_assert revpath' i env' expr | exprs -> - let expr = Boolean.mk_and man exprs in + let expr = Boolean.mk_and ctx exprs in do_assert revpath' i env' expr end and do_assert revpath' i env' expr = Logs.debug "%d: %s" i (Expr.to_string expr); - let track_const = Boolean.mk_const man (Symbol.mk_int man i) in + let track_const = Boolean.mk_const ctx (Symbol.mk_int ctx i) in Solver.assert_and_track solver expr track_const; let status = Solver.check solver [] in From aa87b3e8fd4d39ab9d77f3eaed716a8b68402ee6 Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 19 Dec 2024 10:06:14 +0100 Subject: [PATCH 7/8] Re-indent combine_assign --- src/analyses/region.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/analyses/region.ml b/src/analyses/region.ml index 7cc8d34111..0fb61059e2 100644 --- a/src/analyses/region.ml +++ b/src/analyses/region.ml @@ -143,14 +143,14 @@ struct match au with | `Lifted reg -> begin let old_regpart = man.global () in - let regpart, reg = match lval with - | None -> (old_regpart, reg) - | Some lval -> Reg.assign lval (AddrOf (ReturnUtil.return_lval ())) (old_regpart, reg) - in - let regpart, reg = Reg.remove_vars [ReturnUtil.return_varinfo ()] (regpart, reg) in - if not (RegPart.leq regpart old_regpart) then - man.sideg () regpart; - `Lifted reg + let regpart, reg = match lval with + | None -> (old_regpart, reg) + | Some lval -> Reg.assign lval (AddrOf (ReturnUtil.return_lval ())) (old_regpart, reg) + in + let regpart, reg = Reg.remove_vars [ReturnUtil.return_varinfo ()] (regpart, reg) in + if not (RegPart.leq regpart old_regpart) then + man.sideg () regpart; + `Lifted reg end | _ -> au From 24861856805fde2426b763ac50600d1df75b17aa Mon Sep 17 00:00:00 2001 From: Michael Schwarz Date: Thu, 19 Dec 2024 10:11:00 +0100 Subject: [PATCH 8/8] Doc comment for `man` --- src/framework/analyses.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 985f013ede..5890fef402 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -142,7 +142,8 @@ struct | `Lifted x -> LD.printXml f x end - +(** Man(ager) is passed to transfer functions and offers access to various facilities, e.g., to access the local state, the context, + read values from globals, side-effect values to globals and trigger events. *) type ('d,'g,'c,'v) man = { ask : 'a. 'a Queries.t -> 'a Queries.result (* Inlined Queries.ask *) ; emit : Events.t -> unit