From 9a60066781c249b974e3d0c25b59ce785795feb7 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Fri, 12 Dec 2025 11:48:39 +0100 Subject: [PATCH 01/29] first new modules --- src/analyses/wp_test.ml | 16 + src/framework/constraints_wp.ml | 572 ++++++++++++++++++++++++++++++++ 2 files changed, 588 insertions(+) create mode 100644 src/analyses/wp_test.ml create mode 100644 src/framework/constraints_wp.ml diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml new file mode 100644 index 0000000000..d706c158bf --- /dev/null +++ b/src/analyses/wp_test.ml @@ -0,0 +1,16 @@ +open GoblintCil +open Analyses + +module Spec : Analyses.Spec = +struct + let name () = "wp_test" + + include Analyses.IdentityUnitContextsSpec + + module LiveVariableSet = SetDomain.ToppedSet (Basetype.Variables) (struct let topname = "All variables" end) + module D = LiveVariableSet (*Set of program variables as domain*) + + let startstate v = D.bot() + let exitstate v = D.bot() + +end \ No newline at end of file diff --git a/src/framework/constraints_wp.ml b/src/framework/constraints_wp.ml new file mode 100644 index 0000000000..8293498883 --- /dev/null +++ b/src/framework/constraints_wp.ml @@ -0,0 +1,572 @@ +(** Construction of a {{!Goblint_constraint} constraint system} from an {{!Analyses.Spec} analysis specification} and {{!MyCFG.CfgBackward} CFGs}. + Transformatons of analysis specifications as functors. *) + +open Batteries +open GoblintCil +open MyCFG +open Analyses +open Goblint_constraint.ConstrSys +open GobConfig + + +type Goblint_backtrace.mark += TfLocation of location + +let () = Goblint_backtrace.register_mark_printer (function + | TfLocation loc -> + Some ("transfer function at " ^ CilType.Location.show loc) + | _ -> None (* for other marks *) + ) + + +module type Increment = +sig + val increment: increment_data option +end + + +(** The main point of this file---generating a [DemandGlobConstrSys] from a [Spec]. *) +module FromSpec (S:Spec) (Cfg:CfgForward) (I: Increment) + : sig + include DemandGlobConstrSys with module LVar = VarF (S.C) + and module GVar = GVarF (S.V) + and module D = S.D + and module G = GVarG (S.G) (S.C) + end += +struct + type lv = MyCFG.node * S.C.t + (* type gv = varinfo *) + type ld = S.D.t + (* type gd = S.G.t *) + module LVar = VarF (S.C) + module GVar = GVarF (S.V) + module D = S.D + module G = GVarG (S.G) (S.C) + + (* Two global invariants: + 1. S.V -> S.G -- used for Spec + 2. fundec -> set of S.C -- used for IterSysVars Node *) + + let sync man = + match man.prev_node, Cfg.next man.prev_node with + | _, _ :: _ :: _ -> (* Join in CFG. *) + 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 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_man var edge prev_node pval (getl:lv -> ld) sidel demandl 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 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 + ; control_context = snd var |> Obj.obj + ; context = snd var |> Obj.obj + ; edge = edge + ; local = pval + ; global = (fun g -> G.spec (getg (GVar.spec g))) + ; spawn = spawn + ; split = (fun (d:D.t) es -> assert (List.is_empty es); r := d::!r) + ; sideg = (fun g d -> sideg (GVar.spec g) (G.create_spec d)) + } + and spawn ?(multiple=false) lval f args = + (* TODO: adjust man node/edge? *) + (* TODO: don't repeat for all paths that spawn same *) + 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 man fd d in + sidel (FunctionEntry fd, c) d; + demandl (Function fd, c) + | exception Not_found -> + (* unknown function *) + M.error ~category:Imprecise ~tags:[Category Unsound] "Created a thread from unknown function %s" f.vname; + (* actual implementation (e.g. invalidation) is done by threadenter *) + (* must still sync for side effects, e.g., old sync-based none privatization soundness in 02-base/51-spawn-special *) + let rec sync_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S.query sync_man q); + local = d; + prev_node = Function dummyFunDec; + } + in + (* TODO: more accurate man? *) + ignore (sync sync_man) + ) ds + in + (* ... nice, right! *) + 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 man d spawns = + if List.is_empty spawns then + d + else + 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 fman = + { man with + ask = (fun (type a) (q: a Queries.t) -> S.query fman q) + ; local = fd + } + in + S.threadspawn man' ~multiple lval f args fman + in + bigsqcup (List.map one_spawn spawns) + + let common_join man d splits spawns = + thread_spawns man (bigsqcup (d :: 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 demandl getg sideg d = + let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 demandl getg sideg d = + let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 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 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 demandl getg sideg d = + let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 man sideg + else normal_return ret fd man sideg + in + common_join man d !r !spawns + + let tf_entry var edge prev_node fd getl sidel demandl 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 man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 demandl getg sideg d = + let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 man lv e (f:fundec) args getl sidel demandl 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_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S.query cd_man q); + local = cd; + } + in + 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_man), simulate it here for fd. *) + (* TODO: don't do this extra sync here *) + 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 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_man + in + let r = List.fold_left (fun acc fd1 -> + 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_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_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 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. *) + (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) + let paths = List.map (Tuple3.map2 Option.some) paths in + if M.tracing then M.traceli "combine" "combining"; + let paths = List.map combine paths in + let r = List.fold_left D.join (D.bot ()) paths in + if M.tracing then M.traceu "combine" "combined: %a" S.D.pretty r; + r + + + let rec tf_proc var edge prev_node lv e args getl sidel demandl getg sideg d = + let tf_special_call man f = + let once once_control init_routine = + (* Executes leave event for new local state d if it is not bottom *) + let leave_once d = + if not (S.D.is_bot d) then + let rec man' = + { man with + ask = (fun (type a) (q: a Queries.t) -> S.query man' q); + local = d; + } + in + S.event man' (Events.LeaveOnce { once_control }) man' + else + S.D.bot () + in + let first_call = + let d' = S.event man (Events.EnterOnce { once_control; ran = false }) man in + tf_proc var edge prev_node None init_routine [] getl sidel demandl getg sideg d' + in + let later_call = S.event man (Events.EnterOnce { once_control; ran = true }) man in + D.join (leave_once first_call) (leave_once later_call) + in + let is_once = LibraryFunctions.find ~nowarn:true f in + (* If the prototpye for a library function is wrong, this will throw an exception. Such exceptions are usually unrelated to pthread_once, it is just that the call to `is_once.special` raises here *) + match is_once.special args with + | Once { once_control; init_routine } -> once once_control init_routine + | _ -> S.special man lv f args + in + let man, r, spawns = common_man var edge prev_node d getl sidel demandl getg sideg in + let functions = + match e with + | Lval (Var v, NoOffset) -> + (* Handle statically known function call directly. + Allows deactivating base. *) + [v] + | _ -> + (* Depends on base for query. *) + 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 = + match Cil.unrollType f.vtype with + | TFun (_, params, var_arg, _) -> + let arg_length = List.length args in + let p_length = Option.map_default List.length 0 params in + (* Check whether number of arguments fits. *) + (* If params is None, the function or its parameters are not declared, so we still analyze the unknown function call. *) + if Option.is_none params || p_length = arg_length || (var_arg && arg_length >= p_length) then + let d = + (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 man f + | fd -> + tf_normal_call man lv e fd args getl sidel demandl getg sideg + | exception Not_found -> + tf_special_call man f) + in + Some d + else begin + let geq = if var_arg then ">=" else "" in + M.warn ~category:Unsound ~tags:[Category Call; CWE 685] "Potential call to function %a with wrong number of arguments (expected: %s%d, actual: %d). This call will be ignored." CilType.Varinfo.pretty f geq p_length arg_length; + None + end + | _ -> + M.warn ~category:Call "Something that is not a function (%a) is called." CilType.Varinfo.pretty f; + None + in + let funs = List.filter_map one_function functions in + 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 man funs !r !spawns + + let tf_asm var edge prev_node getl sidel demandl getg sideg d = + let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 demandl getg sideg d = + let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 demandl getg sideg prev_node edge d = + begin match edge with + | Assign (lv,rv) -> tf_assign var edge prev_node lv rv + | VDecl (v) -> tf_vdecl var edge prev_node v + | Proc (r,f,ars) -> tf_proc var edge prev_node r f ars + | Entry f -> tf_entry var edge prev_node f + | Ret (r,fd) -> tf_ret var edge prev_node r fd + | Test (p,b) -> tf_test var edge prev_node p b + | ASM (_, _, _) -> tf_asm var edge prev_node (* TODO: use ASM fields for something? *) + | Skip -> tf_skip var edge prev_node + end getl sidel demandl getg sideg d + + let tf var getl sidel demandl getg sideg prev_node (_,edge) d (f,t) = + let old_loc = !Goblint_tracing.current_loc in + let old_loc2 = !Goblint_tracing.next_loc in + Goblint_tracing.current_loc := f; + Goblint_tracing.next_loc := t; + Goblint_backtrace.protect ~mark:(fun () -> TfLocation f) ~finally:(fun () -> + Goblint_tracing.current_loc := old_loc; + Goblint_tracing.next_loc := old_loc2 + ) (fun () -> + let d = tf var getl sidel demandl getg sideg prev_node edge d in + d + ) + + let tf (v,c) (edges, u) getl sidel demandl getg sideg = + let pval = getl (u,c) in + let _, locs = List.fold_right (fun (f,e) (t,xs) -> f, (f,t)::xs) edges (Node.location v,[]) in + List.fold_left2 (|>) pval (List.map (tf (v,Obj.repr (fun () -> c)) getl sidel demandl getg sideg u) edges) locs + + let tf (v,c) (e,u) getl sidel demandl getg sideg = + let old_node = !current_node in + let old_fd = Option.map Node.find_fundec old_node |? Cil.dummyFunDec in + let new_fd = Node.find_fundec v in + if not (CilType.Fundec.equal old_fd new_fd) then + Timing.Program.enter new_fd.svar.vname; + let old_context = !M.current_context in + current_node := Some u; + M.current_context := Some (Obj.magic c); (* magic is fine because Spec is top-level Control Spec *) + Fun.protect ~finally:(fun () -> + current_node := old_node; + M.current_context := old_context; + if not (CilType.Fundec.equal old_fd new_fd) then + Timing.Program.exit new_fd.svar.vname + ) (fun () -> + let d = tf (v,c) (e,u) getl sidel demandl getg sideg in + d + ) + + let system (v,c) = + match v with + | FunctionEntry _ -> + None + | _ -> + let tf getl sidel demandl getg sideg = + let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S.D.join (S.D.bot ()) xs + in + Some tf + + + let iter_vars getl getg vq fl fg = + (* vars for Spec *) + 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 () -> 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))) + ; spawn = (fun ?(multiple=false) v d -> failwith "Cannot \"spawn\" in query context.") + ; split = (fun d es -> failwith "Cannot \"split\" in query context.") + ; sideg = (fun v g -> failwith "Cannot \"split\" in query context.") + } + in + let f v = fg (GVar.spec (Obj.obj v)) in + S.query man (IterSysVars (vq, f)); + + (* node vars for locals *) + match vq with + | Node {node; fundec} -> + let fd = Option.default_delayed (fun () -> Node.find_fundec node) fundec in + let cs = G.contexts (getg (GVar.contexts fd)) in + G.CSet.iter (fun c -> + fl (node, c) + ) cs + | _ -> + (); + failwith "iter_vars not implemented in WP" + + + let sys_change getl getg = + (* + let open CompareCIL in + + let c = match I.increment with + | Some {changes; _} -> changes + | None -> empty_change_info () + in + List.(Logs.info "change_info = { unchanged = %d; changed = %d (with unchangedHeader = %d); added = %d; removed = %d }" (length c.unchanged) (length c.changed) (BatList.count_matching (fun c -> c.unchangedHeader) c.changed) (length c.added) (length c.removed)); + + let changed_funs = List.filter_map (function + | {old = {d ef = Some (Fun f); _}; diff = None; _} -> + Logs.info "Completely changed function: %s" f.svar.vname; + Some f + | _ -> None + ) c.changed + in + let part_changed_funs = List.filter_map (function + | {old = {def = Some (Fun f); _}; diff = Some nd; _} -> + Logs.info "Partially changed function: %s" f.svar.vname; + Some (f, nd.primObsoleteNodes, nd.unchangedNodes) + | _ -> None + ) c.changed + in + let removed_funs = List.filter_map (function + | {def = Some (Fun f); _} -> + Logs.info "Removed function: %s" f.svar.vname; + Some f + | _ -> None + ) c.removed + in + + let module HM = Hashtbl.Make (Var2 (LVar) (GVar)) in + + let mark_node hm f node = + iter_vars getl getg (Node {node; fundec = Some f}) (fun v -> + HM.replace hm (`L v) () + ) (fun v -> + HM.replace hm (`G v) () + ) + in + + let reluctant = GobConfig.get_bool "incremental.reluctant.enabled" in + let reanalyze_entry f = + (* destabilize the entry points of a changed function when reluctant is off, + or the function is to be force-reanalyzed *) + (not reluctant) || CompareCIL.VarinfoSet.mem f.svar c.exclude_from_rel_destab + in + let obsolete_ret = HM.create 103 in + let obsolete_entry = HM.create 103 in + let obsolete_prim = HM.create 103 in + + (* When reluctant is on: + Only add function entry nodes to obsolete_entry if they are in force-reanalyze *) + List.iter (fun f -> + if reanalyze_entry f then + (* collect function entry for eager destabilization *) + mark_node obsolete_entry f (FunctionEntry f) + else + (* collect function return for reluctant analysis *) + mark_node obsolete_ret f (Function f) + ) changed_funs; + (* Primary changed unknowns from partially changed functions need only to be collected for eager destabilization when reluctant is off *) + (* The return nodes of partially changed functions are collected in obsolete_ret for reluctant analysis *) + (* We utilize that force-reanalyzed functions are always considered as completely changed (and not partially changed) *) + List.iter (fun (f, pn, _) -> + if not reluctant then ( + List.iter (fun n -> + mark_node obsolete_prim f n + ) pn + ) + else + mark_node obsolete_ret f (Function f) + ) part_changed_funs; + + let obsolete = Seq.append (HM.to_seq_keys obsolete_entry) (HM.to_seq_keys obsolete_prim) |> List.of_seq in + let reluctant = HM.to_seq_keys obsolete_ret |> List.of_seq in + + let marked_for_deletion = HM.create 103 in + + let dummy_pseudo_return_node f = + (* not the same as in CFG, but compares equal because of sid *) + Node.Statement ({Cil.dummyStmt with sid = Cilfacade.get_pseudo_return_id f}) + in + let add_nodes_of_fun (functions: fundec list) (withEntry: fundec -> bool) = + let add_stmts (f: fundec) = + List.iter (fun s -> + mark_node marked_for_deletion f (Statement s) + ) f.sallstmts + in + List.iter (fun f -> + if withEntry f then + mark_node marked_for_deletion f (FunctionEntry f); + mark_node marked_for_deletion f (Function f); + add_stmts f; + mark_node marked_for_deletion f (dummy_pseudo_return_node f) + ) functions; + in + + add_nodes_of_fun changed_funs reanalyze_entry; + add_nodes_of_fun removed_funs (fun _ -> true); + (* it is necessary to remove all unknowns for changed pseudo-returns because they have static ids *) + let add_pseudo_return f un = + let pseudo = dummy_pseudo_return_node f in + if not (List.exists (Node.equal pseudo % fst) un) then + mark_node marked_for_deletion f (dummy_pseudo_return_node f) + in + List.iter (fun (f,_,un) -> + mark_node marked_for_deletion f (Function f); + add_pseudo_return f un + ) part_changed_funs; + + let delete = HM.to_seq_keys marked_for_deletion |> List.of_seq in + + let restart = match I.increment with + | Some data -> + let restart = ref [] in + List.iter (fun g -> + iter_vars getl getg g (fun v -> + restart := `L v :: !restart + ) (fun v -> + restart := `G v :: !restart + ) + ) data.restarting; + !restart + | None -> [] + in + + {obsolete; delete; reluctant; restart}*) + failwith "sys_change not implemented in WP" + + let postmortem = function + | FunctionEntry fd, c -> [(Function fd, c)] + | _ -> [] +end From 5faf07fbc97042d9e115ee3de688d3983542c9d6 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Sun, 14 Dec 2025 17:58:29 +0100 Subject: [PATCH 02/29] things happened --- src/analyses/wp_test.ml | 71 +- src/framework/constraints_wp.ml | 41 +- src/framework/control.ml | 1316 ++++++++++++++++++++++++++++--- src/goblint.ml | 2 + xx_easyprog.c | 23 + 5 files changed, 1316 insertions(+), 137 deletions(-) create mode 100644 xx_easyprog.c diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index d706c158bf..a857e47eaf 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -1,16 +1,79 @@ open GoblintCil open Analyses -module Spec : Analyses.Spec = +module Spec : Analyses.MCPSpec = struct let name () = "wp_test" include Analyses.IdentityUnitContextsSpec + module LiveVariableSet = SetDomain.ToppedSet (Basetype.Variables) (struct let topname = "All variables" end) module D = LiveVariableSet (*Set of program variables as domain*) - let startstate v = D.bot() - let exitstate v = D.bot() + let startstate v = D.empty() + let exitstate v = D.empty() + + let get_local = function + | Var v, _ -> Some v (* some local variable*) + | _, _ -> None + + let vars_from_expr (e: exp) : D.t= + let rec aux acc e = + match e with + | Lval (Var v, _) -> D.add v acc + | BinOp (_, e1, e2, _) -> + let acc1 = aux acc e1 in + aux acc1 e2 + | UnOp (_, e1, _) -> aux acc e1 + | CastE (_, e1) -> aux acc e1 + | SizeOfE e1 -> aux acc e1 + | AlignOfE e1 -> aux acc e1 + |Question (e1, e2, e3, _) -> + let acc1 = aux acc e1 in + let acc2 = aux acc1 e2 in + aux acc2 e3 + | _ -> acc + in + aux (D.empty()) e + + let assign man (lval:lval) (rval:exp) = + let () = + Logs.debug "=== man (analysis manager) info ==="; + Logs.debug " lval: %a" CilType.Lval.pretty lval; + Logs.debug " rval: %a" CilType.Exp.pretty rval; + Logs.debug " local state: %a" D.pretty man.local; + Logs.debug " local is_top: %b" (D.is_top man.local); + Logs.debug " local is_bot: %b" (D.is_bot man.local); + in + + let v = get_local lval in + + match v with + | None -> Logs.debug "!!! possibly unsound !!!"; D.top () + | Some v -> + let l = (D.diff man.local (D.singleton v)) in + if D.mem v man.local then D.join l (vars_from_expr rval) + else l + + let branch man (exp:exp) (tv:bool) = + D.join man.local (vars_from_expr exp) + + let body man (f:fundec) = + man.local + + let return man (exp:exp option) (f:fundec) = + match exp with + | None -> man.local + | Some e -> D.join man.local (vars_from_expr e) + + let enter man (lval: lval option) (f:fundec) (args:exp list) = + [man.local, man.local] + + let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + au +end + -end \ No newline at end of file +let _ = + MCP.register_analysis (module Spec : MCPSpec) \ No newline at end of file diff --git a/src/framework/constraints_wp.ml b/src/framework/constraints_wp.ml index 8293498883..b76516b031 100644 --- a/src/framework/constraints_wp.ml +++ b/src/framework/constraints_wp.ml @@ -25,7 +25,7 @@ end (** The main point of this file---generating a [DemandGlobConstrSys] from a [Spec]. *) -module FromSpec (S:Spec) (Cfg:CfgForward) (I: Increment) +module FromSpec (S:Spec) (Cfg:CfgBidir) : sig include DemandGlobConstrSys with module LVar = VarF (S.C) and module GVar = GVarF (S.V) @@ -143,6 +143,7 @@ struct let tf_assign var edge prev_node lv e getl sidel demandl getg sideg d = let man, r, spawns = common_man var edge prev_node d getl sidel demandl getg sideg in let d = S.assign man lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + Logs.debug "######### there was an assign"; common_join man d !r !spawns let tf_vdecl var edge prev_node v getl sidel demandl getg sideg d = @@ -390,16 +391,34 @@ struct ) let system (v,c) = - match v with - | FunctionEntry _ -> - None - | _ -> - let tf getl sidel demandl getg sideg = - let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in - let xs = List.map tf' (Cfg.next v) in - List.fold_left S.D.join (S.D.bot ()) xs - in - Some tf + + let wrap (v,c) = + match v with + | FunctionEntry _ -> + let tf getl sidel demandl getg sideg = + let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S.D.join (S.D.bot ()) xs + in + Logs.debug "## Function Entry" ; + Some tf + | Function _ -> + Logs.debug "## Function call?" ; + None + | _ -> + let tf getl sidel demandl getg sideg = + let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S.D.join (S.D.bot ()) xs + in + Logs.debug "## Not Function Entry. Number of nexts: %d" (List.length (Cfg.next v)) ; + Logs.debug "## Number of prevs: %d" (List.length (Cfg.prev v)) ; + Some tf + + in + + Logs.debug "# Creating transfer function for node %s" (Node.show v); + wrap (v,c) let iter_vars getl getg vq fl fg = diff --git a/src/framework/control.ml b/src/framework/control.ml index 06b07e6f41..5819ed27c4 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -499,119 +499,26 @@ struct let uncalled_dead = ref 0 in let solve_and_postprocess () = - (* handle save_run/load_run *) - let solver_file = "solver.marshalled" in - let load_run = get_string "load_run" in - let compare_runs = get_string_list "compare_runs" in - let gobview = get_bool "gobview" in - let save_run_str = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in - - let lh, gh = if load_run <> "" then ( - let module S2' = (GlobSolverFromEqSolver (Goblint_solver.Generic.LoadRunIncrSolver (PostSolverArg))) (EQSys) (LHT) (GHT) in - let (r2, _) = S2'.solve entrystates entrystates_global startvars' None in (* TODO: has incremental data? *) - r2 - ) else if compare_runs <> [] then ( - match compare_runs with - | d1::d2::[] -> (* the directories of the runs *) - if d1 = d2 then Logs.warn "Beware that you are comparing a run with itself! There should be no differences."; - (* instead of rewriting Compare for EqConstrSys, just transform unmarshaled EqConstrSys solutions to GlobConstrSys solutions *) - let module Splitter = GlobConstrSolFromEqConstrSol (EQSys: DemandGlobConstrSys) (LHT) (GHT) in - let module S2 = Splitter.S2 in - let module VH = Splitter.VH in - let (r1, r1'), (r2, r2') = Tuple2.mapn (fun d -> - let vh = Serialize.unmarshal Fpath.(v d / solver_file) in - - let vh' = VH.create (VH.length vh) in - VH.iter (fun k v -> - VH.replace vh' (S2.Var.relift k) (S2.Dom.relift v) - ) vh; - - (Splitter.split_solution vh', vh') - ) (d1, d2) - in - - if get_bool "dbg.compare_runs.globsys" then - CompareGlobSys.compare (d1, d2) r1 r2; - - let module CompareEqSys = CompareConstraints.CompareEqSys (EqConstrSysFromDemandConstrSys (S2) ) (VH) in - if get_bool "dbg.compare_runs.eqsys" then - CompareEqSys.compare (d1, d2) r1' r2'; - - let module CompareGlobal = CompareConstraints.CompareGlobal (EQSys.GVar) (EQSys.G) (GHT) in - if get_bool "dbg.compare_runs.global" then - CompareGlobal.compare (d1, d2) (snd r1) (snd r2); - - let module CompareNode = CompareConstraints.CompareNode (Spec.C) (EQSys.D) (LHT) in - if get_bool "dbg.compare_runs.node" then - CompareNode.compare (d1, d2) (fst r1) (fst r2); - - r1 (* return the result of the first run for further options -- maybe better to exit early since compare_runs is its own mode. Only excluded verify below since it's on by default. *) - | _ -> failwith "Currently only two runs can be compared!"; - ) else ( - let solver_data = - match Inc.increment with - | Some {solver_data; server; _} -> - if server then - Some (Slvr.copy_marshal solver_data) (* Copy, so that we can abort and reuse old data unmodified. *) - else if GobConfig.get_bool "ana.opt.hashcons" then - Some (Slvr.relift_marshal solver_data) - else - Some solver_data - | None -> None - in - Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); - AnalysisState.should_warn := get_string "warn_at" = "early" || gobview; - let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in - if GobConfig.get_bool "incremental.save" then - Serialize.Cache.(update_data SolverData solver_data); - if save_run_str <> "" then ( - let save_run = Fpath.v save_run_str in - let analyses = Fpath.(save_run / "analyses.marshalled") in - let config = Fpath.(save_run / "config.json") in - let meta = Fpath.(save_run / "meta.json") in - let solver_stats = Fpath.(save_run / "solver_stats.csv") in (* see Generic.SolverStats... *) - let cil = Fpath.(save_run / "cil.marshalled") in - let warnings = Fpath.(save_run / "warnings.marshalled") in - let stats = Fpath.(save_run / "stats.marshalled") in - Logs.Format.debug "Saving the current configuration to %a, meta-data about this run to %a, and solver statistics to %a" Fpath.pp config Fpath.pp meta Fpath.pp solver_stats; - GobSys.mkdir_or_exists save_run; - GobConfig.write_file config; - let module Meta = struct - type t = { command : string; version: string; timestamp : float; localtime : string } [@@deriving to_yojson] - let json = to_yojson { command = GobSys.command_line; version = Goblint_build_info.version; timestamp = Unix.time (); localtime = GobUnix.localtime () } - end - in - (* Yojson.Safe.to_file meta Meta.json; *) - Out_channel.with_open_text (Fpath.to_string meta) (fun oc -> - Yojson.Safe.pretty_to_channel oc Meta.json (* the above is compact, this is pretty-printed *) - ); - if gobview then ( - Logs.Format.debug "Saving the analysis table to %a, the CIL state to %a, the warning table to %a, and the runtime stats to %a" Fpath.pp analyses Fpath.pp cil Fpath.pp warnings Fpath.pp stats; - Serialize.marshal MCPRegistry.registered_name analyses; - Serialize.marshal (file, Cabs2cil.environment) cil; - Serialize.marshal !Messages.Table.messages_list warnings; - ); - GobSys.(self_signal (signal_of_string (get_string "dbg.solver-signal"))); (* write solver_stats after solving (otherwise no rows if faster than dbg.solver-stats-interval). TODO better way to write solver_stats without terminal output? *) - ); - lh, gh - ) - in - - if get_string "comparesolver" <> "" then ( - let compare_with (module S2 : DemandEqIncrSolver) = - let module PostSolverArg2 = - struct - include PostSolverArg - let should_warn = false (* we already warn from main solver *) - let should_save_run = false (* we already save main solver *) - end - in - let module S2' = (GlobSolverFromEqSolver (S2 (PostSolverArg2))) (EQSys) (LHT) (GHT) in - let (r2, _) = S2'.solve entrystates entrystates_global startvars' None in (* TODO: has incremental data? *) - CompareGlobSys.compare (get_string "solver", get_string "comparesolver") (lh,gh) (r2) + let lh, gh = + let solver_data = + match Inc.increment with + | Some {solver_data; server; _} -> + if server then + Some (Slvr.copy_marshal solver_data) (* Copy, so that we can abort and reuse old data unmodified. *) + else if GobConfig.get_bool "ana.opt.hashcons" then + Some (Slvr.relift_marshal solver_data) + else + Some solver_data + | None -> None in - compare_with (Goblint_solver.Selector.choose_solver (get_string "comparesolver")) - ); + Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); + AnalysisState.should_warn := get_string "warn_at" = "early"; + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in + if GobConfig.get_bool "incremental.save" then + Serialize.Cache.(update_data SolverData solver_data); + lh, gh + + in (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) AnalysisState.should_warn := PostSolverArg.should_warn; @@ -629,6 +536,7 @@ struct not (LibraryFunctions.is_safe_uncalled fn.vname) && not (Cil.hasAttribute "goblint_stub" fn.vattr) in + let print_and_calculate_uncalled = function | GFun (fn, loc) when is_bad_uncalled fn.svar loc-> let cnt = Cilfacade.countLoc fn in @@ -843,16 +751,1180 @@ struct Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg) end -(* This function was originally a part of the [AnalyzeCFG] module, but - now that [AnalyzeCFG] takes [Spec] as a functor parameter, - [analyze_loop] cannot reside in it anymore since each invocation of - [get_spec] in the loop might/should return a different module, and we - cannot swap the functor parameter from inside [AnalyzeCFG]. *) -let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = - try - let (module Spec) = get_spec () in - let module A = AnalyzeCFG (CFG) (Spec) (struct let increment = change_info end) in - GobConfig.with_immutable_conf (fun () -> A.analyze file fs) +module AnalyzeCFG_2 (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = +struct + + module SpecSys: SpecSys with module Spec = Spec = + struct + (* Must be created in module, because cannot be wrapped in a module later. *) + module Spec = Spec + + (* The Equation system *) + module EQSys = Constraints_wp.FromSpec (Spec) (Cfg) + + (* Hashtbl for locals *) + module LHT = BatHashtbl.Make (EQSys.LVar) + (* Hashtbl for globals *) + module GHT = BatHashtbl.Make (EQSys.GVar) + end + + open SpecSys + + (* The solver *) + module PostSolverArg = + struct + let should_prune = false + let should_verify = false (*get_bool "verify"*) + let should_warn = get_string "warn_at" <> "never" + let should_save_run = + (* copied from solve_and_postprocess *) + let gobview = get_bool "gobview" in + let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in + save_run <> "" + end + module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) + (* The comparator *) + module CompareGlobSys = CompareConstraints.CompareGlobSys (SpecSys) + + (* Triple of the function, context, and the local value. *) + module RT = AnalysisResult.ResultType2 (Spec) + (* Set of triples [RT] *) + module LT = SetDomain.HeadlessSet (RT) + (* Analysis result structure---a hashtable from program points to [LT] *) + module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis" end) + module ResultOutput = AnalysisResultOutput.Make (Result) + + module Query = ResultQuery.Query (SpecSys) + + + let print_one f (module S : Printable.S) x : unit = + BatPrintf.fprintf f "\n" (Spec.name ()); + S.printXml f (Obj.obj x); + BatPrintf.fprintf f "\n" + + + (* print out information about dead code *) + let print_dead_code (xs:Result.t) uncalled_fn_loc = + let module NH = Hashtbl.Make (Node) in + let live_nodes : unit NH.t = NH.create 10 in + let count = ref 0 in (* Is only populated if "ana.dead-code.lines" or "ana.dead-code.branches" is true *) + let module StringMap = BatMap.Make (String) in + let live_lines = ref StringMap.empty in + let dead_lines = ref StringMap.empty in + let module FunSet = Hashtbl.Make (CilType.Fundec) in + let live_funs: unit FunSet.t = FunSet.create 13 in + let add_one n v = + match n with + | Statement s when Cilfacade.(StmtH.mem pseudo_return_to_fun s) -> + (* Exclude pseudo returns from dead lines counting. No user code at "}". *) + () + | _ -> + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let l = UpdateCil.getLoc n in + let f = Node.find_fundec n in + FunSet.replace live_funs f (); + let add_fun = BatISet.add l.line in + let add_file = StringMap.modify_def BatISet.empty f.svar.vname add_fun in + let is_dead = LT.for_all (fun (_,x,f) -> Spec.D.is_bot x) v in + if is_dead then ( + dead_lines := StringMap.modify_def StringMap.empty l.file add_file !dead_lines + ) else ( + live_lines := StringMap.modify_def StringMap.empty l.file add_file !live_lines; + NH.add live_nodes n () + ); + in + Result.iter add_one xs; + let live_count = StringMap.fold (fun _ file_lines acc -> + StringMap.fold (fun _ fun_lines acc -> + acc + ISet.cardinal fun_lines + ) file_lines acc + ) !live_lines 0 + in + let live file fn = + try StringMap.find fn (StringMap.find file !live_lines) + with Not_found -> BatISet.empty + in + if List.mem "termination" @@ get_string_list "ana.activated" then ( + (* check if we have upjumping gotos *) + let open Cilfacade in + let warn_for_upjumps fundec gotos = + if FunSet.mem live_funs fundec then ( + (* set nortermiantion flag *) + AnalysisState.svcomp_may_not_terminate := true; + (* iterate through locations to produce warnings *) + LocSet.iter (fun l _ -> + M.warn ~loc:(M.Location.CilLocation l) ~category:Termination "The program might not terminate! (Upjumping Goto)" + ) gotos + ) + in + FunLocH.iter warn_for_upjumps funs_with_upjumping_gotos + ); + dead_lines := StringMap.mapi (fun fi -> StringMap.mapi (fun fu ded -> BatISet.diff ded (live fi fu))) !dead_lines; + dead_lines := StringMap.map (StringMap.filter (fun _ x -> not (BatISet.is_empty x))) !dead_lines; + dead_lines := StringMap.filter (fun _ x -> not (StringMap.is_empty x)) !dead_lines; + let warn_func file f xs = + let warn_range b e = + count := !count + (e - b + 1); (* for total count below *) + let doc = + if b = e then + Pretty.dprintf "on line %d" b + else + Pretty.dprintf "on lines %d..%d" b e + in + let loc: Cil.location = { + file; + line = b; + column = -1; (* not shown *) + byte = 0; (* wrong, but not shown *) + endLine = e; + endColumn = -1; (* not shown *) + endByte = 0; (* wrong, but not shown *) + synthetic = false; + } + in + (doc, Some (Messages.Location.CilLocation loc)) (* CilLocation is fine because always printed from scratch *) + in + let msgs = + BatISet.fold_range (fun b e acc -> + warn_range b e :: acc + ) xs [] + in + let msgs = List.rev msgs in (* lines in ascending order *) + M.msg_group Warning ~category:Deadcode "Function '%s' has dead code" f msgs (* TODO: function location for group *) + in + let warn_file f = StringMap.iter (warn_func f) in + if get_bool "ana.dead-code.lines" then ( + StringMap.iter warn_file !dead_lines; (* populates count by side-effect *) + let severity: M.Severity.t = if StringMap.is_empty !dead_lines then Info else Warning in + let dead_total = !count + uncalled_fn_loc in + let total = live_count + dead_total in (* We can only give total LoC if we counted dead code *) + M.msg_group severity ~category:Deadcode "Logical lines of code (LLoC) summary" [ + (Pretty.dprintf "live: %d" live_count, None); + (Pretty.dprintf "dead: %d%s" dead_total (if uncalled_fn_loc > 0 then Printf.sprintf " (%d in uncalled functions)" uncalled_fn_loc else ""), None); + (Pretty.dprintf "total lines: %d" total, None); + ] + ); + NH.mem live_nodes + + (* convert result that can be out-put *) + let solver2source_result h : Result.t = + (* processed result *) + let res = Result.create 113 in + + (* Adding the state at each system variable to the final result *) + let add_local_var (n,es) state = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let loc = UpdateCil.getLoc n in + if loc <> locUnknown then try + let fundec = Node.find_fundec n in + if Result.mem res n then + (* If this source location has been added before, we look it up + * and add another node to it information to it. *) + let prev = Result.find res n in + Result.replace res n (LT.add (es,state,fundec) prev) + else + Result.add res n (LT.singleton (es,state,fundec)) + (* If the function is not defined, and yet has been included to the + * analysis result, we generate a warning. *) + with Not_found -> + Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n + in + LHT.iter add_local_var h; + res + + (** The main function to preform the selected analyses. *) + let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = + let module FileCfg: FileCfg = + struct + let file = file + module Cfg = Cfg + end + in + + AnalysisState.should_warn := false; (* reset for server mode *) + + (* exctract global xml from result *) + let make_global_fast_xml f g = + let open Printf in + let print_globals k v = + fprintf f "\n%s%a" (XmlUtil.escape (EQSys.GVar.show k)) EQSys.G.printXml v; + in + GHT.iter print_globals g + in + + (* add extern variables to local state *) + 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 + | _ -> s + in + let vars = foldGlobals file add_glob VS.empty in + let set_bad v st = + Spec.assign {man with local = st} (var v) MyCFG.unknown_exp + in + let is_std = function + | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) + | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) + | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) + | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) + | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) + | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) + true + | _ -> false + in + let add_externs s = function + | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s + | _ -> s + in + foldGlobals file add_externs (Spec.startstate MyCFG.dummy_func.svar) + in + + (* Simulate globals before analysis. *) + (* TODO: make extern/global inits part of constraint system so all of this would be unnecessary. *) + let gh = GHT.create 13 in + let getg v = GHT.find_default gh v (EQSys.G.bot ()) in + let sideg v d = + if M.tracing then M.trace "global_inits" "sideg %a = %a" EQSys.GVar.pretty v EQSys.G.pretty d; + GHT.replace gh v (EQSys.G.join (getg v) d) + in + (* Old-style global function for context. + * This indirectly prevents global initializers from depending on each others' global side effects, which would require proper solving. *) + let getg v = EQSys.G.bot () in + + (* analyze cil's global-inits function to get a starting state *) + let do_global_inits (file: file) : Spec.D.t * fundec list = + 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 () -> 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))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Global initializers trying to split paths.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let edges = CfgTools.getGlobalInits file in + Logs.debug "Executing %d assigns." (List.length edges); + let funs = ref [] in + (*let count = ref 0 in*) + let transfer_func (st : Spec.D.t) (loc, edge) : Spec.D.t = + if M.tracing then M.trace "con" "Initializer %a" CilType.Location.pretty loc; + (*incr count; + if (get_bool "dbg.verbose")&& (!count mod 1000 = 0) then Printf.printf "%d %!" !count; *) + match edge with + | MyCFG.Entry func -> + if M.tracing then M.trace "global_inits" "Entry %a" d_lval (var func.svar); + 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 + | (Var v,o), (AddrOf (Var f,NoOffset)) + when v.vstorage <> Static && isFunctionType f.vtype -> + (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) + | _ -> () + end; + 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 {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 transfer_func st (loc, edge) = + let old_loc = !Goblint_tracing.current_loc in + Goblint_tracing.current_loc := loc; + (* TODO: next_loc? *) + Goblint_backtrace.protect ~mark:(fun () -> Constraints.TfLocation loc) ~finally:(fun () -> + Goblint_tracing.current_loc := old_loc; + ) (fun () -> + transfer_func st (loc, edge) + ) + 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 result : Spec.D.t = List.fold_left transfer_func with_externs edges in + if M.tracing then M.trace "global_inits" "startstate: %a" Spec.D.pretty result; + result, !funs + in + + let print_globals glob = + let out = M.get_out (Spec.name ()) !M.out in + let print_one v st = + ignore (Pretty.fprintf out "%a -> %a\n" EQSys.GVar.pretty_trace v EQSys.G.pretty st) + in + GHT.iter print_one glob + in + + (* real beginning of the [analyze] function *) + if get_bool "ana.sv-comp.enabled" then + Witness.init (module FileCfg); (* TODO: move this out of analyze_loop *) + YamlWitness.init (); + + AnalysisState.global_initialization := true; + GobConfig.earlyglobs := get_bool "exp.earlyglobs"; + let marshal: Spec.marshal option = + if get_string "load_run" <> "" then + Some (Serialize.unmarshal Fpath.(v (get_string "load_run") / "spec_marshal")) + else if Serialize.results_exist () && get_bool "incremental.load" then + Some (Serialize.Cache.(get_data AnalysisData)) + else + None + in + + (* Some happen in init, so enable this temporarily (if required by option). *) + AnalysisState.should_warn := PostSolverArg.should_warn; + Spec.init marshal; + Access.init file; + AnalysisState.should_warn := false; + + let test_domain (module D: Lattice.S): unit = + let module DP = DomainProperties.All (D) in + Logs.debug "domain testing...: %s" (D.name ()); + let errcode = QCheck_base_runner.run_tests DP.tests in + if (errcode <> 0) then + failwith "domain tests failed" + in + let _ = + if (get_bool "dbg.test.domain") then ( + Logs.debug "domain testing analysis...: %s" (Spec.name ()); + test_domain (module Spec.D); + test_domain (module Spec.G); + ) + in + + let startstate, more_funs = + Logs.debug "Initializing %d globals." (CfgTools.numGlobals file); + Timing.wrap "global_inits" do_global_inits file + in + + let otherfuns = if get_bool "kernel" then otherfuns @ more_funs else otherfuns in + + let enter_with st fd = + let st = st fd.svar in + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec.startcontext + ; edge = MyCFG.Skip + ; local = st + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in + let ents = Spec.enter man None fd args in + List.map (fun (_,s) -> fd, s) ents + in + + (try MyCFG.dummy_func.svar.vdecl <- (List.hd otherfuns).svar.vdecl with Failure _ -> ()); + + let startvars = + if startfuns = [] + then [[MyCFG.dummy_func, startstate]] + else + let morph f = Spec.morphstate f startstate in + List.map (enter_with morph) startfuns + in + + let exitvars = List.map (enter_with Spec.exitstate) exitfuns in + let otherstate st v = + 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 () -> 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))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + (* TODO: don't hd *) + 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 *) + let othervars = List.map (enter_with (otherstate prestartstate)) otherfuns in + let startvars = List.concat (startvars @ exitvars @ othervars) in + if startvars = [] then + failwith "BUG: Empty set of start variables; may happen if enter_func of any analysis returns an empty list."; + + AnalysisState.global_initialization := false; + + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec.startcontext + ; edge = MyCFG.Skip + ; local = e + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let startvars' = + (* if get_bool "exp.forward" then *) + if true then + 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 (man e) n e)) startvars + in + + (* let entrystates = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (man e) n e), e) startvars in *) + let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec.context (man e) n e), e) startvars in + let entrystates_global = GHT.to_list gh in + + let uncalled_dead = ref 0 in + + let solve_and_postprocess () = + let lh, gh = + let solver_data = + match Inc.increment with + | Some {solver_data; server; _} -> + if server then + Some (Slvr.copy_marshal solver_data) (* Copy, so that we can abort and reuse old data unmodified. *) + else if GobConfig.get_bool "ana.opt.hashcons" then + Some (Slvr.relift_marshal solver_data) + else + Some solver_data + | None -> None + in + Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); + + (*######################### START OF ACTUAL SOLVING ##########################*) + + (*### START OF LOG ###*) + (*print set of entrystates, entrystatex_global and startvars'*) + let log_analysis_inputs () = + Logs.debug "=== Analysis Inputs ==="; + + (* Log entrystates *) + Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); + List.iteri (fun i ((node, ctx), state) -> + Logs.debug "EntryState %d:" (i + 1); + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec.C.pretty ctx; + Logs.debug " State: %a" Spec.D.pretty state; + ) entrystates; + + (* Log entrystates_global *) + Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); + List.iteri (fun i (gvar, gstate) -> + Logs.debug "GlobalEntryState %d:" (i + 1); + Logs.debug " GVar: %a" EQSys.GVar.pretty gvar; + Logs.debug " GState: %a" EQSys.G.pretty gstate; + ) entrystates_global; + + (* Log startvars' *) + Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); + List.iteri (fun i (node, ctx) -> + Logs.debug "StartVar %d:" (i + 1); + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec.C.pretty ctx; + ) startvars'; + + (* Log startvars (without apostrophe) *) + Logs.debug "--- Start Variables (no apostrophe) (count: %d) ---" (List.length startvars); + List.iteri (fun i (node, state) -> + Logs.debug "StartVar (no apostrophe) %d:" (i + 1); + Logs.debug " Node: %a" CilType.Fundec.pretty node; + Logs.debug " State: %a" Spec.D.pretty state; + ) startvars; + + Logs.debug "=== End Analysis Inputs ===" + in + log_analysis_inputs (); + (*### END OF LOG ###*) + + AnalysisState.should_warn := get_string "warn_at" = "early"; + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in + if GobConfig.get_bool "incremental.save" then + Serialize.Cache.(update_data SolverData solver_data); + lh, gh + + (*######################### END OF ACTUAL SOLVING ##########################*) + + in + + (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) + AnalysisState.should_warn := PostSolverArg.should_warn; + + let insrt k _ s = match k with + | (MyCFG.Function fn,_) -> if not (get_bool "exp.forward") then Set.Int.add fn.svar.vid s else s + | (MyCFG.FunctionEntry fn,_) -> if (get_bool "exp.forward") then Set.Int.add fn.svar.vid s else s + | _ -> s + in + (* set of ids of called functions *) + let calledFuns = LHT.fold insrt lh Set.Int.empty in + let is_bad_uncalled fn loc = + not (Set.Int.mem fn.vid calledFuns) && + not (Str.last_chars loc.file 2 = ".h") && + not (LibraryFunctions.is_safe_uncalled fn.vname) && + not (Cil.hasAttribute "goblint_stub" fn.vattr) + in + + let print_and_calculate_uncalled = function + | GFun (fn, loc) when is_bad_uncalled fn.svar loc-> + let cnt = Cilfacade.countLoc fn in + uncalled_dead := !uncalled_dead + cnt; + if get_bool "ana.dead-code.functions" then + M.warn ~loc:(CilLocation loc) ~category:Deadcode "Function '%a' is uncalled: %d LLoC" CilType.Fundec.pretty fn cnt (* CilLocation is fine because always printed from scratch *) + | _ -> () + in + List.iter print_and_calculate_uncalled file.globals; + + (* check for dead code at the last state: *) + let main_sol = try LHT.find lh (List.hd startvars') with Not_found -> Spec.D.bot () in + if Spec.D.is_bot main_sol then + M.warn_noloc ~category:Deadcode "Function 'main' does not return"; + + if get_bool "dump_globs" then + print_globals gh; + + (* run activated transformations with the analysis result *) + let active_transformations = get_string_list "trans.activated" in + if active_transformations <> [] then ( + + (* Most transformations use the locations of statements, since they run using Cil visitors. + Join abstract values once per location and once per node. *) + let joined_by_loc, joined_by_node = + let open Enum in + let node_values = LHT.enum lh |> map (Tuple2.map1 fst) in (* drop context from key *) (* nosemgrep: batenum-enum *) + let hashtbl_size = if fast_count node_values then count node_values else 123 in + let by_loc, by_node = Hashtbl.create hashtbl_size, NodeH.create hashtbl_size in + iter (fun (node, v) -> + let loc = match node with + | Statement s -> Cil.get_stmtLoc s.skind (* nosemgrep: cilfacade *) (* Must use CIL's because syntactic search is in CIL. *) + | FunctionEntry _ | Function _ -> Node.location node + in + (* join values once for the same location and once for the same node *) + let join = Option.some % function None -> v | Some v' -> Spec.D.join v v' in + Hashtbl.modify_opt loc join by_loc; + NodeH.modify_opt node join by_node; + ) node_values; + by_loc, by_node + in + + let ask ?(node = MyCFG.dummy_node) loc = + let f (type a) (q : a Queries.t) : a = + match Hashtbl.find_option joined_by_loc loc with + | None -> Queries.Result.bot q + | Some local -> Query.ask_local_node gh node local q + in + ({ f } : Queries.ask) + in + + (* A node is dead when its abstract value is bottom in all contexts; + it holds that: bottom in all contexts iff. bottom in the join of all contexts. + Therefore, we just answer whether the (stored) join is bottom. *) + let must_be_dead node = + NodeH.find_option joined_by_node node + (* nodes that didn't make it into the result are definitely dead (hence for_all) *) + |> GobOption.for_all Spec.D.is_bot + in + + let must_be_uncalled fd = not @@ BatSet.Int.mem fd.svar.vid calledFuns in + + let skipped_statements from_node edge to_node = + try + Cfg.skippedByEdge from_node edge to_node + with Not_found -> + [] + in + + Transform.run_transformations file active_transformations + { ask ; must_be_dead ; must_be_uncalled ; + cfg_forward = Cfg.next ; cfg_backward = Cfg.prev ; skipped_statements }; + ); + + lh, gh + in + + (* Use "normal" constraint solving *) + let timeout_reached () = + M.error "Timeout reached!"; + (* let module S = Generic.SolverStats (EQSys) (LHT) in *) + (* Can't call Generic.SolverStats...print_stats :( + print_stats is triggered by dbg.solver-signal, so we send that signal to ourself in maingoblint before re-raising Timeout. + The alternative would be to catch the below Timeout, print_stats and re-raise in each solver (or include it in some functor above them). *) + raise Timeout.Timeout + in + let timeout = get_string "dbg.timeout" |> TimeUtil.seconds_of_duration_string in + let lh, gh = Timeout.wrap solve_and_postprocess () (float_of_int timeout) timeout_reached in + + let module SpecSysSol: SpecSysSol with module SpecSys = SpecSys = + struct + module SpecSys = SpecSys + let lh = lh + let gh = gh + end + in + let module R: ResultQuery.SpecSysSol2 with module SpecSys = SpecSys = ResultQuery.Make (FileCfg) (SpecSysSol) in + + let local_xml = solver2source_result lh in + current_node_state_json := (fun node -> Option.map LT.to_yojson (Result.find_option local_xml node)); + + current_varquery_global_state_json := (fun vq_opt -> + let iter_vars f = match vq_opt with + | None -> GHT.iter (fun v _ -> f v) gh + | Some vq -> + EQSys.iter_vars + (fun x -> try LHT.find lh x with Not_found -> EQSys.D.bot ()) + (fun x -> try GHT.find gh x with Not_found -> EQSys.G.bot ()) + vq + (fun _ -> ()) + f + in + (* TODO: optimize this once server has a way to properly convert vid -> varinfo *) + let vars = GHT.create 113 in + iter_vars (fun x -> + GHT.replace vars x () + ); + let assoc = GHT.fold (fun x g acc -> + if GHT.mem vars x then + (EQSys.GVar.show x, EQSys.G.to_yojson g) :: acc + else + acc + ) gh [] + in + `Assoc assoc + ); + + let liveness = + if get_bool "ana.dead-code.lines" || get_bool "ana.dead-code.branches" then + print_dead_code local_xml !uncalled_dead + else + fun _ -> true (* TODO: warn about conflicting options *) + in + + if get_bool "exp.cfgdot" then + CfgTools.dead_code_cfg ~path:(Fpath.v "cfgs") (module FileCfg) liveness; + + let warn_global g v = + (* Logs.debug "warn_global %a %a" EQSys.GVar.pretty_trace g EQSys.G.pretty v; *) + match g with + | `Left g -> (* Spec global *) + R.ask_global (WarnGlobal (Obj.repr g)) + | `Right _ -> (* contexts global *) + () + in + Timing.wrap "warn_global" (GHT.iter warn_global) gh; + + if get_bool "exp.arg.enabled" then ( + let module ArgTool = ArgTools.Make (R) in + let module Arg = (val ArgTool.create entrystates) in + let arg_dot_path = get_string "exp.arg.dot.path" in + if arg_dot_path <> "" then ( + let module NoLabelNodeStyle = + struct + type node = Arg.Node.t + let extra_node_styles node = + match GobConfig.get_string "exp.arg.dot.node-label" with + | "node" -> [] + | "empty" -> ["label=\"_\""] (* can't have empty string because graph-easy will default to node ID then... *) + | _ -> assert false + end + in + let module ArgDot = ArgTools.Dot (Arg) (NoLabelNodeStyle) in + Out_channel.with_open_text arg_dot_path (fun oc -> + let ppf = Stdlib.Format.formatter_of_out_channel oc in + ArgDot.dot ppf; + Format.pp_print_flush ppf () + ) + ); + ArgTools.current_arg := Some (module Arg); + ); + + (* Before SV-COMP, so result can depend on YAML witness validation. *) + let yaml_validate_result = + if get_string "witness.yaml.validate" <> "" then ( + let module YWitness = YamlWitness.Validator (R) in + Some (YWitness.validate ()) + ) + else + None + in + + let svcomp_result = + if get_bool "ana.sv-comp.enabled" then ( + (* SV-COMP and witness generation *) + let module WResult = Witness.Result (R) in + Some (WResult.write yaml_validate_result entrystates) + ) + else + None + in + + if get_bool "witness.yaml.enabled" then ( + let module YWitness = YamlWitness.Make (R) in + YWitness.write ~svcomp_result + ); + + let marshal = Spec.finalize () in + (* copied from solve_and_postprocess *) + let gobview = get_bool "gobview" in + let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in + if save_run <> "" then ( + Serialize.marshal marshal Fpath.(v save_run / "spec_marshal") + ); + if get_bool "incremental.save" then ( + Serialize.Cache.(update_data AnalysisData marshal); + if not (get_bool "server.enabled") then + Serialize.Cache.store_data () + ); + if get_string "result" <> "none" then Logs.debug "Generating output: %s" (get_string "result"); + + Messages.finalize (); + Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg); + + + (*Iterating through elements of lh and Logging the contents*) + + let log_lh_contents lh = + Messages.warn "=== LHT Contents ==="; let count = ref 0 in + + Logs.debug "--- Full entry details ---"; + LHT.iter (fun (node, ctx) state -> + incr count; + Logs.debug "Entry %d:" !count; + Logs.debug " Node: %a" Node.pretty_trace node; + + (* Test context pretty printing *) + (try + Logs.debug " Context: %a" Spec.C.pretty ctx + with e -> + Logs.debug " Context: ERROR - %s" (Printexc.to_string e) + ); + + (* Check state properties *) + (* Logs.debug " State is_top: %b" (Spec.D.is_top state); + Logs.debug " State is_bot: %b" (Spec.D.is_bot state); *) + + (* Test state pretty printing with exception handling *) + (try + Logs.debug " State: %a" Spec.D.pretty state + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + ) lh; + Logs.debug "Total entries in LHT: %d" !count; + Logs.debug "=== End LHT Contents ===" + in + log_lh_contents lh; +end + + +(** Given a [Cfg] and a [Spec], and unused [Inc] computes the solution to [???] *) +module AnalyzeCFG_WP (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = +struct + + module SpecSys: SpecSys with module Spec = Spec = + struct + (* Must be created in module, because cannot be wrapped in a module later. *) + module Spec = Spec + + (* The Equation system *) + module EQSys = Constraints_wp.FromSpec (Spec) (Cfg) + + (* Hashtbl for locals *) + module LHT = BatHashtbl.Make (EQSys.LVar) + (* Hashtbl for globals *) + module GHT = BatHashtbl.Make (EQSys.GVar) + end + + open SpecSys + + (* The solver *) + module PostSolverArg = + struct + let should_prune = true + let should_verify = get_bool "verify" + let should_warn = get_string "warn_at" <> "never" + let should_save_run = + (* copied from solve_and_postprocess *) + let gobview = get_bool "gobview" in + let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in + save_run <> "" + end + module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) + (* The comparator *) + module CompareGlobSys = CompareConstraints.CompareGlobSys (SpecSys) + + (* Triple of the function, context, and the local value. *) + module RT = AnalysisResult.ResultType2 (Spec) + (* Set of triples [RT] *) + module LT = SetDomain.HeadlessSet (RT) + (* Analysis result structure---a hashtable from program points to [LT] *) + module Result = AnalysisResult.Result (LT) (struct let result_name = "wp_analysis" end) + module ResultOutput = AnalysisResultOutput.Make (Result) + + module Query = ResultQuery.Query (SpecSys) + + let solver2source_result h : Result.t = + (* processed result *) + let res = Result.create 113 in + + (* Adding the state at each system variable to the final result *) + let add_local_var (n,es) state = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let loc = UpdateCil.getLoc n in + if loc <> locUnknown then try + let fundec = Node.find_fundec n in + if Result.mem res n then + (* If this source location has been added before, we look it up + * and add another node to it information to it. *) + let prev = Result.find res n in + Result.replace res n (LT.add (es,state,fundec) prev) + else + Result.add res n (LT.singleton (es,state,fundec)) + (* If the function is not defined, and yet has been included to the + * analysis result, we generate a warning. *) + with Not_found -> + Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n + in + LHT.iter add_local_var h; + res + + (** The main function to preform the selected analyses. *) + let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = + Messages.warn "Starting analysis '%s:'" (Spec.name ()); + + Logs.debug "Spec: Type of D: %s" (Spec.D.name ()); + Logs.debug "Spec: Type of G: %s" (Spec.G.name ()); + + Logs.debug "Startfuns: %s" (List.fold_left (fun a f -> a ^ " ; " ^ f.svar.vname) "" startfuns); + + (*## COPIED ##*) + let module FileCfg: FileCfg = + struct + let file = file + module Cfg = Cfg + end + in + + AnalysisState.should_warn := false; (* reset for server mode *) + + (* add extern variables to local state *) + 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 + | _ -> s + in + let vars = foldGlobals file add_glob VS.empty in + let set_bad v st = + Spec.assign {man with local = st} (var v) MyCFG.unknown_exp + in + let is_std = function + | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) + | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) + | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) + | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) + | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) + | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) + true + | _ -> false + in + let add_externs s = function + | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s + | _ -> s + in + foldGlobals file add_externs (Spec.startstate MyCFG.dummy_func.svar) + in + + (* Simulate globals before analysis. *) + (* TODO: make extern/global inits part of constraint system so all of this would be unnecessary. *) + let gh = GHT.create 13 in + let getg v = GHT.find_default gh v (EQSys.G.bot ()) in + let sideg v d = + if M.tracing then M.trace "global_inits" "sideg %a = %a" EQSys.GVar.pretty v EQSys.G.pretty d; + GHT.replace gh v (EQSys.G.join (getg v) d) + in + (* Old-style global function for context. + * This indirectly prevents global initializers from depending on each others' global side effects, which would require proper solving. *) + let getg v = EQSys.G.bot () in + + (* analyze cil's global-inits function to get a starting state *) + let do_global_inits (file: file) : Spec.D.t * fundec list = + 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 () -> 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))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Global initializers trying to split paths.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let edges = CfgTools.getGlobalInits file in + Logs.debug "Executing %d assigns." (List.length edges); + let funs = ref [] in + (*let count = ref 0 in*) + let transfer_func (st : Spec.D.t) (loc, edge) : Spec.D.t = + if M.tracing then M.trace "con" "Initializer %a" CilType.Location.pretty loc; + (*incr count; + if (get_bool "dbg.verbose")&& (!count mod 1000 = 0) then Printf.printf "%d %!" !count; *) + match edge with + | MyCFG.Entry func -> + if M.tracing then M.trace "global_inits" "Entry %a" d_lval (var func.svar); + 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 + | (Var v,o), (AddrOf (Var f,NoOffset)) + when v.vstorage <> Static && isFunctionType f.vtype -> + (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) + | _ -> () + end; + 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 {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 transfer_func st (loc, edge) = + let old_loc = !Goblint_tracing.current_loc in + Goblint_tracing.current_loc := loc; + (* TODO: next_loc? *) + Goblint_backtrace.protect ~mark:(fun () -> Constraints.TfLocation loc) ~finally:(fun () -> + Goblint_tracing.current_loc := old_loc; + ) (fun () -> + transfer_func st (loc, edge) + ) + 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 result : Spec.D.t = List.fold_left transfer_func with_externs edges in + if M.tracing then M.trace "global_inits" "startstate: %a" Spec.D.pretty result; + result, !funs + in + + let print_globals glob = + let out = M.get_out (Spec.name ()) !M.out in + let print_one v st = + ignore (Pretty.fprintf out "%a -> %a\n" EQSys.GVar.pretty_trace v EQSys.G.pretty st) + in + GHT.iter print_one glob + in + + (* real beginning of the [analyze] function *) + if get_bool "ana.sv-comp.enabled" then + Witness.init (module FileCfg); (* TODO: move this out of analyze_loop *) + YamlWitness.init (); + + AnalysisState.global_initialization := true; + GobConfig.earlyglobs := get_bool "exp.earlyglobs"; + let marshal: Spec.marshal option = + if get_string "load_run" <> "" then + Some (Serialize.unmarshal Fpath.(v (get_string "load_run") / "spec_marshal")) + else if Serialize.results_exist () && get_bool "incremental.load" then + Some (Serialize.Cache.(get_data AnalysisData)) + else + None + in + + (* Some happen in init, so enable this temporarily (if required by option). *) + AnalysisState.should_warn := PostSolverArg.should_warn; + Spec.init marshal; + Access.init file; + AnalysisState.should_warn := false; + + let test_domain (module D: Lattice.S): unit = + let module DP = DomainProperties.All (D) in + Logs.debug "domain testing...: %s" (D.name ()); + let errcode = QCheck_base_runner.run_tests DP.tests in + if (errcode <> 0) then + failwith "domain tests failed" + in + let _ = + if (get_bool "dbg.test.domain") then ( + Logs.debug "domain testing analysis...: %s" (Spec.name ()); + test_domain (module Spec.D); + test_domain (module Spec.G); + ) + in + + let startstate, more_funs = + Logs.debug "Initializing %d globals." (CfgTools.numGlobals file); + Timing.wrap "global_inits" do_global_inits file + in + + let otherfuns = if get_bool "kernel" then otherfuns @ more_funs else otherfuns in + + let enter_with st fd = + let st = st fd.svar in + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec.startcontext + ; edge = MyCFG.Skip + ; local = st + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in + let ents = Spec.enter man None fd args in + List.map (fun (_,s) -> fd, s) ents + in + + (try MyCFG.dummy_func.svar.vdecl <- (List.hd otherfuns).svar.vdecl with Failure _ -> ()); + + let startvars = + if startfuns = [] + then [[MyCFG.dummy_func, startstate]] + else + let morph f = Spec.morphstate f startstate in + List.map (enter_with morph) startfuns + in + + let exitvars = List.map (enter_with Spec.exitstate) exitfuns in + let otherstate st v = + 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 () -> 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))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + (* TODO: don't hd *) + 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 *) + let othervars = List.map (enter_with (otherstate prestartstate)) otherfuns in + let startvars = List.concat (startvars @ exitvars @ othervars) in + if startvars = [] then + failwith "BUG: Empty set of start variables; may happen if enter_func of any analysis returns an empty list."; + + AnalysisState.global_initialization := false; + + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec.startcontext + ; edge = MyCFG.Skip + ; local = e + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + + (*## COPIED ##*) + + (* empty entrystates:*) + (* let entrystates = [] in + let entrystates_global = [] in + let startvars' = [] in *) + + (* Non-Empty entrystates copied*) + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec.startcontext + ; edge = MyCFG.Skip + ; local = e + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let startvars' = + if get_bool "exp.forward" then + 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 (man e) n 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 + + (*what if i use exitwars as starvars? *) + + let (local_res, global_res), _ = Slvr.solve entrystates entrystates_global startvars' None in + let local_xml = solver2source_result local_res in + + let make_global_fast_xml f g = + let open Printf in + let print_globals k v = + fprintf f "\n%s%a" (XmlUtil.escape (EQSys.GVar.show k)) EQSys.G.printXml v; + in + GHT.iter print_globals g + in + + + ResultOutput.output (lazy local_xml) (fun _ -> true) global_res make_global_fast_xml (module FileCfg); + (); + + +end + +(* This function was originally a part of the [AnalyzeCFG] module, but + now that [AnalyzeCFG] takes [Spec] as a functor parameter, + [analyze_loop] cannot reside in it anymore since each invocation of + [get_spec] in the loop might/should return a different module, and we + cannot swap the functor parameter from inside [AnalyzeCFG]. *) +let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = + try + let (module Spec) = get_spec () in + let module A = AnalyzeCFG (CFG) (Spec) (struct let increment = change_info end) in + + let module DummyWPSPec = Wp_test.Spec in + let module B = AnalyzeCFG_2 (CFG) (DummyWPSPec) (struct let increment = change_info end) in + GobConfig.with_immutable_conf (fun () -> + (*A.analyze file fs;*) + B.analyze file fs + ) with Refinement.RestartAnalysis -> (* Tail-recursively restart the analysis again, when requested. All solving starts from scratch. diff --git a/src/goblint.ml b/src/goblint.ml index 0eb9a315bd..2e8095310b 100644 --- a/src/goblint.ml +++ b/src/goblint.ml @@ -61,6 +61,8 @@ let main () = if get_string "ana.specification" <> "" then AutoSoundConfig.enableAnalysesForSpecification (); if get_bool "ana.autotune.enabled" then AutoTune.chooseConfig file; file |> do_analyze changeInfo; + (*TODO: BACKWARDS ANALYSIS *) + do_gobview file; do_stats (); Goblint_timing.teardown_tef (); diff --git a/xx_easyprog.c b/xx_easyprog.c new file mode 100644 index 0000000000..1b2b41f62e --- /dev/null +++ b/xx_easyprog.c @@ -0,0 +1,23 @@ + #include + +int main() { + int z = 0; + int x = 0; + int y = 0; + int i = 0; + + i = i + 1; + i = i + 2; + i = i + 3; + + x = x + 1; + + if (x > 0) { + x = y; + } else { + x = x + 2; + } + + int z = z + 1; + return i + x; +} \ No newline at end of file From b91d566c9f0bef53270e1b9eb6fff6b692d92242 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Sun, 14 Dec 2025 17:58:57 +0100 Subject: [PATCH 03/29] changing test program --- xx_easyprog.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/xx_easyprog.c b/xx_easyprog.c index 1b2b41f62e..06a1825731 100644 --- a/xx_easyprog.c +++ b/xx_easyprog.c @@ -18,6 +18,6 @@ int main() { x = x + 2; } - int z = z + 1; + z = z + 1; return i + x; } \ No newline at end of file From b565a75e6b12438864198dd2a82ed1b0abc7f2b3 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Sun, 14 Dec 2025 20:06:47 +0100 Subject: [PATCH 04/29] added better representation in html viewer --- src/analyses/wp_test.ml | 5 +--- src/framework/control.ml | 57 +++++++++++++++++++++++++++++++++++++--- xslt/node.xsl | 22 ++++++++++++++++ xx_easyprog.c | 4 ++- 4 files changed, 79 insertions(+), 9 deletions(-) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index a857e47eaf..482a712c69 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -72,8 +72,5 @@ struct let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = au -end - -let _ = - MCP.register_analysis (module Spec : MCPSpec) \ No newline at end of file +end diff --git a/src/framework/control.ml b/src/framework/control.ml index 5819ed27c4..d27fa32c10 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -791,7 +791,7 @@ struct (* Set of triples [RT] *) module LT = SetDomain.HeadlessSet (RT) (* Analysis result structure---a hashtable from program points to [LT] *) - module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis" end) + module Result = AnalysisResult.Result (LT) (struct let result_name = "wp_analysis" end) module ResultOutput = AnalysisResultOutput.Make (Result) module Query = ResultQuery.Query (SpecSys) @@ -1496,11 +1496,11 @@ struct if get_string "result" <> "none" then Logs.debug "Generating output: %s" (get_string "result"); Messages.finalize (); - Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg); + (* Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg); *) + (*TODO: Script adding these results to the already existing node xml files*) (*Iterating through elements of lh and Logging the contents*) - let log_lh_contents lh = Messages.warn "=== LHT Contents ==="; let count = ref 0 in @@ -1532,6 +1532,55 @@ struct Logs.debug "=== End LHT Contents ===" in log_lh_contents lh; + + (*Script adding these results to the already existing node xml files*) + let output_wp_results_to_xml lh = + (* iterate through all nodes and update corresponding .xml in result/nodes *) + LHT.iter (fun (node, ctx) state -> + try + (* Get node ID as string *) + (* let node_id_str = match node with + | MyCFG.Statement stmt -> string_of_int stmt.sid + | MyCFG.FunctionEntry fundec -> string_of_int fundec.svar.vid + | _ -> raise Not_found (* Skip non-statement nodes *) + in *) + let node_id_str = Node.show_id node in + + let xml_path = Filename.concat "./result/nodes" (node_id_str ^ ".xml") in + if Sys.file_exists xml_path then ( + (* Read existing XML *) + let ic = Stdlib.open_in xml_path in + let content = Stdlib.really_input_string ic (Stdlib.in_channel_length ic) in + Stdlib.close_in ic; + + (* Create WP analysis data *) + let wp_res = Pretty.sprint 100 (Spec.D.pretty () state) in + let wp_data = + "\n\n\n\n" ^ wp_res ^" \n\n\n\n\n" + in + + (* Insert before *) + let close_pattern = "" in + let updated_content = + try + let insert_pos = Str.search_backward (Str.regexp_string close_pattern) content (String.length content) in + let before = String.sub content 0 insert_pos in + let after = String.sub content insert_pos (String.length content - insert_pos) in + before ^ wp_data ^ after + with Not_found -> + content ^ wp_data + in + + (* Write back *) + let oc = Stdlib.open_out xml_path in + Stdlib.output_string oc updated_content; + Stdlib.close_out oc; + Logs.debug "Updated XML file for node %s" node_id_str + ) + with _ -> () (* Skip errors silently *) + ) lh + in + output_wp_results_to_xml lh; end @@ -1922,7 +1971,7 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = let module DummyWPSPec = Wp_test.Spec in let module B = AnalyzeCFG_2 (CFG) (DummyWPSPec) (struct let increment = change_info end) in GobConfig.with_immutable_conf (fun () -> - (*A.analyze file fs;*) + A.analyze file fs; B.analyze file fs ) with Refinement.RestartAnalysis -> diff --git a/xslt/node.xsl b/xslt/node.xsl index bb1ddcabfd..7d580adc79 100644 --- a/xslt/node.xsl +++ b/xslt/node.xsl @@ -101,6 +101,27 @@ + + + +
+ wp_path: +
+ +
+
+ + +
+ wp_path: + + + +
+ + + + ../frame.html?file=&fun=&node= @@ -118,6 +139,7 @@ + diff --git a/xx_easyprog.c b/xx_easyprog.c index 06a1825731..3ffe90a9da 100644 --- a/xx_easyprog.c +++ b/xx_easyprog.c @@ -20,4 +20,6 @@ int main() { z = z + 1; return i + x; -} \ No newline at end of file +} + +//git diff --cached --name-only --diff-filter=ACM | grep -E '\.(ml|mli)$' | xargs -I {} ocp-indent -i {} \ No newline at end of file From 7b532a3a75259766c8117bff977ad5759c21f3c7 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Sun, 14 Dec 2025 20:24:58 +0100 Subject: [PATCH 05/29] tweaking transfer funcs --- src/analyses/wp_test.ml | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index 482a712c69..5aeaa90492 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -14,9 +14,10 @@ struct let startstate v = D.empty() let exitstate v = D.empty() - let get_local = function - | Var v, _ -> Some v (* some local variable*) - | _, _ -> None + let vars_from_lval l = + match l with + | Var v, _ -> Some v (* some variable*) + | Mem _, _ -> None (*do not know what to do here yet*) let vars_from_expr (e: exp) : D.t= let rec aux acc e = @@ -26,17 +27,21 @@ struct let acc1 = aux acc e1 in aux acc1 e2 | UnOp (_, e1, _) -> aux acc e1 - | CastE (_, e1) -> aux acc e1 | SizeOfE e1 -> aux acc e1 | AlignOfE e1 -> aux acc e1 - |Question (e1, e2, e3, _) -> + | Question (e1, e2, e3, _) -> let acc1 = aux acc e1 in let acc2 = aux acc1 e2 in aux acc2 e3 + | CastE (_, e1) -> aux acc e1 + | AddrOf (l1) -> (match vars_from_lval l1 with + | None -> acc + | Some v -> D.add v acc) | _ -> acc in aux (D.empty()) e + let assign man (lval:lval) (rval:exp) = let () = Logs.debug "=== man (analysis manager) info ==="; @@ -47,10 +52,10 @@ struct Logs.debug " local is_bot: %b" (D.is_bot man.local); in - let v = get_local lval in + let v = vars_from_lval lval in match v with - | None -> Logs.debug "!!! possibly unsound !!!"; D.top () + | None -> D.join man.local (vars_from_expr rval) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) | Some v -> let l = (D.diff man.local (D.singleton v)) in if D.mem v man.local then D.join l (vars_from_expr rval) @@ -61,15 +66,16 @@ struct let body man (f:fundec) = man.local - let return man (exp:exp option) (f:fundec) = match exp with | None -> man.local | Some e -> D.join man.local (vars_from_expr e) + (* TODO *) let enter man (lval: lval option) (f:fundec) (args:exp list) = [man.local, man.local] + (* TODO *) let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = au From d2cdb8b27138b99ca971ba517bcf6035f54da370 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Tue, 16 Dec 2025 16:33:19 +0100 Subject: [PATCH 06/29] now for procedure calls --- src/analyses/wp_test.ml | 21 ++-- src/framework/constraints_wp.ml | 181 +++----------------------------- src/framework/control.ml | 33 +++--- xx_easyprog.c | 20 ++-- 4 files changed, 54 insertions(+), 201 deletions(-) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index 5aeaa90492..783e93d219 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -16,8 +16,8 @@ struct let vars_from_lval l = match l with - | Var v, _ -> Some v (* some variable*) - | Mem _, _ -> None (*do not know what to do here yet*) + | Var v, NoOffset when isIntegralType v.vtype && not (v.vglob || v.vaddrof) -> Some v (* local integer variable whose address is never taken *) + | _, _ -> None (*do not know what to do here yet*) let vars_from_expr (e: exp) : D.t= let rec aux acc e = @@ -43,14 +43,14 @@ struct let assign man (lval:lval) (rval:exp) = - let () = + (* let () = Logs.debug "=== man (analysis manager) info ==="; Logs.debug " lval: %a" CilType.Lval.pretty lval; Logs.debug " rval: %a" CilType.Exp.pretty rval; Logs.debug " local state: %a" D.pretty man.local; Logs.debug " local is_top: %b" (D.is_top man.local); Logs.debug " local is_bot: %b" (D.is_bot man.local); - in + in *) let v = vars_from_lval lval in @@ -73,10 +73,19 @@ struct (* TODO *) let enter man (lval: lval option) (f:fundec) (args:exp list) = - [man.local, man.local] + Logs.debug "=== enter function %s ===" f.svar.vname; + + [man.local, D.bot()] (* TODO *) let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - au + Logs.debug "=== combine_env of function %s ===" f.svar.vname; + + D.join man.local au + + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + Logs.debug "=== combine_assign of function %s ===" f.svar.vname; + man.local + end diff --git a/src/framework/constraints_wp.ml b/src/framework/constraints_wp.ml index b76516b031..11f997e83c 100644 --- a/src/framework/constraints_wp.ml +++ b/src/framework/constraints_wp.ml @@ -143,7 +143,6 @@ struct let tf_assign var edge prev_node lv e getl sidel demandl getg sideg d = let man, r, spawns = common_man var edge prev_node d getl sidel demandl getg sideg in let d = S.assign man lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - Logs.debug "######### there was an assign"; common_join man d !r !spawns let tf_vdecl var edge prev_node v getl sidel demandl getg sideg d = @@ -187,10 +186,15 @@ struct 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 + (*TODO: THIS HAS TO BE BACKWARDS*) let tf_normal_call man lv e (f:fundec) args getl sidel demandl 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; + + Logs.debug "combine: local: %a" S.D.pretty cd; + Logs.debug "combine: function: %a" S.D.pretty fd; + let rec cd_man = { man with ask = (fun (type a) (q: a Queries.t) -> S.query cd_man q); @@ -248,12 +252,14 @@ struct (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) let paths = List.map (Tuple3.map2 Option.some) paths in if M.tracing then M.traceli "combine" "combining"; + Logs.debug "combining"; let paths = List.map combine paths in let r = List.fold_left D.join (D.bot ()) paths in if M.tracing then M.traceu "combine" "combined: %a" S.D.pretty r; + Logs.debug "combined: %a" S.D.pretty r; r - + (*TODO: HERE AS WELL*) let rec tf_proc var edge prev_node lv e args getl sidel demandl getg sideg d = let tf_special_call man f = let once once_control init_routine = @@ -391,7 +397,6 @@ struct ) let system (v,c) = - let wrap (v,c) = match v with | FunctionEntry _ -> @@ -400,10 +405,8 @@ struct let xs = List.map tf' (Cfg.next v) in List.fold_left S.D.join (S.D.bot ()) xs in - Logs.debug "## Function Entry" ; Some tf | Function _ -> - Logs.debug "## Function call?" ; None | _ -> let tf getl sidel demandl getg sideg = @@ -411,180 +414,26 @@ struct let xs = List.map tf' (Cfg.next v) in List.fold_left S.D.join (S.D.bot ()) xs in - Logs.debug "## Not Function Entry. Number of nexts: %d" (List.length (Cfg.next v)) ; - Logs.debug "## Number of prevs: %d" (List.length (Cfg.prev v)) ; + Some tf in - Logs.debug "# Creating transfer function for node %s" (Node.show v); + Logs.debug "# Creating transfer function for %s" (Node.show v); + Logs.debug " Number of nexts: %d" (List.length (Cfg.next v)) ; + Logs.debug " Number of prevs: %d" (List.length (Cfg.prev v)) ; wrap (v,c) - + + (* what does this do? *) let iter_vars getl getg vq fl fg = - (* vars for Spec *) - 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 () -> 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))) - ; spawn = (fun ?(multiple=false) v d -> failwith "Cannot \"spawn\" in query context.") - ; split = (fun d es -> failwith "Cannot \"split\" in query context.") - ; sideg = (fun v g -> failwith "Cannot \"split\" in query context.") - } - in - let f v = fg (GVar.spec (Obj.obj v)) in - S.query man (IterSysVars (vq, f)); - - (* node vars for locals *) - match vq with - | Node {node; fundec} -> - let fd = Option.default_delayed (fun () -> Node.find_fundec node) fundec in - let cs = G.contexts (getg (GVar.contexts fd)) in - G.CSet.iter (fun c -> - fl (node, c) - ) cs - | _ -> - (); failwith "iter_vars not implemented in WP" let sys_change getl getg = - (* - let open CompareCIL in - - let c = match I.increment with - | Some {changes; _} -> changes - | None -> empty_change_info () - in - List.(Logs.info "change_info = { unchanged = %d; changed = %d (with unchangedHeader = %d); added = %d; removed = %d }" (length c.unchanged) (length c.changed) (BatList.count_matching (fun c -> c.unchangedHeader) c.changed) (length c.added) (length c.removed)); - - let changed_funs = List.filter_map (function - | {old = {d ef = Some (Fun f); _}; diff = None; _} -> - Logs.info "Completely changed function: %s" f.svar.vname; - Some f - | _ -> None - ) c.changed - in - let part_changed_funs = List.filter_map (function - | {old = {def = Some (Fun f); _}; diff = Some nd; _} -> - Logs.info "Partially changed function: %s" f.svar.vname; - Some (f, nd.primObsoleteNodes, nd.unchangedNodes) - | _ -> None - ) c.changed - in - let removed_funs = List.filter_map (function - | {def = Some (Fun f); _} -> - Logs.info "Removed function: %s" f.svar.vname; - Some f - | _ -> None - ) c.removed - in - - let module HM = Hashtbl.Make (Var2 (LVar) (GVar)) in - - let mark_node hm f node = - iter_vars getl getg (Node {node; fundec = Some f}) (fun v -> - HM.replace hm (`L v) () - ) (fun v -> - HM.replace hm (`G v) () - ) - in - - let reluctant = GobConfig.get_bool "incremental.reluctant.enabled" in - let reanalyze_entry f = - (* destabilize the entry points of a changed function when reluctant is off, - or the function is to be force-reanalyzed *) - (not reluctant) || CompareCIL.VarinfoSet.mem f.svar c.exclude_from_rel_destab - in - let obsolete_ret = HM.create 103 in - let obsolete_entry = HM.create 103 in - let obsolete_prim = HM.create 103 in - - (* When reluctant is on: - Only add function entry nodes to obsolete_entry if they are in force-reanalyze *) - List.iter (fun f -> - if reanalyze_entry f then - (* collect function entry for eager destabilization *) - mark_node obsolete_entry f (FunctionEntry f) - else - (* collect function return for reluctant analysis *) - mark_node obsolete_ret f (Function f) - ) changed_funs; - (* Primary changed unknowns from partially changed functions need only to be collected for eager destabilization when reluctant is off *) - (* The return nodes of partially changed functions are collected in obsolete_ret for reluctant analysis *) - (* We utilize that force-reanalyzed functions are always considered as completely changed (and not partially changed) *) - List.iter (fun (f, pn, _) -> - if not reluctant then ( - List.iter (fun n -> - mark_node obsolete_prim f n - ) pn - ) - else - mark_node obsolete_ret f (Function f) - ) part_changed_funs; - - let obsolete = Seq.append (HM.to_seq_keys obsolete_entry) (HM.to_seq_keys obsolete_prim) |> List.of_seq in - let reluctant = HM.to_seq_keys obsolete_ret |> List.of_seq in - - let marked_for_deletion = HM.create 103 in - - let dummy_pseudo_return_node f = - (* not the same as in CFG, but compares equal because of sid *) - Node.Statement ({Cil.dummyStmt with sid = Cilfacade.get_pseudo_return_id f}) - in - let add_nodes_of_fun (functions: fundec list) (withEntry: fundec -> bool) = - let add_stmts (f: fundec) = - List.iter (fun s -> - mark_node marked_for_deletion f (Statement s) - ) f.sallstmts - in - List.iter (fun f -> - if withEntry f then - mark_node marked_for_deletion f (FunctionEntry f); - mark_node marked_for_deletion f (Function f); - add_stmts f; - mark_node marked_for_deletion f (dummy_pseudo_return_node f) - ) functions; - in - - add_nodes_of_fun changed_funs reanalyze_entry; - add_nodes_of_fun removed_funs (fun _ -> true); - (* it is necessary to remove all unknowns for changed pseudo-returns because they have static ids *) - let add_pseudo_return f un = - let pseudo = dummy_pseudo_return_node f in - if not (List.exists (Node.equal pseudo % fst) un) then - mark_node marked_for_deletion f (dummy_pseudo_return_node f) - in - List.iter (fun (f,_,un) -> - mark_node marked_for_deletion f (Function f); - add_pseudo_return f un - ) part_changed_funs; - - let delete = HM.to_seq_keys marked_for_deletion |> List.of_seq in - - let restart = match I.increment with - | Some data -> - let restart = ref [] in - List.iter (fun g -> - iter_vars getl getg g (fun v -> - restart := `L v :: !restart - ) (fun v -> - restart := `G v :: !restart - ) - ) data.restarting; - !restart - | None -> [] - in - - {obsolete; delete; reluctant; restart}*) failwith "sys_change not implemented in WP" + (*What does this do?*) let postmortem = function | FunctionEntry fd, c -> [(Function fd, c)] | _ -> [] diff --git a/src/framework/control.ml b/src/framework/control.ml index d27fa32c10..0db66dcd90 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -773,8 +773,8 @@ struct (* The solver *) module PostSolverArg = struct - let should_prune = false - let should_verify = false (*get_bool "verify"*) + let should_prune = true + let should_verify = true (*get_bool "verify"*) let should_warn = get_string "warn_at" <> "never" let should_save_run = (* copied from solve_and_postprocess *) @@ -796,13 +796,6 @@ struct module Query = ResultQuery.Query (SpecSys) - - let print_one f (module S : Printable.S) x : unit = - BatPrintf.fprintf f "\n" (Spec.name ()); - S.printXml f (Obj.obj x); - BatPrintf.fprintf f "\n" - - (* print out information about dead code *) let print_dead_code (xs:Result.t) uncalled_fn_loc = let module NH = Hashtbl.Make (Node) in @@ -934,7 +927,7 @@ struct LHT.iter add_local_var h; res - (** The main function to preform the selected analyses. *) + (** [analyze file startfuns exitfuns otherfuns] is the main function to preform the selected analyses.*) let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = let module FileCfg: FileCfg = struct @@ -943,6 +936,18 @@ struct end in + let () = + let log_fun_list name funs = + let fun_names = List.map (fun f -> f.svar.vname) funs in + Logs.debug "%s functions: %s" name (String.concat ", " fun_names) + in + Logs.debug "================= Analysis Setup ================"; + log_fun_list "Start" startfuns; + log_fun_list "Exit" exitfuns; + log_fun_list "Other" otherfuns; + Logs.debug "================================================"; + in + AnalysisState.should_warn := false; (* reset for server mode *) (* exctract global xml from result *) @@ -1191,7 +1196,7 @@ struct 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 (man e) n e), e) startvars in *) + (* let entrystates = List.clearmap (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (man e) n e), e) startvars in *) let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec.context (man e) n e), e) startvars in let entrystates_global = GHT.to_list gh in @@ -1249,7 +1254,7 @@ struct List.iteri (fun i (node, state) -> Logs.debug "StartVar (no apostrophe) %d:" (i + 1); Logs.debug " Node: %a" CilType.Fundec.pretty node; - Logs.debug " State: %a" Spec.D.pretty state; + Logs.debug " State: (of type EQSys.D.t) %a" Spec.D.pretty state; ) startvars; Logs.debug "=== End Analysis Inputs ===" @@ -1498,8 +1503,6 @@ struct Messages.finalize (); (* Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg); *) - (*TODO: Script adding these results to the already existing node xml files*) - (*Iterating through elements of lh and Logging the contents*) let log_lh_contents lh = Messages.warn "=== LHT Contents ==="; let count = ref 0 in @@ -1958,7 +1961,7 @@ struct end -(* This function was originally a part of the [AnalyzeCFG] module, but +(** This function was originally a part of the [AnalyzeCFG] module, but now that [AnalyzeCFG] takes [Spec] as a functor parameter, [analyze_loop] cannot reside in it anymore since each invocation of [get_spec] in the loop might/should return a different module, and we diff --git a/xx_easyprog.c b/xx_easyprog.c index 3ffe90a9da..9b8ca1a3b6 100644 --- a/xx_easyprog.c +++ b/xx_easyprog.c @@ -1,25 +1,17 @@ #include -int main() { - int z = 0; +int f() { int x = 0; - int y = 0; int i = 0; i = i + 1; - i = i + 2; - i = i + 3; - - x = x + 1; + return i + x; +} - if (x > 0) { - x = y; - } else { - x = x + 2; - } - z = z + 1; - return i + x; +int main() { + int a = f(); + return a; } //git diff --cached --name-only --diff-filter=ACM | grep -E '\.(ml|mli)$' | xargs -I {} ocp-indent -i {} \ No newline at end of file From b7b41df7d03bfcbbe5bf18a7e9e3c1b73402da55 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Tue, 16 Dec 2025 16:33:34 +0100 Subject: [PATCH 07/29] and formatted now --- src/analyses/wp_test.ml | 24 ++++++++++++------------ src/framework/constraints_wp.ml | 6 +++--- src/framework/control.ml | 8 ++++---- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index 783e93d219..5742261dec 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -44,13 +44,13 @@ struct let assign man (lval:lval) (rval:exp) = (* let () = - Logs.debug "=== man (analysis manager) info ==="; - Logs.debug " lval: %a" CilType.Lval.pretty lval; - Logs.debug " rval: %a" CilType.Exp.pretty rval; - Logs.debug " local state: %a" D.pretty man.local; - Logs.debug " local is_top: %b" (D.is_top man.local); - Logs.debug " local is_bot: %b" (D.is_bot man.local); - in *) + Logs.debug "=== man (analysis manager) info ==="; + Logs.debug " lval: %a" CilType.Lval.pretty lval; + Logs.debug " rval: %a" CilType.Exp.pretty rval; + Logs.debug " local state: %a" D.pretty man.local; + Logs.debug " local is_top: %b" (D.is_top man.local); + Logs.debug " local is_bot: %b" (D.is_bot man.local); + in *) let v = vars_from_lval lval in @@ -74,18 +74,18 @@ struct (* TODO *) let enter man (lval: lval option) (f:fundec) (args:exp list) = Logs.debug "=== enter function %s ===" f.svar.vname; - + [man.local, D.bot()] (* TODO *) let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = Logs.debug "=== combine_env of function %s ===" f.svar.vname; - + D.join man.local au - + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - Logs.debug "=== combine_assign of function %s ===" f.svar.vname; + Logs.debug "=== combine_assign of function %s ===" f.svar.vname; man.local - + end diff --git a/src/framework/constraints_wp.ml b/src/framework/constraints_wp.ml index 11f997e83c..3977e3fd9c 100644 --- a/src/framework/constraints_wp.ml +++ b/src/framework/constraints_wp.ml @@ -414,7 +414,7 @@ struct let xs = List.map tf' (Cfg.next v) in List.fold_left S.D.join (S.D.bot ()) xs in - + Some tf in @@ -424,10 +424,10 @@ struct Logs.debug " Number of prevs: %d" (List.length (Cfg.prev v)) ; wrap (v,c) - + (* what does this do? *) let iter_vars getl getg vq fl fg = - failwith "iter_vars not implemented in WP" + failwith "iter_vars not implemented in WP" let sys_change getl getg = diff --git a/src/framework/control.ml b/src/framework/control.ml index 0db66dcd90..18ac6a12c5 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -1962,10 +1962,10 @@ struct end (** This function was originally a part of the [AnalyzeCFG] module, but - now that [AnalyzeCFG] takes [Spec] as a functor parameter, - [analyze_loop] cannot reside in it anymore since each invocation of - [get_spec] in the loop might/should return a different module, and we - cannot swap the functor parameter from inside [AnalyzeCFG]. *) + now that [AnalyzeCFG] takes [Spec] as a functor parameter, + [analyze_loop] cannot reside in it anymore since each invocation of + [get_spec] in the loop might/should return a different module, and we + cannot swap the functor parameter from inside [AnalyzeCFG]. *) let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = try let (module Spec) = get_spec () in From 6a9ae2a55c0bf8e4a4b57734a875382f3bdcfb51 Mon Sep 17 00:00:00 2001 From: ge94riv Date: Wed, 31 Dec 2025 11:52:08 +0100 Subject: [PATCH 08/29] more --- src/analyses/wp_test.ml | 41 +++++++++++++++++++++++++-------- src/framework/constraints_wp.ml | 13 ++++++++--- xx_easyprog.c | 8 +++---- 3 files changed, 45 insertions(+), 17 deletions(-) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index 5742261dec..7d993e5cdc 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -14,7 +14,7 @@ struct let startstate v = D.empty() let exitstate v = D.empty() - let vars_from_lval l = + let vars_from_lval (l: lval) = match l with | Var v, NoOffset when isIntegralType v.vtype && not (v.vglob || v.vaddrof) -> Some v (* local integer variable whose address is never taken *) | _, _ -> None (*do not know what to do here yet*) @@ -73,19 +73,40 @@ struct (* TODO *) let enter man (lval: lval option) (f:fundec) (args:exp list) = - Logs.debug "=== enter function %s ===" f.svar.vname; + Logs.debug "=== enter function %s with args %s ===" f.svar.vname + (String.concat ", " (List.map (CilType.Exp.show) args)); - [man.local, D.bot()] + let vars = + match lval with + | None -> man.local + | Some lv -> man.local (*i have to check for every arg ... no wait... I do not care about the args here, i care about those at the combine!!!!*) +) +in - (* TODO *) - let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - Logs.debug "=== combine_env of function %s ===" f.svar.vname; +[man.local, vars] - D.join man.local au +(* TODO *) +let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + Logs.debug "=== combine_env of function %s ===" f.svar.vname; + (*here I would just add relevant global vars, which is nothing currently nothing. so i would actually *) + D.join man.local au - let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - Logs.debug "=== combine_assign of function %s ===" f.svar.vname; - man.local +let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + Logs.debug "=== combine_assign of function %s ===" f.svar.vname; + (*here I add the relevant args. to get the relevant args I have to query the start point of f.. *) + man.local + + + +(** A transfer function which handles the return statement, i.e., + "return exp" or "return" in the passed function (fundec) *) +let return man (exp: exp option) (f:fundec) : D.t = + let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in (*this does not take globals int account, only checks for "temp"*) + match exp with + | None -> D.empty() + | Some e -> if return_val_is_important + then D.join (D.empty()) (vars_from_expr e) + else D.empty(); end diff --git a/src/framework/constraints_wp.ml b/src/framework/constraints_wp.ml index 3977e3fd9c..017b63e21a 100644 --- a/src/framework/constraints_wp.ml +++ b/src/framework/constraints_wp.ml @@ -242,12 +242,19 @@ struct ) (S.D.bot ()) (S.paths_as_set fd_man) in if M.tracing then M.traceu "combine" "combined local: %a" S.D.pretty r; + Logs.debug "combined local: %a" S.D.pretty r; r in - let paths = S.enter man lv f args in + let paths = + Logs.debug "manager info at call to %a" Node.pretty man.node; + 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 + + (* List.iter (fun (c,fc,v) -> if not (S.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; *) + List.iter (fun (c,fc,v) -> if not (S.D.is_bot v) then sidel (Function 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; *) + let paths = List.map (fun (c,fc,v) -> (c, fc, if S.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in + (* Don't filter bot paths, otherwise LongjmpLifter is not called. *) (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) let paths = List.map (Tuple3.map2 Option.some) paths in diff --git a/xx_easyprog.c b/xx_easyprog.c index 9b8ca1a3b6..51231e87ba 100644 --- a/xx_easyprog.c +++ b/xx_easyprog.c @@ -1,7 +1,6 @@ #include -int f() { - int x = 0; +int f(int x) { int i = 0; i = i + 1; @@ -10,8 +9,9 @@ int f() { int main() { - int a = f(); - return a; + int a = 0; + int b = f(a); + return b; } //git diff --cached --name-only --diff-filter=ACM | grep -E '\.(ml|mli)$' | xargs -I {} ocp-indent -i {} \ No newline at end of file From d3cdd34cca379d3964ecde2554497861fc157090 Mon Sep 17 00:00:00 2001 From: ge94riv Date: Fri, 9 Jan 2026 12:25:54 +0100 Subject: [PATCH 09/29] working on combine --- src/analyses/wp_test.ml | 76 ++++++++++++++++++++++++--------- src/framework/constraints_wp.ml | 10 +++-- xx_easyprog.c | 14 ++++-- 3 files changed, 72 insertions(+), 28 deletions(-) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index 7d993e5cdc..209cf3b32f 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -66,6 +66,7 @@ struct let body man (f:fundec) = man.local + let return man (exp:exp option) (f:fundec) = match exp with | None -> man.local @@ -80,33 +81,66 @@ struct match lval with | None -> man.local | Some lv -> man.local (*i have to check for every arg ... no wait... I do not care about the args here, i care about those at the combine!!!!*) -) -in -[man.local, vars] + in + + [man.local, vars] + + (* TODO *) + let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + Logs.debug "=== combine_env of function %s ===" f.svar.vname; + let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in + Logs.debug " args: %s" args_pretty; + + let sformals_pretty = String.concat ", " (List.map (fun v -> v.vname) f.sformals) in + Logs.debug " sformals: %s" sformals_pretty; + + (*map relevant sformals in man.local to the corresponding variables contained in the argument*) + let arg_formal_pairs = List.combine args f.sformals in + let relevant_arg_vars = + List.fold_left (fun acc (arg_exp, formal_var) -> + if D.mem formal_var au then + D.join acc (vars_from_expr arg_exp) + else + acc + ) (D.empty()) arg_formal_pairs + in + + (*join relevant*) + D.join man.local relevant_arg_vars + + let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + Logs.debug "=== combine_assign of function %s ===" f.svar.vname; + (*how do I know which args are important? i.e. how do I match the local name of the variable in the function with the passed parameters (if there are several)*) + let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in + Logs.debug " args: %s" args_pretty; + + let simple_assign lval exp acc = + let v = vars_from_lval lval in -(* TODO *) -let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - Logs.debug "=== combine_env of function %s ===" f.svar.vname; - (*here I would just add relevant global vars, which is nothing currently nothing. so i would actually *) - D.join man.local au + match v with + | None -> D.join acc (vars_from_expr exp) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) + | Some v -> + let l = (D.diff acc (D.singleton v)) in + if D.mem v acc then D.join l (vars_from_expr exp) + else l + in -let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - Logs.debug "=== combine_assign of function %s ===" f.svar.vname; - (*here I add the relevant args. to get the relevant args I have to query the start point of f.. *) - man.local + match lval with + | Some lval -> List.fold_right (fun exp acc -> simple_assign lval exp acc) args man.local + | None -> man.local -(** A transfer function which handles the return statement, i.e., - "return exp" or "return" in the passed function (fundec) *) -let return man (exp: exp option) (f:fundec) : D.t = - let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in (*this does not take globals int account, only checks for "temp"*) + (** A transfer function which handles the return statement, i.e., + "return exp" or "return" in the passed function (fundec) *) + let return man (exp: exp option) (f:fundec) : D.t = + let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in (*this does not take globals int account, only checks for "temp"*) - match exp with - | None -> D.empty() - | Some e -> if return_val_is_important - then D.join (D.empty()) (vars_from_expr e) - else D.empty(); + match exp with + | None -> D.empty() + | Some e -> if return_val_is_important + then D.join (D.empty()) (vars_from_expr e) + else D.empty(); end diff --git a/src/framework/constraints_wp.ml b/src/framework/constraints_wp.ml index 017b63e21a..2b296c29df 100644 --- a/src/framework/constraints_wp.ml +++ b/src/framework/constraints_wp.ml @@ -211,7 +211,8 @@ struct { man with ask = (fun (type a) (q: a Queries.t) -> S.query sync_man q); local = fd; - prev_node = Function f; + (*prev_node = Function f*) + prev_node = FunctionEntry f; } in (* TODO: more accurate man? *) @@ -253,6 +254,7 @@ struct (* List.iter (fun (c,fc,v) -> if not (S.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; *) List.iter (fun (c,fc,v) -> if not (S.D.is_bot v) then sidel (Function 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; *) + (* *) let paths = List.map (fun (c,fc,v) -> (c, fc, if S.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in (* Don't filter bot paths, otherwise LongjmpLifter is not called. *) @@ -426,9 +428,9 @@ struct in - Logs.debug "# Creating transfer function for %s" (Node.show v); - Logs.debug " Number of nexts: %d" (List.length (Cfg.next v)) ; - Logs.debug " Number of prevs: %d" (List.length (Cfg.prev v)) ; + (* Logs.debug "# Creating transfer function for %s" (Node.show v); + Logs.debug " Number of nexts: %d" (List.length (Cfg.next v)) ; + Logs.debug " Number of prevs: %d" (List.length (Cfg.prev v)) ; *) wrap (v,c) diff --git a/xx_easyprog.c b/xx_easyprog.c index 51231e87ba..58dacd324b 100644 --- a/xx_easyprog.c +++ b/xx_easyprog.c @@ -1,16 +1,24 @@ #include -int f(int x) { +int f(int x, int y) { int i = 0; i = i + 1; - return i + x; + + if (x > 0) { + i = i + 2; + return i; + } else { + i = i + 3; + return i + x; + } } int main() { int a = 0; - int b = f(a); + int c = 3; + int b = f(a, c); return b; } From a7e512b98274cdf2a9cc7814a4e7aef25d67e5c7 Mon Sep 17 00:00:00 2001 From: ge94riv Date: Mon, 19 Jan 2026 12:06:58 +0100 Subject: [PATCH 10/29] mainly comments from conversations --- src/analyses/wp_test.ml | 23 +++++-- src/framework/constraints_wp.ml | 4 +- src/framework/constraints_wrapper.ml | 91 ++++++++++++++++++++++++++++ src/framework/control.ml | 6 +- 4 files changed, 115 insertions(+), 9 deletions(-) create mode 100644 src/framework/constraints_wrapper.ml diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index 209cf3b32f..a296fe3cb2 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -1,11 +1,21 @@ open GoblintCil open Analyses + module Spec : Analyses.MCPSpec = struct let name () = "wp_test" - include Analyses.IdentityUnitContextsSpec + include Analyses.IdentitySpec + + (*## context ##*) + (*Idea: make context type passsable, so add parameter.*) + module C = Printable.Unit + + let context man _ _ = () + let startcontext () = () + + (*## end of context ##*) module LiveVariableSet = SetDomain.ToppedSet (Basetype.Variables) (struct let topname = "All variables" end) @@ -46,7 +56,7 @@ struct (* let () = Logs.debug "=== man (analysis manager) info ==="; Logs.debug " lval: %a" CilType.Lval.pretty lval; - Logs.debug " rval: %a" CilType.Exp.pretty rval; + Logs.debug " rval: %a" Cil Type.Exp.pretty rval; Logs.debug " local state: %a" D.pretty man.local; Logs.debug " local is_top: %b" (D.is_top man.local); Logs.debug " local is_bot: %b" (D.is_bot man.local); @@ -119,16 +129,17 @@ struct let v = vars_from_lval lval in match v with - | None -> D.join acc (vars_from_expr exp) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) + | None -> acc (*D.join acc (vars_from_expr exp) if I do not know what the value is assigned to, then all RHS-Variables might be relevant *) | Some v -> let l = (D.diff acc (D.singleton v)) in - if D.mem v acc then D.join l (vars_from_expr exp) - else l + (* if D.mem v acc then D.join l (vars_from_expr exp) + else l *) + l in match lval with | Some lval -> List.fold_right (fun exp acc -> simple_assign lval exp acc) args man.local - | None -> man.local + | _ -> man.local diff --git a/src/framework/constraints_wp.ml b/src/framework/constraints_wp.ml index 2b296c29df..f45c6131a4 100644 --- a/src/framework/constraints_wp.ml +++ b/src/framework/constraints_wp.ml @@ -249,6 +249,7 @@ struct let paths = Logs.debug "manager info at call to %a" Node.pretty man.node; S.enter man lv f args in + (* Wollen eig vorwärts-kontext benutzen *) 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; *) @@ -308,7 +309,8 @@ struct | _ -> (* Depends on base for query. *) let ad = man.ask (Queries.EvalFunvar e) in - Queries.AD.to_var_may ad (* TODO: don't convert, handle UnknownPtr below *) + Queries.AD.to_var_may ad (* TODO: don't convert, handle UnknownPtr below *) + (*PROBLEM: Pointer. Brauche Ergebnisse der anderen Analysen*) in let one_function f = match Cil.unrollType f.vtype with diff --git a/src/framework/constraints_wrapper.ml b/src/framework/constraints_wrapper.ml new file mode 100644 index 0000000000..2477a76e60 --- /dev/null +++ b/src/framework/constraints_wrapper.ml @@ -0,0 +1,91 @@ +(** Construction of a {{!Goblint_constraint} constraint system} from an {{!Analyses.Spec} analysis specification} and {{!MyCFG.CfgBackward} CFGs}. + Transformatons of analysis specifications as functors. *) + +open Batteries +open GoblintCil +open MyCFG +open Analyses +open Goblint_constraint.ConstrSys +open GobConfig + + +type Goblint_backtrace.mark += TfLocation of location + +let () = Goblint_backtrace.register_mark_printer (function + | TfLocation loc -> + Some ("transfer function at " ^ CilType.Location.show loc) + | _ -> None (* for other marks *) + ) + + +module type Increment = +sig + val increment: increment_data option +end + + +(** The main point of this file---generating a [DemandGlobConstrSys] from a [Spec]. *) +module Spec_wrapper (S_forwards:Spec) (S_backwards:Spec) (Cfg:CfgBidir) + : sig + include DemandGlobConstrSys with module LVar = VarF (S_forwards.C) + and module GVar = GVarF (S_forwards.V) + and module D = S_forwards.D + and module G = GVarG (S_forwards.G) (S_forwards.C) + end += +struct + type lv = MyCFG.node * S_forwards.C.t + (* type gv = varinfo *) + type ld = S_forwards.D.t + (* type gd = S_forwards.G.t *) + module LVar = VarF (S_forwards.C) + module GVar = GVarF (S_forwards.V) (* * GVarF (S_backward.V) ## I probably need another functor*) + module D = S_forwards.D + module G = GVarG (S_forwards.G) (S_forwards.C) + + (* Two global invariants: + 1. S_forwards.V -> S_forwards.G -- used for Spec + 2. fundec -> set of S_forwards.C -- used for IterSysVars Node *) + + let system (v,c) = + let wrap (v,c) = + match v with + | FunctionEntry _ -> + let tf getl sidel demandl getg sideg = + let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S_forwards.D.join (S_forwards.D.bot ()) xs + in + Some tf + | Function _ -> + None + | _ -> + let tf getl sidel demandl getg sideg = + let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S_forwards.D.join (S_forwards.D.bot ()) xs + in + + Some tf + + in + + (* Logs.debug "# Creating transfer function for %s" (Node.show v); + Logs.debug " Number of nexts: %d" (List.length (Cfg.next v)) ; + Logs.debug " Number of prevs: %d" (List.length (Cfg.prev v)) ; *) + wrap (v,c) + + + (* what does this do? *) + let iter_vars getl getg vq fl fg = + failwith "iter_vars not implemented in WP" + + + let sys_change getl getg = + failwith "sys_change not implemented in WP" + + (*What does this do?*) + let postmortem = function + | FunctionEntry fd, c -> [(Function fd, c)] + | _ -> [] +end diff --git a/src/framework/control.ml b/src/framework/control.ml index 18ac6a12c5..0f4e6c1db8 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -1190,7 +1190,7 @@ struct in let startvars' = (* if get_bool "exp.forward" then *) - if true then + if true then (*does this deside which variables I query?*) 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 (man e) n e)) startvars @@ -1204,6 +1204,7 @@ struct let solve_and_postprocess () = let lh, gh = + (*Solver data??*) let solver_data = match Inc.increment with | Some {solver_data; server; _} -> @@ -1213,10 +1214,11 @@ struct Some (Slvr.relift_marshal solver_data) else Some solver_data - | None -> None + | None -> None in Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); + (*######################### START OF ACTUAL SOLVING ##########################*) (*### START OF LOG ###*) From 9690b860b73ce238cb92f1cd7c883a356d9c346c Mon Sep 17 00:00:00 2001 From: ge94riv Date: Fri, 30 Jan 2026 13:08:34 +0100 Subject: [PATCH 11/29] working on integrating bidirConstraints into control --- src/framework/bidirConstrains.ml | 585 ++++++++++++++ src/framework/constraints_wrapper.ml | 91 --- src/framework/control.ml | 1049 +++++++++++++++++++++----- 3 files changed, 1463 insertions(+), 262 deletions(-) create mode 100644 src/framework/bidirConstrains.ml delete mode 100644 src/framework/constraints_wrapper.ml diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml new file mode 100644 index 0000000000..609e2b0db9 --- /dev/null +++ b/src/framework/bidirConstrains.ml @@ -0,0 +1,585 @@ +open Batteries +open GoblintCil +open MyCFG +open Analyses +open Goblint_constraint.ConstrSys +open GobConfig + +module type Increment = +sig + val increment: increment_data option +end + + + +module BidirFromSpec (S_forw:Spec) (S_backw:Spec with type C.t = S_forw.C.t ) (Cfg:CfgBidir) (I:Increment) + : sig + module LVar : Goblint_constraint.ConstrSys.VarType with type t = [ `L_forw of VarF(S_forw.C).t | `L_backw of VarF(S_forw.C).t ] + module GVar : Goblint_constraint.ConstrSys.VarType with type t = [ `G_forw of GVarF(S_forw.V).t | `G_backw of GVarF(S_backw.V).t ] + include DemandGlobConstrSys with module LVar := LVar + and module GVar := GVar + and module D = Lattice.Lift2(S_forw.D)(S_backw.D) + and module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) + end += +struct + (* type lv = [ `lv_forw of MyCFG.node * S_forw.C.t | `lv_back of MyCFG.node * S_forw.C.t] *) + (* type ld = Lattice.Lift2(S_forw.D)(S_backw.D).t *) + + module LV = VarF (S_forw.C) + module LVar = + struct + type t = [ `L_forw of LV.t | `L_backw of LV.t ] [@@deriving eq, ord, hash] + + let relift = function + | `L_forw x -> `L_forw (LV.relift x) + | `L_backw x -> `L_backw (LV.relift x) + + let pretty_trace () = function + | `L_forw a -> GoblintCil.Pretty.dprintf "L_forw:%a" LV.pretty_trace a + | `L_backw a -> GoblintCil.Pretty.dprintf "L_backw:%a" LV.pretty_trace a + + let printXml f = function + | `L_forw a -> LV.printXml f a + | `L_backw a -> LV.printXml f a + + let var_id = function + | `L_forw a -> LV.var_id a + | `L_backw a -> LV.var_id a + + let node = function + | `L_forw a -> LV.node a + | `L_backw a -> LV.node a + + let is_write_only = function + | `L_forw a -> LV.is_write_only a + | `L_backw a -> LV.is_write_only a + end + + module D = Lattice.Lift2(S_forw.D)(S_backw.D) + module GV_forw = GVarF (S_forw.V) + module GV_backw = GVarF (S_backw.V) + module GVar = + struct + type t = [ `G_forw of GV_forw.t | `G_backw of GV_backw.t ] [@@deriving eq, ord, hash] + + let relift = function + | `G_forw x -> `G_forw (GV_forw.relift x) + | `G_backw x -> `G_backw (GV_backw.relift x) + + let pretty_trace () = function + | `G_forw a -> GoblintCil.Pretty.dprintf "G_forw:%a" GV_forw.pretty_trace a + | `G_backw a -> GoblintCil.Pretty.dprintf "G_backw:%a" GV_backw.pretty_trace a + + let printXml f = function + | `G_forw a -> GV_forw.printXml f a + | `G_backw a -> GV_backw.printXml f a + + let var_id = function + | `G_forw a -> GV_forw.var_id a + | `G_backw a -> GV_backw.var_id a + + let node = function + | `G_forw a -> GV_forw.node a + | `G_backw a -> GV_backw.node a + + let is_write_only = function + | `G_forw a -> GV_forw.is_write_only a + | `G_backw a -> GV_backw.is_write_only a + end + + module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) + module G_forw = GVarG (S_forw.G) (S_forw.C) + module G_backw = GVarG (S_backw.G) (S_forw.C) + + module Forward = Constraints_wp.FromSpec (S_forw) (Cfg) + module CfgBackward = struct let prev = Cfg.prev end + module Backward = Constraints.FromSpec (S_backw) (CfgBackward) (I) + + let backw_lv_of_forw ((n,c): LV.t) : Backward.LVar.t = (n, Obj.magic c) + let forw_lv_of_backw ((n,c): Backward.LVar.t) : LV.t = (n, Obj.magic c) + + let to_l_backw (v:LVar.t) = + match v with + | `L_forw (n, l) -> `L_backw (n, l) + | `L_backw (n, l) -> `L_backw (n, l) + + + let cset_to_forw c = + G.CSet.fold (fun x acc -> Forward.G.CSet.add x acc) c (Forward.G.CSet.empty ()) + + let cset_of_forw c = + Forward.G.CSet.fold (fun x acc -> G.CSet.add x acc) c (G.CSet.empty ()) + + let cset_to_backw c = + G.CSet.fold (fun x acc -> G_backw.CSet.add (Obj.magic x) acc) c (G_backw.CSet.empty ()) + + let cset_of_backw c = + G_backw.CSet.fold (fun x acc -> G.CSet.add (Obj.magic x) acc) c (G.CSet.empty ()) + + let to_forw_d (d: D.t) : S_forw.D.t = + match d with + | `Lifted1 d -> d + | `Bot -> S_forw.D.bot () + | `Top -> S_forw.D.top () + | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" + + let to_backw_d (d: D.t) : S_backw.D.t = + match d with + | `Lifted2 d -> d + | `Bot -> S_backw.D.bot () + | `Top -> S_backw.D.top () + | `Lifted1 _ -> failwith "bidirConstrains: backward local got forward value" + + let of_forw_d (d: S_forw.D.t) : D.t = `Lifted1 d + let of_backw_d (d: S_backw.D.t) : D.t = `Lifted2 d + + let to_forw_g (g: G.t) : Forward.G.t = + match g with + | `Lifted1 (`Lifted1 g) -> `Lifted1 g + | `Lifted1 `Bot -> `Bot + | `Lifted1 `Top -> `Top + | `Lifted1 (`Lifted2 _) -> failwith "bidirConstrains: forward global got backward value" + | `Lifted2 c -> `Lifted2 (cset_to_forw c) + | `Bot -> `Bot + | `Top -> `Top + + let to_backw_g (g: G.t) : G_backw.t = + match g with + | `Lifted1 (`Lifted2 g) -> `Lifted1 g + | `Lifted1 `Bot -> `Bot + | `Lifted1 `Top -> `Top + | `Lifted1 (`Lifted1 _) -> failwith "bidirConstrains: backward global got forward value" + | `Lifted2 c -> `Lifted2 (cset_to_backw c) + | `Bot -> `Bot + | `Top -> `Top + + let of_forw_g (g: Forward.G.t) : G.t = + match g with + | `Lifted1 g -> `Lifted1 (`Lifted1 g) + | `Lifted2 c -> `Lifted2 (cset_of_forw c) + | `Bot -> `Bot + | `Top -> `Top + + let of_backw_g (g: G_backw.t) : G.t = + match g with + | `Lifted1 g -> `Lifted1 (`Lifted2 g) + | `Lifted2 c -> `Lifted2 (cset_of_backw c) + | `Bot -> `Bot + | `Top -> `Top + + let sync_backw man = + match man.prev_node, Cfg.next man.prev_node with + | _, _ :: _ :: _ -> (* Join in CFG. *) + S_backw.sync man `Join + | FunctionEntry f, _ -> (* Function entry, also needs sync because partial contexts joined by solver, see 00-sanity/35-join-contexts. *) + S_backw.sync man (`JoinCall f) + | _, _ -> S_backw.sync man `Normal + + let side_context_backw sideg f c = + if !AnalysisState.postsolving then + sideg (GV_backw.contexts f) (G_backw.create_contexts (G_backw.CSet.singleton c)) + + let common_man_backw var edge prev_node pval getl sidel demandl getg sideg : (S_backw.D.t, S_backw.G.t, S_backw.C.t, S_backw.V.t) man * S_backw.D.t list ref * (lval option * varinfo * exp list * S_backw.D.t * bool) list ref = + let r = ref [] in + let spawns = ref [] in + (* now watch this ... *) + let rec man = + { ask = (fun (type a) (q: a Queries.t) -> S_backw.query man q) + ; emit = (fun _ -> failwith "emit outside MCP") + ; node = fst var + ; prev_node = prev_node + ; control_context = snd var |> Obj.obj + ; context = snd var |> Obj.obj + ; edge = edge + ; local = pval + ; global = (fun g -> G_backw.spec (getg (GV_backw.spec g))) + ; spawn = spawn + ; split = (fun (d:S_backw.D.t) es -> assert (List.is_empty es); r := d::!r) + ; sideg = (fun g d -> sideg (GV_backw.spec g) (G_backw.create_spec d)) + } + and spawn ?(multiple=false) lval f args = + (* TODO: adjust man node/edge? *) + (* TODO: don't repeat for all paths that spawn same *) + let ds = S_backw.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_backw.context man fd d in + sidel (FunctionEntry fd, c) d; + demandl (Function fd, c) + | exception Not_found -> + (* unknown function *) + M.error ~category:Imprecise ~tags:[Category Unsound] "Created a thread from unknown function %s" f.vname; + (* actual implementation (e.g. invalidation) is done by threadenter *) + (* must still sync for side effects, e.g., old sync-based none privatization soundness in 02-base/51-spawn-special *) + let rec sync_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man q); + local = d; + prev_node = Function dummyFunDec; + } + in + (* TODO: more accurate man? *) + ignore (sync_backw sync_man) + ) ds + in + (* ... nice, right! *) + let pval = sync_backw man in + { man with local = pval }, r, spawns + + let rec bigsqcup_backw = function + | [] -> S_backw.D.bot () + | [x] -> x + | x::xs -> S_backw.D.join x (bigsqcup_backw xs) + + let thread_spawns_backws man d spawns = + if List.is_empty spawns then + d + else + let rec man' = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' q) + ; local = d + } + in + (* TODO: don't forget path dependencies *) + let one_spawn (lval, f, args, fd, multiple) = + let rec fman = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fman q) + ; local = fd + } + in + S_backw.threadspawn man' ~multiple lval f args fman + in + bigsqcup_backw (List.map one_spawn spawns) + + let common_join_backw man d splits spawns = + thread_spawns_backws man (bigsqcup_backw (d :: splits)) spawns + + let common_joins_backw man ds splits spawns = common_join_backw man (bigsqcup_backw ds) splits spawns + + let tf_assign_backw var edge prev_node lv e getl sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.assign man lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let tf_vdecl_backw var edge prev_node v getl sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.vdecl man v in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let normal_return_backw r fd man sideg = + let spawning_return = S_backw.return man r fd in + let nval = S_backw.sync { man with local = spawning_return } `Return in + nval + + let toplevel_kernel_return_backw r fd man sideg = + let st = if fd.svar.vname = MyCFG.dummy_func.svar.vname then man.local else S_backw.return man r fd in + let spawning_return = S_backw.return {man with local = st} None MyCFG.dummy_func in + let nval = S_backw.sync { man with local = spawning_return } `Return in + nval + + let tf_ret_backw var edge prev_node ret fd getl sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl 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_backw ret fd man sideg + else normal_return_backw ret fd man sideg + in + common_join_backw man d !r !spawns + + let tf_entry_backw var edge prev_node fd getl sidel demandl 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_forw.C.t = snd var |> Obj.obj in + side_context_backw sideg fd (c ()); + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.body man fd in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let tf_test_backw var edge prev_node e tv getl sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.branch man e tv in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + (*TODO: THIS HAS TO BE BACKWARDS*) (*forward context not implemented yet*) + let tf_normal_call_backw man lv e (f:fundec) args getl sidel demandl getg sideg = + let combine (cd, fc, fd) = + if M.tracing then M.traceli "combine" "local: %a" S_backw.D.pretty cd; + if M.tracing then M.trace "combine" "function: %a" S_backw.D.pretty fd; + + Logs.debug "combine: local: %a" S_backw.D.pretty cd; + Logs.debug "combine: function: %a" S_backw.D.pretty fd; + + let rec cd_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query cd_man q); + local = cd; + } + in + 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_man), simulate it here for fd. *) + (* TODO: don't do this extra sync here *) + let rec sync_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man q); + local = fd; + (*prev_node = Function f*) + prev_node = FunctionEntry f; + } + in + (* TODO: more accurate man? *) + let synced = sync_backw sync_man in + let rec fd_man = + { sync_man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd_man q); + local = synced; + } + in + fd_man + in + let r = List.fold_left (fun acc fd1 -> + let rec fd1_man = + { fd_man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd1_man q); + local = fd1; + } + in + let combine_enved = S_backw.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_backw.query combine_assign_man q); + local = combine_enved; + } + in + S_backw.D.join acc (S_backw.combine_assign combine_assign_man lv e f args fc fd1_man.local (Analyses.ask_of_man fd1_man)) + ) (S_backw.D.bot ()) (S_backw.paths_as_set fd_man) + in + if M.tracing then M.traceu "combine" "combined local: %a" S_backw.D.pretty r; + Logs.debug "combined local: %a" S_backw.D.pretty r; + r + in + let paths = + Logs.debug "manager info at call to %a" Node.pretty man.node; + S_backw.enter man lv f args in + (* Wollen eig vorwärts-kontext benutzen *) + let paths = List.map (fun (c,v) -> (c, S_backw.context man f v, v)) paths in + + (* List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; *) + List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (Function f, fc) v) paths; + (* let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (Function f, fc))) paths; *) + (* *) + let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in + + (* Don't filter bot paths, otherwise LongjmpLifter is not called. *) + (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) + let paths = List.map (Tuple3.map2 Option.some) paths in + if M.tracing then M.traceli "combine" "combining"; + Logs.debug "combining"; + let paths = List.map combine paths in + let r = List.fold_left S_backw.D.join (S_backw.D.bot ()) paths in + if M.tracing then M.traceu "combine" "combined: %a" S_backw.D.pretty r; + Logs.debug "combined: %a" S_backw.D.pretty r; + r + + (*TODO: HERE AS WELL*) + let rec tf_proc_backw var edge prev_node lv e args getl sidel demandl getg sideg d = + let tf_special_call man f = + let once once_control init_routine = + (* Executes leave event for new local state d if it is not bottom *) + let leave_once d = + if not (S_backw.D.is_bot d) then + let rec man' = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' q); + local = d; + } + in + S_backw.event man' (Events.LeaveOnce { once_control }) man' + else + S_backw.D.bot () + in + let first_call = + let d' = S_backw.event man (Events.EnterOnce { once_control; ran = false }) man in + tf_proc_backw var edge prev_node None init_routine [] getl sidel demandl getg sideg d' + in + let later_call = S_backw.event man (Events.EnterOnce { once_control; ran = true }) man in + S_backw.D.join (leave_once first_call) (leave_once later_call) + in + let is_once = LibraryFunctions.find ~nowarn:true f in + (* If the prototpye for a library function is wrong, this will throw an exception. Such exceptions are usually unrelated to pthread_once, it is just that the call to `is_once.special` raises here *) + match is_once.special args with + | Once { once_control; init_routine } -> once once_control init_routine + | _ -> S_backw.special man lv f args + in + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let functions = + match e with + | Lval (Var v, NoOffset) -> + (* Handle statically known function call directly. + Allows deactivating base. *) + [v] + | _ -> + (* Depends on base for query. *) + let ad = man.ask (Queries.EvalFunvar e) in + Queries.AD.to_var_may ad (* TODO: don't convert, handle UnknownPtr below *) + (*PROBLEM: Pointer. Brauche Ergebnisse der anderen Analysen*) + in + let one_function f = + match Cil.unrollType f.vtype with + | TFun (_, params, var_arg, _) -> + let arg_length = List.length args in + let p_length = Option.map_default List.length 0 params in + (* Check whether number of arguments fits. *) + (* If params is None, the function or its parameters are not declared, so we still analyze the unknown function call. *) + if Option.is_none params || p_length = arg_length || (var_arg && arg_length >= p_length) then + let d = + (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 man f + | fd -> + tf_normal_call_backw man lv e fd args getl sidel demandl getg sideg + | exception Not_found -> + tf_special_call man f) + in + Some d + else begin + let geq = if var_arg then ">=" else "" in + M.warn ~category:Unsound ~tags:[Category Call; CWE 685] "Potential call to function %a with wrong number of arguments (expected: %s%d, actual: %d). This call will be ignored." CilType.Varinfo.pretty f geq p_length arg_length; + None + end + | _ -> + M.warn ~category:Call "Something that is not a function (%a) is called." CilType.Varinfo.pretty f; + None + in + let funs = List.filter_map one_function functions in + if [] = funs && not (S_backw.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_backw man funs !r !spawns + + let tf_asm_backw var edge prev_node getl sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.asm man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let tf_skip_backw var edge prev_node getl sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.skip man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let tf_backw var getl sidel demandl getg sideg prev_node edge d = + begin match edge with + | Assign (lv,rv) -> tf_assign_backw var edge prev_node lv rv + | VDecl (v) -> tf_vdecl_backw var edge prev_node v + | Proc (r,f,ars) -> tf_proc_backw var edge prev_node r f ars + | Entry f -> tf_entry_backw var edge prev_node f + | Ret (r,fd) -> tf_ret_backw var edge prev_node r fd + | Test (p,b) -> tf_test_backw var edge prev_node p b + | ASM (_, _, _) -> tf_asm_backw var edge prev_node (* TODO: use ASM fields for something? *) + | Skip -> tf_skip_backw var edge prev_node + end getl sidel demandl getg sideg d + + let tf_backw var getl sidel demandl getg sideg prev_node (_,edge) d (f,t) = + (* let old_loc = !Goblint_tracing.current_loc in + let old_loc2 = !Goblint_tracing.next_loc in + Goblint_tracing.current_loc := f; + Goblint_tracing.next_loc := t; + Goblint_backtrace.protect ~mark:(fun () -> TfLocation f) ~finally:(fun () -> + Goblint_tracing.current_loc := old_loc; + Goblint_tracing.next_loc := old_loc2 + ) (fun () -> + let d = tf_backw var getl sidel demandl getg sideg prev_node edge d in + d + ) *) + tf_backw var getl sidel demandl getg sideg prev_node edge d + + let tf_backw (v,c) (edges, u) getl sidel demandl getg sideg = + let pval = getl (u,c) in + let _, locs = List.fold_right (fun (f,e) (t,xs) -> f, (f,t)::xs) edges (Node.location v,[]) in + List.fold_left2 (|>) pval (List.map (tf_backw (v,Obj.repr (fun () -> c)) getl sidel demandl getg sideg u) edges) locs + + let tf_backw (v,c) (e,u) getl sidel demandl getg sideg = + let old_node = !current_node in + let old_fd = Option.map Node.find_fundec old_node |? Cil.dummyFunDec in + let new_fd = Node.find_fundec v in + if not (CilType.Fundec.equal old_fd new_fd) then + Timing.Program.enter new_fd.svar.vname; + let old_context = !M.current_context in + current_node := Some u; + M.current_context := Some (Obj.magic c); (* magic is fine because Spec is top-level Control Spec *) + Fun.protect ~finally:(fun () -> + current_node := old_node; + M.current_context := old_context; + if not (CilType.Fundec.equal old_fd new_fd) then + Timing.Program.exit new_fd.svar.vname + ) (fun () -> + let d = tf_backw (v,c) (e,u) getl sidel demandl getg sideg in + d + ) + + let system_backw (v,c) = + match v with + | FunctionEntry _ -> + let tf_backw getl sidel demandl getg sideg = + let tf' eu = tf_backw (v,c) eu getl sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S_backw.D.join (S_backw.D.bot ()) xs + in + Some tf_backw + | Function _ -> + None + | _ -> + let tf_backw getl sidel demandl getg sideg = + let tf' eu = tf_backw (v,c) eu getl sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S_backw.D.join (S_backw.D.bot ()) xs + in + + Some tf_backw + + + let system var = + match var with + | `L_forw v -> None + (* Forward.system v + |> Option.map (fun tf getl sidel demandl getg sideg -> + let getl' v = getl (`L_forw v) |> to_forw_d in + let sidel' v d = sidel (`L_forw v) (of_forw_d d) in + let demandl' v = demandl (`L_forw v) in + let getg' v = getg (`G_forw v) |> to_forw_g in + let sideg' v d = sideg (`G_forw v) (of_forw_g d) in + tf getl' sidel' demandl' getg' sideg' |> of_forw_d + ) *) + | `L_backw v -> + system_backw v + |> Option.map (fun tf getl sidel demandl getg sideg -> + let getl' v = getl (`L_backw (forw_lv_of_backw v)) |> to_backw_d in + let sidel' v d = sidel (`L_backw (forw_lv_of_backw v)) (of_backw_d d) in + let demandl' v = demandl (`L_backw (forw_lv_of_backw v)) in + let getg' v = getg (`G_backw v) |> to_backw_g in + let sideg' v d = sideg (`G_backw v) (of_backw_g d) in + tf getl' sidel' demandl' getg' sideg' |> of_backw_d + ) + + let iter_vars getl getg vq fl fg = + failwith "damn" + + let sys_change getl getg = + failwith "damn" + + let postmortem = function + | `L_forw v -> List.map (fun v -> `L_forw v) (Forward.postmortem v) + | `L_backw v -> List.map (fun v -> `L_backw (v)) (Backward.postmortem (v)) +end \ No newline at end of file diff --git a/src/framework/constraints_wrapper.ml b/src/framework/constraints_wrapper.ml deleted file mode 100644 index 2477a76e60..0000000000 --- a/src/framework/constraints_wrapper.ml +++ /dev/null @@ -1,91 +0,0 @@ -(** Construction of a {{!Goblint_constraint} constraint system} from an {{!Analyses.Spec} analysis specification} and {{!MyCFG.CfgBackward} CFGs}. - Transformatons of analysis specifications as functors. *) - -open Batteries -open GoblintCil -open MyCFG -open Analyses -open Goblint_constraint.ConstrSys -open GobConfig - - -type Goblint_backtrace.mark += TfLocation of location - -let () = Goblint_backtrace.register_mark_printer (function - | TfLocation loc -> - Some ("transfer function at " ^ CilType.Location.show loc) - | _ -> None (* for other marks *) - ) - - -module type Increment = -sig - val increment: increment_data option -end - - -(** The main point of this file---generating a [DemandGlobConstrSys] from a [Spec]. *) -module Spec_wrapper (S_forwards:Spec) (S_backwards:Spec) (Cfg:CfgBidir) - : sig - include DemandGlobConstrSys with module LVar = VarF (S_forwards.C) - and module GVar = GVarF (S_forwards.V) - and module D = S_forwards.D - and module G = GVarG (S_forwards.G) (S_forwards.C) - end -= -struct - type lv = MyCFG.node * S_forwards.C.t - (* type gv = varinfo *) - type ld = S_forwards.D.t - (* type gd = S_forwards.G.t *) - module LVar = VarF (S_forwards.C) - module GVar = GVarF (S_forwards.V) (* * GVarF (S_backward.V) ## I probably need another functor*) - module D = S_forwards.D - module G = GVarG (S_forwards.G) (S_forwards.C) - - (* Two global invariants: - 1. S_forwards.V -> S_forwards.G -- used for Spec - 2. fundec -> set of S_forwards.C -- used for IterSysVars Node *) - - let system (v,c) = - let wrap (v,c) = - match v with - | FunctionEntry _ -> - let tf getl sidel demandl getg sideg = - let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in - let xs = List.map tf' (Cfg.next v) in - List.fold_left S_forwards.D.join (S_forwards.D.bot ()) xs - in - Some tf - | Function _ -> - None - | _ -> - let tf getl sidel demandl getg sideg = - let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in - let xs = List.map tf' (Cfg.next v) in - List.fold_left S_forwards.D.join (S_forwards.D.bot ()) xs - in - - Some tf - - in - - (* Logs.debug "# Creating transfer function for %s" (Node.show v); - Logs.debug " Number of nexts: %d" (List.length (Cfg.next v)) ; - Logs.debug " Number of prevs: %d" (List.length (Cfg.prev v)) ; *) - wrap (v,c) - - - (* what does this do? *) - let iter_vars getl getg vq fl fg = - failwith "iter_vars not implemented in WP" - - - let sys_change getl getg = - failwith "sys_change not implemented in WP" - - (*What does this do?*) - let postmortem = function - | FunctionEntry fd, c -> [(Function fd, c)] - | _ -> [] -end diff --git a/src/framework/control.ml b/src/framework/control.ml index 0f4e6c1db8..d9d4bf952f 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -12,9 +12,62 @@ open Goblint_constraint.SolverTypes open GobConfig open Constraints open SpecLifters +open BidirConstrains module type S2S = Spec2Spec +(*module that takes a Spec and a Context Domain type C and returns a SPec using this context instead*) +module ContextOverride (S: Spec) (C: Printable.S) : Spec with module C = C = +struct + module D = S.D + module G = S.G + module C = C + module V = S.V + module P = S.P + + let name = S.name + + type marshal = S.marshal + let init = S.init + let finalize = S.finalize + + let startstate = S.startstate + let morphstate = S.morphstate + let exitstate = S.exitstate + + let coerce_man (man: (D.t, G.t, C.t, V.t) man) : (D.t, G.t, S.C.t, V.t) man = + Obj.magic man + + let context man fd d = Obj.magic (S.context (coerce_man man) fd d) + let startcontext () = Obj.magic (S.startcontext ()) + + let sync man k = S.sync (coerce_man man) k + let query man q = S.query (coerce_man man) q + + let assign man lv e = S.assign (coerce_man man) lv e + let vdecl man v = S.vdecl (coerce_man man) v + let branch man e b = S.branch (coerce_man man) e b + let body man fd = S.body (coerce_man man) fd + let return man r fd = S.return (coerce_man man) r fd + let asm man = S.asm (coerce_man man) + let skip man = S.skip (coerce_man man) + let special man lv f args = S.special (coerce_man man) lv f args + let enter man lv f args = S.enter (coerce_man man) lv f args + let event man ev man2 = S.event (coerce_man man) ev (coerce_man man2) + + let combine_env man lv e f args c d ask = + S.combine_env (coerce_man man) lv e f args (Obj.magic c) d ask + let combine_assign man lv e f args c d ask = + S.combine_assign (coerce_man man) lv e f args (Obj.magic c) d ask + + let paths_as_set man = S.paths_as_set (coerce_man man) + let threadenter man ~multiple lv f args = S.threadenter (coerce_man man) ~multiple lv f args + let threadspawn man ~multiple lv f args fman = + S.threadspawn (coerce_man man) ~multiple lv f args (coerce_man fman) +end + + + (* spec is lazy, so HConsed table in Hashcons lifters is preserved between analyses in server mode *) let spec_module: (module Spec) Lazy.t = lazy ( GobConfig.building_spec := true; @@ -1588,32 +1641,25 @@ struct output_wp_results_to_xml lh; end +module AnalyzeCFG_3 (Cfg:CfgBidirSkip) (Spec_forw:Spec) (Spec_backw: Spec with type C.t = Spec_forw.C.t ) (Inc:Increment) = -(** Given a [Cfg] and a [Spec], and unused [Inc] computes the solution to [???] *) -module AnalyzeCFG_WP (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = struct - module SpecSys: SpecSys with module Spec = Spec = - struct - (* Must be created in module, because cannot be wrapped in a module later. *) - module Spec = Spec + (* The Equation system *) + module EQSys = BidirConstrains.BidirFromSpec (Spec_forw) (Spec_backw) (Cfg) (Inc) - (* The Equation system *) - module EQSys = Constraints_wp.FromSpec (Spec) (Cfg) + (* Hashtbl for locals *) + module LHT = BatHashtbl.Make (EQSys.LVar) + (* Hashtbl for globals *) + module GHT = BatHashtbl.Make (EQSys.GVar) - (* Hashtbl for locals *) - module LHT = BatHashtbl.Make (EQSys.LVar) - (* Hashtbl for globals *) - module GHT = BatHashtbl.Make (EQSys.GVar) - end - open SpecSys (* The solver *) module PostSolverArg = struct let should_prune = true - let should_verify = get_bool "verify" + let should_verify = true (*get_bool "verify"*) let should_warn = get_string "warn_at" <> "never" let should_save_run = (* copied from solve_and_postprocess *) @@ -1622,55 +1668,21 @@ struct save_run <> "" end module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) - (* The comparator *) - module CompareGlobSys = CompareConstraints.CompareGlobSys (SpecSys) - (* Triple of the function, context, and the local value. *) - module RT = AnalysisResult.ResultType2 (Spec) - (* Set of triples [RT] *) - module LT = SetDomain.HeadlessSet (RT) - (* Analysis result structure---a hashtable from program points to [LT] *) - module Result = AnalysisResult.Result (LT) (struct let result_name = "wp_analysis" end) - module ResultOutput = AnalysisResultOutput.Make (Result) + (* Triple of the function, context, and the local value. It uses SPec and therefore hast the wrong types.*) + (* module RT = AnalysisResult.ResultType2 (Spec) + module LT = SetDomain.HeadlessSet (RT) *) - module Query = ResultQuery.Query (SpecSys) + (* Analysis result structure---a hashtable from program points to [LT] *) + (* module Result = AnalysisResult.Result (LT) (struct let result_name = "wp_analysis" end) + module ResultOutput = AnalysisResultOutput.Make (Result) *) - let solver2source_result h : Result.t = - (* processed result *) - let res = Result.create 113 in + (* not having a Query module is problematic!*) + (* module Query = ResultQuery.Query (SpecSys) *) - (* Adding the state at each system variable to the final result *) - let add_local_var (n,es) state = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let loc = UpdateCil.getLoc n in - if loc <> locUnknown then try - let fundec = Node.find_fundec n in - if Result.mem res n then - (* If this source location has been added before, we look it up - * and add another node to it information to it. *) - let prev = Result.find res n in - Result.replace res n (LT.add (es,state,fundec) prev) - else - Result.add res n (LT.singleton (es,state,fundec)) - (* If the function is not defined, and yet has been included to the - * analysis result, we generate a warning. *) - with Not_found -> - Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n - in - LHT.iter add_local_var h; - res - (** The main function to preform the selected analyses. *) + (** [analyze file startfuns exitfuns otherfuns] is the main function to preform the selected analyses.*) let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = - Messages.warn "Starting analysis '%s:'" (Spec.name ()); - - Logs.debug "Spec: Type of D: %s" (Spec.D.name ()); - Logs.debug "Spec: Type of G: %s" (Spec.G.name ()); - - Logs.debug "Startfuns: %s" (List.fold_left (fun a f -> a ^ " ; " ^ f.svar.vname) "" startfuns); - - (*## COPIED ##*) let module FileCfg: FileCfg = struct let file = file @@ -1678,8 +1690,101 @@ struct end in + let () = + let log_fun_list name funs = + let fun_names = List.map (fun f -> f.svar.vname) funs in + Logs.debug "%s functions: %s" name (String.concat ", " fun_names) + in + Logs.debug "================= Analysis Setup ================"; + log_fun_list "Start" startfuns; + log_fun_list "Exit" exitfuns; + log_fun_list "Other" otherfuns; + Logs.debug "================================================"; + in + AnalysisState.should_warn := false; (* reset for server mode *) + (* muss iwie die typen exposen..?*) + + (* Doing forwards and backwards inits*) + (* Simulate globals before analysis. *) + let gh = GHT.create 13 in + let getg v = GHT.find_default gh v (EQSys.G.bot ()) in + let sideg v d = GHT.replace gh v (EQSys.G.join (getg v) d) + in + + let do_forwards_inits () = + + (* analyze cil's global-inits function to get a starting state *) + let do_global_inits (file: file) : Spec_forw.D.t * fundec list = + 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 () -> man_failwith "Global initializers have no context.") + ; context = (fun () -> man_failwith "Global initializers have no context.") + ; edge = MyCFG.Skip + ; local = EQSys.D.top () + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Global initializers trying to split paths.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + + let edges = CfgTools.getGlobalInits file in + Logs.debug "Executing %d assigns." (List.length edges); + let funs = ref [] in + + let transfer_func (st : Spec_forw.D.t) (loc, edge) : Spec.D.t = + match edge with + | MyCFG.Entry func -> Spec.body {man with local = st} func + | MyCFG.Assign (lval,exp) -> + begin match lval, exp with + | (Var v,o), (AddrOf (Var f,NoOffset)) + when v.vstorage <> Static && isFunctionType f.vtype -> + (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) + | _ -> () + end; + let res = Spec_forw.assign {man with local = st} lval exp in + (* Needed for privatizations (e.g. None) that do not side immediately *) + let res' = Spec_forw.sync {man with local = res} `Normal in + res' + | _ -> failwith "Unsupported global initializer edge" + in + + let with_externs = do_extern_inits man file in + let result : Spec.D.t = List.fold_left transfer_func with_externs edges in + result, !funs + in + + + let startstate, _ = do_global_inits file + + in + startstate + in + + let do_backwards_inits () = () in + + let calculate_solver_input () = () in + + let solve () = + let solver_data = None in + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in + lh, gh + in + + + + + + + + + + (* add extern variables to local state *) let do_extern_inits man (file : file) : Spec.D.t = let module VS = Set.Make (Basetype.Variables) in @@ -1707,15 +1812,6 @@ struct in foldGlobals file add_externs (Spec.startstate MyCFG.dummy_func.svar) in - - (* Simulate globals before analysis. *) - (* TODO: make extern/global inits part of constraint system so all of this would be unnecessary. *) - let gh = GHT.create 13 in - let getg v = GHT.find_default gh v (EQSys.G.bot ()) in - let sideg v d = - if M.tracing then M.trace "global_inits" "sideg %a = %a" EQSys.GVar.pretty v EQSys.G.pretty d; - GHT.replace gh v (EQSys.G.join (getg v) d) - in (* Old-style global function for context. * This indirectly prevents global initializers from depending on each others' global side effects, which would require proper solving. *) let getg v = EQSys.G.bot () in @@ -1740,17 +1836,11 @@ struct let edges = CfgTools.getGlobalInits file in Logs.debug "Executing %d assigns." (List.length edges); let funs = ref [] in - (*let count = ref 0 in*) + let transfer_func (st : Spec.D.t) (loc, edge) : Spec.D.t = - if M.tracing then M.trace "con" "Initializer %a" CilType.Location.pretty loc; - (*incr count; - if (get_bool "dbg.verbose")&& (!count mod 1000 = 0) then Printf.printf "%d %!" !count; *) match edge with - | MyCFG.Entry func -> - if M.tracing then M.trace "global_inits" "Entry %a" d_lval (var func.svar); - Spec.body {man with local = st} func + | MyCFG.Entry 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 | (Var v,o), (AddrOf (Var f,NoOffset)) when v.vstorage <> Static && isFunctionType f.vtype -> @@ -1760,50 +1850,18 @@ struct 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 {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 transfer_func st (loc, edge) = - let old_loc = !Goblint_tracing.current_loc in - Goblint_tracing.current_loc := loc; - (* TODO: next_loc? *) - Goblint_backtrace.protect ~mark:(fun () -> Constraints.TfLocation loc) ~finally:(fun () -> - Goblint_tracing.current_loc := old_loc; - ) (fun () -> - transfer_func st (loc, edge) - ) - 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 result : Spec.D.t = List.fold_left transfer_func with_externs edges in - if M.tracing then M.trace "global_inits" "startstate: %a" Spec.D.pretty result; result, !funs in - let print_globals glob = - let out = M.get_out (Spec.name ()) !M.out in - let print_one v st = - ignore (Pretty.fprintf out "%a -> %a\n" EQSys.GVar.pretty_trace v EQSys.G.pretty st) - in - GHT.iter print_one glob - in - (* real beginning of the [analyze] function *) - if get_bool "ana.sv-comp.enabled" then - Witness.init (module FileCfg); (* TODO: move this out of analyze_loop *) - YamlWitness.init (); - AnalysisState.global_initialization := true; - GobConfig.earlyglobs := get_bool "exp.earlyglobs"; - let marshal: Spec.marshal option = - if get_string "load_run" <> "" then - Some (Serialize.unmarshal Fpath.(v (get_string "load_run") / "spec_marshal")) - else if Serialize.results_exist () && get_bool "incremental.load" then - Some (Serialize.Cache.(get_data AnalysisData)) - else - None - in + let marshal: Spec.marshal option = None in (* Some happen in init, so enable this temporarily (if required by option). *) AnalysisState.should_warn := PostSolverArg.should_warn; @@ -1811,27 +1869,10 @@ struct Access.init file; AnalysisState.should_warn := false; - let test_domain (module D: Lattice.S): unit = - let module DP = DomainProperties.All (D) in - Logs.debug "domain testing...: %s" (D.name ()); - let errcode = QCheck_base_runner.run_tests DP.tests in - if (errcode <> 0) then - failwith "domain tests failed" - in - let _ = - if (get_bool "dbg.test.domain") then ( - Logs.debug "domain testing analysis...: %s" (Spec.name ()); - test_domain (module Spec.D); - test_domain (module Spec.G); - ) - in - let startstate, more_funs = - Logs.debug "Initializing %d globals." (CfgTools.numGlobals file); - Timing.wrap "global_inits" do_global_inits file - in + let startstate, _ = do_global_inits file in - let otherfuns = if get_bool "kernel" then otherfuns @ more_funs else otherfuns in + let otherfuns = otherfuns in let enter_with st fd = let st = st fd.svar in @@ -1894,30 +1935,6 @@ struct AnalysisState.global_initialization := false; - 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec.startcontext - ; edge = MyCFG.Skip - ; local = e - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - - (*## COPIED ##*) - - (* empty entrystates:*) - (* let entrystates = [] in - let entrystates_global = [] in - let startvars' = [] in *) - - (* Non-Empty entrystates copied*) let man e = { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) ; emit = (fun _ -> failwith "Cannot \"emit\" in enter_with context.") @@ -1934,38 +1951,724 @@ struct } in let startvars' = - if get_bool "exp.forward" then + (* if get_bool "exp.forward" then *) + if true then (*does this deside which variables I query?*) 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 (man e) n e)) startvars in - let entrystates = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (man e) n e), e) startvars in + (* let entrystates = List.clearmap (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (man e) n e), e) startvars in *) + let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec.context (man e) n e), e) startvars in let entrystates_global = GHT.to_list gh in - (*what if i use exitwars as starvars? *) + let uncalled_dead = ref 0 in - let (local_res, global_res), _ = Slvr.solve entrystates entrystates_global startvars' None in - let local_xml = solver2source_result local_res in + let solve_and_postprocess () = + let lh, gh = + let solver_data = None in + Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); - let make_global_fast_xml f g = - let open Printf in - let print_globals k v = - fprintf f "\n%s%a" (XmlUtil.escape (EQSys.GVar.show k)) EQSys.G.printXml v; - in - GHT.iter print_globals g - in + (*######################### START OF ACTUAL SOLVING ##########################*) + (*### START OF LOG ###*) + (*print set of entrystates, entrystatex_global and startvars'*) + let log_analysis_inputs () = + Logs.debug "=== Analysis Inputs ==="; - ResultOutput.output (lazy local_xml) (fun _ -> true) global_res make_global_fast_xml (module FileCfg); - (); + (* Log entrystates *) + Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); + List.iteri (fun i ((node, ctx), state) -> + Logs.debug "EntryState %d:" (i + 1); + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec.C.pretty ctx; + Logs.debug " State: %a" Spec.D.pretty state; + ) entrystates; + (* Log entrystates_global *) + Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); + List.iteri (fun i (gvar, gstate) -> + Logs.debug "GlobalEntryState %d:" (i + 1); + Logs.debug " GVar: %a" EQSys.GVar.pretty gvar; + Logs.debug " GState: %a" EQSys.G.pretty gstate; + ) entrystates_global; -end + (* Log startvars' *) + Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); + List.iteri (fun i (node, ctx) -> + Logs.debug "StartVar %d:" (i + 1); + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec.C.pretty ctx; + ) startvars'; -(** This function was originally a part of the [AnalyzeCFG] module, but - now that [AnalyzeCFG] takes [Spec] as a functor parameter, - [analyze_loop] cannot reside in it anymore since each invocation of + (* Log startvars (without apostrophe) *) + Logs.debug "--- Start Variables (no apostrophe) (count: %d) ---" (List.length startvars); + List.iteri (fun i (node, state) -> + Logs.debug "StartVar (no apostrophe) %d:" (i + 1); + Logs.debug " Node: %a" CilType.Fundec.pretty node; + Logs.debug " State: (of type EQSys.D.t) %a" Spec.D.pretty state; + ) startvars; + + Logs.debug "=== End Analysis Inputs ===" + in + log_analysis_inputs (); + (*### END OF LOG ###*) + + AnalysisState.should_warn := get_string "warn_at" = "early"; + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in + lh, gh + + (*######################### END OF ACTUAL SOLVING ##########################*) + + in + + (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) + AnalysisState.should_warn := PostSolverArg.should_warn; + + let insrt k _ s = match k with + | (MyCFG.Function fn,_) -> if not (get_bool "exp.forward") then Set.Int.add fn.svar.vid s else s + | (MyCFG.FunctionEntry fn,_) -> if (get_bool "exp.forward") then Set.Int.add fn.svar.vid s else s + | _ -> s + in + (* set of ids of called functions *) + let calledFuns = LHT.fold insrt lh Set.Int.empty in + let is_bad_uncalled fn loc = + not (Set.Int.mem fn.vid calledFuns) && + not (Str.last_chars loc.file 2 = ".h") && + not (LibraryFunctions.is_safe_uncalled fn.vname) && + not (Cil.hasAttribute "goblint_stub" fn.vattr) + in + + let print_and_calculate_uncalled = function + | GFun (fn, loc) when is_bad_uncalled fn.svar loc-> + let cnt = Cilfacade.countLoc fn in + uncalled_dead := !uncalled_dead + cnt; + if get_bool "ana.dead-code.functions" then + M.warn ~loc:(CilLocation loc) ~category:Deadcode "Function '%a' is uncalled: %d LLoC" CilType.Fundec.pretty fn cnt (* CilLocation is fine because always printed from scratch *) + | _ -> () + in + List.iter print_and_calculate_uncalled file.globals; + + (* check for dead code at the last state: *) + let main_sol = try LHT.find lh (List.hd startvars') with Not_found -> EQSys.D.bot () in + if EQSys.D.is_bot main_sol then + M.warn_noloc ~category:Deadcode "Function 'main' does not return"; + + (* run activated transformations with the analysis result *) + let active_transformations = get_string_list "trans.activated" in + if active_transformations <> [] then ( + + (* Most transformations use the locations of statements, since they run using Cil visitors. + Join abstract values once per location and once per node. *) + let joined_by_loc, joined_by_node = + let open Enum in + let node_values = LHT.enum lh |> map (Tuple2.map1 fst) in (* drop context from key *) (* nosemgrep: batenum-enum *) + let hashtbl_size = if fast_count node_values then count node_values else 123 in + let by_loc, by_node = Hashtbl.create hashtbl_size, NodeH.create hashtbl_size in + iter (fun (node, v) -> + let loc = match node with + | Statement s -> Cil.get_stmtLoc s.skind (* nosemgrep: cilfacade *) (* Must use CIL's because syntactic search is in CIL. *) + | FunctionEntry _ | Function _ -> Node.location node + in + (* join values once for the same location and once for the same node *) + let join = Option.some % function None -> v | Some v' -> Spec.D.join v v' in + Hashtbl.modify_opt loc join by_loc; + NodeH.modify_opt node join by_node; + ) node_values; + by_loc, by_node + in + + let ask ?(node = MyCFG.dummy_node) loc = + let f (type a) (q : a Queries.t) : a = + match Hashtbl.find_option joined_by_loc loc with + | None -> Queries.Result.bot q + | Some local -> Query.ask_local_node gh node local q + in + ({ f } : Queries.ask) + in + + (* A node is dead when its abstract value is bottom in all contexts; + it holds that: bottom in all contexts iff. bottom in the join of all contexts. + Therefore, we just answer whether the (stored) join is bottom. *) + let must_be_dead node = + NodeH.find_option joined_by_node node + (* nodes that didn't make it into the result are definitely dead (hence for_all) *) + |> GobOption.for_all Spec.D.is_bot + in + + let must_be_uncalled fd = not @@ BatSet.Int.mem fd.svar.vid calledFuns in + + let skipped_statements from_node edge to_node = + try + Cfg.skippedByEdge from_node edge to_node + with Not_found -> + [] + in + + Transform.run_transformations file active_transformations + { ask ; must_be_dead ; must_be_uncalled ; + cfg_forward = Cfg.next ; cfg_backward = Cfg.prev ; skipped_statements }; + ); + + lh, gh + in + + (* Use "normal" constraint solving *) + let timeout_reached () = + M.error "Timeout reached!"; + raise Timeout.Timeout + in + let timeout = get_string "dbg.timeout" |> TimeUtil.seconds_of_duration_string in + let lh, gh = Timeout.wrap solve_and_postprocess () (float_of_int timeout) timeout_reached in + + let module SpecSysSol: SpecSysSol with module SpecSys = SpecSys = + struct + module SpecSys = SpecSys + let lh = lh + let gh = gh + end + in + let module R: ResultQuery.SpecSysSol2 with module SpecSys = SpecSys = ResultQuery.Make (FileCfg) (SpecSysSol) in + + let local_xml = solver2source_result lh in + current_node_state_json := (fun node -> Option.map LT.to_yojson (Result.find_option local_xml node)); + + current_varquery_global_state_json := (fun vq_opt -> + let iter_vars f = match vq_opt with + | None -> GHT.iter (fun v _ -> f v) gh + | Some vq -> + EQSys.iter_vars + (fun x -> try LHT.find lh x with Not_found -> EQSys.D.bot ()) + (fun x -> try GHT.find gh x with Not_found -> EQSys.G.bot ()) + vq + (fun _ -> ()) + f + in + (* TODO: optimize this once server has a way to properly convert vid -> varinfo *) + let vars = GHT.create 113 in + iter_vars (fun x -> + GHT.replace vars x () + ); + let assoc = GHT.fold (fun x g acc -> + if GHT.mem vars x then + (EQSys.GVar.show x, EQSys.G.to_yojson g) :: acc + else + acc + ) gh [] + in + `Assoc assoc + ); + + let liveness = + if get_bool "ana.dead-code.lines" || get_bool "ana.dead-code.branches" then + print_dead_code local_xml !uncalled_dead + else + fun _ -> true (* TODO: warn about conflicting options *) + in + + if get_bool "exp.cfgdot" then + CfgTools.dead_code_cfg ~path:(Fpath.v "cfgs") (module FileCfg) liveness; + + let warn_global g v = + (* Logs.debug "warn_global %a %a" EQSys.GVar.pretty_trace g EQSys.G.pretty v; *) + match g with + | `Left g -> (* Spec global *) + R.ask_global (WarnGlobal (Obj.repr g)) + | `Right _ -> (* contexts global *) + () + in + Timing.wrap "warn_global" (GHT.iter warn_global) gh; + + if get_bool "exp.arg.enabled" then ( + let module ArgTool = ArgTools.Make (R) in + let module Arg = (val ArgTool.create entrystates) in + let arg_dot_path = get_string "exp.arg.dot.path" in + if arg_dot_path <> "" then ( + let module NoLabelNodeStyle = + struct + type node = Arg.Node.t + let extra_node_styles node = + match GobConfig.get_string "exp.arg.dot.node-label" with + | "node" -> [] + | "empty" -> ["label=\"_\""] (* can't have empty string because graph-easy will default to node ID then... *) + | _ -> assert false + end + in + let module ArgDot = ArgTools.Dot (Arg) (NoLabelNodeStyle) in + Out_channel.with_open_text arg_dot_path (fun oc -> + let ppf = Stdlib.Format.formatter_of_out_channel oc in + ArgDot.dot ppf; + Format.pp_print_flush ppf () + ) + ); + ArgTools.current_arg := Some (module Arg); + ); + + if get_string "result" <> "none" then Logs.debug "Generating output: %s" (get_string "result"); + + Messages.finalize (); + + (*Iterating through elements of lh and Logging the contents*) + let log_lh_contents lh = + Messages.warn "=== LHT Contents ==="; let count = ref 0 in + + Logs.debug "--- Full entry details ---"; + LHT.iter (fun (node, ctx) state -> + incr count; + Logs.debug "Entry %d:" !count; + Logs.debug " Node: %a" Node.pretty_trace node; + + (* Test context pretty printing *) + (try + Logs.debug " Context: %a" Spec.C.pretty ctx + with e -> + Logs.debug " Context: ERROR - %s" (Printexc.to_string e) + ); + + (* Check state properties *) + (* Logs.debug " State is_top: %b" (Spec.D.is_top state); + Logs.debug " State is_bot: %b" (Spec.D.is_bot state); *) + + (* Test state pretty printing with exception handling *) + (try + Logs.debug " State: %a" Spec.D.pretty state + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + ) lh; + Logs.debug "Total entries in LHT: %d" !count; + Logs.debug "=== End LHT Contents ===" + in + log_lh_contents lh; + + (*Script adding these results to the already existing node xml files*) + let output_wp_results_to_xml lh = + (* iterate through all nodes and update corresponding .xml in result/nodes *) + LHT.iter (fun (node, ctx) state -> + try + (* Get node ID as string *) + (* let node_id_str = match node with + | MyCFG.Statement stmt -> string_of_int stmt.sid + | MyCFG.FunctionEntry fundec -> string_of_int fundec.svar.vid + | _ -> raise Not_found (* Skip non-statement nodes *) + in *) + let node_id_str = Node.show_id node in + + let xml_path = Filename.concat "./result/nodes" (node_id_str ^ ".xml") in + if Sys.file_exists xml_path then ( + (* Read existing XML *) + let ic = Stdlib.open_in xml_path in + let content = Stdlib.really_input_string ic (Stdlib.in_channel_length ic) in + Stdlib.close_in ic; + + (* Create WP analysis data *) + let wp_res = Pretty.sprint 100 (Spec.D.pretty () state) in + let wp_data = + "\n\n\n\n" ^ wp_res ^" \n\n\n\n\n" + in + + (* Insert before *) + let close_pattern = "" in + let updated_content = + try + let insert_pos = Str.search_backward (Str.regexp_string close_pattern) content (String.length content) in + let before = String.sub content 0 insert_pos in + let after = String.sub content insert_pos (String.length content - insert_pos) in + before ^ wp_data ^ after + with Not_found -> + content ^ wp_data + in + + (* Write back *) + let oc = Stdlib.open_out xml_path in + Stdlib.output_string oc updated_content; + Stdlib.close_out oc; + Logs.debug "Updated XML file for node %s" node_id_str + ) + with _ -> () (* Skip errors silently *) + ) lh + in + output_wp_results_to_xml lh; +end + + +(** Given a [Cfg] and a [Spec], and unused [Inc] computes the solution to [???] *) +module AnalyzeCFG_WP (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = +struct + + module SpecSys: SpecSys with module Spec = Spec = + struct + (* Must be created in module, because cannot be wrapped in a module later. *) + module Spec = Spec + + (* The Equation system *) + module EQSys = Constraints_wp.FromSpec (Spec) (Cfg) + + (* Hashtbl for locals *) + module LHT = BatHashtbl.Make (EQSys.LVar) + (* Hashtbl for globals *) + module GHT = BatHashtbl.Make (EQSys.GVar) + end + + open SpecSys + + (* The solver *) + module PostSolverArg = + struct + let should_prune = true + let should_verify = get_bool "verify" + let should_warn = get_string "warn_at" <> "never" + let should_save_run = + (* copied from solve_and_postprocess *) + let gobview = get_bool "gobview" in + let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in + save_run <> "" + end + module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) + (* The comparator *) + module CompareGlobSys = CompareConstraints.CompareGlobSys (SpecSys) + + (* Triple of the function, context, and the local value. *) + module RT = AnalysisResult.ResultType2 (Spec) + (* Set of triples [RT] *) + module LT = SetDomain.HeadlessSet (RT) + (* Analysis result structure---a hashtable from program points to [LT] *) + module Result = AnalysisResult.Result (LT) (struct let result_name = "wp_analysis" end) + module ResultOutput = AnalysisResultOutput.Make (Result) + + module Query = ResultQuery.Query (SpecSys) + + let solver2source_result h : Result.t = + (* processed result *) + let res = Result.create 113 in + + (* Adding the state at each system variable to the final result *) + let add_local_var (n,es) state = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let loc = UpdateCil.getLoc n in + if loc <> locUnknown then try + let fundec = Node.find_fundec n in + if Result.mem res n then + (* If this source location has been added before, we look it up + * and add another node to it information to it. *) + let prev = Result.find res n in + Result.replace res n (LT.add (es,state,fundec) prev) + else + Result.add res n (LT.singleton (es,state,fundec)) + (* If the function is not defined, and yet has been included to the + * analysis result, we generate a warning. *) + with Not_found -> + Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n + in + LHT.iter add_local_var h; + res + + (** The main function to preform the selected analyses. *) + let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = + Messages.warn "Starting analysis '%s:'" (Spec.name ()); + + Logs.debug "Spec: Type of D: %s" (Spec.D.name ()); + Logs.debug "Spec: Type of G: %s" (Spec.G.name ()); + + Logs.debug "Startfuns: %s" (List.fold_left (fun a f -> a ^ " ; " ^ f.svar.vname) "" startfuns); + + (*## COPIED ##*) + let module FileCfg: FileCfg = + struct + let file = file + module Cfg = Cfg + end + in + + AnalysisState.should_warn := false; (* reset for server mode *) + + (* add extern variables to local state *) + 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 + | _ -> s + in + let vars = foldGlobals file add_glob VS.empty in + let set_bad v st = + Spec.assign {man with local = st} (var v) MyCFG.unknown_exp + in + let is_std = function + | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) + | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) + | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) + | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) + | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) + | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) + true + | _ -> false + in + let add_externs s = function + | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s + | _ -> s + in + foldGlobals file add_externs (Spec.startstate MyCFG.dummy_func.svar) + in + + (* Simulate globals before analysis. *) + (* TODO: make extern/global inits part of constraint system so all of this would be unnecessary. *) + let gh = GHT.create 13 in + let getg v = GHT.find_default gh v (EQSys.G.bot ()) in + let sideg v d = + if M.tracing then M.trace "global_inits" "sideg %a = %a" EQSys.GVar.pretty v EQSys.G.pretty d; + GHT.replace gh v (EQSys.G.join (getg v) d) + in + (* Old-style global function for context. + * This indirectly prevents global initializers from depending on each others' global side effects, which would require proper solving. *) + let getg v = EQSys.G.bot () in + + (* analyze cil's global-inits function to get a starting state *) + let do_global_inits (file: file) : Spec.D.t * fundec list = + 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 () -> 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))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Global initializers trying to split paths.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let edges = CfgTools.getGlobalInits file in + Logs.debug "Executing %d assigns." (List.length edges); + let funs = ref [] in + (*let count = ref 0 in*) + let transfer_func (st : Spec.D.t) (loc, edge) : Spec.D.t = + if M.tracing then M.trace "con" "Initializer %a" CilType.Location.pretty loc; + (*incr count; + if (get_bool "dbg.verbose")&& (!count mod 1000 = 0) then Printf.printf "%d %!" !count; *) + match edge with + | MyCFG.Entry func -> + if M.tracing then M.trace "global_inits" "Entry %a" d_lval (var func.svar); + 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 + | (Var v,o), (AddrOf (Var f,NoOffset)) + when v.vstorage <> Static && isFunctionType f.vtype -> + (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) + | _ -> () + end; + 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 {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 transfer_func st (loc, edge) = + let old_loc = !Goblint_tracing.current_loc in + Goblint_tracing.current_loc := loc; + (* TODO: next_loc? *) + Goblint_backtrace.protect ~mark:(fun () -> Constraints.TfLocation loc) ~finally:(fun () -> + Goblint_tracing.current_loc := old_loc; + ) (fun () -> + transfer_func st (loc, edge) + ) + 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 result : Spec.D.t = List.fold_left transfer_func with_externs edges in + if M.tracing then M.trace "global_inits" "startstate: %a" Spec.D.pretty result; + result, !funs + in + + let print_globals glob = + let out = M.get_out (Spec.name ()) !M.out in + let print_one v st = + ignore (Pretty.fprintf out "%a -> %a\n" EQSys.GVar.pretty_trace v EQSys.G.pretty st) + in + GHT.iter print_one glob + in + + (* real beginning of the [analyze] function *) + if get_bool "ana.sv-comp.enabled" then + Witness.init (module FileCfg); (* TODO: move this out of analyze_loop *) + YamlWitness.init (); + + AnalysisState.global_initialization := true; + GobConfig.earlyglobs := get_bool "exp.earlyglobs"; + let marshal: Spec.marshal option = + if get_string "load_run" <> "" then + Some (Serialize.unmarshal Fpath.(v (get_string "load_run") / "spec_marshal")) + else if Serialize.results_exist () && get_bool "incremental.load" then + Some (Serialize.Cache.(get_data AnalysisData)) + else + None + in + + (* Some happen in init, so enable this temporarily (if required by option). *) + AnalysisState.should_warn := PostSolverArg.should_warn; + Spec.init marshal; + Access.init file; + AnalysisState.should_warn := false; + + let test_domain (module D: Lattice.S): unit = + let module DP = DomainProperties.All (D) in + Logs.debug "domain testing...: %s" (D.name ()); + let errcode = QCheck_base_runner.run_tests DP.tests in + if (errcode <> 0) then + failwith "domain tests failed" + in + let _ = + if (get_bool "dbg.test.domain") then ( + Logs.debug "domain testing analysis...: %s" (Spec.name ()); + test_domain (module Spec.D); + test_domain (module Spec.G); + ) + in + + let startstate, more_funs = + Logs.debug "Initializing %d globals." (CfgTools.numGlobals file); + Timing.wrap "global_inits" do_global_inits file + in + + let otherfuns = if get_bool "kernel" then otherfuns @ more_funs else otherfuns in + + let enter_with st fd = + let st = st fd.svar in + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec.startcontext + ; edge = MyCFG.Skip + ; local = st + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in + let ents = Spec.enter man None fd args in + List.map (fun (_,s) -> fd, s) ents + in + + (try MyCFG.dummy_func.svar.vdecl <- (List.hd otherfuns).svar.vdecl with Failure _ -> ()); + + let startvars = + if startfuns = [] + then [[MyCFG.dummy_func, startstate]] + else + let morph f = Spec.morphstate f startstate in + List.map (enter_with morph) startfuns + in + + let exitvars = List.map (enter_with Spec.exitstate) exitfuns in + let otherstate st v = + 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 () -> 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))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + (* TODO: don't hd *) + 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 *) + let othervars = List.map (enter_with (otherstate prestartstate)) otherfuns in + let startvars = List.concat (startvars @ exitvars @ othervars) in + if startvars = [] then + failwith "BUG: Empty set of start variables; may happen if enter_func of any analysis returns an empty list."; + + AnalysisState.global_initialization := false; + + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec.startcontext + ; edge = MyCFG.Skip + ; local = e + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + + (*## COPIED ##*) + + (* empty entrystates:*) + (* let entrystates = [] in + let entrystates_global = [] in + let startvars' = [] in *) + + (* Non-Empty entrystates copied*) + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec.startcontext + ; edge = MyCFG.Skip + ; local = e + ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + } + in + let startvars' = + if get_bool "exp.forward" then + 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 (man e) n 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 + + (*what if i use exitwars as starvars? *) + + let (local_res, global_res), _ = Slvr.solve entrystates entrystates_global startvars' None in + let local_xml = solver2source_result local_res in + + let make_global_fast_xml f g = + let open Printf in + let print_globals k v = + fprintf f "\n%s%a" (XmlUtil.escape (EQSys.GVar.show k)) EQSys.G.printXml v; + in + GHT.iter print_globals g + in + + + ResultOutput.output (lazy local_xml) (fun _ -> true) global_res make_global_fast_xml (module FileCfg); + (); + + +end + +(** This function was originally a part of the [AnalyzeCFG] module, but + now that [AnalyzeCFG] takes [Spec] as a functor parameter, + [analyze_loop] cannot reside in it anymore since each invocation of [get_spec] in the loop might/should return a different module, and we cannot swap the functor parameter from inside [AnalyzeCFG]. *) let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = @@ -1975,9 +2678,13 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = let module DummyWPSPec = Wp_test.Spec in let module B = AnalyzeCFG_2 (CFG) (DummyWPSPec) (struct let increment = change_info end) in + + let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec.C) in + let module C = AnalyzeCFG_3 (CFG) (Spec) (DummyWPSPec) (struct let increment = change_info end) in GobConfig.with_immutable_conf (fun () -> A.analyze file fs; - B.analyze file fs + B.analyze file fs; + (* C.analyze file fs; *) ) with Refinement.RestartAnalysis -> (* Tail-recursively restart the analysis again, when requested. From 6450feb25bb8d0a257e77036da857b93cb23fffb Mon Sep 17 00:00:00 2001 From: ge94riv Date: Fri, 30 Jan 2026 16:47:26 +0100 Subject: [PATCH 12/29] control AnalyzeCFG_3 forward init --- src/framework/bidirConstrains.ml | 2 +- src/framework/control.ml | 747 +++++++++---------------------- 2 files changed, 225 insertions(+), 524 deletions(-) diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 609e2b0db9..8994f27a96 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -88,9 +88,9 @@ struct | `G_backw a -> GV_backw.is_write_only a end - module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) module G_forw = GVarG (S_forw.G) (S_forw.C) module G_backw = GVarG (S_backw.G) (S_forw.C) + module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) module Forward = Constraints_wp.FromSpec (S_forw) (Cfg) module CfgBackward = struct let prev = Cfg.prev end diff --git a/src/framework/control.ml b/src/framework/control.ml index d9d4bf952f..8f5b027a6a 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -1690,6 +1690,13 @@ struct end in + let module GV_forw = GVarF (Spec_forw.V) in + let module GV_backw = GVarF (Spec_backw.V) in + + let module G_forw = GVarG (Spec_forw.G) (Spec_forw.C) in + let module G_backw = GVarG (Spec_backw.G) (Spec_backw.C) in + + let () = let log_fun_list name funs = let fun_names = List.map (fun f -> f.svar.vname) funs in @@ -1699,7 +1706,7 @@ struct log_fun_list "Start" startfuns; log_fun_list "Exit" exitfuns; log_fun_list "Other" otherfuns; - Logs.debug "================================================"; + Logs.debug "================================================="; in AnalysisState.should_warn := false; (* reset for server mode *) @@ -1713,10 +1720,47 @@ struct let sideg v d = GHT.replace gh v (EQSys.G.join (getg v) d) in - let do_forwards_inits () = + let do_forward_inits () = + + let sideg_forw v d = sideg (`G_forw (v)) ((`Lifted1 d)) in + let getg_forw v = + match EQSys.G.spec (getg (`G_forw v)) with + | `Lifted1 g -> G_forw.create_spec g + | `Bot -> `Bot + | `Top -> `Top + | `Lifted2 _ -> failwith "Unexpected backward global state" + in + + (** This function nalyzes cil's global-inits function to get a starting state *) + let do_global_inits_forw (file: file) : Spec_forw.D.t * fundec list = + + let do_extern_inits_forw man (file: file) : Spec_forw.D.t = + let module VS = Set.Make (Basetype.Variables) in + let add_glob s = function + | GVar (v,_,_) -> VS.add v s + | _ -> s + in + let vars = foldGlobals file add_glob VS.empty in + let set_bad v st = + Spec_forw.assign {man with local = st} (var v) MyCFG.unknown_exp + in + let is_std = function + | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) + | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) + | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) + | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) + | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) + | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) + true + | _ -> false + in + let add_externs s = function + | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s + | _ -> s + in + foldGlobals file add_externs (Spec_forw.startstate MyCFG.dummy_func.svar) + in - (* analyze cil's global-inits function to get a starting state *) - let do_global_inits (file: file) : Spec_forw.D.t * fundec list = let man = { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) ; emit = (fun _ -> failwith "Cannot \"emit\" in global initializer context.") @@ -1725,11 +1769,11 @@ struct ; control_context = (fun () -> man_failwith "Global initializers have no context.") ; context = (fun () -> man_failwith "Global initializers have no context.") ; edge = MyCFG.Skip - ; local = EQSys.D.top () - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) + ; local = Spec_forw.D.top () + ; global = (fun _ -> Spec_forw.G.bot ()) ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") ; split = (fun _ -> failwith "Global initializers trying to split paths.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) + ; sideg = (fun g d -> sideg_forw (GV_forw.spec g) (G_forw.create_spec d)) } in @@ -1737,9 +1781,9 @@ struct Logs.debug "Executing %d assigns." (List.length edges); let funs = ref [] in - let transfer_func (st : Spec_forw.D.t) (loc, edge) : Spec.D.t = + let transfer_func (st : Spec_forw.D.t) (loc, edge) : Spec_forw.D.t = match edge with - | MyCFG.Entry func -> Spec.body {man with local = st} func + | MyCFG.Entry func -> Spec_forw.body {man with local = st} func | MyCFG.Assign (lval,exp) -> begin match lval, exp with | (Var v,o), (AddrOf (Var f,NoOffset)) @@ -1754,541 +1798,198 @@ struct | _ -> failwith "Unsupported global initializer edge" in - let with_externs = do_extern_inits man file in - let result : Spec.D.t = List.fold_left transfer_func with_externs edges in + let with_externs = do_extern_inits_forw man file in + let result : Spec_forw.D.t = List.fold_left transfer_func with_externs edges in result, !funs in + let startstate, _ = do_global_inits_forw file in + + + (** calculate startvars *) + let calculate_startvars_forw () = + + let enter_with st fd = + let st = st fd.svar in + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec_forw.startcontext + ; edge = MyCFG.Skip + ; local = st + ; global = (fun g -> G_forw.spec (getg_forw (GV_forw.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg_forw (GV_forw.spec g) (G_forw.create_spec (d))) + } + in + let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in + let ents = Spec_forw.enter man None fd args in + List.map (fun (_,s) -> fd, s) ents + in - let startstate, _ = do_global_inits file - - in - startstate - in - - let do_backwards_inits () = () in - - let calculate_solver_input () = () in - - let solve () = - let solver_data = None in - let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in - lh, gh - in - - - - - - - + (try MyCFG.dummy_func.svar.vdecl <- (List.hd otherfuns).svar.vdecl with Failure _ -> ()); + let startvars = + if startfuns = [] + then [[MyCFG.dummy_func, startstate]] + else + let morph f = Spec_forw.morphstate f startstate in + List.map (enter_with morph) startfuns + in + let exitvars = List.map (enter_with Spec_forw.exitstate) exitfuns in + let otherstate st v = + 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 () -> man_failwith "enter_func has no context.") + ; context = (fun () -> man_failwith "enter_func has no context.") + ; edge = MyCFG.Skip + ; local = st + ; global = (fun g -> G_forw.spec (getg_forw (GV_forw.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg_forw (GV_forw.spec g) (G_forw.create_spec (d))) + } + in + (* TODO: don't hd *) + List.hd (Spec_forw.threadenter man ~multiple:false None v []) + (* TODO: do threadspawn to mainfuns? *) + in + let prestartstate = Spec_forw.startstate MyCFG.dummy_func.svar in (* like in do_extern_inits *) + let othervars = List.map (enter_with (otherstate prestartstate)) otherfuns in + let startvars = List.concat (startvars @ exitvars @ othervars) in + if startvars = [] then + failwith "BUG: Empty set of start variables; may happen if enter_func of any analysis returns an empty list."; - (* add extern variables to local state *) - 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 - | _ -> s - in - let vars = foldGlobals file add_glob VS.empty in - let set_bad v st = - Spec.assign {man with local = st} (var v) MyCFG.unknown_exp - in - let is_std = function - | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) - | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) - | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) - | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) - | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) - | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) - true - | _ -> false - in - let add_externs s = function - | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s - | _ -> s - in - foldGlobals file add_externs (Spec.startstate MyCFG.dummy_func.svar) - in - (* Old-style global function for context. - * This indirectly prevents global initializers from depending on each others' global side effects, which would require proper solving. *) - let getg v = EQSys.G.bot () in + AnalysisState.global_initialization := false; - (* analyze cil's global-inits function to get a starting state *) - let do_global_inits (file: file) : Spec.D.t * fundec list = - 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 () -> 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))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") - ; split = (fun _ -> failwith "Global initializers trying to split paths.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let edges = CfgTools.getGlobalInits file in - Logs.debug "Executing %d assigns." (List.length edges); - let funs = ref [] in + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec_forw.startcontext + ; edge = MyCFG.Skip + ; local = e + ; global = (fun g -> G_forw.spec (getg_forw (GV_forw.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg_forw (GV_forw.spec g) (G_forw.create_spec d)) + } + in + let startvars' = List.map (fun (n,e) -> (MyCFG.Function n, Spec_forw.context (man e) n e)) startvars in + let entrystates = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_forw.context (man e) n e), e) startvars in - let transfer_func (st : Spec.D.t) (loc, edge) : Spec.D.t = - match edge with - | MyCFG.Entry func -> Spec.body {man with local = st} func - | MyCFG.Assign (lval,exp) -> - begin match lval, exp with - | (Var v,o), (AddrOf (Var f,NoOffset)) - when v.vstorage <> Static && isFunctionType f.vtype -> - (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) - | _ -> () - end; - 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 {man with local = res} `Normal in - res' - | _ -> failwith "Unsupported global initializer edge" + startvars', entrystates in - let with_externs = do_extern_inits man file in - let result : Spec.D.t = List.fold_left transfer_func with_externs edges in - result, !funs + calculate_startvars_forw () in - (* real beginning of the [analyze] function *) - AnalysisState.global_initialization := true; - let marshal: Spec.marshal option = None in - - (* Some happen in init, so enable this temporarily (if required by option). *) - AnalysisState.should_warn := PostSolverArg.should_warn; - Spec.init marshal; - Access.init file; - AnalysisState.should_warn := false; - + let do_backward_inits () = () in - let startstate, _ = do_global_inits file in + (** Combining the solver input calculation from the forwards and backwards part of the constrant system*) + let calculate_solver_input () = + let entrystates_global = GHT.to_list gh in + let startvars'_forw, entrystates_forw = do_forward_inits () in - let otherfuns = otherfuns in + (* Lifting the forward satrtvars and entrystates to the constraint systems types*) + let startvars' = List.map (fun v -> `L_forw v) startvars'_forw in + let entrystates = List.map (fun (v, d) -> (`L_forw v, `Lifted1 d)) entrystates_forw in - let enter_with st fd = - let st = st fd.svar in - 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec.startcontext - ; edge = MyCFG.Skip - ; local = st - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in - let ents = Spec.enter man None fd args in - List.map (fun (_,s) -> fd, s) ents + startvars', entrystates, entrystates_global in - (try MyCFG.dummy_func.svar.vdecl <- (List.hd otherfuns).svar.vdecl with Failure _ -> ()); - - let startvars = - if startfuns = [] - then [[MyCFG.dummy_func, startstate]] - else - let morph f = Spec.morphstate f startstate in - List.map (enter_with morph) startfuns - in + let solve () = + let solver_data = None in + let startvars', entrystates, entrystates_global = calculate_solver_input () in + + let log_analysis_inputs () = + Logs.debug "=== Analysis Inputs ==="; + + (* Log entrystates *) + Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); + List.iteri (fun i (v, state) -> + Logs.debug "EntryState %d:" (i + 1); + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + ); + Logs.debug " State: %a" EQSys.D.pretty state; + ) entrystates; + + (* Log entrystates_global *) + Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); + List.iteri (fun i (gvar, gstate) -> + Logs.debug "GlobalEntryState %d:" (i + 1); + Logs.debug " GVar: %a" EQSys.GVar.pretty_trace gvar; + Logs.debug " GState: %a" EQSys.G.pretty gstate; + ) entrystates_global; + + (* Log startvars' *) + Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); + List.iteri (fun i v -> + Logs.debug "StartVar %d:" (i + 1); + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + ) + ) startvars'; - let exitvars = List.map (enter_with Spec.exitstate) exitfuns in - let otherstate st v = - 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 () -> 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))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } + Logs.debug "=== End Analysis Inputs ===" in - (* TODO: don't hd *) - 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 *) - let othervars = List.map (enter_with (otherstate prestartstate)) otherfuns in - let startvars = List.concat (startvars @ exitvars @ othervars) in - if startvars = [] then - failwith "BUG: Empty set of start variables; may happen if enter_func of any analysis returns an empty list."; + log_analysis_inputs (); - AnalysisState.global_initialization := false; + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in - 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec.startcontext - ; edge = MyCFG.Skip - ; local = e - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let startvars' = - (* if get_bool "exp.forward" then *) - if true then (*does this deside which variables I query?*) - 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 (man e) n e)) startvars + let log_lh_contents lh = + Logs.debug "=== LHT Contents ==="; + let count = ref 0 in + + Logs.debug "--- Full entry details ---"; + LHT.iter (fun v state -> + incr count; + Logs.debug "Entry %d:" !count; + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> + Logs.debug " Node: %a" Node.pretty_trace node; + (try + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + with e -> + Logs.debug " Context: ERROR - %s" (Printexc.to_string e) + ) + ); + + (* Test state pretty printing with exception handling *) + (try + Logs.debug " State: %a" EQSys.D.pretty state + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + ) lh; + Logs.debug "Total entries in LHT: %d" !count; + Logs.debug "=== End LHT Contents ===" + in + log_lh_contents lh; in - (* let entrystates = List.clearmap (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (man e) n e), e) startvars in *) - let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec.context (man e) n e), e) startvars in - let entrystates_global = GHT.to_list gh in - - let uncalled_dead = ref 0 in - - let solve_and_postprocess () = - let lh, gh = - let solver_data = None in - Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); - - (*######################### START OF ACTUAL SOLVING ##########################*) - - (*### START OF LOG ###*) - (*print set of entrystates, entrystatex_global and startvars'*) - let log_analysis_inputs () = - Logs.debug "=== Analysis Inputs ==="; - - (* Log entrystates *) - Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); - List.iteri (fun i ((node, ctx), state) -> - Logs.debug "EntryState %d:" (i + 1); - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec.C.pretty ctx; - Logs.debug " State: %a" Spec.D.pretty state; - ) entrystates; - - (* Log entrystates_global *) - Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); - List.iteri (fun i (gvar, gstate) -> - Logs.debug "GlobalEntryState %d:" (i + 1); - Logs.debug " GVar: %a" EQSys.GVar.pretty gvar; - Logs.debug " GState: %a" EQSys.G.pretty gstate; - ) entrystates_global; - - (* Log startvars' *) - Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); - List.iteri (fun i (node, ctx) -> - Logs.debug "StartVar %d:" (i + 1); - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec.C.pretty ctx; - ) startvars'; - - (* Log startvars (without apostrophe) *) - Logs.debug "--- Start Variables (no apostrophe) (count: %d) ---" (List.length startvars); - List.iteri (fun i (node, state) -> - Logs.debug "StartVar (no apostrophe) %d:" (i + 1); - Logs.debug " Node: %a" CilType.Fundec.pretty node; - Logs.debug " State: (of type EQSys.D.t) %a" Spec.D.pretty state; - ) startvars; - - Logs.debug "=== End Analysis Inputs ===" - in - log_analysis_inputs (); - (*### END OF LOG ###*) - - AnalysisState.should_warn := get_string "warn_at" = "early"; - let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in - lh, gh - - (*######################### END OF ACTUAL SOLVING ##########################*) - - in - - (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) - AnalysisState.should_warn := PostSolverArg.should_warn; - - let insrt k _ s = match k with - | (MyCFG.Function fn,_) -> if not (get_bool "exp.forward") then Set.Int.add fn.svar.vid s else s - | (MyCFG.FunctionEntry fn,_) -> if (get_bool "exp.forward") then Set.Int.add fn.svar.vid s else s - | _ -> s - in - (* set of ids of called functions *) - let calledFuns = LHT.fold insrt lh Set.Int.empty in - let is_bad_uncalled fn loc = - not (Set.Int.mem fn.vid calledFuns) && - not (Str.last_chars loc.file 2 = ".h") && - not (LibraryFunctions.is_safe_uncalled fn.vname) && - not (Cil.hasAttribute "goblint_stub" fn.vattr) - in - - let print_and_calculate_uncalled = function - | GFun (fn, loc) when is_bad_uncalled fn.svar loc-> - let cnt = Cilfacade.countLoc fn in - uncalled_dead := !uncalled_dead + cnt; - if get_bool "ana.dead-code.functions" then - M.warn ~loc:(CilLocation loc) ~category:Deadcode "Function '%a' is uncalled: %d LLoC" CilType.Fundec.pretty fn cnt (* CilLocation is fine because always printed from scratch *) - | _ -> () - in - List.iter print_and_calculate_uncalled file.globals; - - (* check for dead code at the last state: *) - let main_sol = try LHT.find lh (List.hd startvars') with Not_found -> EQSys.D.bot () in - if EQSys.D.is_bot main_sol then - M.warn_noloc ~category:Deadcode "Function 'main' does not return"; - - (* run activated transformations with the analysis result *) - let active_transformations = get_string_list "trans.activated" in - if active_transformations <> [] then ( - - (* Most transformations use the locations of statements, since they run using Cil visitors. - Join abstract values once per location and once per node. *) - let joined_by_loc, joined_by_node = - let open Enum in - let node_values = LHT.enum lh |> map (Tuple2.map1 fst) in (* drop context from key *) (* nosemgrep: batenum-enum *) - let hashtbl_size = if fast_count node_values then count node_values else 123 in - let by_loc, by_node = Hashtbl.create hashtbl_size, NodeH.create hashtbl_size in - iter (fun (node, v) -> - let loc = match node with - | Statement s -> Cil.get_stmtLoc s.skind (* nosemgrep: cilfacade *) (* Must use CIL's because syntactic search is in CIL. *) - | FunctionEntry _ | Function _ -> Node.location node - in - (* join values once for the same location and once for the same node *) - let join = Option.some % function None -> v | Some v' -> Spec.D.join v v' in - Hashtbl.modify_opt loc join by_loc; - NodeH.modify_opt node join by_node; - ) node_values; - by_loc, by_node - in - - let ask ?(node = MyCFG.dummy_node) loc = - let f (type a) (q : a Queries.t) : a = - match Hashtbl.find_option joined_by_loc loc with - | None -> Queries.Result.bot q - | Some local -> Query.ask_local_node gh node local q - in - ({ f } : Queries.ask) - in - - (* A node is dead when its abstract value is bottom in all contexts; - it holds that: bottom in all contexts iff. bottom in the join of all contexts. - Therefore, we just answer whether the (stored) join is bottom. *) - let must_be_dead node = - NodeH.find_option joined_by_node node - (* nodes that didn't make it into the result are definitely dead (hence for_all) *) - |> GobOption.for_all Spec.D.is_bot - in - - let must_be_uncalled fd = not @@ BatSet.Int.mem fd.svar.vid calledFuns in - - let skipped_statements from_node edge to_node = - try - Cfg.skippedByEdge from_node edge to_node - with Not_found -> - [] - in - - Transform.run_transformations file active_transformations - { ask ; must_be_dead ; must_be_uncalled ; - cfg_forward = Cfg.next ; cfg_backward = Cfg.prev ; skipped_statements }; - ); - - lh, gh - in - - (* Use "normal" constraint solving *) - let timeout_reached () = - M.error "Timeout reached!"; - raise Timeout.Timeout - in - let timeout = get_string "dbg.timeout" |> TimeUtil.seconds_of_duration_string in - let lh, gh = Timeout.wrap solve_and_postprocess () (float_of_int timeout) timeout_reached in - - let module SpecSysSol: SpecSysSol with module SpecSys = SpecSys = - struct - module SpecSys = SpecSys - let lh = lh - let gh = gh - end - in - let module R: ResultQuery.SpecSysSol2 with module SpecSys = SpecSys = ResultQuery.Make (FileCfg) (SpecSysSol) in - - let local_xml = solver2source_result lh in - current_node_state_json := (fun node -> Option.map LT.to_yojson (Result.find_option local_xml node)); - - current_varquery_global_state_json := (fun vq_opt -> - let iter_vars f = match vq_opt with - | None -> GHT.iter (fun v _ -> f v) gh - | Some vq -> - EQSys.iter_vars - (fun x -> try LHT.find lh x with Not_found -> EQSys.D.bot ()) - (fun x -> try GHT.find gh x with Not_found -> EQSys.G.bot ()) - vq - (fun _ -> ()) - f - in - (* TODO: optimize this once server has a way to properly convert vid -> varinfo *) - let vars = GHT.create 113 in - iter_vars (fun x -> - GHT.replace vars x () - ); - let assoc = GHT.fold (fun x g acc -> - if GHT.mem vars x then - (EQSys.GVar.show x, EQSys.G.to_yojson g) :: acc - else - acc - ) gh [] - in - `Assoc assoc - ); - - let liveness = - if get_bool "ana.dead-code.lines" || get_bool "ana.dead-code.branches" then - print_dead_code local_xml !uncalled_dead - else - fun _ -> true (* TODO: warn about conflicting options *) - in - - if get_bool "exp.cfgdot" then - CfgTools.dead_code_cfg ~path:(Fpath.v "cfgs") (module FileCfg) liveness; - - let warn_global g v = - (* Logs.debug "warn_global %a %a" EQSys.GVar.pretty_trace g EQSys.G.pretty v; *) - match g with - | `Left g -> (* Spec global *) - R.ask_global (WarnGlobal (Obj.repr g)) - | `Right _ -> (* contexts global *) - () - in - Timing.wrap "warn_global" (GHT.iter warn_global) gh; - - if get_bool "exp.arg.enabled" then ( - let module ArgTool = ArgTools.Make (R) in - let module Arg = (val ArgTool.create entrystates) in - let arg_dot_path = get_string "exp.arg.dot.path" in - if arg_dot_path <> "" then ( - let module NoLabelNodeStyle = - struct - type node = Arg.Node.t - let extra_node_styles node = - match GobConfig.get_string "exp.arg.dot.node-label" with - | "node" -> [] - | "empty" -> ["label=\"_\""] (* can't have empty string because graph-easy will default to node ID then... *) - | _ -> assert false - end - in - let module ArgDot = ArgTools.Dot (Arg) (NoLabelNodeStyle) in - Out_channel.with_open_text arg_dot_path (fun oc -> - let ppf = Stdlib.Format.formatter_of_out_channel oc in - ArgDot.dot ppf; - Format.pp_print_flush ppf () - ) - ); - ArgTools.current_arg := Some (module Arg); - ); - - if get_string "result" <> "none" then Logs.debug "Generating output: %s" (get_string "result"); - - Messages.finalize (); - - (*Iterating through elements of lh and Logging the contents*) - let log_lh_contents lh = - Messages.warn "=== LHT Contents ==="; let count = ref 0 in - - Logs.debug "--- Full entry details ---"; - LHT.iter (fun (node, ctx) state -> - incr count; - Logs.debug "Entry %d:" !count; - Logs.debug " Node: %a" Node.pretty_trace node; - - (* Test context pretty printing *) - (try - Logs.debug " Context: %a" Spec.C.pretty ctx - with e -> - Logs.debug " Context: ERROR - %s" (Printexc.to_string e) - ); - - (* Check state properties *) - (* Logs.debug " State is_top: %b" (Spec.D.is_top state); - Logs.debug " State is_bot: %b" (Spec.D.is_bot state); *) - - (* Test state pretty printing with exception handling *) - (try - Logs.debug " State: %a" Spec.D.pretty state - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - ) lh; - Logs.debug "Total entries in LHT: %d" !count; - Logs.debug "=== End LHT Contents ===" - in - log_lh_contents lh; - - (*Script adding these results to the already existing node xml files*) - let output_wp_results_to_xml lh = - (* iterate through all nodes and update corresponding .xml in result/nodes *) - LHT.iter (fun (node, ctx) state -> - try - (* Get node ID as string *) - (* let node_id_str = match node with - | MyCFG.Statement stmt -> string_of_int stmt.sid - | MyCFG.FunctionEntry fundec -> string_of_int fundec.svar.vid - | _ -> raise Not_found (* Skip non-statement nodes *) - in *) - let node_id_str = Node.show_id node in - - let xml_path = Filename.concat "./result/nodes" (node_id_str ^ ".xml") in - if Sys.file_exists xml_path then ( - (* Read existing XML *) - let ic = Stdlib.open_in xml_path in - let content = Stdlib.really_input_string ic (Stdlib.in_channel_length ic) in - Stdlib.close_in ic; - - (* Create WP analysis data *) - let wp_res = Pretty.sprint 100 (Spec.D.pretty () state) in - let wp_data = - "\n\n\n\n" ^ wp_res ^" \n\n\n\n\n" - in - - (* Insert before *) - let close_pattern = "" in - let updated_content = - try - let insert_pos = Str.search_backward (Str.regexp_string close_pattern) content (String.length content) in - let before = String.sub content 0 insert_pos in - let after = String.sub content insert_pos (String.length content - insert_pos) in - before ^ wp_data ^ after - with Not_found -> - content ^ wp_data - in - - (* Write back *) - let oc = Stdlib.open_out xml_path in - Stdlib.output_string oc updated_content; - Stdlib.close_out oc; - Logs.debug "Updated XML file for node %s" node_id_str - ) - with _ -> () (* Skip errors silently *) - ) lh - in - output_wp_results_to_xml lh; + solve(); end @@ -2682,9 +2383,9 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec.C) in let module C = AnalyzeCFG_3 (CFG) (Spec) (DummyWPSPec) (struct let increment = change_info end) in GobConfig.with_immutable_conf (fun () -> - A.analyze file fs; - B.analyze file fs; - (* C.analyze file fs; *) + (* A.analyze file fs; + B.analyze file fs; *) + C.analyze file fs ) with Refinement.RestartAnalysis -> (* Tail-recursively restart the analysis again, when requested. From 87b6749d743a4139bb369fa232d4728ce6095a90 Mon Sep 17 00:00:00 2001 From: ge94riv Date: Mon, 2 Feb 2026 12:53:40 +0100 Subject: [PATCH 13/29] working on backwards init --- src/framework/bidirConstrains.ml | 11 +- src/framework/control.ml | 226 +++++++++++++++++++++++++++++-- xx_easyprog.c => xy_easyprog.c | 0 3 files changed, 219 insertions(+), 18 deletions(-) rename xx_easyprog.c => xy_easyprog.c (100%) diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 8994f27a96..2a3a8dfb72 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -92,9 +92,8 @@ struct module G_backw = GVarG (S_backw.G) (S_forw.C) module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) - module Forward = Constraints_wp.FromSpec (S_forw) (Cfg) - module CfgBackward = struct let prev = Cfg.prev end - module Backward = Constraints.FromSpec (S_backw) (CfgBackward) (I) + module Forward = Constraints.FromSpec (S_forw) (Cfg) (I) + module Backward = Constraints_wp.FromSpec (S_backw) (Cfg) let backw_lv_of_forw ((n,c): LV.t) : Backward.LVar.t = (n, Obj.magic c) let forw_lv_of_backw ((n,c): Backward.LVar.t) : LV.t = (n, Obj.magic c) @@ -552,8 +551,8 @@ struct let system var = match var with - | `L_forw v -> None - (* Forward.system v + | `L_forw v -> + Forward.system v |> Option.map (fun tf getl sidel demandl getg sideg -> let getl' v = getl (`L_forw v) |> to_forw_d in let sidel' v d = sidel (`L_forw v) (of_forw_d d) in @@ -561,7 +560,7 @@ struct let getg' v = getg (`G_forw v) |> to_forw_g in let sideg' v d = sideg (`G_forw v) (of_forw_g d) in tf getl' sidel' demandl' getg' sideg' |> of_forw_d - ) *) + ) | `L_backw v -> system_backw v |> Option.map (fun tf getl sidel demandl getg sideg -> diff --git a/src/framework/control.ml b/src/framework/control.ml index 8f5b027a6a..5d866ef509 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -1642,7 +1642,6 @@ struct end module AnalyzeCFG_3 (Cfg:CfgBidirSkip) (Spec_forw:Spec) (Spec_backw: Spec with type C.t = Spec_forw.C.t ) (Inc:Increment) = - struct (* The Equation system *) @@ -1680,7 +1679,6 @@ struct (* not having a Query module is problematic!*) (* module Query = ResultQuery.Query (SpecSys) *) - (** [analyze file startfuns exitfuns otherfuns] is the main function to preform the selected analyses.*) let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = let module FileCfg: FileCfg = @@ -1731,7 +1729,7 @@ struct | `Lifted2 _ -> failwith "Unexpected backward global state" in - (** This function nalyzes cil's global-inits function to get a starting state *) + (** This function nalyzelhs cil's global-inits function to get a starting state *) let do_global_inits_forw (file: file) : Spec_forw.D.t * fundec list = let do_extern_inits_forw man (file: file) : Spec_forw.D.t = @@ -1894,7 +1892,178 @@ struct calculate_startvars_forw () in - let do_backward_inits () = () in + let do_backward_inits () = + + let sideg_backw v d = sideg (`G_backw (v)) ((`Lifted2 d)) in + let getg_backw v = + match EQSys.G.spec (getg (`G_backw v)) with + | `Lifted1 _ -> failwith "Unexpected backward global state" + | `Bot -> `Bot + | `Top -> `Top + | `Lifted2 g -> G_backw.create_spec g + in + + (** This function nalyzelhs cil's global-inits function to get a starting state *) + let do_global_inits_backw (file: file) : Spec_backw.D.t * fundec list = + + let do_extern_inits_backw man (file: file) : Spec_backw.D.t = + let module VS = Set.Make (Basetype.Variables) in + let add_glob s = function + | GVar (v,_,_) -> VS.add v s + | _ -> s + in + let vars = foldGlobals file add_glob VS.empty in + let set_bad v st = + Spec_backw.assign {man with local = st} (var v) MyCFG.unknown_exp + in + let is_std = function + | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) + | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) + | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) + | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) + | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) + | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) + true + | _ -> false + in + let add_externs s = function + | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s + | _ -> s + in + foldGlobals file add_externs (Spec_backw.startstate MyCFG.dummy_func.svar) + in + + 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 () -> man_failwith "Global initializers have no context.") + ; context = (fun () -> man_failwith "Global initializers have no context.") + ; edge = MyCFG.Skip + ; local = Spec_backw.D.top () + ; global = (fun _ -> Spec_backw.G.bot ()) + ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Global initializers trying to split paths.") + ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) (G_backw.create_spec d)) + } + in + + let edges = CfgTools.getGlobalInits file in + Logs.debug "Executing %d assigns." (List.length edges); + let funs = ref [] in + + let transfer_func (st : Spec_backw.D.t) (loc, edge) : Spec_backw.D.t = + match edge with + | MyCFG.Entry func -> Spec_backw.body {man with local = st} func + | MyCFG.Assign (lval,exp) -> + begin match lval, exp with + | (Var v,o), (AddrOf (Var f,NoOffset)) + when v.vstorage <> Static && isFunctionType f.vtype -> + (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) + | _ -> () + end; + let res = Spec_backw.assign {man with local = st} lval exp in + (* Needed for privatizations (e.g. None) that do not side immediately *) + let res' = Spec_backw.sync {man with local = res} `Normal in + res' + | _ -> failwith "Unsupported global initializer edge" + in + + let with_externs = do_extern_inits_backw man file in + let result : Spec_backw.D.t = List.fold_left transfer_func with_externs edges in + result, !funs + in + + let startstate, _ = do_global_inits_backw file in + + + (** calculate startvars *) + let calculate_startvars_backw () = + + let enter_with st fd = + let st = st fd.svar in + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec_backw.startcontext + ; edge = MyCFG.Skip + ; local = st + ; global = (fun g -> G_backw.spec (getg_backw (GV_backw.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) (G_backw.create_spec (d))) + } + in + let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in + let ents = Spec_backw.enter man None fd args in + List.map (fun (_,s) -> fd, s) ents + in + + (try MyCFG.dummy_func.svar.vdecl <- (List.hd otherfuns).svar.vdecl with Failure _ -> ()); + + let startvars = + if startfuns = [] + then [[MyCFG.dummy_func, startstate]] + else + let morph f = Spec_backw.morphstate f startstate in + List.map (enter_with morph) startfuns + in + + let exitvars = List.map (enter_with Spec_backw.exitstate) exitfuns in + let otherstate st v = + 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 () -> man_failwith "enter_func has no context.") + ; context = (fun () -> man_failwith "enter_func has no context.") + ; edge = MyCFG.Skip + ; local = st + ; global = (fun g -> G_backw.spec (getg_backw (GV_backw.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) (G_backw.create_spec (d))) + } + in + (* TODO: don't hd *) + List.hd (Spec_forw.threadenter man ~multiple:false None v []) + (* TODO: do threadspawn to mainfuns? *) + in + let prestartstate = Spec_backw.startstate MyCFG.dummy_func.svar in (* like in do_extern_inits *) + let othervars = List.map (enter_with (otherstate prestartstate)) otherfuns in + let startvars = List.concat (startvars @ exitvars @ othervars) in + if startvars = [] then + failwith "BUG: Empty set of start variables; may happen if enter_func of any analysis returns an empty list."; + + AnalysisState.global_initialization := false; + + 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 () -> man_failwith "enter_with has no control_context.") + ; context = Spec_backw.startcontext + ; edge = MyCFG.Skip + ; local = e + ; global = (fun g -> G_backw.spec (getg_backw (GV_backw.spec g))) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) (G_backw.create_spec d)) + } + in + let startvars' = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_backw.context (man e) n e)) startvars in + let entrystates = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_backw.context (man e) n e), e) startvars in + + startvars', entrystates + in + + calculate_startvars_backw () (** Combining the solver input calculation from the forwards and backwards part of the constrant system*) let calculate_solver_input () = @@ -1958,6 +2127,7 @@ struct let log_lh_contents lh = Logs.debug "=== LHT Contents ==="; + Logs.debug "LHT size: %d" (LHT.length lh); let count = ref 0 in Logs.debug "--- Full entry details ---"; @@ -1966,8 +2136,16 @@ struct Logs.debug "Entry %d:" !count; Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; (match v with - | `L_forw (node, ctx) + | `L_forw (node, ctx) -> + (* Logs.debug " Var kind: forward"; *) + Logs.debug " Node: %a" Node.pretty_trace node; + (try + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + with e -> + Logs.debug " Context: ERROR - %s" (Printexc.to_string e) + ); | `L_backw (node, ctx) -> + (* Logs.debug " Var kind: backward"; *) Logs.debug " Node: %a" Node.pretty_trace node; (try Logs.debug " Context: %a" Spec_forw.C.pretty ctx @@ -1975,18 +2153,42 @@ struct Logs.debug " Context: ERROR - %s" (Printexc.to_string e) ) ); - - (* Test state pretty printing with exception handling *) - (try - Logs.debug " State: %a" EQSys.D.pretty state - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) + (match state with + | `Lifted1 d -> + (try + (* Logs.debug " State kind: Lifted1"; *) + Logs.debug " State: %a" Spec_forw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + ( + let base_id = MCPRegistry.find_id "base" in + let d_list : (int * Obj.t) list = Obj.magic d in + match List.assoc_opt base_id d_list with + | Some base_state -> + let module BaseDom = (val (MCPRegistry.find_spec base_id).dom : Lattice.S) in + Logs.debug " MCP base: %a" BaseDom.pretty (Obj.obj base_state) + | None -> + Logs.debug " MCP base: " + ); + | `Lifted2 d -> + (try + (* Logs.debug " State kind: Lifted2"; *) + Logs.debug " State: %a" Spec_backw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + | `Top -> + Logs.debug " State kind: Top"; + | `Bot -> + Logs.debug " State kind: Bot" ); ) lh; Logs.debug "Total entries in LHT: %d" !count; Logs.debug "=== End LHT Contents ===" in log_lh_contents lh; + in solve(); @@ -2378,7 +2580,7 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = let module A = AnalyzeCFG (CFG) (Spec) (struct let increment = change_info end) in let module DummyWPSPec = Wp_test.Spec in - let module B = AnalyzeCFG_2 (CFG) (DummyWPSPec) (struct let increment = change_info end) in + (* let module B = AnalyzeCFG_2 (CFG) (DummyWPSPec) (struct let increment = change_info end) in *) let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec.C) in let module C = AnalyzeCFG_3 (CFG) (Spec) (DummyWPSPec) (struct let increment = change_info end) in diff --git a/xx_easyprog.c b/xy_easyprog.c similarity index 100% rename from xx_easyprog.c rename to xy_easyprog.c From a4eb80c42f9c2b3e42b15b3722df9a1692c9ec87 Mon Sep 17 00:00:00 2001 From: ge94riv Date: Mon, 2 Feb 2026 12:54:04 +0100 Subject: [PATCH 14/29] backwards init --- src/framework/bidirConstrains.ml | 16 +- src/framework/control.ml | 246 +++++++++++++++---------------- 2 files changed, 131 insertions(+), 131 deletions(-) diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 2a3a8dfb72..675f680c84 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -553,14 +553,14 @@ struct match var with | `L_forw v -> Forward.system v - |> Option.map (fun tf getl sidel demandl getg sideg -> - let getl' v = getl (`L_forw v) |> to_forw_d in - let sidel' v d = sidel (`L_forw v) (of_forw_d d) in - let demandl' v = demandl (`L_forw v) in - let getg' v = getg (`G_forw v) |> to_forw_g in - let sideg' v d = sideg (`G_forw v) (of_forw_g d) in - tf getl' sidel' demandl' getg' sideg' |> of_forw_d - ) + |> Option.map (fun tf getl sidel demandl getg sideg -> + let getl' v = getl (`L_forw v) |> to_forw_d in + let sidel' v d = sidel (`L_forw v) (of_forw_d d) in + let demandl' v = demandl (`L_forw v) in + let getg' v = getg (`G_forw v) |> to_forw_g in + let sideg' v d = sideg (`G_forw v) (of_forw_g d) in + tf getl' sidel' demandl' getg' sideg' |> of_forw_d + ) | `L_backw v -> system_backw v |> Option.map (fun tf getl sidel demandl getg sideg -> diff --git a/src/framework/control.ml b/src/framework/control.ml index 5d866ef509..57fee2cccb 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -2065,133 +2065,133 @@ struct calculate_startvars_backw () - (** Combining the solver input calculation from the forwards and backwards part of the constrant system*) - let calculate_solver_input () = - let entrystates_global = GHT.to_list gh in - let startvars'_forw, entrystates_forw = do_forward_inits () in - - (* Lifting the forward satrtvars and entrystates to the constraint systems types*) - let startvars' = List.map (fun v -> `L_forw v) startvars'_forw in - let entrystates = List.map (fun (v, d) -> (`L_forw v, `Lifted1 d)) entrystates_forw in - - startvars', entrystates, entrystates_global - in - - let solve () = - let solver_data = None in - let startvars', entrystates, entrystates_global = calculate_solver_input () in - - let log_analysis_inputs () = - Logs.debug "=== Analysis Inputs ==="; - - (* Log entrystates *) - Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); - List.iteri (fun i (v, state) -> - Logs.debug "EntryState %d:" (i + 1); - Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) - | `L_backw (node, ctx) -> - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - ); - Logs.debug " State: %a" EQSys.D.pretty state; - ) entrystates; - - (* Log entrystates_global *) - Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); - List.iteri (fun i (gvar, gstate) -> - Logs.debug "GlobalEntryState %d:" (i + 1); - Logs.debug " GVar: %a" EQSys.GVar.pretty_trace gvar; - Logs.debug " GState: %a" EQSys.G.pretty gstate; - ) entrystates_global; - - (* Log startvars' *) - Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); - List.iteri (fun i v -> - Logs.debug "StartVar %d:" (i + 1); - Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) - | `L_backw (node, ctx) -> - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - ) - ) startvars'; + (** Combining the solver input calculation from the forwards and backwards part of the constrant system*) + let calculate_solver_input () = + let entrystates_global = GHT.to_list gh in + let startvars'_forw, entrystates_forw = do_forward_inits () in - Logs.debug "=== End Analysis Inputs ===" - in - log_analysis_inputs (); - - let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in - - let log_lh_contents lh = - Logs.debug "=== LHT Contents ==="; - Logs.debug "LHT size: %d" (LHT.length lh); - let count = ref 0 in - - Logs.debug "--- Full entry details ---"; - LHT.iter (fun v state -> - incr count; - Logs.debug "Entry %d:" !count; - Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) -> - (* Logs.debug " Var kind: forward"; *) - Logs.debug " Node: %a" Node.pretty_trace node; - (try - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - with e -> - Logs.debug " Context: ERROR - %s" (Printexc.to_string e) - ); - | `L_backw (node, ctx) -> - (* Logs.debug " Var kind: backward"; *) - Logs.debug " Node: %a" Node.pretty_trace node; - (try - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - with e -> - Logs.debug " Context: ERROR - %s" (Printexc.to_string e) - ) - ); - (match state with - | `Lifted1 d -> - (try - (* Logs.debug " State kind: Lifted1"; *) - Logs.debug " State: %a" Spec_forw.D.pretty d - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - ( - let base_id = MCPRegistry.find_id "base" in - let d_list : (int * Obj.t) list = Obj.magic d in - match List.assoc_opt base_id d_list with - | Some base_state -> - let module BaseDom = (val (MCPRegistry.find_spec base_id).dom : Lattice.S) in - Logs.debug " MCP base: %a" BaseDom.pretty (Obj.obj base_state) - | None -> - Logs.debug " MCP base: " - ); - | `Lifted2 d -> - (try - (* Logs.debug " State kind: Lifted2"; *) - Logs.debug " State: %a" Spec_backw.D.pretty d - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - | `Top -> - Logs.debug " State kind: Top"; - | `Bot -> - Logs.debug " State kind: Bot" - ); - ) lh; - Logs.debug "Total entries in LHT: %d" !count; - Logs.debug "=== End LHT Contents ===" - in - log_lh_contents lh; + (* Lifting the forward satrtvars and entrystates to the constraint systems types*) + let startvars' = List.map (fun v -> `L_forw v) startvars'_forw in + let entrystates = List.map (fun (v, d) -> (`L_forw v, `Lifted1 d)) entrystates_forw in + startvars', entrystates, entrystates_global + in + + let solve () = + let solver_data = None in + let startvars', entrystates, entrystates_global = calculate_solver_input () in + + let log_analysis_inputs () = + Logs.debug "=== Analysis Inputs ==="; + + (* Log entrystates *) + Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); + List.iteri (fun i (v, state) -> + Logs.debug "EntryState %d:" (i + 1); + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + ); + Logs.debug " State: %a" EQSys.D.pretty state; + ) entrystates; + + (* Log entrystates_global *) + Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); + List.iteri (fun i (gvar, gstate) -> + Logs.debug "GlobalEntryState %d:" (i + 1); + Logs.debug " GVar: %a" EQSys.GVar.pretty_trace gvar; + Logs.debug " GState: %a" EQSys.G.pretty gstate; + ) entrystates_global; + + (* Log startvars' *) + Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); + List.iteri (fun i v -> + Logs.debug "StartVar %d:" (i + 1); + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + ) + ) startvars'; + + Logs.debug "=== End Analysis Inputs ===" in + log_analysis_inputs (); + + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in + + let log_lh_contents lh = + Logs.debug "=== LHT Contents ==="; + Logs.debug "LHT size: %d" (LHT.length lh); + let count = ref 0 in + + Logs.debug "--- Full entry details ---"; + LHT.iter (fun v state -> + incr count; + Logs.debug "Entry %d:" !count; + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) -> + (* Logs.debug " Var kind: forward"; *) + Logs.debug " Node: %a" Node.pretty_trace node; + (try + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + with e -> + Logs.debug " Context: ERROR - %s" (Printexc.to_string e) + ); + | `L_backw (node, ctx) -> + (* Logs.debug " Var kind: backward"; *) + Logs.debug " Node: %a" Node.pretty_trace node; + (try + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + with e -> + Logs.debug " Context: ERROR - %s" (Printexc.to_string e) + ) + ); + (match state with + | `Lifted1 d -> + (try + (* Logs.debug " State kind: Lifted1"; *) + Logs.debug " State: %a" Spec_forw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + ( + let base_id = MCPRegistry.find_id "base" in + let d_list : (int * Obj.t) list = Obj.magic d in + match List.assoc_opt base_id d_list with + | Some base_state -> + let module BaseDom = (val (MCPRegistry.find_spec base_id).dom : Lattice.S) in + Logs.debug " MCP base: %a" BaseDom.pretty (Obj.obj base_state) + | None -> + Logs.debug " MCP base: " + ); + | `Lifted2 d -> + (try + (* Logs.debug " State kind: Lifted2"; *) + Logs.debug " State: %a" Spec_backw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + | `Top -> + Logs.debug " State kind: Top"; + | `Bot -> + Logs.debug " State kind: Bot" + ); + ) lh; + Logs.debug "Total entries in LHT: %d" !count; + Logs.debug "=== End LHT Contents ===" + in + log_lh_contents lh; + + in - solve(); + solve(); end From 77ac4fe3799c2480bfbd7efaddf34ee27d0016da Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Mon, 2 Feb 2026 17:30:56 +0100 Subject: [PATCH 15/29] Backwards_analysis now works as part of bidirectional constraint system! --- src/common/util/cilfacade.ml | 4 +- src/framework/bidirConstrains.ml | 97 +++++++--- src/framework/control.ml | 297 +++++++++++++++++-------------- 3 files changed, 234 insertions(+), 164 deletions(-) diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index 452d0297a5..2efa343d2e 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -91,8 +91,8 @@ let init () = RmUnused.keepUnused := true; print_CIL_Input := true; Cabs2cil.allowDuplication := false; (* needed for ARG uncilling, maybe something else as well? *) - Cabs2cil.silenceLongDoubleWarning := true; - Cabs2cil.addLoopConditionLabels := true + Cabs2cil.silenceLongDoubleWarning := true +(* Cabs2cil.addLoopConditionLabels := true *) let current_file = ref dummyFile diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 675f680c84..9cd3ab650d 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -103,7 +103,19 @@ struct | `L_forw (n, l) -> `L_backw (n, l) | `L_backw (n, l) -> `L_backw (n, l) + let getl_backw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_backw.D.t = + match getl (`L_backw v) with + | `Lifted2 d -> d + | `Bot -> S_backw.D.bot () + | `Top -> S_backw.D.top () + | `Lifted1 _ -> failwith "bidirConstrains: backward local got forward value" + let getl_forw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_forw.D.t = + match getl (`L_forw v) with + | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" + | `Bot -> S_forw.D.bot () + | `Top -> S_forw.D.top () + | `Lifted1 d -> d let cset_to_forw c = G.CSet.fold (fun x acc -> Forward.G.CSet.add x acc) c (Forward.G.CSet.empty ()) @@ -200,6 +212,8 @@ struct and spawn ?(multiple=false) lval f args = (* TODO: adjust man node/edge? *) (* TODO: don't repeat for all paths that spawn same *) + + (* This porbalbly needs to be changed for backwards*) let ds = S_backw.threadenter ~multiple man lval f args in List.iter (fun d -> spawns := (lval, f, args, d, multiple) :: !spawns; @@ -260,12 +274,12 @@ struct let common_joins_backw man ds splits spawns = common_join_backw man (bigsqcup_backw ds) splits spawns - let tf_assign_backw var edge prev_node lv e getl sidel demandl getg sideg d = + let tf_assign_backw var edge prev_node lv e getl getl_forw sidel demandl getg sideg d = let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in let d = S_backw.assign man lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) common_join_backw man d !r !spawns - let tf_vdecl_backw var edge prev_node v getl sidel demandl getg sideg d = + let tf_vdecl_backw var edge prev_node v getl getl_forw sidel demandl getg sideg d = let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in let d = S_backw.vdecl man v in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) common_join_backw man d !r !spawns @@ -281,7 +295,7 @@ struct let nval = S_backw.sync { man with local = spawning_return } `Return in nval - let tf_ret_backw var edge prev_node ret fd getl sidel demandl getg sideg d = + let tf_ret_backw var edge prev_node ret fd getl getl_forw sidel demandl getg sideg d = let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl 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 || @@ -292,7 +306,7 @@ struct in common_join_backw man d !r !spawns - let tf_entry_backw var edge prev_node fd getl sidel demandl getg sideg d = + let tf_entry_backw var edge prev_node fd getl getl_forw sidel demandl 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_forw.C.t = snd var |> Obj.obj in @@ -301,13 +315,13 @@ struct let d = S_backw.body man fd in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) common_join_backw man d !r !spawns - let tf_test_backw var edge prev_node e tv getl sidel demandl getg sideg d = + let tf_test_backw var edge prev_node e tv getl getl_forw sidel demandl getg sideg d = let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in let d = S_backw.branch man e tv in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) common_join_backw man d !r !spawns (*TODO: THIS HAS TO BE BACKWARDS*) (*forward context not implemented yet*) - let tf_normal_call_backw man lv e (f:fundec) args getl sidel demandl getg sideg = + let tf_normal_call_backw man lv e (f:fundec) args getl getl_forw sidel demandl getg sideg = let combine (cd, fc, fd) = if M.tracing then M.traceli "combine" "local: %a" S_backw.D.pretty cd; if M.tracing then M.trace "combine" "function: %a" S_backw.D.pretty fd; @@ -370,10 +384,36 @@ struct Logs.debug "manager info at call to %a" Node.pretty man.node; S_backw.enter man lv f args in (* Wollen eig vorwärts-kontext benutzen *) - let paths = List.map (fun (c,v) -> (c, S_backw.context man f v, v)) paths in + (* getl_forw should query the corresopoding unknown from the forward analysis *) + (* context = S_forw.context (S_forw.enter (getl_forw [this_node_, this_context])) *) + let r = ref [] in + let rec man_forw = + { ask = (fun (type a) (q: a Queries.t) -> failwith "manager for calculating context does not support queries") + ; emit = (fun _ -> failwith "emit outside MCP") + ; node = man.node + ; prev_node = man.prev_node (* this is problematic, as this is backwards *) + ; control_context = man.control_context + ; context = man.context + ; edge = man.edge + ; local = (getl_forw (man.node, man.context ())) + ; global = (fun _ -> failwith "manager for calculating context does not have globals") + ; spawn = (fun ?multiple _ _ _ -> failwith "manager for calculating context does not support spawn") + ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) + ; sideg = (fun _ _ -> failwith "manager for calculating context does not support sideg") + } in + + let paths_forw = + Logs.debug "forward manager info at call to %a" Node.pretty man_forw.node; + S_forw.enter man_forw lv f args in + + let paths = List.combine paths paths_forw in + + (* this list now uses forward contexts*) + let paths = List.map (fun ((c,v),(a,b)) -> (c, S_forw.context man_forw f b, v)) paths in (* List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; *) - List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (Function f, fc) v) paths; + + List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (Function f, fc) v) paths; (* let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (Function f, fc))) paths; *) (* *) let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in @@ -390,7 +430,7 @@ struct r (*TODO: HERE AS WELL*) - let rec tf_proc_backw var edge prev_node lv e args getl sidel demandl getg sideg d = + let rec tf_proc_backw var edge prev_node lv e args getl getl_forw sidel demandl getg sideg d = let tf_special_call man f = let once once_control init_routine = (* Executes leave event for new local state d if it is not bottom *) @@ -408,7 +448,7 @@ struct in let first_call = let d' = S_backw.event man (Events.EnterOnce { once_control; ran = false }) man in - tf_proc_backw var edge prev_node None init_routine [] getl sidel demandl getg sideg d' + tf_proc_backw var edge prev_node None init_routine [] getl getl_forw sidel demandl getg sideg d' in let later_call = S_backw.event man (Events.EnterOnce { once_control; ran = true }) man in S_backw.D.join (leave_once first_call) (leave_once later_call) @@ -446,7 +486,7 @@ struct M.info ~category:Analyzer "Using special for defined function %s" f.vname; tf_special_call man f | fd -> - tf_normal_call_backw man lv e fd args getl sidel demandl getg sideg + tf_normal_call_backw man lv e fd args getl getl_forw sidel demandl getg sideg | exception Not_found -> tf_special_call man f) in @@ -468,17 +508,17 @@ struct end else common_joins_backw man funs !r !spawns - let tf_asm_backw var edge prev_node getl sidel demandl getg sideg d = + let tf_asm_backw var edge prev_node getl getl_forw sidel demandl getg sideg d = let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in let d = S_backw.asm man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) common_join_backw man d !r !spawns - let tf_skip_backw var edge prev_node getl sidel demandl getg sideg d = + let tf_skip_backw var edge prev_node getl getl_forw sidel demandl getg sideg d = let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in let d = S_backw.skip man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) common_join_backw man d !r !spawns - let tf_backw var getl sidel demandl getg sideg prev_node edge d = + let tf_backw var getl getl_forw sidel demandl getg sideg prev_node edge d = begin match edge with | Assign (lv,rv) -> tf_assign_backw var edge prev_node lv rv | VDecl (v) -> tf_vdecl_backw var edge prev_node v @@ -488,9 +528,9 @@ struct | Test (p,b) -> tf_test_backw var edge prev_node p b | ASM (_, _, _) -> tf_asm_backw var edge prev_node (* TODO: use ASM fields for something? *) | Skip -> tf_skip_backw var edge prev_node - end getl sidel demandl getg sideg d + end getl getl_forw sidel demandl getg sideg d - let tf_backw var getl sidel demandl getg sideg prev_node (_,edge) d (f,t) = + let tf_backw var getl getl_forw sidel demandl getg sideg prev_node (_,edge) d (f,t) = (* let old_loc = !Goblint_tracing.current_loc in let old_loc2 = !Goblint_tracing.next_loc in Goblint_tracing.current_loc := f; @@ -502,14 +542,14 @@ struct let d = tf_backw var getl sidel demandl getg sideg prev_node edge d in d ) *) - tf_backw var getl sidel demandl getg sideg prev_node edge d + tf_backw var getl getl_forw sidel demandl getg sideg prev_node edge d - let tf_backw (v,c) (edges, u) getl sidel demandl getg sideg = + let tf_backw (v,c) (edges, u) getl getl_forw sidel demandl getg sideg = let pval = getl (u,c) in let _, locs = List.fold_right (fun (f,e) (t,xs) -> f, (f,t)::xs) edges (Node.location v,[]) in - List.fold_left2 (|>) pval (List.map (tf_backw (v,Obj.repr (fun () -> c)) getl sidel demandl getg sideg u) edges) locs + List.fold_left2 (|>) pval (List.map (tf_backw (v,Obj.repr (fun () -> c)) getl getl_forw sidel demandl getg sideg u) edges) locs - let tf_backw (v,c) (e,u) getl sidel demandl getg sideg = + let tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg sideg = let old_node = !current_node in let old_fd = Option.map Node.find_fundec old_node |? Cil.dummyFunDec in let new_fd = Node.find_fundec v in @@ -524,15 +564,18 @@ struct if not (CilType.Fundec.equal old_fd new_fd) then Timing.Program.exit new_fd.svar.vname ) (fun () -> - let d = tf_backw (v,c) (e,u) getl sidel demandl getg sideg in + let d = tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg sideg in d ) let system_backw (v,c) = + match v with | FunctionEntry _ -> let tf_backw getl sidel demandl getg sideg = - let tf' eu = tf_backw (v,c) eu getl sidel demandl getg sideg in + let getl_backw = getl_backw_wrapper getl in + let getl_forw = getl_forw_wrapper getl in + let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg sideg in let xs = List.map tf' (Cfg.next v) in List.fold_left S_backw.D.join (S_backw.D.bot ()) xs in @@ -541,14 +584,16 @@ struct None | _ -> let tf_backw getl sidel demandl getg sideg = - let tf' eu = tf_backw (v,c) eu getl sidel demandl getg sideg in + let getl_backw = getl_backw_wrapper getl in + let getl_forw = getl_forw_wrapper getl in + let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg sideg in let xs = List.map tf' (Cfg.next v) in List.fold_left S_backw.D.join (S_backw.D.bot ()) xs in - Some tf_backw + (*WEIRD VARIABLE TYPES??*) let system var = match var with | `L_forw v -> @@ -564,12 +609,12 @@ struct | `L_backw v -> system_backw v |> Option.map (fun tf getl sidel demandl getg sideg -> - let getl' v = getl (`L_backw (forw_lv_of_backw v)) |> to_backw_d in + (* let getl' (v : Backward.LVar.t) : (S_backw.D.t) = getl (`L_backw (forw_lv_of_backw v)) |> to_backw_d in *) let sidel' v d = sidel (`L_backw (forw_lv_of_backw v)) (of_backw_d d) in let demandl' v = demandl (`L_backw (forw_lv_of_backw v)) in let getg' v = getg (`G_backw v) |> to_backw_g in let sideg' v d = sideg (`G_backw v) (of_backw_g d) in - tf getl' sidel' demandl' getg' sideg' |> of_backw_d + tf getl sidel' demandl' getg' sideg' |> of_backw_d ) let iter_vars getl getg vq fl fg = diff --git a/src/framework/control.ml b/src/framework/control.ml index 57fee2cccb..f4c359c9bb 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -17,11 +17,11 @@ open BidirConstrains module type S2S = Spec2Spec (*module that takes a Spec and a Context Domain type C and returns a SPec using this context instead*) -module ContextOverride (S: Spec) (C: Printable.S) : Spec with module C = C = +module ContextOverride (S: Spec) (S_forw: Spec) : Spec with module C = S_forw.C = struct module D = S.D module G = S.G - module C = C + module C = S_forw.C module V = S.V module P = S.P @@ -38,7 +38,9 @@ struct let coerce_man (man: (D.t, G.t, C.t, V.t) man) : (D.t, G.t, S.C.t, V.t) man = Obj.magic man - let context man fd d = Obj.magic (S.context (coerce_man man) fd d) + let context man fd d = + (* let man_forw = S_forw.context man fd d in *) + Obj.magic (S.context (coerce_man man) fd d) let startcontext () = Obj.magic (S.startcontext ()) let sync man k = S.sync (coerce_man man) k @@ -1894,7 +1896,7 @@ struct let do_backward_inits () = - let sideg_backw v d = sideg (`G_backw (v)) ((`Lifted2 d)) in + let sideg_backw v d = sideg (`G_backw v) (EQSys.G.create_spec (`Lifted2 d)) in let getg_backw v = match EQSys.G.spec (getg (`G_backw v)) with | `Lifted1 _ -> failwith "Unexpected backward global state" @@ -1945,7 +1947,7 @@ struct ; global = (fun _ -> Spec_backw.G.bot ()) ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") ; split = (fun _ -> failwith "Global initializers trying to split paths.") - ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) (G_backw.create_spec d)) + ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) d) } in @@ -1977,7 +1979,6 @@ struct let startstate, _ = do_global_inits_backw file in - (** calculate startvars *) let calculate_startvars_backw () = @@ -1989,13 +1990,13 @@ struct ; node = MyCFG.dummy_node ; prev_node = MyCFG.dummy_node ; control_context = (fun () -> man_failwith "enter_with has no control_context.") - ; context = Spec_backw.startcontext + ; context = Spec_forw.startcontext ; edge = MyCFG.Skip ; local = st ; global = (fun g -> G_backw.spec (getg_backw (GV_backw.spec g))) ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) (G_backw.create_spec (d))) + ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) d) } in let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in @@ -2027,11 +2028,11 @@ struct ; global = (fun g -> G_backw.spec (getg_backw (GV_backw.spec g))) ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) (G_backw.create_spec (d))) + ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) d) } in (* TODO: don't hd *) - List.hd (Spec_forw.threadenter man ~multiple:false None v []) + List.hd (Spec_backw.threadenter man ~multiple:false None v []) (* TODO: do threadspawn to mainfuns? *) in let prestartstate = Spec_backw.startstate MyCFG.dummy_func.svar in (* like in do_extern_inits *) @@ -2042,156 +2043,180 @@ struct AnalysisState.global_initialization := false; + (* 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec_backw.startcontext + ; context = Spec_forw.startcontext ; edge = MyCFG.Skip ; local = e ; global = (fun g -> G_backw.spec (getg_backw (GV_backw.spec g))) ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) (G_backw.create_spec d)) + ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) d) } in let startvars' = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_backw.context (man e) n e)) startvars in - let entrystates = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_backw.context (man e) n e), e) startvars in + let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec_backw.context (man e) n e), e) startvars in *) + + (* Using dummy contexts which will be replaced by the contextx of the forward functions*) + let startvars' = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_forw.startcontext)) startvars in + let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec_forw.startcontext), e) startvars in startvars', entrystates in calculate_startvars_backw () - - (** Combining the solver input calculation from the forwards and backwards part of the constrant system*) - let calculate_solver_input () = - let entrystates_global = GHT.to_list gh in - let startvars'_forw, entrystates_forw = do_forward_inits () in - - (* Lifting the forward satrtvars and entrystates to the constraint systems types*) - let startvars' = List.map (fun v -> `L_forw v) startvars'_forw in - let entrystates = List.map (fun (v, d) -> (`L_forw v, `Lifted1 d)) entrystates_forw in - - startvars', entrystates, entrystates_global - in - - let solve () = - let solver_data = None in - let startvars', entrystates, entrystates_global = calculate_solver_input () in - - let log_analysis_inputs () = - Logs.debug "=== Analysis Inputs ==="; - - (* Log entrystates *) - Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); - List.iteri (fun i (v, state) -> - Logs.debug "EntryState %d:" (i + 1); - Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) - | `L_backw (node, ctx) -> - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - ); - Logs.debug " State: %a" EQSys.D.pretty state; - ) entrystates; - - (* Log entrystates_global *) - Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); - List.iteri (fun i (gvar, gstate) -> - Logs.debug "GlobalEntryState %d:" (i + 1); - Logs.debug " GVar: %a" EQSys.GVar.pretty_trace gvar; - Logs.debug " GState: %a" EQSys.G.pretty gstate; - ) entrystates_global; - - (* Log startvars' *) - Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); - List.iteri (fun i v -> - Logs.debug "StartVar %d:" (i + 1); - Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) - | `L_backw (node, ctx) -> - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - ) - ) startvars'; - - Logs.debug "=== End Analysis Inputs ===" in - log_analysis_inputs (); - let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in + (** Combining the solver input calculation from the forwards and backwards part of the constrant system*) + let calculate_solver_input () = + let entrystates_global = GHT.to_list gh in + let startvars'_forw, entrystates_forw = do_forward_inits () in + let startvars'_backw, entrystates_backw = do_backward_inits () in + + (* Let's assume there is onyl one entrystate and startvar each. In what examples is this not the case?*) + let forward_context = match startvars'_forw with + | (_, ctx) :: _ -> ctx + | [] -> failwith "No startvars from forward analysis" + in + let startvars'_backw = List.map (fun (n, _) -> (n, forward_context)) startvars'_backw in + let entrystates_backw = List.map (fun ((n, _), d) -> ((n, forward_context), d)) entrystates_backw in + + (* Lifting and combining the startvars and entrystates from forwards and backwards analysis*) + let startvars' = List. append (List.map (fun v -> `L_forw v) startvars'_forw) (List.map (fun v -> `L_backw v) startvars'_backw) in + let entrystates = List.append (List.map (fun (v, d) -> (`L_forw v, `Lifted1 d)) entrystates_forw) (List.map (fun (v, d) -> (`L_backw v, `Lifted2 d)) entrystates_backw) in + + startvars', entrystates, entrystates_global + in + + let solve () = + let solver_data = None in + let startvars', entrystates, entrystates_global = calculate_solver_input () in + + let log_analysis_inputs () = + Logs.debug "=== Analysis Inputs ==="; + + (* Log entrystates *) + Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); + List.iteri (fun i (v, state) -> + Logs.debug "EntryState %d:" (i + 1); + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + ); + (match state with + | `Lifted1 d -> + Logs.debug " State: %a" Spec_forw.D.pretty d + | `Lifted2 d -> + Logs.debug " State: %a" Spec_backw.D.pretty d + | `Top -> + Logs.debug " State kind: Top"; + | `Bot -> + Logs.debug " State kind: Bot" + ); + ) entrystates; + + (* Log entrystates_global *) + Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); + List.iteri (fun i (gvar, gstate) -> + Logs.debug "GlobalEntryState %d:" (i + 1); + Logs.debug " GVar: %a" EQSys.GVar.pretty_trace gvar; + Logs.debug " GState: %a" EQSys.G.pretty gstate; + ) entrystates_global; + + (* Log startvars' *) + Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); + List.iteri (fun i v -> + Logs.debug "StartVar %d:" (i + 1); + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + ) + ) startvars'; - let log_lh_contents lh = - Logs.debug "=== LHT Contents ==="; - Logs.debug "LHT size: %d" (LHT.length lh); - let count = ref 0 in + Logs.debug "=== End Analysis Inputs ===" + in + log_analysis_inputs (); + + let (lh, gh), solver_data = Slvr.solve entrystates entrystates_global startvars' solver_data in + + let log_lh_contents lh = + Logs.debug "=== LHT Contents ==="; + Logs.debug "LHT size: %d" (LHT.length lh); + let count = ref 0 in + + Logs.debug "--- Full entry details ---"; + LHT.iter (fun v state -> + incr count; + Logs.debug "Entry %d:" !count; + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + (match v with + | `L_forw (node, ctx) -> + (* Logs.debug " Var kind: forward"; *) + Logs.debug " Node: %a" Node.pretty_trace node; + (try + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + with e -> + Logs.debug " Context: ERROR - %s" (Printexc.to_string e) + ); + | `L_backw (node, ctx) -> + (* Logs.debug " Var kind: backward"; *) + Logs.debug " Node: %a" Node.pretty_trace node; + (try + Logs.debug " Context: %a" Spec_forw.C.pretty ctx + with e -> + Logs.debug " Context: ERROR - %s" (Printexc.to_string e) + ) + ); + (match state with + | `Lifted1 d -> + (try + (* Logs.debug " State kind: Lifted1"; *) + Logs.debug " State: %a" Spec_forw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + ( + let base_id = MCPRegistry.find_id "base" in + let d_list : (int * Obj.t) list = Obj.magic d in + match List.assoc_opt base_id d_list with + | Some base_state -> + let module BaseDom = (val (MCPRegistry.find_spec base_id).dom : Lattice.S) in + Logs.debug " MCP base: %a" BaseDom.pretty (Obj.obj base_state) + | None -> + Logs.debug " MCP base: " + ); + | `Lifted2 d -> + (try + (* Logs.debug " State kind: Lifted2"; *) + Logs.debug " State: %a" Spec_backw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + | `Top -> + Logs.debug " State kind: Top"; + | `Bot -> + Logs.debug " State kind: Bot" + ); + ) lh; + Logs.debug "Total entries in LHT: %d" !count; + Logs.debug "=== End LHT Contents ===" + in + log_lh_contents lh; - Logs.debug "--- Full entry details ---"; - LHT.iter (fun v state -> - incr count; - Logs.debug "Entry %d:" !count; - Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) -> - (* Logs.debug " Var kind: forward"; *) - Logs.debug " Node: %a" Node.pretty_trace node; - (try - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - with e -> - Logs.debug " Context: ERROR - %s" (Printexc.to_string e) - ); - | `L_backw (node, ctx) -> - (* Logs.debug " Var kind: backward"; *) - Logs.debug " Node: %a" Node.pretty_trace node; - (try - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - with e -> - Logs.debug " Context: ERROR - %s" (Printexc.to_string e) - ) - ); - (match state with - | `Lifted1 d -> - (try - (* Logs.debug " State kind: Lifted1"; *) - Logs.debug " State: %a" Spec_forw.D.pretty d - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - ( - let base_id = MCPRegistry.find_id "base" in - let d_list : (int * Obj.t) list = Obj.magic d in - match List.assoc_opt base_id d_list with - | Some base_state -> - let module BaseDom = (val (MCPRegistry.find_spec base_id).dom : Lattice.S) in - Logs.debug " MCP base: %a" BaseDom.pretty (Obj.obj base_state) - | None -> - Logs.debug " MCP base: " - ); - | `Lifted2 d -> - (try - (* Logs.debug " State kind: Lifted2"; *) - Logs.debug " State: %a" Spec_backw.D.pretty d - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - | `Top -> - Logs.debug " State kind: Top"; - | `Bot -> - Logs.debug " State kind: Bot" - ); - ) lh; - Logs.debug "Total entries in LHT: %d" !count; - Logs.debug "=== End LHT Contents ===" in - log_lh_contents lh; - - in - solve(); + solve(); end @@ -2582,7 +2607,7 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = let module DummyWPSPec = Wp_test.Spec in (* let module B = AnalyzeCFG_2 (CFG) (DummyWPSPec) (struct let increment = change_info end) in *) - let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec.C) in + let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec) in let module C = AnalyzeCFG_3 (CFG) (Spec) (DummyWPSPec) (struct let increment = change_info end) in GobConfig.with_immutable_conf (fun () -> (* A.analyze file fs; From d52f9164e1751b268a41b08afbd78feafa5fc636 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Tue, 3 Feb 2026 14:04:19 +0100 Subject: [PATCH 16/29] - forwards and backwards analysis now work - backwardsa analysis now uses inforamtion from forwards analysis for contexts and resolving function call targets - modified test program xy_easyprog.c to test the new features --- src/analyses/wp_test.ml | 22 +- src/framework/bidirConstrains.ml | 73 +++- src/framework/control.ml | 699 ++++++++----------------------- xy_easyprog.c | 26 +- 4 files changed, 265 insertions(+), 555 deletions(-) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index a296fe3cb2..a912c7a913 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -84,8 +84,8 @@ struct (* TODO *) let enter man (lval: lval option) (f:fundec) (args:exp list) = - Logs.debug "=== enter function %s with args %s ===" f.svar.vname - (String.concat ", " (List.map (CilType.Exp.show) args)); + (* Logs.debug "=== enter function %s with args %s ===" f.svar.vname + (String.concat ", " (List.map (CilType.Exp.show) args)); *) let vars = match lval with @@ -98,12 +98,12 @@ struct (* TODO *) let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - Logs.debug "=== combine_env of function %s ===" f.svar.vname; - let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in - Logs.debug " args: %s" args_pretty; + (* Logs.debug "=== combine_env of function %s ===" f.svar.vname; + let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in + Logs.debug " args: %s" args_pretty; - let sformals_pretty = String.concat ", " (List.map (fun v -> v.vname) f.sformals) in - Logs.debug " sformals: %s" sformals_pretty; + let sformals_pretty = String.concat ", " (List.map (fun v -> v.vname) f.sformals) in + Logs.debug " sformals: %s" sformals_pretty; *) (*map relevant sformals in man.local to the corresponding variables contained in the argument*) let arg_formal_pairs = List.combine args f.sformals in @@ -120,10 +120,10 @@ struct D.join man.local relevant_arg_vars let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - Logs.debug "=== combine_assign of function %s ===" f.svar.vname; - (*how do I know which args are important? i.e. how do I match the local name of the variable in the function with the passed parameters (if there are several)*) - let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in - Logs.debug " args: %s" args_pretty; + (* Logs.debug "=== combine_assign of function %s ===" f.svar.vname; + (*how do I know which args are important? i.e. how do I match the local name of the variable in the function with the passed parameters (if there are several)*) + let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in + Logs.debug " args: %s" args_pretty; *) let simple_assign lval exp acc = let v = vars_from_lval lval in diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 9cd3ab650d..a88b99d03c 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -11,7 +11,6 @@ sig end - module BidirFromSpec (S_forw:Spec) (S_backw:Spec with type C.t = S_forw.C.t ) (Cfg:CfgBidir) (I:Increment) : sig module LVar : Goblint_constraint.ConstrSys.VarType with type t = [ `L_forw of VarF(S_forw.C).t | `L_backw of VarF(S_forw.C).t ] @@ -95,14 +94,7 @@ struct module Forward = Constraints.FromSpec (S_forw) (Cfg) (I) module Backward = Constraints_wp.FromSpec (S_backw) (Cfg) - let backw_lv_of_forw ((n,c): LV.t) : Backward.LVar.t = (n, Obj.magic c) - let forw_lv_of_backw ((n,c): Backward.LVar.t) : LV.t = (n, Obj.magic c) - - let to_l_backw (v:LVar.t) = - match v with - | `L_forw (n, l) -> `L_backw (n, l) - | `L_backw (n, l) -> `L_backw (n, l) - + (* functions for converting between forwards and backwards types*) let getl_backw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_backw.D.t = match getl (`L_backw v) with | `Lifted2 d -> d @@ -115,7 +107,15 @@ struct | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" | `Bot -> S_forw.D.bot () | `Top -> S_forw.D.top () - | `Lifted1 d -> d + | `Lifted1 d -> d + + let lv_of_backw ((n,c): Backward.LVar.t) : LV.t = (n, Obj.magic c) + + let to_l_backw (v:LVar.t) = + match v with + | `L_forw (n, l) -> `L_backw (n, l) + | `L_backw (n, l) -> `L_backw (n, l) + let cset_to_forw c = G.CSet.fold (fun x acc -> Forward.G.CSet.add x acc) c (Forward.G.CSet.empty ()) @@ -179,6 +179,8 @@ struct | `Bot -> `Bot | `Top -> `Top + + (* actually relevant (transfer) functions*) let sync_backw man = match man.prev_node, Cfg.next man.prev_node with | _, _ :: _ :: _ -> (* Join in CFG. *) @@ -326,8 +328,8 @@ struct if M.tracing then M.traceli "combine" "local: %a" S_backw.D.pretty cd; if M.tracing then M.trace "combine" "function: %a" S_backw.D.pretty fd; - Logs.debug "combine: local: %a" S_backw.D.pretty cd; - Logs.debug "combine: function: %a" S_backw.D.pretty fd; + (* Logs.debug "combine: local: %a" S_backw.D.pretty cd; + Logs.debug "combine: function: %a" S_backw.D.pretty fd; *) let rec cd_man = { man with @@ -377,7 +379,7 @@ struct ) (S_backw.D.bot ()) (S_backw.paths_as_set fd_man) in if M.tracing then M.traceu "combine" "combined local: %a" S_backw.D.pretty r; - Logs.debug "combined local: %a" S_backw.D.pretty r; + (* Logs.debug "combined local: %a" S_backw.D.pretty r; *) r in let paths = @@ -409,8 +411,12 @@ struct let paths = List.combine paths paths_forw in + (* filter paths were the forward analysis found out they are unreachable*) + let paths = List.filter (fun ((c,v),(_,b)) -> not (S_forw.D.is_bot b)) paths in + + (* this list now uses forward contexts*) - let paths = List.map (fun ((c,v),(a,b)) -> (c, S_forw.context man_forw f b, v)) paths in + let paths = List.map (fun ((c,v),(_,b)) -> (c, S_forw.context man_forw f b, v)) paths in (* List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; *) List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (Function f, fc) v) paths; @@ -422,11 +428,11 @@ struct (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) let paths = List.map (Tuple3.map2 Option.some) paths in if M.tracing then M.traceli "combine" "combining"; - Logs.debug "combining"; + (* Logs.debug "combining"; *) let paths = List.map combine paths in let r = List.fold_left S_backw.D.join (S_backw.D.bot ()) paths in if M.tracing then M.traceu "combine" "combined: %a" S_backw.D.pretty r; - Logs.debug "combined: %a" S_backw.D.pretty r; + (* Logs.debug "combined: %a" S_backw.D.pretty r; *) r (*TODO: HERE AS WELL*) @@ -467,10 +473,34 @@ struct Allows deactivating base. *) [v] | _ -> + (*constructing fake forwards manager s.t. the inforamtion for the pointer information can be retireved*) + let r = ref [] in + let rec man_forw = + { ask = (fun (type a) (q: a Queries.t) -> S_forw.query man_forw q) + ; emit = (fun _ -> failwith "emit outside MCP") + ; node = man.node + ; prev_node = man.prev_node (* this is problematic, as this is backwards *) + ; control_context = man.control_context + ; context = man.context + ; edge = man.edge + ; local = (getl_forw (man.node, man.context ())) (* accessing forward inforkation*) + ; global = (fun _ -> failwith "whoops, query for resolving function pointer depends on globals") + ; spawn = (fun ?multiple _ _ _ -> failwith "manager for resolving function pointer does not support spawn") + ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) (*what is this?*) + ; sideg = (fun _ _ -> failwith "manager for resolving function pointer does not support sideg") + } in + let () = Logs.debug "manager info at call to function pointer %a" Node.pretty man_forw.node in (* Depends on base for query. *) - let ad = man.ask (Queries.EvalFunvar e) in - Queries.AD.to_var_may ad (* TODO: don't convert, handle UnknownPtr below *) + let ad = man_forw.ask (Queries.EvalFunvar e) in + let res = Queries.AD.to_var_may ad in (* TODO: don't convert, handle UnknownPtr below *) (*PROBLEM: Pointer. Brauche Ergebnisse der anderen Analysen*) + (Logs.debug "(!) resolved function pointer to %d functions" (List.length res); + (match res with + | x::xs -> + List.iter (fun vi -> Logs.debug " possible function: %s" vi.vname) res; + | _ -> (); + )); + res in let one_function f = match Cil.unrollType f.vtype with @@ -592,8 +622,7 @@ struct in Some tf_backw - - (*WEIRD VARIABLE TYPES??*) + (* TODO: non-problematic but weird inconsisteny between forward and backward variable types*) let system var = match var with | `L_forw v -> @@ -610,8 +639,8 @@ struct system_backw v |> Option.map (fun tf getl sidel demandl getg sideg -> (* let getl' (v : Backward.LVar.t) : (S_backw.D.t) = getl (`L_backw (forw_lv_of_backw v)) |> to_backw_d in *) - let sidel' v d = sidel (`L_backw (forw_lv_of_backw v)) (of_backw_d d) in - let demandl' v = demandl (`L_backw (forw_lv_of_backw v)) in + let sidel' v d = sidel (`L_backw (lv_of_backw v)) (of_backw_d d) in + let demandl' v = demandl (`L_backw (lv_of_backw v)) in let getg' v = getg (`G_backw v) |> to_backw_g in let sideg' v d = sideg (`G_backw v) (of_backw_g d) in tf getl sidel' demandl' getg' sideg' |> of_backw_d diff --git a/src/framework/control.ml b/src/framework/control.ml index f4c359c9bb..94d6f225ee 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -16,7 +16,8 @@ open BidirConstrains module type S2S = Spec2Spec -(*module that takes a Spec and a Context Domain type C and returns a SPec using this context instead*) +(** Module that takes a Spec and a Context Domain type C and returns a Spec using this context instead. This is purely for type-signature reasons. + * The context-related functions in the returned (backwards-)Spec should not be used.*) module ContextOverride (S: Spec) (S_forw: Spec) : Spec with module C = S_forw.C = struct module D = S.D @@ -69,7 +70,6 @@ struct end - (* spec is lazy, so HConsed table in Hashcons lifters is preserved between analyses in server mode *) let spec_module: (module Spec) Lazy.t = lazy ( GobConfig.building_spec := true; @@ -568,6 +568,48 @@ struct in Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); AnalysisState.should_warn := get_string "warn_at" = "early"; + + let log_analysis_inputs () = + Logs.debug "=== Analysis Inputs ==="; + + (* Log entrystates *) + Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); + List.iteri (fun i ((node, ctx), state) -> + Logs.debug "EntryState %d:" (i + 1); + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec.C.pretty ctx; + Logs.debug " State: %a" Spec.D.pretty state; + ) entrystates; + + (* Log entrystates_global *) + Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); + List.iteri (fun i (gvar, gstate) -> + Logs.debug "GlobalEntryState %d:" (i + 1); + Logs.debug " GVar: %a" EQSys.GVar.pretty gvar; + Logs.debug " GState: %a" EQSys.G.pretty gstate; + ) entrystates_global; + + (* Log startvars' *) + Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); + List.iteri (fun i (node, ctx) -> + Logs.debug "StartVar %d:" (i + 1); + Logs.debug " Node: %a" Node.pretty_trace node; + Logs.debug " Context: %a" Spec.C.pretty ctx; + ) startvars'; + + (* Log startvars (without apostrophe) *) + Logs.debug "--- Start Variables (no apostrophe) (count: %d) ---" (List.length startvars); + List.iteri (fun i (node, state) -> + Logs.debug "StartVar (no apostrophe) %d:" (i + 1); + Logs.debug " Node: %a" CilType.Fundec.pretty node; + Logs.debug " State: (of type EQSys.D.t) %a" Spec.D.pretty state; + ) startvars; + + Logs.debug "=== End Analysis Inputs ===" + in + log_analysis_inputs (); + + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in if GobConfig.get_bool "incremental.save" then Serialize.Cache.(update_data SolverData solver_data); @@ -806,7 +848,7 @@ struct Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg) end -module AnalyzeCFG_2 (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = +module AnalyzeCFG_backw (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = struct module SpecSys: SpecSys with module Spec = Spec = @@ -1643,7 +1685,8 @@ struct output_wp_results_to_xml lh; end -module AnalyzeCFG_3 (Cfg:CfgBidirSkip) (Spec_forw:Spec) (Spec_backw: Spec with type C.t = Spec_forw.C.t ) (Inc:Increment) = +(** Given a [Cfg], a [Spec_forw], [Spec_back], and an unused [Inc], computes the solution] *) +module AnalyzeCFG_bidir (Cfg:CfgBidirSkip) (Spec_forw:Spec) (Spec_backw: Spec with type C.t = Spec_forw.C.t ) (Inc:Increment) = struct (* The Equation system *) @@ -1654,8 +1697,6 @@ struct (* Hashtbl for globals *) module GHT = BatHashtbl.Make (EQSys.GVar) - - (* The solver *) module PostSolverArg = struct @@ -1670,7 +1711,8 @@ struct end module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) - (* Triple of the function, context, and the local value. It uses SPec and therefore hast the wrong types.*) + (* There are a lot of things I do not use here*) + (* Triple of the function, context, and the local value. It uses Spec and therefore hast the wrong types.*) (* module RT = AnalysisResult.ResultType2 (Spec) module LT = SetDomain.HeadlessSet (RT) *) @@ -1697,7 +1739,7 @@ struct let module G_backw = GVarG (Spec_backw.G) (Spec_backw.C) in - let () = + let log_analysis_setup () = let log_fun_list name funs = let fun_names = List.map (fun f -> f.svar.vname) funs in Logs.debug "%s functions: %s" name (String.concat ", " fun_names) @@ -1708,59 +1750,62 @@ struct log_fun_list "Other" otherfuns; Logs.debug "================================================="; in + log_analysis_setup (); - AnalysisState.should_warn := false; (* reset for server mode *) + AnalysisState.should_warn := false; - (* muss iwie die typen exposen..?*) - - (* Doing forwards and backwards inits*) - (* Simulate globals before analysis. *) + (* initialize hastable for globals*) let gh = GHT.create 13 in let getg v = GHT.find_default gh v (EQSys.G.bot ()) in let sideg v d = GHT.replace gh v (EQSys.G.join (getg v) d) in - let do_forward_inits () = + (* the intit globals should not depend on each other*) + let getg v = EQSys.G.bot () in + + (** this function calculates and returns [startvars'_forw] and [entrystates_forw] *) + let do_forward_inits () : (node * Spec_forw.C.t) list * ((node * Spec_forw.C.t) * Spec_forw.D.t) list = + (* wrapping functions accessing and modifying global variables *) let sideg_forw v d = sideg (`G_forw (v)) ((`Lifted1 d)) in let getg_forw v = match EQSys.G.spec (getg (`G_forw v)) with | `Lifted1 g -> G_forw.create_spec g - | `Bot -> `Bot - | `Top -> `Top + | `Bot -> failwith "Unexpected global state" (*G_forw.bot (); *) + | `Top -> failwith "Unexpected global state" (*G_forw.top ()*) | `Lifted2 _ -> failwith "Unexpected backward global state" in - (** This function nalyzelhs cil's global-inits function to get a starting state *) - let do_global_inits_forw (file: file) : Spec_forw.D.t * fundec list = - - let do_extern_inits_forw man (file: file) : Spec_forw.D.t = - let module VS = Set.Make (Basetype.Variables) in - let add_glob s = function - | GVar (v,_,_) -> VS.add v s - | _ -> s - in - let vars = foldGlobals file add_glob VS.empty in - let set_bad v st = - Spec_forw.assign {man with local = st} (var v) MyCFG.unknown_exp - in - let is_std = function - | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) - | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) - | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) - | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) - | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) - | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) - true - | _ -> false - in - let add_externs s = function - | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s - | _ -> s - in - foldGlobals file add_externs (Spec_forw.startstate MyCFG.dummy_func.svar) + let do_extern_inits_forw man (file: file) : Spec_forw.D.t = + let module VS = Set.Make (Basetype.Variables) in + let add_glob s = function + | GVar (v,_,_) -> VS.add v s + | _ -> s in + let vars = foldGlobals file add_glob VS.empty in + let set_bad v st = + Spec_forw.assign {man with local = st} (var v) MyCFG.unknown_exp + in + let is_std = function + | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) + | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) + | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) + | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) + | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) + | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) + true + | _ -> false + in + let add_externs s = function + | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s + | _ -> s + in + Logs.debug "startstate of Spec_forw: %a" Spec_forw.D.pretty (Spec_forw.startstate MyCFG.dummy_func.svar); + foldGlobals file add_externs (Spec_forw.startstate MyCFG.dummy_func.svar) + in + (** this function uses cil's global-inits function to get a starting state *) + let do_global_inits_forw (file: file) : Spec_forw.D.t * fundec list = let man = { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) ; emit = (fun _ -> failwith "Cannot \"emit\" in global initializer context.") @@ -1770,7 +1815,7 @@ struct ; context = (fun () -> man_failwith "Global initializers have no context.") ; edge = MyCFG.Skip ; local = Spec_forw.D.top () - ; global = (fun _ -> Spec_forw.G.bot ()) + ; global = (fun g -> G_forw.spec (getg (GV_forw.spec g))) ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") ; split = (fun _ -> failwith "Global initializers trying to split paths.") ; sideg = (fun g d -> sideg_forw (GV_forw.spec g) (G_forw.create_spec d)) @@ -1799,13 +1844,13 @@ struct in let with_externs = do_extern_inits_forw man file in + Logs.debug "witch_externs: %a" Spec_forw.D.pretty with_externs; let result : Spec_forw.D.t = List.fold_left transfer_func with_externs edges in result, !funs in let startstate, _ = do_global_inits_forw file in - (** calculate startvars *) let calculate_startvars_forw () = @@ -1894,46 +1939,46 @@ struct calculate_startvars_forw () in - let do_backward_inits () = - + (** this function calculates and returns [startvars'_backw] and [entrystates_backw] *) + let do_backward_inits () : (node * Spec_backw.C.t) list * ((node * Spec_forw.C.t) * Spec_backw.D.t) list = let sideg_backw v d = sideg (`G_backw v) (EQSys.G.create_spec (`Lifted2 d)) in let getg_backw v = match EQSys.G.spec (getg (`G_backw v)) with | `Lifted1 _ -> failwith "Unexpected backward global state" - | `Bot -> `Bot - | `Top -> `Top + | `Bot -> G_backw.bot () + | `Top -> G_backw.top () | `Lifted2 g -> G_backw.create_spec g in - (** This function nalyzelhs cil's global-inits function to get a starting state *) - let do_global_inits_backw (file: file) : Spec_backw.D.t * fundec list = - - let do_extern_inits_backw man (file: file) : Spec_backw.D.t = - let module VS = Set.Make (Basetype.Variables) in - let add_glob s = function - | GVar (v,_,_) -> VS.add v s - | _ -> s - in - let vars = foldGlobals file add_glob VS.empty in - let set_bad v st = - Spec_backw.assign {man with local = st} (var v) MyCFG.unknown_exp - in - let is_std = function - | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) - | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) - | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) - | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) - | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) - | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) - true - | _ -> false - in - let add_externs s = function - | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s - | _ -> s - in - foldGlobals file add_externs (Spec_backw.startstate MyCFG.dummy_func.svar) + let do_extern_inits_backw man (file: file) : Spec_backw.D.t = + let module VS = Set.Make (Basetype.Variables) in + let add_glob s = function + | GVar (v,_,_) -> VS.add v s + | _ -> s + in + let vars = foldGlobals file add_glob VS.empty in + let set_bad v st = + Spec_backw.assign {man with local = st} (var v) MyCFG.unknown_exp + in + let is_std = function + | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) + | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) + | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) + | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) + | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) + | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) + true + | _ -> false in + let add_externs s = function + | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s + | _ -> s + in + foldGlobals file add_externs (Spec_backw.startstate MyCFG.dummy_func.svar) + in + + (** This function analyses cil's global-inits function to get a starting state *) + let do_global_inits_backw (file: file) : Spec_backw.D.t * fundec list = let man = { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) @@ -2063,8 +2108,8 @@ struct let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec_backw.context (man e) n e), e) startvars in *) (* Using dummy contexts which will be replaced by the contextx of the forward functions*) - let startvars' = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_forw.startcontext)) startvars in - let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec_forw.startcontext), e) startvars in + let startvars' = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_forw.startcontext ())) startvars in + let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec_forw.startcontext ()), e) startvars in startvars', entrystates in @@ -2072,8 +2117,16 @@ struct calculate_startvars_backw () in - (** Combining the solver input calculation from the forwards and backwards part of the constrant system*) - let calculate_solver_input () = + (** calculates and combines the solver input calculation from the forwards and backwards part of the constraint system. Returns [startvars'] and [entrystate] and [entrystates_global].*) + let calculate_solver_input () = + AnalysisState.global_initialization := true; + (* Some happen in init, so enable this temporarily (if required by option). *) + AnalysisState.should_warn := PostSolverArg.should_warn; + Spec_forw.init None; + Access.init file; + AnalysisState.should_warn := false; + + let entrystates_global = GHT.to_list gh in let startvars'_forw, entrystates_forw = do_forward_inits () in let startvars'_backw, entrystates_backw = do_backward_inits () in @@ -2093,6 +2146,7 @@ struct startvars', entrystates, entrystates_global in + (** solves constraint system*) let solve () = let solver_data = None in let startvars', entrystates, entrystates_global = calculate_solver_input () in @@ -2105,12 +2159,12 @@ struct List.iteri (fun i (v, state) -> Logs.debug "EntryState %d:" (i + 1); Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) - | `L_backw (node, ctx) -> + (* (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> Logs.debug " Node: %a" Node.pretty_trace node; Logs.debug " Context: %a" Spec_forw.C.pretty ctx - ); + ); *) (match state with | `Lifted1 d -> Logs.debug " State: %a" Spec_forw.D.pretty d @@ -2136,12 +2190,12 @@ struct List.iteri (fun i v -> Logs.debug "StartVar %d:" (i + 1); Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) - | `L_backw (node, ctx) -> + (* (match v with + | `L_forw (node, ctx) + | `L_backw (node, ctx) -> Logs.debug " Node: %a" Node.pretty_trace node; Logs.debug " Context: %a" Spec_forw.C.pretty ctx - ) + ) *) ) startvars'; Logs.debug "=== End Analysis Inputs ===" @@ -2150,7 +2204,10 @@ struct let (lh, gh), solver_data = Slvr.solve entrystates entrystates_global startvars' solver_data in - let log_lh_contents lh = + let log_lh_contents lh = + let print_forw_entries : bool = false in + let print_backw_entries : bool = true in + Logs.debug "=== LHT Contents ==="; Logs.debug "LHT size: %d" (LHT.length lh); let count = ref 0 in @@ -2159,58 +2216,36 @@ struct LHT.iter (fun v state -> incr count; Logs.debug "Entry %d:" !count; - Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - (match v with - | `L_forw (node, ctx) -> - (* Logs.debug " Var kind: forward"; *) - Logs.debug " Node: %a" Node.pretty_trace node; - (try - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - with e -> - Logs.debug " Context: ERROR - %s" (Printexc.to_string e) - ); - | `L_backw (node, ctx) -> - (* Logs.debug " Var kind: backward"; *) - Logs.debug " Node: %a" Node.pretty_trace node; - (try - Logs.debug " Context: %a" Spec_forw.C.pretty ctx - with e -> - Logs.debug " Context: ERROR - %s" (Printexc.to_string e) - ) - ); - (match state with - | `Lifted1 d -> - (try - (* Logs.debug " State kind: Lifted1"; *) - Logs.debug " State: %a" Spec_forw.D.pretty d - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - ( - let base_id = MCPRegistry.find_id "base" in - let d_list : (int * Obj.t) list = Obj.magic d in - match List.assoc_opt base_id d_list with - | Some base_state -> - let module BaseDom = (val (MCPRegistry.find_spec base_id).dom : Lattice.S) in - Logs.debug " MCP base: %a" BaseDom.pretty (Obj.obj base_state) - | None -> - Logs.debug " MCP base: " - ); - | `Lifted2 d -> - (try - (* Logs.debug " State kind: Lifted2"; *) - Logs.debug " State: %a" Spec_backw.D.pretty d - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - | `Top -> - Logs.debug " State kind: Top"; - | `Bot -> - Logs.debug " State kind: Bot" - ); - ) lh; + if (match v with `L_forw _ -> print_forw_entries | `L_backw _ -> print_backw_entries) + then ( + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + Logs.debug " Context: %a" Spec_forw.C.pretty (match v with + | `L_forw (_, ctx) + | `L_backw (_, ctx) -> ctx); + (match state with + | `Lifted1 d -> + (try + Logs.debug " State:%a" Spec_forw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e)) + | `Lifted2 d -> + (try + Logs.debug " State: %a" Spec_backw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + | `Top -> + Logs.debug " State kind: Top"; + | `Bot -> + Logs.debug " State kind: Bot" + ); + ) else ( + Logs.debug " (Entry skipped in log)" + ) + ) + lh; Logs.debug "Total entries in LHT: %d" !count; - Logs.debug "=== End LHT Contents ===" + Logs.debug "=== End LHT Contents ==="; in log_lh_contents lh; @@ -2219,381 +2254,6 @@ struct solve(); end - -(** Given a [Cfg] and a [Spec], and unused [Inc] computes the solution to [???] *) -module AnalyzeCFG_WP (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = -struct - - module SpecSys: SpecSys with module Spec = Spec = - struct - (* Must be created in module, because cannot be wrapped in a module later. *) - module Spec = Spec - - (* The Equation system *) - module EQSys = Constraints_wp.FromSpec (Spec) (Cfg) - - (* Hashtbl for locals *) - module LHT = BatHashtbl.Make (EQSys.LVar) - (* Hashtbl for globals *) - module GHT = BatHashtbl.Make (EQSys.GVar) - end - - open SpecSys - - (* The solver *) - module PostSolverArg = - struct - let should_prune = true - let should_verify = get_bool "verify" - let should_warn = get_string "warn_at" <> "never" - let should_save_run = - (* copied from solve_and_postprocess *) - let gobview = get_bool "gobview" in - let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in - save_run <> "" - end - module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) - (* The comparator *) - module CompareGlobSys = CompareConstraints.CompareGlobSys (SpecSys) - - (* Triple of the function, context, and the local value. *) - module RT = AnalysisResult.ResultType2 (Spec) - (* Set of triples [RT] *) - module LT = SetDomain.HeadlessSet (RT) - (* Analysis result structure---a hashtable from program points to [LT] *) - module Result = AnalysisResult.Result (LT) (struct let result_name = "wp_analysis" end) - module ResultOutput = AnalysisResultOutput.Make (Result) - - module Query = ResultQuery.Query (SpecSys) - - let solver2source_result h : Result.t = - (* processed result *) - let res = Result.create 113 in - - (* Adding the state at each system variable to the final result *) - let add_local_var (n,es) state = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let loc = UpdateCil.getLoc n in - if loc <> locUnknown then try - let fundec = Node.find_fundec n in - if Result.mem res n then - (* If this source location has been added before, we look it up - * and add another node to it information to it. *) - let prev = Result.find res n in - Result.replace res n (LT.add (es,state,fundec) prev) - else - Result.add res n (LT.singleton (es,state,fundec)) - (* If the function is not defined, and yet has been included to the - * analysis result, we generate a warning. *) - with Not_found -> - Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n - in - LHT.iter add_local_var h; - res - - (** The main function to preform the selected analyses. *) - let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = - Messages.warn "Starting analysis '%s:'" (Spec.name ()); - - Logs.debug "Spec: Type of D: %s" (Spec.D.name ()); - Logs.debug "Spec: Type of G: %s" (Spec.G.name ()); - - Logs.debug "Startfuns: %s" (List.fold_left (fun a f -> a ^ " ; " ^ f.svar.vname) "" startfuns); - - (*## COPIED ##*) - let module FileCfg: FileCfg = - struct - let file = file - module Cfg = Cfg - end - in - - AnalysisState.should_warn := false; (* reset for server mode *) - - (* add extern variables to local state *) - 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 - | _ -> s - in - let vars = foldGlobals file add_glob VS.empty in - let set_bad v st = - Spec.assign {man with local = st} (var v) MyCFG.unknown_exp - in - let is_std = function - | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) - | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) - | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) - | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) - | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) - | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) - true - | _ -> false - in - let add_externs s = function - | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s - | _ -> s - in - foldGlobals file add_externs (Spec.startstate MyCFG.dummy_func.svar) - in - - (* Simulate globals before analysis. *) - (* TODO: make extern/global inits part of constraint system so all of this would be unnecessary. *) - let gh = GHT.create 13 in - let getg v = GHT.find_default gh v (EQSys.G.bot ()) in - let sideg v d = - if M.tracing then M.trace "global_inits" "sideg %a = %a" EQSys.GVar.pretty v EQSys.G.pretty d; - GHT.replace gh v (EQSys.G.join (getg v) d) - in - (* Old-style global function for context. - * This indirectly prevents global initializers from depending on each others' global side effects, which would require proper solving. *) - let getg v = EQSys.G.bot () in - - (* analyze cil's global-inits function to get a starting state *) - let do_global_inits (file: file) : Spec.D.t * fundec list = - 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 () -> 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))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") - ; split = (fun _ -> failwith "Global initializers trying to split paths.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let edges = CfgTools.getGlobalInits file in - Logs.debug "Executing %d assigns." (List.length edges); - let funs = ref [] in - (*let count = ref 0 in*) - let transfer_func (st : Spec.D.t) (loc, edge) : Spec.D.t = - if M.tracing then M.trace "con" "Initializer %a" CilType.Location.pretty loc; - (*incr count; - if (get_bool "dbg.verbose")&& (!count mod 1000 = 0) then Printf.printf "%d %!" !count; *) - match edge with - | MyCFG.Entry func -> - if M.tracing then M.trace "global_inits" "Entry %a" d_lval (var func.svar); - 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 - | (Var v,o), (AddrOf (Var f,NoOffset)) - when v.vstorage <> Static && isFunctionType f.vtype -> - (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) - | _ -> () - end; - 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 {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 transfer_func st (loc, edge) = - let old_loc = !Goblint_tracing.current_loc in - Goblint_tracing.current_loc := loc; - (* TODO: next_loc? *) - Goblint_backtrace.protect ~mark:(fun () -> Constraints.TfLocation loc) ~finally:(fun () -> - Goblint_tracing.current_loc := old_loc; - ) (fun () -> - transfer_func st (loc, edge) - ) - 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 result : Spec.D.t = List.fold_left transfer_func with_externs edges in - if M.tracing then M.trace "global_inits" "startstate: %a" Spec.D.pretty result; - result, !funs - in - - let print_globals glob = - let out = M.get_out (Spec.name ()) !M.out in - let print_one v st = - ignore (Pretty.fprintf out "%a -> %a\n" EQSys.GVar.pretty_trace v EQSys.G.pretty st) - in - GHT.iter print_one glob - in - - (* real beginning of the [analyze] function *) - if get_bool "ana.sv-comp.enabled" then - Witness.init (module FileCfg); (* TODO: move this out of analyze_loop *) - YamlWitness.init (); - - AnalysisState.global_initialization := true; - GobConfig.earlyglobs := get_bool "exp.earlyglobs"; - let marshal: Spec.marshal option = - if get_string "load_run" <> "" then - Some (Serialize.unmarshal Fpath.(v (get_string "load_run") / "spec_marshal")) - else if Serialize.results_exist () && get_bool "incremental.load" then - Some (Serialize.Cache.(get_data AnalysisData)) - else - None - in - - (* Some happen in init, so enable this temporarily (if required by option). *) - AnalysisState.should_warn := PostSolverArg.should_warn; - Spec.init marshal; - Access.init file; - AnalysisState.should_warn := false; - - let test_domain (module D: Lattice.S): unit = - let module DP = DomainProperties.All (D) in - Logs.debug "domain testing...: %s" (D.name ()); - let errcode = QCheck_base_runner.run_tests DP.tests in - if (errcode <> 0) then - failwith "domain tests failed" - in - let _ = - if (get_bool "dbg.test.domain") then ( - Logs.debug "domain testing analysis...: %s" (Spec.name ()); - test_domain (module Spec.D); - test_domain (module Spec.G); - ) - in - - let startstate, more_funs = - Logs.debug "Initializing %d globals." (CfgTools.numGlobals file); - Timing.wrap "global_inits" do_global_inits file - in - - let otherfuns = if get_bool "kernel" then otherfuns @ more_funs else otherfuns in - - let enter_with st fd = - let st = st fd.svar in - 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec.startcontext - ; edge = MyCFG.Skip - ; local = st - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in - let ents = Spec.enter man None fd args in - List.map (fun (_,s) -> fd, s) ents - in - - (try MyCFG.dummy_func.svar.vdecl <- (List.hd otherfuns).svar.vdecl with Failure _ -> ()); - - let startvars = - if startfuns = [] - then [[MyCFG.dummy_func, startstate]] - else - let morph f = Spec.morphstate f startstate in - List.map (enter_with morph) startfuns - in - - let exitvars = List.map (enter_with Spec.exitstate) exitfuns in - let otherstate st v = - 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 () -> 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))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - (* TODO: don't hd *) - 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 *) - let othervars = List.map (enter_with (otherstate prestartstate)) otherfuns in - let startvars = List.concat (startvars @ exitvars @ othervars) in - if startvars = [] then - failwith "BUG: Empty set of start variables; may happen if enter_func of any analysis returns an empty list."; - - AnalysisState.global_initialization := false; - - 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec.startcontext - ; edge = MyCFG.Skip - ; local = e - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - - (*## COPIED ##*) - - (* empty entrystates:*) - (* let entrystates = [] in - let entrystates_global = [] in - let startvars' = [] in *) - - (* Non-Empty entrystates copied*) - 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec.startcontext - ; edge = MyCFG.Skip - ; local = e - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let startvars' = - if get_bool "exp.forward" then - 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 (man e) n 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 - - (*what if i use exitwars as starvars? *) - - let (local_res, global_res), _ = Slvr.solve entrystates entrystates_global startvars' None in - let local_xml = solver2source_result local_res in - - let make_global_fast_xml f g = - let open Printf in - let print_globals k v = - fprintf f "\n%s%a" (XmlUtil.escape (EQSys.GVar.show k)) EQSys.G.printXml v; - in - GHT.iter print_globals g - in - - - ResultOutput.output (lazy local_xml) (fun _ -> true) global_res make_global_fast_xml (module FileCfg); - (); - - -end - (** This function was originally a part of the [AnalyzeCFG] module, but now that [AnalyzeCFG] takes [Spec] as a functor parameter, [analyze_loop] cannot reside in it anymore since each invocation of @@ -2605,10 +2265,11 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = let module A = AnalyzeCFG (CFG) (Spec) (struct let increment = change_info end) in let module DummyWPSPec = Wp_test.Spec in - (* let module B = AnalyzeCFG_2 (CFG) (DummyWPSPec) (struct let increment = change_info end) in *) + (* let module B = AnalyzeCFG_backw (CFG) (DummyWPSPec) (struct let increment = change_info end) in *) let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec) in - let module C = AnalyzeCFG_3 (CFG) (Spec) (DummyWPSPec) (struct let increment = change_info end) in + let module C = AnalyzeCFG_bidir (CFG) (Spec) (DummyWPSPec) (struct let increment = change_info end) in + GobConfig.with_immutable_conf (fun () -> (* A.analyze file fs; B.analyze file fs; *) diff --git a/xy_easyprog.c b/xy_easyprog.c index 58dacd324b..c31c6dd76a 100644 --- a/xy_easyprog.c +++ b/xy_easyprog.c @@ -1,9 +1,19 @@ #include int f(int x, int y) { - int i = 0; + int i = 2; + + if (x > 0) { + i = i + 2; + return i; + } else { + i = i + 3; + return i + x; + } +} - i = i + 1; +int g (int x, int y) { + int i = 2; if (x > 0) { i = i + 2; @@ -18,7 +28,17 @@ int f(int x, int y) { int main() { int a = 0; int c = 3; - int b = f(a, c); + + int rand; + + int (*h)(int, int); // function pointer to f + h = &f; + + if (rand) { + h = &g; + } + + int b = (*h)(a, c); return b; } From 237399e795eac95ef4b657c233c4a78170019b51 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Fri, 6 Feb 2026 18:22:06 +0100 Subject: [PATCH 17/29] working on result to xml --- src/framework/bidirConstrains.ml | 93 ++++++++++++++++-------- src/framework/control.ml | 121 ++++++++++++++++++++++++++++--- 2 files changed, 175 insertions(+), 39 deletions(-) diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index a88b99d03c..357e68696d 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -10,11 +10,70 @@ sig val increment: increment_data option end +module GVarF2 (V_forw: SpecSysVar) (V_backw : SpecSysVar) : +sig + include VarType with type t = [ `G_forw of GVarF(V_forw).t | `G_backw of GVarF(V_backw).t ] + include SpecSysVar with type t := t +end += +struct + module GV_forw = GVarF (V_forw) + module GV_backw = GVarF (V_backw) + type t = [ `G_forw of GV_forw.t | `G_backw of GV_backw.t ] [@@deriving eq, ord, hash] + let name () = "BidirFromSpec" + + let tag _ = failwith "Std: no tag" + + let relift = function + | `G_forw x -> `G_forw (GV_forw.relift x) + | `G_backw x -> `G_backw (GV_backw.relift x) + + let pretty_trace () = function + | `G_forw a -> GoblintCil.Pretty.dprintf "G_forw:%a" GV_forw.pretty_trace a + | `G_backw a -> GoblintCil.Pretty.dprintf "G_backw:%a" GV_backw.pretty_trace a + + let printXml f = function + | `G_forw a -> GV_forw.printXml f a + | `G_backw a -> GV_backw.printXml f a + + let node = function + | `G_forw a -> GV_forw.node a + | `G_backw a -> GV_backw.node a + + let is_write_only = function + | `G_forw a -> GV_forw.is_write_only a + | `G_backw a -> GV_backw.is_write_only a + + let show = function + | `G_forw a -> GV_forw.show a + | `G_backw a -> GV_backw.show a + + let pretty () = function + | `G_forw a -> GV_forw.pretty () a + | `G_backw a -> GV_backw.pretty () a + let to_yojson = function + | `G_forw a -> GV_forw.to_yojson a + | `G_backw a -> GV_backw.to_yojson a + + let spec = function + | `G_forw a -> GV_forw.spec a + | `G_backw a -> GV_backw.spec a + + let contexts = function + | `G_forw a -> GV_forw.contexts a + | `G_backw a -> GV_backw.contexts a + + let var_id = show + + let arbitrary () = + failwith "no arbitrary" +end + module BidirFromSpec (S_forw:Spec) (S_backw:Spec with type C.t = S_forw.C.t ) (Cfg:CfgBidir) (I:Increment) : sig module LVar : Goblint_constraint.ConstrSys.VarType with type t = [ `L_forw of VarF(S_forw.C).t | `L_backw of VarF(S_forw.C).t ] - module GVar : Goblint_constraint.ConstrSys.VarType with type t = [ `G_forw of GVarF(S_forw.V).t | `G_backw of GVarF(S_backw.V).t ] + module GVar : (module type of GVarF2(S_forw.V)(S_backw.V)) include DemandGlobConstrSys with module LVar := LVar and module GVar := GVar and module D = Lattice.Lift2(S_forw.D)(S_backw.D) @@ -58,34 +117,7 @@ struct module D = Lattice.Lift2(S_forw.D)(S_backw.D) module GV_forw = GVarF (S_forw.V) module GV_backw = GVarF (S_backw.V) - module GVar = - struct - type t = [ `G_forw of GV_forw.t | `G_backw of GV_backw.t ] [@@deriving eq, ord, hash] - - let relift = function - | `G_forw x -> `G_forw (GV_forw.relift x) - | `G_backw x -> `G_backw (GV_backw.relift x) - - let pretty_trace () = function - | `G_forw a -> GoblintCil.Pretty.dprintf "G_forw:%a" GV_forw.pretty_trace a - | `G_backw a -> GoblintCil.Pretty.dprintf "G_backw:%a" GV_backw.pretty_trace a - - let printXml f = function - | `G_forw a -> GV_forw.printXml f a - | `G_backw a -> GV_backw.printXml f a - - let var_id = function - | `G_forw a -> GV_forw.var_id a - | `G_backw a -> GV_backw.var_id a - - let node = function - | `G_forw a -> GV_forw.node a - | `G_backw a -> GV_backw.node a - - let is_write_only = function - | `G_forw a -> GV_forw.is_write_only a - | `G_backw a -> GV_backw.is_write_only a - end + module GVar = GVarF2(S_forw.V)(S_backw.V) module G_forw = GVarG (S_forw.G) (S_forw.C) module G_backw = GVarG (S_backw.G) (S_forw.C) @@ -215,7 +247,7 @@ struct (* TODO: adjust man node/edge? *) (* TODO: don't repeat for all paths that spawn same *) - (* This porbalbly needs to be changed for backwards*) + (* TODO: This needs to be changed for backwards!! Context is created using S_backw.context*) let ds = S_backw.threadenter ~multiple man lval f args in List.iter (fun d -> spawns := (lval, f, args, d, multiple) :: !spawns; @@ -560,6 +592,7 @@ struct | Skip -> tf_skip_backw var edge prev_node end getl getl_forw sidel demandl getg sideg d + (* TODO: Don't call it prev_node when it is actually the next node. *) let tf_backw var getl getl_forw sidel demandl getg sideg prev_node (_,edge) d (f,t) = (* let old_loc = !Goblint_tracing.current_loc in let old_loc2 = !Goblint_tracing.next_loc in diff --git a/src/framework/control.ml b/src/framework/control.ml index 94d6f225ee..512e0e05c1 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -1711,18 +1711,105 @@ struct end module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) - (* There are a lot of things I do not use here*) - (* Triple of the function, context, and the local value. It uses Spec and therefore hast the wrong types.*) - (* module RT = AnalysisResult.ResultType2 (Spec) - module LT = SetDomain.HeadlessSet (RT) *) + (* Forward result module *) + (* Triple of the function, context, and the local value. It uses Spec and therefore has the wrong types.*) + module type ResultBundle = sig + module Spec : Spec + module RT : module type of AnalysisResult.ResultType2 (Spec) + module LT : module type of SetDomain.HeadlessSet (RT) + module Result : module type of AnalysisResult.Result (LT) (struct let result_name = "" end) + module ResultOutput : module type of AnalysisResultOutput.Make (Result) + end - (* Analysis result structure---a hashtable from program points to [LT] *) - (* module Result = AnalysisResult.Result (LT) (struct let result_name = "wp_analysis" end) - module ResultOutput = AnalysisResultOutput.Make (Result) *) + module ResBundle_forw : ResultBundle with module Spec = Spec_forw = + struct + module Spec = Spec_forw + module RT = AnalysisResult.ResultType2 (Spec_forw) + module LT = SetDomain.HeadlessSet (RT) + module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis_forw" end) + module ResultOutput = AnalysisResultOutput.Make (Result) + end - (* not having a Query module is problematic!*) + module ResBundle_backw : ResultBundle with module Spec = Spec_backw = + struct + (* Triple of the function, context, and the local value. It uses Spec and therefore has the wrong types.*) + module Spec = Spec_backw + module RT = AnalysisResult.ResultType2 (Spec_backw) + module LT = SetDomain.HeadlessSet (RT) + module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis_backw" end) + module ResultOutput = AnalysisResultOutput.Make (Result) + end + + (* not having a Query module is problematic! Is it?*) (* module Query = ResultQuery.Query (SpecSys) *) + (** this function converts the LHT to two Results of type forwards and backwards *) + let solver2source_result h = + let res_forw = ResBundle_forw.Result.create 113 in + let res_backw = ResBundle_backw.Result.create 113 in + + (* Adding the state at each system variable to the final result *) + let add_local_var_forw (n,es) state = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let state = match state with + | `Lifted1 s -> s + | `Bot -> Spec_forw.D.bot () + | `Top -> Spec_forw.D.top () + | `Lifted2 _ -> failwith "Unexpected backward state in forward result" + in + + let loc = UpdateCil.getLoc n in + if loc <> locUnknown then try + let fundec = Node.find_fundec n in + if ResBundle_forw.Result.mem res_forw n then + (* If this source location has been added before, we look it up + * and add another node to it information to it. *) + let prev = ResBundle_forw.Result.find res_forw n in + ResBundle_forw.Result.replace res_forw n (ResBundle_forw.LT.add (es,state,fundec) prev) + else + ResBundle_forw.Result.add res_forw n (ResBundle_forw.LT.singleton (es,state,fundec)) + (* If the function is not defined, and yet has been included to the + * analysis result, we generate a warning. *) + with Not_found -> + Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n + in + + let add_local_var_backw (n,es) state = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + + let state = match state with + | `Lifted2 s -> s + | `Bot -> Spec_backw.D.bot () + | `Top -> Spec_backw.D.top () + | `Lifted1 _ -> failwith "Unexpected forward state in backward result" + in + let loc = UpdateCil.getLoc n in + if loc <> locUnknown then try + let fundec = Node.find_fundec n in + if ResBundle_backw.Result.mem res_backw n then + (* If this source location has been added before, we look it up + * and add another node to it information to it. *) + let prev = ResBundle_backw.Result.find res_backw n in + ResBundle_backw.Result.replace res_backw n (ResBundle_backw.LT.add (es,state,fundec) prev) + else + ResBundle_backw.Result.add res_backw n (ResBundle_backw.LT.singleton (es,state,fundec)) + (* If the function is not defined, and yet has been included to the + * analysis result, we generate a warning. *) + with Not_found -> + Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n + in + + + LHT.iter (fun key -> + match key with + | `L_forw (n,es) -> add_local_var_forw (n,es) + | `L_backw (n,es) -> add_local_var_backw (n, es)) h; + + res_forw, res_backw + + (** [analyze file startfuns exitfuns otherfuns] is the main function to preform the selected analyses.*) let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = let module FileCfg: FileCfg = @@ -1941,6 +2028,7 @@ struct (** this function calculates and returns [startvars'_backw] and [entrystates_backw] *) let do_backward_inits () : (node * Spec_backw.C.t) list * ((node * Spec_forw.C.t) * Spec_backw.D.t) list = + let sideg_backw v d = sideg (`G_backw v) (EQSys.G.create_spec (`Lifted2 d)) in let getg_backw v = match EQSys.G.spec (getg (`G_backw v)) with @@ -2120,7 +2208,8 @@ struct (** calculates and combines the solver input calculation from the forwards and backwards part of the constraint system. Returns [startvars'] and [entrystate] and [entrystates_global].*) let calculate_solver_input () = AnalysisState.global_initialization := true; - (* Some happen in init, so enable this temporarily (if required by option). *) + + (* Spec_forw (MCP) initialization *) AnalysisState.should_warn := PostSolverArg.should_warn; Spec_forw.init None; Access.init file; @@ -2249,6 +2338,20 @@ struct in log_lh_contents lh; + let make_global_fast_xml f g = + let open Printf in + let print_globals k v = + fprintf f "\n%s%a" (XmlUtil.escape (EQSys.GVar.show k)) EQSys.G.printXml v; + in + GHT.iter print_globals g + in + + let liveness _ = true in + + let local_xml_forw, local_xml_backw = solver2source_result lh in + + (* ResBundle_forw.ResultOutput.output (lazy local_xml_forw) liveness gh make_global_fast_xml (module FileCfg); *) + ResBundle_backw.ResultOutput.output (lazy local_xml_backw) liveness gh make_global_fast_xml (module FileCfg) in solve(); From d8d891383dd979634f078b8607708269bf93c56a Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Sun, 8 Feb 2026 22:10:18 +0100 Subject: [PATCH 18/29] Working on Backwards-Spec --- src/analyses/wp_test.ml | 194 ++++++++++++++++++++++--- src/framework/analyses.ml | 108 +++++++++++++- src/framework/backwAnalyses.ml | 256 +++++++++++++++++++++++++++++++++ src/framework/control.ml | 102 +++++++++---- xy_easyprog.c | 13 +- 5 files changed, 625 insertions(+), 48 deletions(-) create mode 100644 src/framework/backwAnalyses.ml diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index a912c7a913..0d2beca2d3 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -2,12 +2,13 @@ open GoblintCil open Analyses -module Spec : Analyses.MCPSpec = +module Spec : Analyses.Spec = struct let name () = "wp_test" - include Analyses.IdentitySpec + (* include Analyses.DefaultBackwSpec *) + include Analyses.IdentitySpec (*## context ##*) (*Idea: make context type passsable, so add parameter.*) module C = Printable.Unit @@ -53,15 +54,6 @@ struct let assign man (lval:lval) (rval:exp) = - (* let () = - Logs.debug "=== man (analysis manager) info ==="; - Logs.debug " lval: %a" CilType.Lval.pretty lval; - Logs.debug " rval: %a" Cil Type.Exp.pretty rval; - Logs.debug " local state: %a" D.pretty man.local; - Logs.debug " local is_top: %b" (D.is_top man.local); - Logs.debug " local is_bot: %b" (D.is_bot man.local); - in *) - let v = vars_from_lval lval in match v with @@ -71,19 +63,19 @@ struct if D.mem v man.local then D.join l (vars_from_expr rval) else l - let branch man (exp:exp) (tv:bool) = + let branch man (exp:exp) (tv:bool) = D.join man.local (vars_from_expr exp) - let body man (f:fundec) = + let body man (f:fundec) = man.local - let return man (exp:exp option) (f:fundec) = + let return man (exp:exp option) (f:fundec) = match exp with | None -> man.local | Some e -> D.join man.local (vars_from_expr e) (* TODO *) - let enter man (lval: lval option) (f:fundec) (args:exp list) = + let enter man (lval: lval option) (f:fundec) (args:exp list) = (* Logs.debug "=== enter function %s with args %s ===" f.svar.vname (String.concat ", " (List.map (CilType.Exp.show) args)); *) @@ -152,6 +144,176 @@ struct | None -> D.empty() | Some e -> if return_val_is_important then D.join (D.empty()) (vars_from_expr e) - else D.empty(); + else D.empty() + + + let special man (lval: lval option) (f:varinfo) (arglist:exp list) = + man.local + + let threadenter man ~multiple lval f args = [man.local] + let threadspawn man ~multiple lval f args fman = man.local +end + + +module BackwSpec : BackwAnalyses.BackwSpecSpec = functor (ForwSpec : Analyses.Spec) -> +struct + + include BackwAnalyses.DefaultBackwSpec (ForwSpec) + module C = ForwSpec.C + + (* Adding those because the "include" makes problems*) + module D_forw = ForwSpec.D + module G_forw = ForwSpec.G + module V_forw = ForwSpec.V + module P_forw = ForwSpec.P + let name () = "wp_test" + + (* include Analyses.DefaultBackwSpec *) + + (* include Analyses.IdentitySpec *) + (*## context ##*) + (*Idea: make context type passsable, so add parameter.*) + (* module C = Printable.Unit *) + + (* let context man _ _ = () + let startcontext () = () *) + + (*## end of context ##*) + module G = Lattice.Unit + module V = EmptyV + module P = EmptyP + + module LiveVariableSet = SetDomain.ToppedSet (Basetype.Variables) (struct let topname = "All variables" end) + module D = LiveVariableSet (*Set of program variables as domain*) + + let startstate v = D.empty() + let exitstate v = D.empty() + + let vars_from_lval (l: lval) = + match l with + | Var v, NoOffset when isIntegralType v.vtype && not (v.vglob || v.vaddrof) -> Some v (* local integer variable whose address is never taken *) + | _, _ -> None (*do not know what to do here yet*) + + let vars_from_expr (e: exp) : D.t= + let rec aux acc e = + match e with + | Lval (Var v, _) -> D.add v acc + | BinOp (_, e1, e2, _) -> + let acc1 = aux acc e1 in + aux acc1 e2 + | UnOp (_, e1, _) -> aux acc e1 + | SizeOfE e1 -> aux acc e1 + | AlignOfE e1 -> aux acc e1 + | Question (e1, e2, e3, _) -> + let acc1 = aux acc e1 in + let acc2 = aux acc1 e2 in + aux acc2 e3 + | CastE (_, e1) -> aux acc e1 + | AddrOf (l1) -> (match vars_from_lval l1 with + | None -> acc + | Some v -> D.add v acc) + | _ -> acc + in + aux (D.empty()) e + + + let assign man man_forw (lval:lval) (rval:exp) = + let v = vars_from_lval lval in + + match v with + | None -> D.join man.local (vars_from_expr rval) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) + | Some v -> + let l = (D.diff man.local (D.singleton v)) in + if D.mem v man.local then D.join l (vars_from_expr rval) + else l + + let branch man man_forw (exp:exp) (tv:bool) = + D.join man.local (vars_from_expr exp) + + let body man man_forw (f:fundec) = + man.local + + let return man man_forw (exp:exp option) (f:fundec) = + match exp with + | None -> man.local + | Some e -> D.join man.local (vars_from_expr e) + + (* TODO *) + let enter man man_forw (lval: lval option) (f:fundec) (args:exp list) = + (* Logs.debug "=== enter function %s with args %s ===" f.svar.vname + (String.concat ", " (List.map (CilType.Exp.show) args)); *) + + let vars = + match lval with + | None -> man.local + | Some lv -> man.local (*i have to check for every arg ... no wait... I do not care about the args here, i care about those at the combine!!!!*) + + in + + [man.local, vars] + + (* TODO *) + let combine_env man man_forw (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + (* Logs.debug "=== combine_env of function %s ===" f.svar.vname; + let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in + Logs.debug " args: %s" args_pretty; + + let sformals_pretty = String.concat ", " (List.map (fun v -> v.vname) f.sformals) in + Logs.debug " sformals: %s" sformals_pretty; *) + + (*map relevant sformals in man.local to the corresponding variables contained in the argument*) + let arg_formal_pairs = List.combine args f.sformals in + let relevant_arg_vars = + List.fold_left (fun acc (arg_exp, formal_var) -> + if D.mem formal_var au then + D.join acc (vars_from_expr arg_exp) + else + acc + ) (D.empty()) arg_formal_pairs + in + + (*join relevant*) + D.join man.local relevant_arg_vars + + let combine_assign man man_forw (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = + (* Logs.debug "=== combine_assign of function %s ===" f.svar.vname; + (*how do I know which args are important? i.e. how do I match the local name of the variable in the function with the passed parameters (if there are several)*) + let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in + Logs.debug " args: %s" args_pretty; *) + + let simple_assign lval exp acc = + let v = vars_from_lval lval in + + match v with + | None -> acc (*D.join acc (vars_from_expr exp) if I do not know what the value is assigned to, then all RHS-Variables might be relevant *) + | Some v -> + let l = (D.diff acc (D.singleton v)) in + (* if D.mem v acc then D.join l (vars_from_expr exp) + else l *) + l + in + + match lval with + | Some lval -> List.fold_right (fun exp acc -> simple_assign lval exp acc) args man.local + | _ -> man.local + + + + (** A transfer function which handles the return statement, i.e., + "return exp" or "return" in the passed function (fundec) *) + let return man man_forw (exp: exp option) (f:fundec) : D.t = + let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in (*this does not take globals int account, only checks for "temp"*) + + match exp with + | None -> D.empty() + | Some e -> if return_val_is_important + then D.join (D.empty()) (vars_from_expr e) + else D.empty() + + + let special man man_forw (lval: lval option) (f:varinfo) (arglist:exp list) = + man.local + let threadenter man man_forw ~multiple lval f args = [man.local] + let threadspawn man man_forw ~multiple lval f args fman = man.local end diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index f655d89316..8edd23dc65 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -262,6 +262,108 @@ sig 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 BackwSpec = + sig + module D : Lattice.S + module G : Lattice.S + module C : Printable.S + module V: SpecSysVar (** Global constraint variables. *) + module P: DisjointDomain.Representative with type elt := D.t (** Path-representative. *) + + module D_forw: Lattice.S + module G_forw: Lattice.S + module V_forw: SpecSysVar (** Global constraint variables. *) + module P_forw: DisjointDomain.Representative with type elt := D_forw.t (** Path-representative. *) + val name : unit -> string + + (** Auxiliary data (outside of solution domains) that needs to be marshaled and unmarshaled. + This includes: + * hashtables, + * varinfos (create_var), + * RichVarinfos. *) + type marshal + + (** Initialize using unmarshaled auxiliary data (if present). *) + val init : marshal option -> unit + + (** Finalize and return auxiliary data to be marshaled. *) + val finalize : unit -> marshal + (* val finalize : G.t -> unit *) + + val startstate : varinfo -> D.t + val morphstate : varinfo -> D.t -> D.t + val exitstate : varinfo -> D.t + + val context: (D.t, G.t, C.t, V.t) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> fundec -> D.t -> C.t + val startcontext: unit -> C.t + + val sync : (D.t, G.t, C.t, V.t) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t + val query : (D.t, G.t, C.t, V.t) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> lval option -> fundec -> exp list -> (D.t * D.t) list + + (* Combine is split into two steps: *) + + (** Combine environment (global variables, mutexes, etc) + 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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> D.t list + + (** Returns initial state for created thread. *) + val threadenter : (D.t, G.t, C.t, V.t) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> Events.t -> (D.t, G.t, C.t, V.t) man -> D.t + end *) + + module type Spec2Spec = functor (S: Spec) -> Spec module type MCPA = @@ -429,9 +531,9 @@ module type SpecSys = sig module Spec: Spec module EQSys: Goblint_constraint.ConstrSys.DemandGlobConstrSys with module LVar = VarF (Spec.C) - and module GVar = GVarF (Spec.V) - and module D = Spec.D - and module G = GVarG (Spec.G) (Spec.C) + and module GVar = GVarF (Spec.V) + and module D = Spec.D + and module G = GVarG (Spec.G) (Spec.C) module LHT: BatHashtbl.S with type key = EQSys.LVar.t module GHT: BatHashtbl.S with type key = EQSys.GVar.t end diff --git a/src/framework/backwAnalyses.ml b/src/framework/backwAnalyses.ml new file mode 100644 index 0000000000..be47ddeacc --- /dev/null +++ b/src/framework/backwAnalyses.ml @@ -0,0 +1,256 @@ +open GoblintCil +open Pretty +open GobConfig +open Analyses + +module M = Messages + +module type BackwSpec = +sig + module D : Lattice.S + module G : Lattice.S + module C : Printable.S + module V: SpecSysVar (** Global constraint variables. *) + module P: DisjointDomain.Representative with type elt := D.t (** Path-representative. *) + + module D_forw: Lattice.S + module G_forw: Lattice.S + module V_forw: SpecSysVar (** Global constraint variables. *) + module P_forw: DisjointDomain.Representative with type elt := D_forw.t (* Path-representative. *) + val name : unit -> string + + (** Auxiliary data (outside of solution domains) that needs to be marshaled and unmarshaled. + This includes: + * hashtables, + * varinfos (create_var), + * RichVarinfos. *) + type marshal + + (** Initialize using unmarshaled auxiliary data (if present). *) + val init : marshal option -> unit + + (** Finalize and return auxiliary data to be marshaled. *) + val finalize : unit -> marshal + (* val finalize : G.t -> unit *) + + val startstate : varinfo -> D.t + val morphstate : varinfo -> D.t -> D.t + val exitstate : varinfo -> D.t + + val context: (D_forw.t, G_forw.t, C.t, V_forw.t) man -> fundec -> D_forw.t -> C.t + val startcontext: unit -> C.t + + (* val sync : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t *) + val query : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> lval option -> fundec -> exp list -> (D.t * D.t) list + + (* Combine is split into two steps: *) + + (** Combine environment (global variables, mutexes, etc) + 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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> D.t list + + (** Returns initial state for created thread. *) + val threadenter : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> Events.t -> (D.t, G.t, C.t, V.t) man -> D.t +end + +module type BackwSpecSpec = functor (ForwSpec : Analyses.Spec) -> sig + include BackwSpec + with module C = ForwSpec.C + with module D_forw = ForwSpec.D + with module G_forw = ForwSpec.G + with module V_forw = ForwSpec.V + with module P_forw = ForwSpec.P + (* val name : unit -> string + + (** Auxiliary data (outside of solution domains) that needs to be marshaled and unmarshaled. + This includes: + * hashtables, + * varinfos (create_var), + * RichVarinfos. *) + type marshal + + (** Initialize using unmarshaled auxiliary data (if present). *) + val init : marshal option -> unit + + (** Finalize and return auxiliary data to be marshaled. *) + val finalize : unit -> marshal + (* val finalize : G.t -> unit *) + + val startstate : varinfo -> D.t + val morphstate : varinfo -> D.t -> D.t + val exitstate : varinfo -> D.t + + val context: (D_forw.t, G_forw.t, C.t, V_forw.t) man -> fundec -> ForwSpec.D.t -> ForwSpec.C.t + val startcontext: unit -> C.t + + (* val sync : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t *) + val query : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> lval option -> fundec -> exp list -> (D.t * D.t) list + + (* Combine is split into two steps: *) + + (** Combine environment (global variables, mutexes, etc) + 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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> D.t list + + (** Returns initial state for created thread. *) + val threadenter : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> Events.t -> (D.t, G.t, C.t, V.t) man -> D.t *) +end + +module DefaultBackwSpec (ForwSpec : Analyses.Spec) = +struct + module G = Lattice.Unit + module C = ForwSpec.C + module V = EmptyV + module P = EmptyP + + module D_forw: Lattice.S = ForwSpec.D + module G_forw: Lattice.S = ForwSpec.G + module V_forw: SpecSysVar = ForwSpec.V (** Global constraint variables. *) + module P_forw: DisjointDomain.Representative with type elt := ForwSpec.D.t = ForwSpec.P (*Path-representative.*) + + type marshal = unit + let init _ = () + + (* This means it does not matter which Spec's context function we use in control and BidirFromSpec. + * For understandability in other parts of the code the context-function of the forward spec should be used explicitely*) + + let context = ForwSpec.context + let startcontext _ = ForwSpec.startcontext () + let finalize () = () + (* no inits nor finalize -- only analyses like Mutex, Base, ... need + these to do postprocessing or other imperative hacks. *) + + let vdecl man _ _ = man.local + + let asm x _ = + M.msg_final Info ~category:Unsound "ASM ignored"; + M.info ~category:Unsound "ASM statement ignored."; + x.local (* Just ignore. *) + + let skip x _ = x.local (* Just ignore. *) + + let query _ _ (type a) (q: a Queries.t) = Queries.Result.top q + (* Don't know anything --- most will want to redefine this. *) + + let event man _ _ _ = man.local + + let morphstate v d = d + (* Only for those who track thread IDs. *) + + let sync man _ _ _ _ = man.local + (* Most domains do not have a global part. *) + + (* let context man _ fd x = x *) + (* Everything is context sensitive --- override in MCP and maybe elsewhere*) + + let paths_as_set man _ = [man.local] + + (* module A = UnitA *) + (* let access _ _ = () *) +end diff --git a/src/framework/control.ml b/src/framework/control.ml index 512e0e05c1..e8dc8afd86 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -6,6 +6,7 @@ open Batteries open GoblintCil open MyCFG open Analyses +open BackwAnalyses open Goblint_constraint.ConstrSys open Goblint_constraint.Translators open Goblint_constraint.SolverTypes @@ -1686,7 +1687,7 @@ struct end (** Given a [Cfg], a [Spec_forw], [Spec_back], and an unused [Inc], computes the solution] *) -module AnalyzeCFG_bidir (Cfg:CfgBidirSkip) (Spec_forw:Spec) (Spec_backw: Spec with type C.t = Spec_forw.C.t ) (Inc:Increment) = +module AnalyzeCFG_bidir (Cfg:CfgBidirSkip) (Spec_forw:Spec) (Spec_backw: Spec with type C.t = Spec_forw.C.t ) (Spec_backwA : BackwSpec) (Inc:Increment) = struct (* The Equation system *) @@ -1730,15 +1731,15 @@ struct module ResultOutput = AnalysisResultOutput.Make (Result) end - module ResBundle_backw : ResultBundle with module Spec = Spec_backw = - struct - (* Triple of the function, context, and the local value. It uses Spec and therefore has the wrong types.*) - module Spec = Spec_backw - module RT = AnalysisResult.ResultType2 (Spec_backw) - module LT = SetDomain.HeadlessSet (RT) - module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis_backw" end) - module ResultOutput = AnalysisResultOutput.Make (Result) - end + (* module ResBundle_backw : ResultBundle with module Spec = Spec_backw = + struct + (* Triple of the function, context, and the local value. It uses Spec and therefore has the wrong types.*) + module Spec = Spec_backw + module RT = AnalysisResult.ResultType2 (Spec_backw) + module LT = SetDomain.HeadlessSet (RT) + module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis_backw" end) + module ResultOutput = AnalysisResultOutput.Make (Result) + end *) (* not having a Query module is problematic! Is it?*) (* module Query = ResultQuery.Query (SpecSys) *) @@ -1746,7 +1747,7 @@ struct (** this function converts the LHT to two Results of type forwards and backwards *) let solver2source_result h = let res_forw = ResBundle_forw.Result.create 113 in - let res_backw = ResBundle_backw.Result.create 113 in + (* let res_backw = ResBundle_backw.Result.create 113 in *) (* Adding the state at each system variable to the final result *) let add_local_var_forw (n,es) state = @@ -1775,18 +1776,18 @@ struct Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n in - let add_local_var_backw (n,es) state = - (* Not using Node.location here to have updated locations in incremental analysis. + (* let add_local_var_backw (n,es) state = + (* Not using Node.location here to have updated locations in incremental analysis. See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let state = match state with + let state = match state with | `Lifted2 s -> s | `Bot -> Spec_backw.D.bot () | `Top -> Spec_backw.D.top () | `Lifted1 _ -> failwith "Unexpected forward state in backward result" - in - let loc = UpdateCil.getLoc n in - if loc <> locUnknown then try + in + let loc = UpdateCil.getLoc n in + if loc <> locUnknown then try let fundec = Node.find_fundec n in if ResBundle_backw.Result.mem res_backw n then (* If this source location has been added before, we look it up @@ -1799,15 +1800,15 @@ struct * analysis result, we generate a warning. *) with Not_found -> Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n - in + in *) LHT.iter (fun key -> match key with | `L_forw (n,es) -> add_local_var_forw (n,es) - | `L_backw (n,es) -> add_local_var_backw (n, es)) h; + | `L_backw (n,es) -> (fun _ -> ()) (* add_local_var_backw (n, es))*) ) h; - res_forw, res_backw + res_forw(*, res_backw*) (** [analyze file startfuns exitfuns otherfuns] is the main function to preform the selected analyses.*) @@ -2348,10 +2349,62 @@ struct let liveness _ = true in - let local_xml_forw, local_xml_backw = solver2source_result lh in + let local_xml_forw = solver2source_result lh in + + ResBundle_forw.ResultOutput.output (lazy local_xml_forw) liveness gh make_global_fast_xml (module FileCfg); + (* ResBundle_backw.ResultOutput.output (lazy local_xml_backw) liveness gh make_global_fast_xml (module FileCfg) *) + + (*This is disgusting, but I have more imprtant things to do right now*) + let output_wp_results_to_xml lh = + (* iterate through all nodes and update corresponding .xml in result/nodes *) + LHT.iter (fun v state -> + match v with + | `L_forw _ -> () + | `L_backw (node, c) -> ( + let state = match state with + | `Lifted2 d -> d + | _ -> failwith "Expected backward state" + in + try + let node_id_str = Node.show_id node in + + let xml_path = Filename.concat "./result/nodes" (node_id_str ^ ".xml") in + if Sys.file_exists xml_path then ( + (* Read existing XML *) + let ic = Stdlib.open_in xml_path in + let content = Stdlib.really_input_string ic (Stdlib.in_channel_length ic) in + Stdlib.close_in ic; + + (* Create WP analysis data *) + let wp_res = Pretty.sprint 100 (Spec_backw.D.pretty () state) in + let wp_data = + "\n\n\n\n" ^ wp_res ^" \n\n\n\n\n" + in + + (* Insert before *) + let close_pattern = "" in + let updated_content = + try + let insert_pos = Str.search_backward (Str.regexp_string close_pattern) content (String.length content) in + let before = String.sub content 0 insert_pos in + let after = String.sub content insert_pos (String.length content - insert_pos) in + before ^ wp_data ^ after + with Not_found -> + content ^ wp_data + in + + (* Write back *) + let oc = Stdlib.open_out xml_path in + Stdlib.output_string oc updated_content; + Stdlib.close_out oc; + Logs.debug "Updated XML file for node %s" node_id_str + ) + with _ -> () (* Skip errors silently *) + ) + ) lh + in - (* ResBundle_forw.ResultOutput.output (lazy local_xml_forw) liveness gh make_global_fast_xml (module FileCfg); *) - ResBundle_backw.ResultOutput.output (lazy local_xml_backw) liveness gh make_global_fast_xml (module FileCfg) + output_wp_results_to_xml lh; in solve(); @@ -2371,7 +2424,8 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = (* let module B = AnalyzeCFG_backw (CFG) (DummyWPSPec) (struct let increment = change_info end) in *) let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec) in - let module C = AnalyzeCFG_bidir (CFG) (Spec) (DummyWPSPec) (struct let increment = change_info end) in + let module LivenesSpec = Wp_test.BackwSpec (Spec) in + let module C = AnalyzeCFG_bidir (CFG) (Spec) (DummyWPSPec) (LivenesSpec) (struct let increment = change_info end) in GobConfig.with_immutable_conf (fun () -> (* A.analyze file fs; diff --git a/xy_easyprog.c b/xy_easyprog.c index c31c6dd76a..e3980f084c 100644 --- a/xy_easyprog.c +++ b/xy_easyprog.c @@ -5,7 +5,7 @@ int f(int x, int y) { if (x > 0) { i = i + 2; - return i; + return i + y; } else { i = i + 3; return i + x; @@ -34,12 +34,15 @@ int main() { int (*h)(int, int); // function pointer to f h = &f; - if (rand) { - h = &g; - } + // if (rand) { + // h = &g; + // } + int d = (*h)(a, c); + + a = -100; int b = (*h)(a, c); - return b; + return b + d; } //git diff --cached --name-only --diff-filter=ACM | grep -E '\.(ml|mli)$' | xargs -I {} ocp-indent -i {} \ No newline at end of file From e396a375e0b05aeffc004d1e7d76341f0ca8c100 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Tue, 10 Feb 2026 15:43:31 +0100 Subject: [PATCH 19/29] Bidirconstraints should now construct man_forw whith functional getg --- src/analyses/wp_test.ml | 103 ++-- src/framework/backwAnalyses.ml | 91 +--- src/framework/bidirConstrains.ml | 363 ++++++++------ src/framework/control.ml | 159 +++--- src/framework/oldBidirConstraints.ml | 691 +++++++++++++++++++++++++++ xy_easyprog.c | 6 +- 6 files changed, 1084 insertions(+), 329 deletions(-) create mode 100644 src/framework/oldBidirConstraints.ml diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index 0d2beca2d3..fe00e641f8 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -161,24 +161,13 @@ struct include BackwAnalyses.DefaultBackwSpec (ForwSpec) module C = ForwSpec.C - (* Adding those because the "include" makes problems*) + (* Adding those because the "include" of the DefaultBackwSpec is nor enough*) module D_forw = ForwSpec.D module G_forw = ForwSpec.G module V_forw = ForwSpec.V module P_forw = ForwSpec.P let name () = "wp_test" - (* include Analyses.DefaultBackwSpec *) - - (* include Analyses.IdentitySpec *) - (*## context ##*) - (*Idea: make context type passsable, so add parameter.*) - (* module C = Printable.Unit *) - - (* let context man _ _ = () - let startcontext () = () *) - - (*## end of context ##*) module G = Lattice.Unit module V = EmptyV module P = EmptyP @@ -189,12 +178,36 @@ struct let startstate v = D.empty() let exitstate v = D.empty() - let vars_from_lval (l: lval) = - match l with - | Var v, NoOffset when isIntegralType v.vtype && not (v.vglob || v.vaddrof) -> Some v (* local integer variable whose address is never taken *) - | _, _ -> None (*do not know what to do here yet*) + let rec vars_from_lval (l: lval) : varinfo list = + let vars_written_to = + match l with + | Var v, _ -> [v] (* variable *) + | Mem m, _ -> (D.elements (vars_from_expr m)) + in - let vars_from_expr (e: exp) : D.t= + let vars_in_offset = + match l with + | Var _, off -> vars_from_offset off + | Mem _, off -> vars_from_offset off + in + + (vars_written_to @ vars_in_offset) + and + + vars_from_offset (off: offset) : varinfo list = + match off with + | NoOffset -> [] + | Field (_, off) -> vars_from_offset off + | Index (e, off) -> + let vars_in_e = (D.elements (vars_from_expr e)) in + let vars_in_off = vars_from_offset off in + (match vars_in_off with + | [] -> [] + | vars_in_off -> (vars_in_e @ vars_in_off)) + + and + + vars_from_expr (e: exp) : D.t= let rec aux acc e = match e with | Lval (Var v, _) -> D.add v acc @@ -210,8 +223,8 @@ struct aux acc2 e3 | CastE (_, e1) -> aux acc e1 | AddrOf (l1) -> (match vars_from_lval l1 with - | None -> acc - | Some v -> D.add v acc) + | [] -> acc + | v -> D.join (D.of_list v) acc) | _ -> acc in aux (D.empty()) e @@ -221,14 +234,34 @@ struct let v = vars_from_lval lval in match v with - | None -> D.join man.local (vars_from_expr rval) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) - | Some v -> - let l = (D.diff man.local (D.singleton v)) in - if D.mem v man.local then D.join l (vars_from_expr rval) - else l - - let branch man man_forw (exp:exp) (tv:bool) = - D.join man.local (vars_from_expr exp) + | [] -> D.join man.local (vars_from_expr rval) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) + | v-> + let l = (D.diff man.local (D.of_list v)) in + if (List.exists (fun elem -> D.mem elem man.local) v) then D.join l (vars_from_expr rval) (*if anything on the rhs is important, this is live now*) + else ( + let loc = M.Location.Node man.node in + (match v with + | v::_ -> M.warn ~loc:loc "Unnecessary assignment to variable %s, as it is not live at this program point" v.vname + | [] -> () (*this case is already handled above*) + ); l) + + let branch man man_forw (exp:exp) (tv:bool) = + (* This just randomly asks whether all loops terimante to use getg_forw utilized in man.global *) + (* let () = + match man_forw.ask(Queries.MustTermAllLoops) with + | true -> Logs.debug "MustTermAllLoops is TRUE" + | _ -> Logs.debug "MustTermAllLoops is NOT TRUE" + in *) + + let branch_irrelevant : bool= ( + match Queries.eval_bool (Analyses.ask_of_man man_forw) exp with + | `Lifted b -> tv <> b + | `Bot -> false + | `Top -> false + ) + in + if branch_irrelevant then vars_from_expr exp + else D.join man.local (vars_from_expr exp) let body man man_forw (f:fundec) = man.local @@ -262,6 +295,7 @@ struct Logs.debug " sformals: %s" sformals_pretty; *) (*map relevant sformals in man.local to the corresponding variables contained in the argument*) + let arg_formal_pairs = List.combine args f.sformals in let relevant_arg_vars = List.fold_left (fun acc (arg_exp, formal_var) -> @@ -281,20 +315,25 @@ struct let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in Logs.debug " args: %s" args_pretty; *) + let exp_vars = vars_from_expr fexp in + + Logs.debug "(!) combine_assign: exp_vars = %s" (String.concat ", " (List.map (fun v -> v.vname) (D.elements exp_vars))); + let simple_assign lval exp acc = - let v = vars_from_lval lval in + let v = vars_from_lval lval + in match v with - | None -> acc (*D.join acc (vars_from_expr exp) if I do not know what the value is assigned to, then all RHS-Variables might be relevant *) - | Some v -> - let l = (D.diff acc (D.singleton v)) in + | [] -> acc (*D.join acc (vars_from_expr exp) if I do not know what the value is assigned to, then all RHS-Variables might be relevant *) + | v -> + let l = (D.diff acc (D.of_list v)) in (* if D.mem v acc then D.join l (vars_from_expr exp) else l *) l in match lval with - | Some lval -> List.fold_right (fun exp acc -> simple_assign lval exp acc) args man.local + | Some lval -> D.union (List.fold_right (fun exp acc -> simple_assign lval exp acc) args man.local) exp_vars | _ -> man.local diff --git a/src/framework/backwAnalyses.ml b/src/framework/backwAnalyses.ml index be47ddeacc..e32a4e3e34 100644 --- a/src/framework/backwAnalyses.ml +++ b/src/framework/backwAnalyses.ml @@ -40,7 +40,7 @@ sig val context: (D_forw.t, G_forw.t, C.t, V_forw.t) man -> fundec -> D_forw.t -> C.t val startcontext: unit -> C.t - (* val sync : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t *) + val sync : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t val query : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> 'a Queries.t -> 'a Queries.result (** A transfer function which handles the assignment of a rval to a lval, i.e., @@ -113,93 +113,6 @@ module type BackwSpecSpec = functor (ForwSpec : Analyses.Spec) -> sig with module G_forw = ForwSpec.G with module V_forw = ForwSpec.V with module P_forw = ForwSpec.P - (* val name : unit -> string - - (** Auxiliary data (outside of solution domains) that needs to be marshaled and unmarshaled. - This includes: - * hashtables, - * varinfos (create_var), - * RichVarinfos. *) - type marshal - - (** Initialize using unmarshaled auxiliary data (if present). *) - val init : marshal option -> unit - - (** Finalize and return auxiliary data to be marshaled. *) - val finalize : unit -> marshal - (* val finalize : G.t -> unit *) - - val startstate : varinfo -> D.t - val morphstate : varinfo -> D.t -> D.t - val exitstate : varinfo -> D.t - - val context: (D_forw.t, G_forw.t, C.t, V_forw.t) man -> fundec -> ForwSpec.D.t -> ForwSpec.C.t - val startcontext: unit -> C.t - - (* val sync : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t *) - val query : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> lval option -> fundec -> exp list -> (D.t * D.t) list - - (* Combine is split into two steps: *) - - (** Combine environment (global variables, mutexes, etc) - 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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> D.t list - - (** Returns initial state for created thread. *) - val threadenter : (D.t, G.t, C.t, V.t) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.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) man -> (D_forw.t, G_forw.t, C.t, V_forw.t) man -> Events.t -> (D.t, G.t, C.t, V.t) man -> D.t *) end module DefaultBackwSpec (ForwSpec : Analyses.Spec) = @@ -243,7 +156,7 @@ struct let morphstate v d = d (* Only for those who track thread IDs. *) - let sync man _ _ _ _ = man.local + let sync man _ _ = man.local (* Most domains do not have a global part. *) (* let context man _ fd x = x *) diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 357e68696d..b77e867d10 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -2,6 +2,7 @@ open Batteries open GoblintCil open MyCFG open Analyses +open BackwAnalyses open Goblint_constraint.ConstrSys open GobConfig @@ -11,57 +12,62 @@ sig end module GVarF2 (V_forw: SpecSysVar) (V_backw : SpecSysVar) : -sig - include VarType with type t = [ `G_forw of GVarF(V_forw).t | `G_backw of GVarF(V_backw).t ] +sig + module GV_forw : module type of GVarF (V_forw) + module GV_backw : module type of GVarF (V_backw) + include VarType with type t = [ `Forw of GV_forw.t | `Backw of GV_backw.t ] include SpecSysVar with type t := t + val spec : [ `Forw of V_forw.t | `Backw of V_backw.t ] -> [ `Forw of [`Left of V_forw.t] | `Backw of [`Left of V_backw.t] ] + val contexts : [ `Forw of V_forw.t | `Backw of V_backw.t ] -> [`Forw of [`Right of V_forw.t] | `Backw of [`Right of V_backw.t]] end = struct module GV_forw = GVarF (V_forw) module GV_backw = GVarF (V_backw) - type t = [ `G_forw of GV_forw.t | `G_backw of GV_backw.t ] [@@deriving eq, ord, hash] + type t = [ `Forw of GV_forw.t | `Backw of GV_backw.t ] [@@deriving eq, ord, hash] let name () = "BidirFromSpec" let tag _ = failwith "Std: no tag" let relift = function - | `G_forw x -> `G_forw (GV_forw.relift x) - | `G_backw x -> `G_backw (GV_backw.relift x) + | `Forw x -> `Forw (GV_forw.relift x) + | `Backw x -> `Backw (GV_backw.relift x) let pretty_trace () = function - | `G_forw a -> GoblintCil.Pretty.dprintf "G_forw:%a" GV_forw.pretty_trace a - | `G_backw a -> GoblintCil.Pretty.dprintf "G_backw:%a" GV_backw.pretty_trace a + | `Forw a -> GoblintCil.Pretty.dprintf "G_forw:%a" GV_forw.pretty_trace a + | `Backw a -> GoblintCil.Pretty.dprintf "G_backw:%a" GV_backw.pretty_trace a let printXml f = function - | `G_forw a -> GV_forw.printXml f a - | `G_backw a -> GV_backw.printXml f a + | `Forw a -> GV_forw.printXml f a + | `Backw a -> GV_backw.printXml f a let node = function - | `G_forw a -> GV_forw.node a - | `G_backw a -> GV_backw.node a + | `Forw a -> GV_forw.node a + | `Backw a -> GV_backw.node a let is_write_only = function - | `G_forw a -> GV_forw.is_write_only a - | `G_backw a -> GV_backw.is_write_only a + | `Forw a -> GV_forw.is_write_only a + | `Backw a -> GV_backw.is_write_only a let show = function - | `G_forw a -> GV_forw.show a - | `G_backw a -> GV_backw.show a + | `Forw a -> GV_forw.show a + | `Backw a -> GV_backw.show a let pretty () = function - | `G_forw a -> GV_forw.pretty () a - | `G_backw a -> GV_backw.pretty () a + | `Forw a -> GV_forw.pretty () a + | `Backw a -> GV_backw.pretty () a let to_yojson = function - | `G_forw a -> GV_forw.to_yojson a - | `G_backw a -> GV_backw.to_yojson a + | `Forw a -> GV_forw.to_yojson a + | `Backw a -> GV_backw.to_yojson a + + let spec : [ `Forw of V_forw.t | `Backw of V_backw.t ] -> [ `Forw of [`Left of V_forw.t] | `Backw of [`Left of V_backw.t] ] = function + | `Forw v -> `Forw (GV_forw.spec v ) + | `Backw v -> `Backw (GV_backw.spec v ) - let spec = function - | `G_forw a -> GV_forw.spec a - | `G_backw a -> GV_backw.spec a + let contexts : [ `Forw of V_forw.t | `Backw of V_backw.t ] -> [`Forw of [`Right of V_forw.t] | `Backw of [`Right of V_backw.t]] = function + | `Forw v -> `Forw (GV_forw.contexts v) + | `Backw v -> `Backw (GV_backw.contexts v) - let contexts = function - | `G_forw a -> GV_forw.contexts a - | `G_backw a -> GV_backw.contexts a let var_id = show @@ -70,7 +76,7 @@ struct end -module BidirFromSpec (S_forw:Spec) (S_backw:Spec with type C.t = S_forw.C.t ) (Cfg:CfgBidir) (I:Increment) +module BidirFromSpec (S_forw:Spec) (S_backw:BackwSpec with type D_forw.t = S_forw.D.t and type G_forw.t = S_forw.G.t and type C.t = S_forw.C.t and type V_forw.t = S_forw.V.t) (Cfg:CfgBidir) (I:Increment) : sig module LVar : Goblint_constraint.ConstrSys.VarType with type t = [ `L_forw of VarF(S_forw.C).t | `L_backw of VarF(S_forw.C).t ] module GVar : (module type of GVarF2(S_forw.V)(S_backw.V)) @@ -115,8 +121,8 @@ struct end module D = Lattice.Lift2(S_forw.D)(S_backw.D) - module GV_forw = GVarF (S_forw.V) - module GV_backw = GVarF (S_backw.V) + (* module GV_forw = GVarF (S_forw.V) + module GV_backw = GVarF (S_backw.V) *) module GVar = GVarF2(S_forw.V)(S_backw.V) module G_forw = GVarG (S_forw.G) (S_forw.C) @@ -124,7 +130,7 @@ struct module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) module Forward = Constraints.FromSpec (S_forw) (Cfg) (I) - module Backward = Constraints_wp.FromSpec (S_backw) (Cfg) + (* module Backward = Constraints_wp.FromSpec (S_backw) (Cfg) *) (* functions for converting between forwards and backwards types*) let getl_backw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_backw.D.t = @@ -141,7 +147,22 @@ struct | `Top -> S_forw.D.top () | `Lifted1 d -> d - let lv_of_backw ((n,c): Backward.LVar.t) : LV.t = (n, Obj.magic c) + (* let getg_backw_wrapper (getg) (v) = + match v with + | `Left v -> + | `Right v -> + + match getg (`Backw v) with + | `Lifted1 (`Lifted2 g) -> G_backw.create_spec g + | `Lifted1 (`Lifted1 g) -> failwith "bidirConstrains: backward global got forward value" + | `Lifted1 `Bot -> `Bot + | `Lifted1 `Top -> `Top *) + (* let getg_forw_wrapper (getg: GVar.t -> G.t) (v: GVar.GV_forw.t) : G_forw.t = + match getg (`G_forw v) with + | `Lifted1 (`Left g) -> G_forw.create_spec g + | _ -> failwith "bidirConstrains: backward global got forward value or non-lifted value" *) + + let lv_of_backw ((n,c)) : LV.t = (n, Obj.magic c) let to_l_backw (v:LVar.t) = match v with @@ -213,24 +234,53 @@ struct (* actually relevant (transfer) functions*) - let sync_backw man = + let sync_backw man man_forw = match man.prev_node, Cfg.next man.prev_node with | _, _ :: _ :: _ -> (* Join in CFG. *) - S_backw.sync man `Join - | FunctionEntry f, _ -> (* Function entry, also needs sync because partial contexts joined by solver, see 00-sanity/35-join-contexts. *) - S_backw.sync man (`JoinCall f) - | _, _ -> S_backw.sync man `Normal + S_backw.sync man man_forw `Join + (* | FunctionEntry f, _ -> (* Function entry, also needs sync because partial contexts joined by solver, see 00-sanity/35-join-contexts. *) + S_backw.sync man man_forw (`JoinCall f) *) + | Function f, _ -> (* Function entry, also needs sync because partial contexts joined by solver, see 00-sanity/35-join-contexts. *) + S_backw.sync man man_forw (`JoinCall f) + | _, _ -> S_backw.sync man man_forw `Normal let side_context_backw sideg f c = if !AnalysisState.postsolving then - sideg (GV_backw.contexts f) (G_backw.create_contexts (G_backw.CSet.singleton c)) + sideg (GVar.GV_backw.contexts f) (G_backw.create_contexts (G_backw.CSet.singleton c)) + + + let create_basic_man_forw var edge prev_node pval getl getl_forw sidel demandl getg getg_forw sideg : (S_forw.D.t, S_forw.G.t, S_forw.C.t, S_forw.V.t) man = + (* let r = ref [] in *) + let node = fst var in + let context : (unit -> S_forw.C.t) = snd var |> Obj.obj in + + let rec man_forw = + { ask = (fun (type a) (q: a Queries.t) -> S_forw.query man_forw q) + ; emit = (fun _ -> failwith "emit outside MCP") + ; node = fst var + ; prev_node = prev_node (*This is a bit problematic, as prev node is actually the next node!!*) + ; control_context = (fun () -> failwith "control context not implemented yet for forward manager") (*TODO*) + ; context = context + ; edge = edge + ; local = getl_forw (node, context()) (*getl_forw (fst var, (snd var |> Obj.obj))*) + ; global = (fun g -> Logs.debug "(!) getg_forw was usccesfully used"; G_forw.spec (getg_forw (GVar.GV_forw.spec g))) (*(fun _ -> failwith "getg_forw not implemented yet") TODO*) + ; spawn = (fun ?multiple _ _ _ -> failwith "spawn should not be called from forward manager") + ; split = (fun _ _ -> failwith "split? what does this do?") (*(fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) What does this do?*) + ; sideg = (fun _ _ -> failwith "sideg should not be called from forward manager") + } + in + man_forw - let common_man_backw var edge prev_node pval getl sidel demandl getg sideg : (S_backw.D.t, S_backw.G.t, S_backw.C.t, S_backw.V.t) man * S_backw.D.t list ref * (lval option * varinfo * exp list * S_backw.D.t * bool) list ref = + let common_man_backw (var:node*Obj.t) edge prev_node pval getl getl_forw (sidel : node * S_forw.C.t -> S_backw.D.t -> unit) demandl getg getg_forw sideg : (S_backw.D.t, S_backw.G.t, S_backw.C.t, S_backw.V.t) man * S_backw.D.t list ref * (lval option * varinfo * exp list * S_backw.D.t * bool) list ref = let r = ref [] in let spawns = ref [] in + + let man_forw = create_basic_man_forw var edge prev_node pval getl getl_forw sidel demandl getg getg_forw sideg in + + (* Logs.debug "Created forward manager for node %a, now creating backward manager" Node.pretty (fst var); *) (* now watch this ... *) let rec man = - { ask = (fun (type a) (q: a Queries.t) -> S_backw.query man q) + { ask = (fun (type a) (q: a Queries.t) -> S_backw.query man man_forw q) ; emit = (fun _ -> failwith "emit outside MCP") ; node = fst var ; prev_node = prev_node @@ -238,24 +288,26 @@ struct ; context = snd var |> Obj.obj ; edge = edge ; local = pval - ; global = (fun g -> G_backw.spec (getg (GV_backw.spec g))) + ; global = (fun g -> G_backw.spec (getg (GVar.GV_backw.spec g))) ; spawn = spawn ; split = (fun (d:S_backw.D.t) es -> assert (List.is_empty es); r := d::!r) - ; sideg = (fun g d -> sideg (GV_backw.spec g) (G_backw.create_spec d)) + ; sideg = (fun g d -> sideg (GVar.GV_backw.spec g) (G_backw.create_spec d)) } and spawn ?(multiple=false) lval f args = (* TODO: adjust man node/edge? *) (* TODO: don't repeat for all paths that spawn same *) (* TODO: This needs to be changed for backwards!! Context is created using S_backw.context*) - let ds = S_backw.threadenter ~multiple man lval f args in - List.iter (fun d -> + let ds = S_backw.threadenter ~multiple man man_forw lval f args in + List.iter (fun (d : S_backw.D.t) -> spawns := (lval, f, args, d, multiple) :: !spawns; match Cilfacade.find_varinfo_fundec f with | fd -> - let c = S_backw.context man fd d in - sidel (FunctionEntry fd, c) d; - demandl (Function fd, c) + let c = S_forw.context man_forw fd (man_forw.local) in + (* sidel (FunctionEntry fd, c) d; + demandl (Function fd, c) *) + sidel (Function fd, c) d; + demandl (FunctionEntry fd, c) | exception Not_found -> (* unknown function *) M.error ~category:Imprecise ~tags:[Category Unsound] "Created a thread from unknown function %s" f.vname; @@ -263,17 +315,18 @@ struct (* must still sync for side effects, e.g., old sync-based none privatization soundness in 02-base/51-spawn-special *) let rec sync_man = { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man q); + ask = (fun (type a) (q: a Queries.t) -> (S_backw.query sync_man man_forw q)); local = d; - prev_node = Function dummyFunDec; + (* prev_node = Function dummyFunDec; *) + prev_node = FunctionEntry dummyFunDec; } in (* TODO: more accurate man? *) - ignore (sync_backw sync_man) + ignore (sync_backw sync_man man_forw) ) ds in (* ... nice, right! *) - let pval = sync_backw man in + let pval = sync_backw man man_forw in { man with local = pval }, r, spawns let rec bigsqcup_backw = function @@ -281,13 +334,13 @@ struct | [x] -> x | x::xs -> S_backw.D.join x (bigsqcup_backw xs) - let thread_spawns_backws man d spawns = + let thread_spawns_backws man man_forw d spawns = if List.is_empty spawns then d else let rec man' = { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' q) + ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' man_forw q) ; local = d } in @@ -295,67 +348,72 @@ struct let one_spawn (lval, f, args, fd, multiple) = let rec fman = { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query fman q) + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fman man_forw q) ; local = fd } in - S_backw.threadspawn man' ~multiple lval f args fman + S_backw.threadspawn man' man_forw ~multiple lval f args fman in bigsqcup_backw (List.map one_spawn spawns) - let common_join_backw man d splits spawns = - thread_spawns_backws man (bigsqcup_backw (d :: splits)) spawns + let common_join_backw man man_forw d splits spawns = + thread_spawns_backws man man_forw (bigsqcup_backw (d :: splits)) spawns - let common_joins_backw man ds splits spawns = common_join_backw man (bigsqcup_backw ds) splits spawns + let common_joins_backw man man_forw ds splits spawns = common_join_backw man man_forw (bigsqcup_backw ds) splits spawns - let tf_assign_backw var edge prev_node lv e getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.assign man lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns + let tf_assign_backw var edge prev_node lv e getl getl_forw sidel demandl getg getg_forw sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let man_forw = create_basic_man_forw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let d = S_backw.assign man man_forw lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man man_forw d !r !spawns - let tf_vdecl_backw var edge prev_node v getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.vdecl man v in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns + let tf_vdecl_backw var edge prev_node v getl getl_forw sidel demandl getg getg_forw sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let man_forw = create_basic_man_forw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let d = S_backw.vdecl man man_forw v in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man man_forw d !r !spawns - let normal_return_backw r fd man sideg = - let spawning_return = S_backw.return man r fd in - let nval = S_backw.sync { man with local = spawning_return } `Return in + let normal_return_backw r fd man man_forw sideg = + let spawning_return = S_backw.return man man_forw r fd in + let nval = S_backw.sync { man with local = spawning_return } man_forw `Return in nval - let toplevel_kernel_return_backw r fd man sideg = - let st = if fd.svar.vname = MyCFG.dummy_func.svar.vname then man.local else S_backw.return man r fd in - let spawning_return = S_backw.return {man with local = st} None MyCFG.dummy_func in - let nval = S_backw.sync { man with local = spawning_return } `Return in + let toplevel_kernel_return_backw r fd man man_forw sideg = + let st = if fd.svar.vname = MyCFG.dummy_func.svar.vname then man.local else S_backw.return man man_forw r fd in + let spawning_return = S_backw.return {man with local = st} man_forw None MyCFG.dummy_func in + let nval = S_backw.sync { man with local = spawning_return } man_forw `Return in nval - let tf_ret_backw var edge prev_node ret fd getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let tf_ret_backw var edge prev_node ret fd getl getl_forw sidel demandl getg getg_forw sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let man_forw = create_basic_man_forw var edge prev_node d getl getl_forw sidel demandl getg getg_forw 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_backw ret fd man sideg - else normal_return_backw ret fd man sideg + then toplevel_kernel_return_backw ret fd man man_forw sideg + else normal_return_backw ret fd man man_forw sideg in - common_join_backw man d !r !spawns + common_join_backw man man_forw d !r !spawns - let tf_entry_backw var edge prev_node fd getl getl_forw sidel demandl getg sideg d = + let tf_entry_backw var edge prev_node fd getl getl_forw sidel demandl getg getg_forw 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_forw.C.t = snd var |> Obj.obj in side_context_backw sideg fd (c ()); - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.body man fd in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns + let man, r, spawns = common_man_backw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let man_forw = create_basic_man_forw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let d = S_backw.body man man_forw fd in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man man_forw d !r !spawns - let tf_test_backw var edge prev_node e tv getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.branch man e tv in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns + let tf_test_backw var edge prev_node e tv getl getl_forw sidel demandl getg getg_forw sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let man_forw = create_basic_man_forw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let d = S_backw.branch man man_forw e tv in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man man_forw d !r !spawns (*TODO: THIS HAS TO BE BACKWARDS*) (*forward context not implemented yet*) - let tf_normal_call_backw man lv e (f:fundec) args getl getl_forw sidel demandl getg sideg = + let tf_normal_call_backw man man_forw lv e (f:fundec) args getl (getl_forw : node * S_forw.C.t -> S_forw.D.t) sidel demandl getg getg_forw sideg = let combine (cd, fc, fd) = if M.tracing then M.traceli "combine" "local: %a" S_backw.D.pretty cd; if M.tracing then M.trace "combine" "function: %a" S_backw.D.pretty fd; @@ -365,7 +423,7 @@ struct let rec cd_man = { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query cd_man q); + ask = (fun (type a) (q: a Queries.t) -> S_backw.query cd_man man_forw q); local = cd; } in @@ -377,17 +435,17 @@ struct (* TODO: don't do this extra sync here *) let rec sync_man = { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man q); + ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man man_forw q); local = fd; (*prev_node = Function f*) prev_node = FunctionEntry f; } in (* TODO: more accurate man? *) - let synced = sync_backw sync_man in + let synced = sync_backw sync_man man_forw in let rec fd_man = { sync_man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd_man q); + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd_man man_forw q); local = synced; } in @@ -396,19 +454,19 @@ struct let r = List.fold_left (fun acc fd1 -> let rec fd1_man = { fd_man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd1_man q); + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd1_man man_forw q); local = fd1; } in - let combine_enved = S_backw.combine_env cd_man lv e f args fc fd1_man.local (Analyses.ask_of_man fd1_man) in + let combine_enved = S_backw.combine_env cd_man man_forw 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_backw.query combine_assign_man q); + ask = (fun (type a) (q: a Queries.t) -> S_backw.query combine_assign_man man_forw q); local = combine_enved; } in - S_backw.D.join acc (S_backw.combine_assign combine_assign_man lv e f args fc fd1_man.local (Analyses.ask_of_man fd1_man)) - ) (S_backw.D.bot ()) (S_backw.paths_as_set fd_man) + S_backw.D.join acc (S_backw.combine_assign combine_assign_man man_forw lv e f args fc fd1_man.local (Analyses.ask_of_man fd1_man)) + ) (S_backw.D.bot ()) (S_backw.paths_as_set fd_man man_forw) in if M.tracing then M.traceu "combine" "combined local: %a" S_backw.D.pretty r; (* Logs.debug "combined local: %a" S_backw.D.pretty r; *) @@ -416,7 +474,7 @@ struct in let paths = Logs.debug "manager info at call to %a" Node.pretty man.node; - S_backw.enter man lv f args in + S_backw.enter man man_forw lv f args in (* Wollen eig vorwärts-kontext benutzen *) (* getl_forw should query the corresopoding unknown from the forward analysis *) (* context = S_forw.context (S_forw.enter (getl_forw [this_node_, this_context])) *) @@ -468,36 +526,37 @@ struct r (*TODO: HERE AS WELL*) - let rec tf_proc_backw var edge prev_node lv e args getl getl_forw sidel demandl getg sideg d = - let tf_special_call man f = + let rec tf_proc_backw var edge prev_node lv e args getl (getl_forw: node * S_forw.C.t -> S_forw.D.t) sidel demandl getg getg_forw sideg d = + let tf_special_call man man_forw f = let once once_control init_routine = (* Executes leave event for new local state d if it is not bottom *) let leave_once d = if not (S_backw.D.is_bot d) then let rec man' = { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' q); + ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' man_forw q); local = d; } in - S_backw.event man' (Events.LeaveOnce { once_control }) man' + S_backw.event man' man_forw (Events.LeaveOnce { once_control }) man' else S_backw.D.bot () in let first_call = - let d' = S_backw.event man (Events.EnterOnce { once_control; ran = false }) man in - tf_proc_backw var edge prev_node None init_routine [] getl getl_forw sidel demandl getg sideg d' + let d' = S_backw.event man man_forw (Events.EnterOnce { once_control; ran = false }) man in + tf_proc_backw var edge prev_node None init_routine [] getl getl_forw sidel demandl getg getg_forw sideg d' in - let later_call = S_backw.event man (Events.EnterOnce { once_control; ran = true }) man in + let later_call = S_backw.event man man_forw (Events.EnterOnce { once_control; ran = true }) man in S_backw.D.join (leave_once first_call) (leave_once later_call) in let is_once = LibraryFunctions.find ~nowarn:true f in (* If the prototpye for a library function is wrong, this will throw an exception. Such exceptions are usually unrelated to pthread_once, it is just that the call to `is_once.special` raises here *) match is_once.special args with | Once { once_control; init_routine } -> once once_control init_routine - | _ -> S_backw.special man lv f args + | _ -> S_backw.special man man_forw lv f args in - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let man, r, spawns = common_man_backw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let man_forw = create_basic_man_forw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in let functions = match e with | Lval (Var v, NoOffset) -> @@ -506,21 +565,21 @@ struct [v] | _ -> (*constructing fake forwards manager s.t. the inforamtion for the pointer information can be retireved*) - let r = ref [] in - let rec man_forw = - { ask = (fun (type a) (q: a Queries.t) -> S_forw.query man_forw q) - ; emit = (fun _ -> failwith "emit outside MCP") - ; node = man.node - ; prev_node = man.prev_node (* this is problematic, as this is backwards *) - ; control_context = man.control_context - ; context = man.context - ; edge = man.edge - ; local = (getl_forw (man.node, man.context ())) (* accessing forward inforkation*) - ; global = (fun _ -> failwith "whoops, query for resolving function pointer depends on globals") - ; spawn = (fun ?multiple _ _ _ -> failwith "manager for resolving function pointer does not support spawn") - ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) (*what is this?*) - ; sideg = (fun _ _ -> failwith "manager for resolving function pointer does not support sideg") - } in + (* let r = ref [] in + let rec man_forw = + { ask = (fun (type a) (q: a Queries.t) -> S_forw.query man_forw q) + ; emit = (fun _ -> failwith "emit outside MCP") + ; node = man.node + ; prev_node = man.prev_node (* this is problematic, as this is backwards *) + ; control_context = man.control_context + ; context = man.context + ; edge = man.edge + ; local = (getl_forw (man.node, man.context ())) (* accessing forward inforkation*) + ; global = (fun _ -> failwith "whoops, query for resolving function pointer depends on globals") + ; spawn = (fun ?multiple _ _ _ -> failwith "manager for resolving function pointer does not support spawn") + ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) (*what is this?*) + ; sideg = (fun _ _ -> failwith "manager for resolving function pointer does not support sideg") + } in *) let () = Logs.debug "manager info at call to function pointer %a" Node.pretty man_forw.node in (* Depends on base for query. *) let ad = man_forw.ask (Queries.EvalFunvar e) in @@ -546,11 +605,11 @@ struct (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 man f + tf_special_call man man_forw f | fd -> - tf_normal_call_backw man lv e fd args getl getl_forw sidel demandl getg sideg + tf_normal_call_backw man man_forw lv e fd args getl getl_forw sidel demandl getg getg_forw sideg | exception Not_found -> - tf_special_call man f) + tf_special_call man man_forw f) in Some d else begin @@ -568,19 +627,21 @@ struct 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_backw man funs !r !spawns + common_joins_backw man man_forw funs !r !spawns - let tf_asm_backw var edge prev_node getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.asm man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns + let tf_asm_backw var edge prev_node getl getl_forw sidel demandl getg getg_forw sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let man_forw = create_basic_man_forw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let d = S_backw.asm man man_forw in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man man_forw d !r !spawns - let tf_skip_backw var edge prev_node getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.skip man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns + let tf_skip_backw var edge prev_node getl getl_forw sidel demandl getg getg_forw sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let man_forw = create_basic_man_forw var edge prev_node d getl getl_forw sidel demandl getg getg_forw sideg in + let d = S_backw.skip man man_forw in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man man_forw d !r !spawns - let tf_backw var getl getl_forw sidel demandl getg sideg prev_node edge d = + let tf_backw var getl getl_forw sidel demandl getg getg_forw sideg prev_node edge d = begin match edge with | Assign (lv,rv) -> tf_assign_backw var edge prev_node lv rv | VDecl (v) -> tf_vdecl_backw var edge prev_node v @@ -590,10 +651,10 @@ struct | Test (p,b) -> tf_test_backw var edge prev_node p b | ASM (_, _, _) -> tf_asm_backw var edge prev_node (* TODO: use ASM fields for something? *) | Skip -> tf_skip_backw var edge prev_node - end getl getl_forw sidel demandl getg sideg d + end getl getl_forw sidel demandl getg getg_forw sideg d (* TODO: Don't call it prev_node when it is actually the next node. *) - let tf_backw var getl getl_forw sidel demandl getg sideg prev_node (_,edge) d (f,t) = + let tf_backw var getl getl_forw sidel demandl getg getg_forw sideg prev_node (_,edge) d (f,t) = (* let old_loc = !Goblint_tracing.current_loc in let old_loc2 = !Goblint_tracing.next_loc in Goblint_tracing.current_loc := f; @@ -605,14 +666,14 @@ struct let d = tf_backw var getl sidel demandl getg sideg prev_node edge d in d ) *) - tf_backw var getl getl_forw sidel demandl getg sideg prev_node edge d + tf_backw var getl getl_forw sidel demandl getg getg_forw sideg prev_node edge d - let tf_backw (v,c) (edges, u) getl getl_forw sidel demandl getg sideg = + let tf_backw (v,c) (edges, u) getl getl_forw sidel demandl getg getg_forw sideg = let pval = getl (u,c) in let _, locs = List.fold_right (fun (f,e) (t,xs) -> f, (f,t)::xs) edges (Node.location v,[]) in - List.fold_left2 (|>) pval (List.map (tf_backw (v,Obj.repr (fun () -> c)) getl getl_forw sidel demandl getg sideg u) edges) locs + List.fold_left2 (|>) pval (List.map (tf_backw (v,Obj.repr (fun () -> c)) getl getl_forw sidel demandl getg getg_forw sideg u) edges) locs - let tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg sideg = + let tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg getg_forw sideg = let old_node = !current_node in let old_fd = Option.map Node.find_fundec old_node |? Cil.dummyFunDec in let new_fd = Node.find_fundec v in @@ -627,7 +688,7 @@ struct if not (CilType.Fundec.equal old_fd new_fd) then Timing.Program.exit new_fd.svar.vname ) (fun () -> - let d = tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg sideg in + let d = tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg getg_forw sideg in d ) @@ -638,7 +699,9 @@ struct let tf_backw getl sidel demandl getg sideg = let getl_backw = getl_backw_wrapper getl in let getl_forw = getl_forw_wrapper getl in - let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg sideg in + let getg_backw v = getg (`Backw v) |> to_backw_g in + let getg_forw v = getg (`Forw v) |> to_forw_g in + let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg_backw getg_forw sideg in let xs = List.map tf' (Cfg.next v) in List.fold_left S_backw.D.join (S_backw.D.bot ()) xs in @@ -649,7 +712,9 @@ struct let tf_backw getl sidel demandl getg sideg = let getl_backw = getl_backw_wrapper getl in let getl_forw = getl_forw_wrapper getl in - let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg sideg in + let getg_backw v = getg (`Backw v) |> to_backw_g in + let getg_forw v = getg (`Forw v) |> to_forw_g in + let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg_backw getg_forw sideg in let xs = List.map tf' (Cfg.next v) in List.fold_left S_backw.D.join (S_backw.D.bot ()) xs in @@ -664,8 +729,8 @@ struct let getl' v = getl (`L_forw v) |> to_forw_d in let sidel' v d = sidel (`L_forw v) (of_forw_d d) in let demandl' v = demandl (`L_forw v) in - let getg' v = getg (`G_forw v) |> to_forw_g in - let sideg' v d = sideg (`G_forw v) (of_forw_g d) in + let getg' v = getg (`Forw v) |> to_forw_g in + let sideg' v d = sideg (`Forw v) (of_forw_g d) in tf getl' sidel' demandl' getg' sideg' |> of_forw_d ) | `L_backw v -> @@ -674,9 +739,9 @@ struct (* let getl' (v : Backward.LVar.t) : (S_backw.D.t) = getl (`L_backw (forw_lv_of_backw v)) |> to_backw_d in *) let sidel' v d = sidel (`L_backw (lv_of_backw v)) (of_backw_d d) in let demandl' v = demandl (`L_backw (lv_of_backw v)) in - let getg' v = getg (`G_backw v) |> to_backw_g in - let sideg' v d = sideg (`G_backw v) (of_backw_g d) in - tf getl sidel' demandl' getg' sideg' |> of_backw_d + (* let getg' v = getg (`G_backw v) |> to_backw_g in *) + let sideg' v d = sideg (`Backw v) (of_backw_g d) in + tf getl sidel' demandl' getg sideg' |> of_backw_d ) let iter_vars getl getg vq fl fg = @@ -685,7 +750,11 @@ struct let sys_change getl getg = failwith "damn" + let postmortem_backw = function + | FunctionEntry fd, c -> [(Function fd, c)] + | _ -> [] + let postmortem = function | `L_forw v -> List.map (fun v -> `L_forw v) (Forward.postmortem v) - | `L_backw v -> List.map (fun v -> `L_backw (v)) (Backward.postmortem (v)) + | `L_backw v -> List.map (fun v -> `L_backw (v)) (postmortem_backw v) end \ No newline at end of file diff --git a/src/framework/control.ml b/src/framework/control.ml index e8dc8afd86..0802092193 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -1687,9 +1687,9 @@ struct end (** Given a [Cfg], a [Spec_forw], [Spec_back], and an unused [Inc], computes the solution] *) -module AnalyzeCFG_bidir (Cfg:CfgBidirSkip) (Spec_forw:Spec) (Spec_backw: Spec with type C.t = Spec_forw.C.t ) (Spec_backwA : BackwSpec) (Inc:Increment) = +module AnalyzeCFG_bidir (Cfg:CfgBidirSkip) (Spec_forw:Spec) (BackwSpecSpec : BackwAnalyses.BackwSpecSpec) (Inc:Increment) = struct - + module Spec_backw = BackwSpecSpec (Spec_forw) (* The Equation system *) module EQSys = BidirConstrains.BidirFromSpec (Spec_forw) (Spec_backw) (Cfg) (Inc) @@ -1731,19 +1731,6 @@ struct module ResultOutput = AnalysisResultOutput.Make (Result) end - (* module ResBundle_backw : ResultBundle with module Spec = Spec_backw = - struct - (* Triple of the function, context, and the local value. It uses Spec and therefore has the wrong types.*) - module Spec = Spec_backw - module RT = AnalysisResult.ResultType2 (Spec_backw) - module LT = SetDomain.HeadlessSet (RT) - module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis_backw" end) - module ResultOutput = AnalysisResultOutput.Make (Result) - end *) - - (* not having a Query module is problematic! Is it?*) - (* module Query = ResultQuery.Query (SpecSys) *) - (** this function converts the LHT to two Results of type forwards and backwards *) let solver2source_result h = let res_forw = ResBundle_forw.Result.create 113 in @@ -1776,33 +1763,6 @@ struct Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n in - (* let add_local_var_backw (n,es) state = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - - let state = match state with - | `Lifted2 s -> s - | `Bot -> Spec_backw.D.bot () - | `Top -> Spec_backw.D.top () - | `Lifted1 _ -> failwith "Unexpected forward state in backward result" - in - let loc = UpdateCil.getLoc n in - if loc <> locUnknown then try - let fundec = Node.find_fundec n in - if ResBundle_backw.Result.mem res_backw n then - (* If this source location has been added before, we look it up - * and add another node to it information to it. *) - let prev = ResBundle_backw.Result.find res_backw n in - ResBundle_backw.Result.replace res_backw n (ResBundle_backw.LT.add (es,state,fundec) prev) - else - ResBundle_backw.Result.add res_backw n (ResBundle_backw.LT.singleton (es,state,fundec)) - (* If the function is not defined, and yet has been included to the - * analysis result, we generate a warning. *) - with Not_found -> - Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n - in *) - - LHT.iter (fun key -> match key with | `L_forw (n,es) -> add_local_var_forw (n,es) @@ -1855,9 +1815,9 @@ struct let do_forward_inits () : (node * Spec_forw.C.t) list * ((node * Spec_forw.C.t) * Spec_forw.D.t) list = (* wrapping functions accessing and modifying global variables *) - let sideg_forw v d = sideg (`G_forw (v)) ((`Lifted1 d)) in + let sideg_forw v d = sideg (`Forw (v)) ((`Lifted1 d)) in let getg_forw v = - match EQSys.G.spec (getg (`G_forw v)) with + match EQSys.G.spec (getg (`Forw v)) with | `Lifted1 g -> G_forw.create_spec g | `Bot -> failwith "Unexpected global state" (*G_forw.bot (); *) | `Top -> failwith "Unexpected global state" (*G_forw.top ()*) @@ -2030,16 +1990,16 @@ struct (** this function calculates and returns [startvars'_backw] and [entrystates_backw] *) let do_backward_inits () : (node * Spec_backw.C.t) list * ((node * Spec_forw.C.t) * Spec_backw.D.t) list = - let sideg_backw v d = sideg (`G_backw v) (EQSys.G.create_spec (`Lifted2 d)) in + let sideg_backw v d = sideg (`Backw v) (EQSys.G.create_spec (`Lifted2 d)) in let getg_backw v = - match EQSys.G.spec (getg (`G_backw v)) with + match EQSys.G.spec (getg (`Backw v)) with | `Lifted1 _ -> failwith "Unexpected backward global state" | `Bot -> G_backw.bot () | `Top -> G_backw.top () | `Lifted2 g -> G_backw.create_spec g in - let do_extern_inits_backw man (file: file) : Spec_backw.D.t = + let do_extern_inits_backw man man_forw (file: file) : Spec_backw.D.t = let module VS = Set.Make (Basetype.Variables) in let add_glob s = function | GVar (v,_,_) -> VS.add v s @@ -2047,7 +2007,7 @@ struct in let vars = foldGlobals file add_glob VS.empty in let set_bad v st = - Spec_backw.assign {man with local = st} (var v) MyCFG.unknown_exp + Spec_backw.assign {man with local = st} man_forw (var v) MyCFG.unknown_exp in let is_std = function | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) @@ -2085,13 +2045,29 @@ struct } in + let man_forw = + { 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 () -> man_failwith "Global initializers have no context.") + ; context = (fun () -> man_failwith "Global initializers have no context.") + ; edge = MyCFG.Skip + ; local = Spec_forw.D.top () (*TODO: SOULD I GET THE VALUE FROM THE FORWARD INITIALIZATION?*) + ; global = (fun _ -> Spec_forw.G.bot ()) + ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Global initializers trying to split paths.") + ; sideg = (fun _ _ -> failwith "forw_man in the backwards initialization should not be used to sideeffect globals.") + } + in + let edges = CfgTools.getGlobalInits file in Logs.debug "Executing %d assigns." (List.length edges); let funs = ref [] in let transfer_func (st : Spec_backw.D.t) (loc, edge) : Spec_backw.D.t = match edge with - | MyCFG.Entry func -> Spec_backw.body {man with local = st} func + | MyCFG.Entry func -> Spec_backw.body {man with local = st} man_forw func | MyCFG.Assign (lval,exp) -> begin match lval, exp with | (Var v,o), (AddrOf (Var f,NoOffset)) @@ -2099,14 +2075,14 @@ struct (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) | _ -> () end; - let res = Spec_backw.assign {man with local = st} lval exp in + let res = Spec_backw.assign {man with local = st} man_forw lval exp in (* Needed for privatizations (e.g. None) that do not side immediately *) - let res' = Spec_backw.sync {man with local = res} `Normal in + let res' = Spec_backw.sync {man with local = res} man_forw `Normal in res' | _ -> failwith "Unsupported global initializer edge" in - let with_externs = do_extern_inits_backw man file in + let with_externs = do_extern_inits_backw man man_forw file in let result : Spec_backw.D.t = List.fold_left transfer_func with_externs edges in result, !funs in @@ -2133,8 +2109,24 @@ struct ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) d) } in + let man_forw = + { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) + ; emit = (fun _ -> failwith "Cannot \"emit\" in global initializer context.") + ; node = man.node + ; prev_node = MyCFG.dummy_node (* SHOULD I USE DUMMY NODES HERE IN GENERAL? I PROBABLY SHOULÖD*) + ; control_context = (fun () -> man_failwith "Global initializers have no context.") + ; context = man.context + ; edge = MyCFG.Skip + ; local = Spec_forw.D.top () (*TODO: SOULD I GET THE VALUE FROM THE FORWARD INITIALIZATION?*) + ; global = (fun _ -> Spec_forw.G.bot ()) (*TODO: SHOULD I ALLOW TO ASK FOR GLOBALS?*) + ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") + ; split = (fun _ -> failwith "Global initializers trying to split paths.") + ; sideg = (fun _ _ -> failwith "forw_man in the backwards initialization should not be used to sideeffect globals.") + } + in + let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in - let ents = Spec_backw.enter man None fd args in + let ents = Spec_backw.enter man man_forw None fd args in List.map (fun (_,s) -> fd, s) ents in @@ -2165,8 +2157,24 @@ struct ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) d) } in + + let man_forw = + { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) + ; emit = (fun _ -> failwith "Cannot \"emit\" in otherstate context.") + ; node = man.node + ; prev_node = MyCFG.dummy_node + ; control_context = (fun () -> man_failwith "enter_func has no context.") + ; context = (fun () -> man_failwith "enter_func has no context.") + ; edge = MyCFG.Skip + ; local = Spec_forw.D.top () (*TODO: SOULD I GET THE VALUE FROM THE FORWARD INITIALIZATION?*) + ; global = (fun _ -> Spec_forw.G.bot ()) (*TODO: SHOULD I ALLOW TO ASK FOR GLOBALS?*) + ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") + ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") + ; sideg = (fun _ _ -> failwith "forw_man in the backwards initialization should not be used to sideeffect globals.") + } + in (* TODO: don't hd *) - List.hd (Spec_backw.threadenter man ~multiple:false None v []) + List.hd (Spec_backw.threadenter man man_forw ~multiple:false None v []) (* TODO: do threadspawn to mainfuns? *) in let prestartstate = Spec_backw.startstate MyCFG.dummy_func.svar in (* like in do_extern_inits *) @@ -2208,8 +2216,6 @@ struct (** calculates and combines the solver input calculation from the forwards and backwards part of the constraint system. Returns [startvars'] and [entrystate] and [entrystates_global].*) let calculate_solver_input () = - AnalysisState.global_initialization := true; - (* Spec_forw (MCP) initialization *) AnalysisState.should_warn := PostSolverArg.should_warn; Spec_forw.init None; @@ -2339,6 +2345,43 @@ struct in log_lh_contents lh; + let joined_by_loc_backw, joined_by_node_backw = + let open Enum in + let node_values = LHT.enum lh in + let node_backw_values = filter_map ( + fun (key, d) -> + match key with + | `L_forw (_,_) -> None + | `L_backw (node, context) -> + (match d with + | `Lifted2 d -> Some (node, d) + | _ -> None) + ) node_values + in + let hashtbl_size = if fast_count node_values then count node_values else 123 in + let by_loc, by_node = Hashtbl.create hashtbl_size, NodeH.create hashtbl_size in + iter (fun (node, v) -> + let loc = match node with + | Statement s -> Cil.get_stmtLoc s.skind (* nosemgrep: cilfacade *) (* Must use CIL's because syntactic search is in CIL. *) + | FunctionEntry _ | Function _ -> Node.location node + in + (* join values once for the same location and once for the same node *) + let join = Option.some % function None -> v | Some v' -> Spec_backw.D.join v v' in + Hashtbl.modify_opt loc join by_loc; + NodeH.modify_opt node join by_node; + ) node_backw_values; + by_loc, by_node + in + + (* NodeH.iter (fun node d -> + match node with + | Statement s -> ( + match s. with + | _ -> () + ) + | _ -> () + ) joined_by_node_backw; *) + let make_global_fast_xml f g = let open Printf in let print_globals k v = @@ -2424,8 +2467,8 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = (* let module B = AnalyzeCFG_backw (CFG) (DummyWPSPec) (struct let increment = change_info end) in *) let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec) in - let module LivenesSpec = Wp_test.BackwSpec (Spec) in - let module C = AnalyzeCFG_bidir (CFG) (Spec) (DummyWPSPec) (LivenesSpec) (struct let increment = change_info end) in + let module LivenesSpec = Wp_test.BackwSpec in + let module C = AnalyzeCFG_bidir (CFG) (Spec) (LivenesSpec) (struct let increment = change_info end) in GobConfig.with_immutable_conf (fun () -> (* A.analyze file fs; diff --git a/src/framework/oldBidirConstraints.ml b/src/framework/oldBidirConstraints.ml new file mode 100644 index 0000000000..357e68696d --- /dev/null +++ b/src/framework/oldBidirConstraints.ml @@ -0,0 +1,691 @@ +open Batteries +open GoblintCil +open MyCFG +open Analyses +open Goblint_constraint.ConstrSys +open GobConfig + +module type Increment = +sig + val increment: increment_data option +end + +module GVarF2 (V_forw: SpecSysVar) (V_backw : SpecSysVar) : +sig + include VarType with type t = [ `G_forw of GVarF(V_forw).t | `G_backw of GVarF(V_backw).t ] + include SpecSysVar with type t := t +end += +struct + module GV_forw = GVarF (V_forw) + module GV_backw = GVarF (V_backw) + type t = [ `G_forw of GV_forw.t | `G_backw of GV_backw.t ] [@@deriving eq, ord, hash] + let name () = "BidirFromSpec" + + let tag _ = failwith "Std: no tag" + + let relift = function + | `G_forw x -> `G_forw (GV_forw.relift x) + | `G_backw x -> `G_backw (GV_backw.relift x) + + let pretty_trace () = function + | `G_forw a -> GoblintCil.Pretty.dprintf "G_forw:%a" GV_forw.pretty_trace a + | `G_backw a -> GoblintCil.Pretty.dprintf "G_backw:%a" GV_backw.pretty_trace a + + let printXml f = function + | `G_forw a -> GV_forw.printXml f a + | `G_backw a -> GV_backw.printXml f a + + let node = function + | `G_forw a -> GV_forw.node a + | `G_backw a -> GV_backw.node a + + let is_write_only = function + | `G_forw a -> GV_forw.is_write_only a + | `G_backw a -> GV_backw.is_write_only a + + let show = function + | `G_forw a -> GV_forw.show a + | `G_backw a -> GV_backw.show a + + let pretty () = function + | `G_forw a -> GV_forw.pretty () a + | `G_backw a -> GV_backw.pretty () a + let to_yojson = function + | `G_forw a -> GV_forw.to_yojson a + | `G_backw a -> GV_backw.to_yojson a + + let spec = function + | `G_forw a -> GV_forw.spec a + | `G_backw a -> GV_backw.spec a + + let contexts = function + | `G_forw a -> GV_forw.contexts a + | `G_backw a -> GV_backw.contexts a + + let var_id = show + + let arbitrary () = + failwith "no arbitrary" +end + + +module BidirFromSpec (S_forw:Spec) (S_backw:Spec with type C.t = S_forw.C.t ) (Cfg:CfgBidir) (I:Increment) + : sig + module LVar : Goblint_constraint.ConstrSys.VarType with type t = [ `L_forw of VarF(S_forw.C).t | `L_backw of VarF(S_forw.C).t ] + module GVar : (module type of GVarF2(S_forw.V)(S_backw.V)) + include DemandGlobConstrSys with module LVar := LVar + and module GVar := GVar + and module D = Lattice.Lift2(S_forw.D)(S_backw.D) + and module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) + end += +struct + (* type lv = [ `lv_forw of MyCFG.node * S_forw.C.t | `lv_back of MyCFG.node * S_forw.C.t] *) + (* type ld = Lattice.Lift2(S_forw.D)(S_backw.D).t *) + + module LV = VarF (S_forw.C) + module LVar = + struct + type t = [ `L_forw of LV.t | `L_backw of LV.t ] [@@deriving eq, ord, hash] + + let relift = function + | `L_forw x -> `L_forw (LV.relift x) + | `L_backw x -> `L_backw (LV.relift x) + + let pretty_trace () = function + | `L_forw a -> GoblintCil.Pretty.dprintf "L_forw:%a" LV.pretty_trace a + | `L_backw a -> GoblintCil.Pretty.dprintf "L_backw:%a" LV.pretty_trace a + + let printXml f = function + | `L_forw a -> LV.printXml f a + | `L_backw a -> LV.printXml f a + + let var_id = function + | `L_forw a -> LV.var_id a + | `L_backw a -> LV.var_id a + + let node = function + | `L_forw a -> LV.node a + | `L_backw a -> LV.node a + + let is_write_only = function + | `L_forw a -> LV.is_write_only a + | `L_backw a -> LV.is_write_only a + end + + module D = Lattice.Lift2(S_forw.D)(S_backw.D) + module GV_forw = GVarF (S_forw.V) + module GV_backw = GVarF (S_backw.V) + module GVar = GVarF2(S_forw.V)(S_backw.V) + + module G_forw = GVarG (S_forw.G) (S_forw.C) + module G_backw = GVarG (S_backw.G) (S_forw.C) + module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) + + module Forward = Constraints.FromSpec (S_forw) (Cfg) (I) + module Backward = Constraints_wp.FromSpec (S_backw) (Cfg) + + (* functions for converting between forwards and backwards types*) + let getl_backw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_backw.D.t = + match getl (`L_backw v) with + | `Lifted2 d -> d + | `Bot -> S_backw.D.bot () + | `Top -> S_backw.D.top () + | `Lifted1 _ -> failwith "bidirConstrains: backward local got forward value" + + let getl_forw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_forw.D.t = + match getl (`L_forw v) with + | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" + | `Bot -> S_forw.D.bot () + | `Top -> S_forw.D.top () + | `Lifted1 d -> d + + let lv_of_backw ((n,c): Backward.LVar.t) : LV.t = (n, Obj.magic c) + + let to_l_backw (v:LVar.t) = + match v with + | `L_forw (n, l) -> `L_backw (n, l) + | `L_backw (n, l) -> `L_backw (n, l) + + let cset_to_forw c = + G.CSet.fold (fun x acc -> Forward.G.CSet.add x acc) c (Forward.G.CSet.empty ()) + + let cset_of_forw c = + Forward.G.CSet.fold (fun x acc -> G.CSet.add x acc) c (G.CSet.empty ()) + + let cset_to_backw c = + G.CSet.fold (fun x acc -> G_backw.CSet.add (Obj.magic x) acc) c (G_backw.CSet.empty ()) + + let cset_of_backw c = + G_backw.CSet.fold (fun x acc -> G.CSet.add (Obj.magic x) acc) c (G.CSet.empty ()) + + let to_forw_d (d: D.t) : S_forw.D.t = + match d with + | `Lifted1 d -> d + | `Bot -> S_forw.D.bot () + | `Top -> S_forw.D.top () + | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" + + let to_backw_d (d: D.t) : S_backw.D.t = + match d with + | `Lifted2 d -> d + | `Bot -> S_backw.D.bot () + | `Top -> S_backw.D.top () + | `Lifted1 _ -> failwith "bidirConstrains: backward local got forward value" + + let of_forw_d (d: S_forw.D.t) : D.t = `Lifted1 d + let of_backw_d (d: S_backw.D.t) : D.t = `Lifted2 d + + let to_forw_g (g: G.t) : Forward.G.t = + match g with + | `Lifted1 (`Lifted1 g) -> `Lifted1 g + | `Lifted1 `Bot -> `Bot + | `Lifted1 `Top -> `Top + | `Lifted1 (`Lifted2 _) -> failwith "bidirConstrains: forward global got backward value" + | `Lifted2 c -> `Lifted2 (cset_to_forw c) + | `Bot -> `Bot + | `Top -> `Top + + let to_backw_g (g: G.t) : G_backw.t = + match g with + | `Lifted1 (`Lifted2 g) -> `Lifted1 g + | `Lifted1 `Bot -> `Bot + | `Lifted1 `Top -> `Top + | `Lifted1 (`Lifted1 _) -> failwith "bidirConstrains: backward global got forward value" + | `Lifted2 c -> `Lifted2 (cset_to_backw c) + | `Bot -> `Bot + | `Top -> `Top + + let of_forw_g (g: Forward.G.t) : G.t = + match g with + | `Lifted1 g -> `Lifted1 (`Lifted1 g) + | `Lifted2 c -> `Lifted2 (cset_of_forw c) + | `Bot -> `Bot + | `Top -> `Top + + let of_backw_g (g: G_backw.t) : G.t = + match g with + | `Lifted1 g -> `Lifted1 (`Lifted2 g) + | `Lifted2 c -> `Lifted2 (cset_of_backw c) + | `Bot -> `Bot + | `Top -> `Top + + + (* actually relevant (transfer) functions*) + let sync_backw man = + match man.prev_node, Cfg.next man.prev_node with + | _, _ :: _ :: _ -> (* Join in CFG. *) + S_backw.sync man `Join + | FunctionEntry f, _ -> (* Function entry, also needs sync because partial contexts joined by solver, see 00-sanity/35-join-contexts. *) + S_backw.sync man (`JoinCall f) + | _, _ -> S_backw.sync man `Normal + + let side_context_backw sideg f c = + if !AnalysisState.postsolving then + sideg (GV_backw.contexts f) (G_backw.create_contexts (G_backw.CSet.singleton c)) + + let common_man_backw var edge prev_node pval getl sidel demandl getg sideg : (S_backw.D.t, S_backw.G.t, S_backw.C.t, S_backw.V.t) man * S_backw.D.t list ref * (lval option * varinfo * exp list * S_backw.D.t * bool) list ref = + let r = ref [] in + let spawns = ref [] in + (* now watch this ... *) + let rec man = + { ask = (fun (type a) (q: a Queries.t) -> S_backw.query man q) + ; emit = (fun _ -> failwith "emit outside MCP") + ; node = fst var + ; prev_node = prev_node + ; control_context = snd var |> Obj.obj + ; context = snd var |> Obj.obj + ; edge = edge + ; local = pval + ; global = (fun g -> G_backw.spec (getg (GV_backw.spec g))) + ; spawn = spawn + ; split = (fun (d:S_backw.D.t) es -> assert (List.is_empty es); r := d::!r) + ; sideg = (fun g d -> sideg (GV_backw.spec g) (G_backw.create_spec d)) + } + and spawn ?(multiple=false) lval f args = + (* TODO: adjust man node/edge? *) + (* TODO: don't repeat for all paths that spawn same *) + + (* TODO: This needs to be changed for backwards!! Context is created using S_backw.context*) + let ds = S_backw.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_backw.context man fd d in + sidel (FunctionEntry fd, c) d; + demandl (Function fd, c) + | exception Not_found -> + (* unknown function *) + M.error ~category:Imprecise ~tags:[Category Unsound] "Created a thread from unknown function %s" f.vname; + (* actual implementation (e.g. invalidation) is done by threadenter *) + (* must still sync for side effects, e.g., old sync-based none privatization soundness in 02-base/51-spawn-special *) + let rec sync_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man q); + local = d; + prev_node = Function dummyFunDec; + } + in + (* TODO: more accurate man? *) + ignore (sync_backw sync_man) + ) ds + in + (* ... nice, right! *) + let pval = sync_backw man in + { man with local = pval }, r, spawns + + let rec bigsqcup_backw = function + | [] -> S_backw.D.bot () + | [x] -> x + | x::xs -> S_backw.D.join x (bigsqcup_backw xs) + + let thread_spawns_backws man d spawns = + if List.is_empty spawns then + d + else + let rec man' = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' q) + ; local = d + } + in + (* TODO: don't forget path dependencies *) + let one_spawn (lval, f, args, fd, multiple) = + let rec fman = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fman q) + ; local = fd + } + in + S_backw.threadspawn man' ~multiple lval f args fman + in + bigsqcup_backw (List.map one_spawn spawns) + + let common_join_backw man d splits spawns = + thread_spawns_backws man (bigsqcup_backw (d :: splits)) spawns + + let common_joins_backw man ds splits spawns = common_join_backw man (bigsqcup_backw ds) splits spawns + + let tf_assign_backw var edge prev_node lv e getl getl_forw sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.assign man lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let tf_vdecl_backw var edge prev_node v getl getl_forw sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.vdecl man v in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let normal_return_backw r fd man sideg = + let spawning_return = S_backw.return man r fd in + let nval = S_backw.sync { man with local = spawning_return } `Return in + nval + + let toplevel_kernel_return_backw r fd man sideg = + let st = if fd.svar.vname = MyCFG.dummy_func.svar.vname then man.local else S_backw.return man r fd in + let spawning_return = S_backw.return {man with local = st} None MyCFG.dummy_func in + let nval = S_backw.sync { man with local = spawning_return } `Return in + nval + + let tf_ret_backw var edge prev_node ret fd getl getl_forw sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl 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_backw ret fd man sideg + else normal_return_backw ret fd man sideg + in + common_join_backw man d !r !spawns + + let tf_entry_backw var edge prev_node fd getl getl_forw sidel demandl 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_forw.C.t = snd var |> Obj.obj in + side_context_backw sideg fd (c ()); + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.body man fd in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let tf_test_backw var edge prev_node e tv getl getl_forw sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.branch man e tv in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + (*TODO: THIS HAS TO BE BACKWARDS*) (*forward context not implemented yet*) + let tf_normal_call_backw man lv e (f:fundec) args getl getl_forw sidel demandl getg sideg = + let combine (cd, fc, fd) = + if M.tracing then M.traceli "combine" "local: %a" S_backw.D.pretty cd; + if M.tracing then M.trace "combine" "function: %a" S_backw.D.pretty fd; + + (* Logs.debug "combine: local: %a" S_backw.D.pretty cd; + Logs.debug "combine: function: %a" S_backw.D.pretty fd; *) + + let rec cd_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query cd_man q); + local = cd; + } + in + 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_man), simulate it here for fd. *) + (* TODO: don't do this extra sync here *) + let rec sync_man = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man q); + local = fd; + (*prev_node = Function f*) + prev_node = FunctionEntry f; + } + in + (* TODO: more accurate man? *) + let synced = sync_backw sync_man in + let rec fd_man = + { sync_man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd_man q); + local = synced; + } + in + fd_man + in + let r = List.fold_left (fun acc fd1 -> + let rec fd1_man = + { fd_man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd1_man q); + local = fd1; + } + in + let combine_enved = S_backw.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_backw.query combine_assign_man q); + local = combine_enved; + } + in + S_backw.D.join acc (S_backw.combine_assign combine_assign_man lv e f args fc fd1_man.local (Analyses.ask_of_man fd1_man)) + ) (S_backw.D.bot ()) (S_backw.paths_as_set fd_man) + in + if M.tracing then M.traceu "combine" "combined local: %a" S_backw.D.pretty r; + (* Logs.debug "combined local: %a" S_backw.D.pretty r; *) + r + in + let paths = + Logs.debug "manager info at call to %a" Node.pretty man.node; + S_backw.enter man lv f args in + (* Wollen eig vorwärts-kontext benutzen *) + (* getl_forw should query the corresopoding unknown from the forward analysis *) + (* context = S_forw.context (S_forw.enter (getl_forw [this_node_, this_context])) *) + + let r = ref [] in + let rec man_forw = + { ask = (fun (type a) (q: a Queries.t) -> failwith "manager for calculating context does not support queries") + ; emit = (fun _ -> failwith "emit outside MCP") + ; node = man.node + ; prev_node = man.prev_node (* this is problematic, as this is backwards *) + ; control_context = man.control_context + ; context = man.context + ; edge = man.edge + ; local = (getl_forw (man.node, man.context ())) + ; global = (fun _ -> failwith "manager for calculating context does not have globals") + ; spawn = (fun ?multiple _ _ _ -> failwith "manager for calculating context does not support spawn") + ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) + ; sideg = (fun _ _ -> failwith "manager for calculating context does not support sideg") + } in + + let paths_forw = + Logs.debug "forward manager info at call to %a" Node.pretty man_forw.node; + S_forw.enter man_forw lv f args in + + let paths = List.combine paths paths_forw in + + (* filter paths were the forward analysis found out they are unreachable*) + let paths = List.filter (fun ((c,v),(_,b)) -> not (S_forw.D.is_bot b)) paths in + + + (* this list now uses forward contexts*) + let paths = List.map (fun ((c,v),(_,b)) -> (c, S_forw.context man_forw f b, v)) paths in + (* List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; *) + + List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (Function f, fc) v) paths; + (* let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (Function f, fc))) paths; *) + (* *) + let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in + + (* Don't filter bot paths, otherwise LongjmpLifter is not called. *) + (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) + let paths = List.map (Tuple3.map2 Option.some) paths in + if M.tracing then M.traceli "combine" "combining"; + (* Logs.debug "combining"; *) + let paths = List.map combine paths in + let r = List.fold_left S_backw.D.join (S_backw.D.bot ()) paths in + if M.tracing then M.traceu "combine" "combined: %a" S_backw.D.pretty r; + (* Logs.debug "combined: %a" S_backw.D.pretty r; *) + r + + (*TODO: HERE AS WELL*) + let rec tf_proc_backw var edge prev_node lv e args getl getl_forw sidel demandl getg sideg d = + let tf_special_call man f = + let once once_control init_routine = + (* Executes leave event for new local state d if it is not bottom *) + let leave_once d = + if not (S_backw.D.is_bot d) then + let rec man' = + { man with + ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' q); + local = d; + } + in + S_backw.event man' (Events.LeaveOnce { once_control }) man' + else + S_backw.D.bot () + in + let first_call = + let d' = S_backw.event man (Events.EnterOnce { once_control; ran = false }) man in + tf_proc_backw var edge prev_node None init_routine [] getl getl_forw sidel demandl getg sideg d' + in + let later_call = S_backw.event man (Events.EnterOnce { once_control; ran = true }) man in + S_backw.D.join (leave_once first_call) (leave_once later_call) + in + let is_once = LibraryFunctions.find ~nowarn:true f in + (* If the prototpye for a library function is wrong, this will throw an exception. Such exceptions are usually unrelated to pthread_once, it is just that the call to `is_once.special` raises here *) + match is_once.special args with + | Once { once_control; init_routine } -> once once_control init_routine + | _ -> S_backw.special man lv f args + in + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let functions = + match e with + | Lval (Var v, NoOffset) -> + (* Handle statically known function call directly. + Allows deactivating base. *) + [v] + | _ -> + (*constructing fake forwards manager s.t. the inforamtion for the pointer information can be retireved*) + let r = ref [] in + let rec man_forw = + { ask = (fun (type a) (q: a Queries.t) -> S_forw.query man_forw q) + ; emit = (fun _ -> failwith "emit outside MCP") + ; node = man.node + ; prev_node = man.prev_node (* this is problematic, as this is backwards *) + ; control_context = man.control_context + ; context = man.context + ; edge = man.edge + ; local = (getl_forw (man.node, man.context ())) (* accessing forward inforkation*) + ; global = (fun _ -> failwith "whoops, query for resolving function pointer depends on globals") + ; spawn = (fun ?multiple _ _ _ -> failwith "manager for resolving function pointer does not support spawn") + ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) (*what is this?*) + ; sideg = (fun _ _ -> failwith "manager for resolving function pointer does not support sideg") + } in + let () = Logs.debug "manager info at call to function pointer %a" Node.pretty man_forw.node in + (* Depends on base for query. *) + let ad = man_forw.ask (Queries.EvalFunvar e) in + let res = Queries.AD.to_var_may ad in (* TODO: don't convert, handle UnknownPtr below *) + (*PROBLEM: Pointer. Brauche Ergebnisse der anderen Analysen*) + (Logs.debug "(!) resolved function pointer to %d functions" (List.length res); + (match res with + | x::xs -> + List.iter (fun vi -> Logs.debug " possible function: %s" vi.vname) res; + | _ -> (); + )); + res + in + let one_function f = + match Cil.unrollType f.vtype with + | TFun (_, params, var_arg, _) -> + let arg_length = List.length args in + let p_length = Option.map_default List.length 0 params in + (* Check whether number of arguments fits. *) + (* If params is None, the function or its parameters are not declared, so we still analyze the unknown function call. *) + if Option.is_none params || p_length = arg_length || (var_arg && arg_length >= p_length) then + let d = + (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 man f + | fd -> + tf_normal_call_backw man lv e fd args getl getl_forw sidel demandl getg sideg + | exception Not_found -> + tf_special_call man f) + in + Some d + else begin + let geq = if var_arg then ">=" else "" in + M.warn ~category:Unsound ~tags:[Category Call; CWE 685] "Potential call to function %a with wrong number of arguments (expected: %s%d, actual: %d). This call will be ignored." CilType.Varinfo.pretty f geq p_length arg_length; + None + end + | _ -> + M.warn ~category:Call "Something that is not a function (%a) is called." CilType.Varinfo.pretty f; + None + in + let funs = List.filter_map one_function functions in + if [] = funs && not (S_backw.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_backw man funs !r !spawns + + let tf_asm_backw var edge prev_node getl getl_forw sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.asm man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let tf_skip_backw var edge prev_node getl getl_forw sidel demandl getg sideg d = + let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in + let d = S_backw.skip man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) + common_join_backw man d !r !spawns + + let tf_backw var getl getl_forw sidel demandl getg sideg prev_node edge d = + begin match edge with + | Assign (lv,rv) -> tf_assign_backw var edge prev_node lv rv + | VDecl (v) -> tf_vdecl_backw var edge prev_node v + | Proc (r,f,ars) -> tf_proc_backw var edge prev_node r f ars + | Entry f -> tf_entry_backw var edge prev_node f + | Ret (r,fd) -> tf_ret_backw var edge prev_node r fd + | Test (p,b) -> tf_test_backw var edge prev_node p b + | ASM (_, _, _) -> tf_asm_backw var edge prev_node (* TODO: use ASM fields for something? *) + | Skip -> tf_skip_backw var edge prev_node + end getl getl_forw sidel demandl getg sideg d + + (* TODO: Don't call it prev_node when it is actually the next node. *) + let tf_backw var getl getl_forw sidel demandl getg sideg prev_node (_,edge) d (f,t) = + (* let old_loc = !Goblint_tracing.current_loc in + let old_loc2 = !Goblint_tracing.next_loc in + Goblint_tracing.current_loc := f; + Goblint_tracing.next_loc := t; + Goblint_backtrace.protect ~mark:(fun () -> TfLocation f) ~finally:(fun () -> + Goblint_tracing.current_loc := old_loc; + Goblint_tracing.next_loc := old_loc2 + ) (fun () -> + let d = tf_backw var getl sidel demandl getg sideg prev_node edge d in + d + ) *) + tf_backw var getl getl_forw sidel demandl getg sideg prev_node edge d + + let tf_backw (v,c) (edges, u) getl getl_forw sidel demandl getg sideg = + let pval = getl (u,c) in + let _, locs = List.fold_right (fun (f,e) (t,xs) -> f, (f,t)::xs) edges (Node.location v,[]) in + List.fold_left2 (|>) pval (List.map (tf_backw (v,Obj.repr (fun () -> c)) getl getl_forw sidel demandl getg sideg u) edges) locs + + let tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg sideg = + let old_node = !current_node in + let old_fd = Option.map Node.find_fundec old_node |? Cil.dummyFunDec in + let new_fd = Node.find_fundec v in + if not (CilType.Fundec.equal old_fd new_fd) then + Timing.Program.enter new_fd.svar.vname; + let old_context = !M.current_context in + current_node := Some u; + M.current_context := Some (Obj.magic c); (* magic is fine because Spec is top-level Control Spec *) + Fun.protect ~finally:(fun () -> + current_node := old_node; + M.current_context := old_context; + if not (CilType.Fundec.equal old_fd new_fd) then + Timing.Program.exit new_fd.svar.vname + ) (fun () -> + let d = tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg sideg in + d + ) + + let system_backw (v,c) = + + match v with + | FunctionEntry _ -> + let tf_backw getl sidel demandl getg sideg = + let getl_backw = getl_backw_wrapper getl in + let getl_forw = getl_forw_wrapper getl in + let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S_backw.D.join (S_backw.D.bot ()) xs + in + Some tf_backw + | Function _ -> + None + | _ -> + let tf_backw getl sidel demandl getg sideg = + let getl_backw = getl_backw_wrapper getl in + let getl_forw = getl_forw_wrapper getl in + let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg sideg in + let xs = List.map tf' (Cfg.next v) in + List.fold_left S_backw.D.join (S_backw.D.bot ()) xs + in + Some tf_backw + + (* TODO: non-problematic but weird inconsisteny between forward and backward variable types*) + let system var = + match var with + | `L_forw v -> + Forward.system v + |> Option.map (fun tf getl sidel demandl getg sideg -> + let getl' v = getl (`L_forw v) |> to_forw_d in + let sidel' v d = sidel (`L_forw v) (of_forw_d d) in + let demandl' v = demandl (`L_forw v) in + let getg' v = getg (`G_forw v) |> to_forw_g in + let sideg' v d = sideg (`G_forw v) (of_forw_g d) in + tf getl' sidel' demandl' getg' sideg' |> of_forw_d + ) + | `L_backw v -> + system_backw v + |> Option.map (fun tf getl sidel demandl getg sideg -> + (* let getl' (v : Backward.LVar.t) : (S_backw.D.t) = getl (`L_backw (forw_lv_of_backw v)) |> to_backw_d in *) + let sidel' v d = sidel (`L_backw (lv_of_backw v)) (of_backw_d d) in + let demandl' v = demandl (`L_backw (lv_of_backw v)) in + let getg' v = getg (`G_backw v) |> to_backw_g in + let sideg' v d = sideg (`G_backw v) (of_backw_g d) in + tf getl sidel' demandl' getg' sideg' |> of_backw_d + ) + + let iter_vars getl getg vq fl fg = + failwith "damn" + + let sys_change getl getg = + failwith "damn" + + let postmortem = function + | `L_forw v -> List.map (fun v -> `L_forw v) (Forward.postmortem v) + | `L_backw v -> List.map (fun v -> `L_backw (v)) (Backward.postmortem (v)) +end \ No newline at end of file diff --git a/xy_easyprog.c b/xy_easyprog.c index e3980f084c..b9d5e88e5f 100644 --- a/xy_easyprog.c +++ b/xy_easyprog.c @@ -39,10 +39,10 @@ int main() { // } int d = (*h)(a, c); - a = -100; + // a = -100; - int b = (*h)(a, c); - return b + d; + // int b = (*h)(a, c); + return d; } //git diff --cached --name-only --diff-filter=ACM | grep -E '\.(ml|mli)$' | xargs -I {} ocp-indent -i {} \ No newline at end of file From 177ed1712294d122ec13840c3fcf0a6db7284067 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Thu, 26 Feb 2026 16:21:15 +0100 Subject: [PATCH 20/29] minor fixes - cleaned up bidirConstraints - improved liveness analysis --- src/analyses/wp_test.ml | 85 +++++++++++++++++------- src/framework/bidirConstrains.ml | 110 ++++++------------------------- xy_easyprog.c | 2 +- 3 files changed, 81 insertions(+), 116 deletions(-) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index fe00e641f8..146e54d968 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -161,7 +161,7 @@ struct include BackwAnalyses.DefaultBackwSpec (ForwSpec) module C = ForwSpec.C - (* Adding those because the "include" of the DefaultBackwSpec is nor enough*) + (* Adding these module definitions because the "include" of the DefaultBackwSpec is not enough*) module D_forw = ForwSpec.D module G_forw = ForwSpec.G module V_forw = ForwSpec.V @@ -181,36 +181,35 @@ struct let rec vars_from_lval (l: lval) : varinfo list = let vars_written_to = match l with - | Var v, _ -> [v] (* variable *) - | Mem m, _ -> (D.elements (vars_from_expr m)) + | Var v, _ -> ( + if (Cil.isFunctionType v.vtype) then [] else [v] (*I do not want functions in the set of live variables*) + ) + | Mem m, _ -> vars_from_expr m in let vars_in_offset = match l with | Var _, off -> vars_from_offset off - | Mem _, off -> vars_from_offset off + | Mem _, off -> Logs.debug "(!) vars_in_offset used"; vars_from_offset off in (vars_written_to @ vars_in_offset) - and - vars_from_offset (off: offset) : varinfo list = + and vars_from_offset (off: offset) : varinfo list = match off with | NoOffset -> [] - | Field (_, off) -> vars_from_offset off + | Field (_, off) -> vars_from_offset off (* what to do with fieldinfo?*) | Index (e, off) -> - let vars_in_e = (D.elements (vars_from_expr e)) in + let vars_in_e = vars_from_expr e in let vars_in_off = vars_from_offset off in (match vars_in_off with | [] -> [] | vars_in_off -> (vars_in_e @ vars_in_off)) - and - - vars_from_expr (e: exp) : D.t= + and vars_from_expr (e: exp) : varinfo list = let rec aux acc e = match e with - | Lval (Var v, _) -> D.add v acc + | Lval v -> vars_from_lval v @ acc | BinOp (_, e1, e2, _) -> let acc1 = aux acc e1 in aux acc1 e2 @@ -224,20 +223,53 @@ struct | CastE (_, e1) -> aux acc e1 | AddrOf (l1) -> (match vars_from_lval l1 with | [] -> acc - | v -> D.join (D.of_list v) acc) - | _ -> acc + | v -> (v @ acc) + ) + (* | AddrOfLabel _ -> Logs.debug "(!) Expression of type AddrOfLabel"; acc + | StartOf l1 -> Logs.debug "(!) Expression of type StartOf"; acc + | Const _ ->Logs.debug "(!) Expression of type Const"; acc + | Real _ -> Logs.debug "(!) Expression of type Real"; acc + | Imag _ -> Logs.debug "(!) Expression of type Imag"; acc + | SizeOf _ -> Logs.debug "(!) Expression of type SizeOf"; acc + | AlignOf _ -> Logs.debug "(!) Expression of type AlignOf"; acc + | SizeOfStr _ -> Logs.debug "(!) Expression of type SizeOfStr"; acc *) + | _ -> acc + in - aux (D.empty()) e + + (* let give_exp_type e = + match e with + | Const _ -> Logs.debug "(!) Expression of type Const" + | Lval _ -> Logs.debug "(!) Expression of type Lval" + | SizeOf _ -> Logs.debug "(!) Expression of type SizeOf" + | Real _ -> Logs.debug "(!) Expression of type Real" + | Imag _ -> Logs.debug "(!) Expression of type Imag" + | SizeOfE _ -> Logs.debug "(!) Expression of type SizeOfE" + | SizeOfStr _ -> Logs.debug "(!) Expression of type SizeOfSTr" + | AlignOf _ -> Logs.debug "(!) Expression of type AlignOf" + | AlignOfE _ -> Logs.debug "(!) Expression of type AlignOfE" + | UnOp _ -> Logs.debug "(!) Expression of type UnOp" + | BinOp _ -> Logs.debug "(!) Expression of type BinOp" + | Question _ -> Logs.debug "(!) Expression of type Question" + | CastE _ -> Logs.debug "(!) Expression of type CastE" + | AddrOf _ -> Logs.debug "(!) Expression of type AddrOf" + | AddrOfLabel _ -> Logs.debug "(!) Expression of type AddrOfLabel" + | StartOf _ -> Logs.debug "(!) Expression of type StartOf" + | _ -> Logs.debug "(!) Impossible: Expression of unknown type" + in + give_exp_type e; *) + + aux [] e let assign man man_forw (lval:lval) (rval:exp) = let v = vars_from_lval lval in match v with - | [] -> D.join man.local (vars_from_expr rval) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) + | [] -> D.join man.local (D.of_list (vars_from_expr rval)) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) | v-> let l = (D.diff man.local (D.of_list v)) in - if (List.exists (fun elem -> D.mem elem man.local) v) then D.join l (vars_from_expr rval) (*if anything on the rhs is important, this is live now*) + if (List.exists (fun elem -> D.mem elem man.local) v) then D.join l (D.of_list (vars_from_expr rval)) (*if anything on the rhs is important, this is live now*) else ( let loc = M.Location.Node man.node in (match v with @@ -253,15 +285,15 @@ struct | _ -> Logs.debug "MustTermAllLoops is NOT TRUE" in *) - let branch_irrelevant : bool= ( + let branch_irrelevant : bool = ( match Queries.eval_bool (Analyses.ask_of_man man_forw) exp with | `Lifted b -> tv <> b | `Bot -> false | `Top -> false ) in - if branch_irrelevant then vars_from_expr exp - else D.join man.local (vars_from_expr exp) + if branch_irrelevant then (D.of_list (vars_from_expr exp)) + else D.join man.local (D.of_list (vars_from_expr exp)) let body man man_forw (f:fundec) = man.local @@ -269,7 +301,7 @@ struct let return man man_forw (exp:exp option) (f:fundec) = match exp with | None -> man.local - | Some e -> D.join man.local (vars_from_expr e) + | Some e -> D.join man.local (D.of_list(vars_from_expr e)) (* TODO *) let enter man man_forw (lval: lval option) (f:fundec) (args:exp list) = @@ -300,7 +332,7 @@ struct let relevant_arg_vars = List.fold_left (fun acc (arg_exp, formal_var) -> if D.mem formal_var au then - D.join acc (vars_from_expr arg_exp) + D.join acc (D.of_list(vars_from_expr arg_exp)) else acc ) (D.empty()) arg_formal_pairs @@ -315,14 +347,17 @@ struct let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in Logs.debug " args: %s" args_pretty; *) - let exp_vars = vars_from_expr fexp in + let exp_vars = D.of_list(vars_from_expr fexp) in + Logs.debug "(!) combine_assign: fexp = %s" (CilType.Exp.show fexp); + (* Type of the expression:*) + let exp_type = Cil.typeOf fexp in + Logs.debug "(!) combine_assign: type of fexp = %s" (CilType.Typ.show exp_type); Logs.debug "(!) combine_assign: exp_vars = %s" (String.concat ", " (List.map (fun v -> v.vname) (D.elements exp_vars))); let simple_assign lval exp acc = let v = vars_from_lval lval in - match v with | [] -> acc (*D.join acc (vars_from_expr exp) if I do not know what the value is assigned to, then all RHS-Variables might be relevant *) | v -> @@ -346,7 +381,7 @@ struct match exp with | None -> D.empty() | Some e -> if return_val_is_important - then D.join (D.empty()) (vars_from_expr e) + then D.of_list (vars_from_expr e) else D.empty() diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index b77e867d10..642d8bef36 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -68,7 +68,6 @@ struct | `Forw v -> `Forw (GV_forw.contexts v) | `Backw v -> `Backw (GV_backw.contexts v) - let var_id = show let arbitrary () = @@ -87,9 +86,6 @@ module BidirFromSpec (S_forw:Spec) (S_backw:BackwSpec with type D_forw.t = S_for end = struct - (* type lv = [ `lv_forw of MyCFG.node * S_forw.C.t | `lv_back of MyCFG.node * S_forw.C.t] *) - (* type ld = Lattice.Lift2(S_forw.D)(S_backw.D).t *) - module LV = VarF (S_forw.C) module LVar = struct @@ -121,82 +117,31 @@ struct end module D = Lattice.Lift2(S_forw.D)(S_backw.D) - (* module GV_forw = GVarF (S_forw.V) - module GV_backw = GVarF (S_backw.V) *) module GVar = GVarF2(S_forw.V)(S_backw.V) module G_forw = GVarG (S_forw.G) (S_forw.C) module G_backw = GVarG (S_backw.G) (S_forw.C) - module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) - - module Forward = Constraints.FromSpec (S_forw) (Cfg) (I) - (* module Backward = Constraints_wp.FromSpec (S_backw) (Cfg) *) - - (* functions for converting between forwards and backwards types*) - let getl_backw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_backw.D.t = - match getl (`L_backw v) with - | `Lifted2 d -> d - | `Bot -> S_backw.D.bot () - | `Top -> S_backw.D.top () - | `Lifted1 _ -> failwith "bidirConstrains: backward local got forward value" - - let getl_forw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_forw.D.t = - match getl (`L_forw v) with - | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" - | `Bot -> S_forw.D.bot () - | `Top -> S_forw.D.top () - | `Lifted1 d -> d - - (* let getg_backw_wrapper (getg) (v) = - match v with - | `Left v -> - | `Right v -> - - match getg (`Backw v) with - | `Lifted1 (`Lifted2 g) -> G_backw.create_spec g - | `Lifted1 (`Lifted1 g) -> failwith "bidirConstrains: backward global got forward value" - | `Lifted1 `Bot -> `Bot - | `Lifted1 `Top -> `Top *) - (* let getg_forw_wrapper (getg: GVar.t -> G.t) (v: GVar.GV_forw.t) : G_forw.t = - match getg (`G_forw v) with - | `Lifted1 (`Left g) -> G_forw.create_spec g - | _ -> failwith "bidirConstrains: backward global got forward value or non-lifted value" *) - - let lv_of_backw ((n,c)) : LV.t = (n, Obj.magic c) - - let to_l_backw (v:LVar.t) = - match v with - | `L_forw (n, l) -> `L_backw (n, l) - | `L_backw (n, l) -> `L_backw (n, l) + module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) - let cset_to_forw c = - G.CSet.fold (fun x acc -> Forward.G.CSet.add x acc) c (Forward.G.CSet.empty ()) - - let cset_of_forw c = - Forward.G.CSet.fold (fun x acc -> G.CSet.add x acc) c (G.CSet.empty ()) - - let cset_to_backw c = - G.CSet.fold (fun x acc -> G_backw.CSet.add (Obj.magic x) acc) c (G_backw.CSet.empty ()) - - let cset_of_backw c = - G_backw.CSet.fold (fun x acc -> G.CSet.add (Obj.magic x) acc) c (G.CSet.empty ()) + module Forward = Constraints.FromSpec(S_forw)(Cfg)(I) + (* Lowering functions for local values.*) let to_forw_d (d: D.t) : S_forw.D.t = match d with | `Lifted1 d -> d | `Bot -> S_forw.D.bot () | `Top -> S_forw.D.top () - | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" + | `Lifted2 _ -> failwith "bidirConstrains: forward local has backward value" let to_backw_d (d: D.t) : S_backw.D.t = match d with | `Lifted2 d -> d | `Bot -> S_backw.D.bot () | `Top -> S_backw.D.top () - | `Lifted1 _ -> failwith "bidirConstrains: backward local got forward value" + | `Lifted1 _ -> failwith "bidirConstrains: backward local has forward value" - let of_forw_d (d: S_forw.D.t) : D.t = `Lifted1 d - let of_backw_d (d: S_backw.D.t) : D.t = `Lifted2 d + (* Lowering and lifting functions to deal with different global values. This is convoluted -- but tbh, it is not that much worse than the G module in the existing forwards analysis. + * The conversion between the CSets is quite disgusting though. *) let to_forw_g (g: G.t) : Forward.G.t = match g with @@ -204,7 +149,7 @@ struct | `Lifted1 `Bot -> `Bot | `Lifted1 `Top -> `Top | `Lifted1 (`Lifted2 _) -> failwith "bidirConstrains: forward global got backward value" - | `Lifted2 c -> `Lifted2 (cset_to_forw c) + | `Lifted2 c -> `Lifted2 (G_forw.CSet.of_list (G.CSet.elements c)) | `Bot -> `Bot | `Top -> `Top @@ -214,26 +159,26 @@ struct | `Lifted1 `Bot -> `Bot | `Lifted1 `Top -> `Top | `Lifted1 (`Lifted1 _) -> failwith "bidirConstrains: backward global got forward value" - | `Lifted2 c -> `Lifted2 (cset_to_backw c) + | `Lifted2 c -> `Lifted2 (G_backw.CSet.of_list (G.CSet.elements c)) | `Bot -> `Bot | `Top -> `Top let of_forw_g (g: Forward.G.t) : G.t = match g with | `Lifted1 g -> `Lifted1 (`Lifted1 g) - | `Lifted2 c -> `Lifted2 (cset_of_forw c) + | `Lifted2 c -> `Lifted2 (G.CSet.of_list (G_forw.CSet.elements c)) | `Bot -> `Bot | `Top -> `Top let of_backw_g (g: G_backw.t) : G.t = match g with | `Lifted1 g -> `Lifted1 (`Lifted2 g) - | `Lifted2 c -> `Lifted2 (cset_of_backw c) + | `Lifted2 c -> `Lifted2 (G.CSet.of_list (G_backw.CSet.elements c)) | `Bot -> `Bot | `Top -> `Top - (* actually relevant (transfer) functions*) + (* actually relevant (transfer) functions *) let sync_backw man man_forw = match man.prev_node, Cfg.next man.prev_node with | _, _ :: _ :: _ -> (* Join in CFG. *) @@ -695,23 +640,11 @@ struct let system_backw (v,c) = match v with - | FunctionEntry _ -> - let tf_backw getl sidel demandl getg sideg = - let getl_backw = getl_backw_wrapper getl in - let getl_forw = getl_forw_wrapper getl in - let getg_backw v = getg (`Backw v) |> to_backw_g in - let getg_forw v = getg (`Forw v) |> to_forw_g in - let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg_backw getg_forw sideg in - let xs = List.map tf' (Cfg.next v) in - List.fold_left S_backw.D.join (S_backw.D.bot ()) xs - in - Some tf_backw - | Function _ -> - None + | Function _ -> None | _ -> let tf_backw getl sidel demandl getg sideg = - let getl_backw = getl_backw_wrapper getl in - let getl_forw = getl_forw_wrapper getl in + let getl_backw d = getl (`L_backw d) |> to_backw_d in + let getl_forw d = getl (`L_forw d) |> to_forw_d in let getg_backw v = getg (`Backw v) |> to_backw_g in let getg_forw v = getg (`Forw v) |> to_forw_g in let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg_backw getg_forw sideg in @@ -720,28 +653,25 @@ struct in Some tf_backw - (* TODO: non-problematic but weird inconsisteny between forward and backward variable types*) let system var = match var with | `L_forw v -> Forward.system v |> Option.map (fun tf getl sidel demandl getg sideg -> let getl' v = getl (`L_forw v) |> to_forw_d in - let sidel' v d = sidel (`L_forw v) (of_forw_d d) in + let sidel' v d = sidel (`L_forw v) (`Lifted1 d) in let demandl' v = demandl (`L_forw v) in let getg' v = getg (`Forw v) |> to_forw_g in let sideg' v d = sideg (`Forw v) (of_forw_g d) in - tf getl' sidel' demandl' getg' sideg' |> of_forw_d + tf getl' sidel' demandl' getg' sideg' |> (fun d -> `Lifted1 d) ) | `L_backw v -> system_backw v |> Option.map (fun tf getl sidel demandl getg sideg -> - (* let getl' (v : Backward.LVar.t) : (S_backw.D.t) = getl (`L_backw (forw_lv_of_backw v)) |> to_backw_d in *) - let sidel' v d = sidel (`L_backw (lv_of_backw v)) (of_backw_d d) in - let demandl' v = demandl (`L_backw (lv_of_backw v)) in - (* let getg' v = getg (`G_backw v) |> to_backw_g in *) + let sidel' v d = sidel (`L_backw v) (`Lifted2 d) in + let demandl' v = demandl (`L_backw v) in let sideg' v d = sideg (`Backw v) (of_backw_g d) in - tf getl sidel' demandl' getg sideg' |> of_backw_d + tf getl sidel' demandl' getg sideg' |> (fun d -> `Lifted2 d) ) let iter_vars getl getg vq fl fg = diff --git a/xy_easyprog.c b/xy_easyprog.c index b9d5e88e5f..34113915f7 100644 --- a/xy_easyprog.c +++ b/xy_easyprog.c @@ -37,7 +37,7 @@ int main() { // if (rand) { // h = &g; // } - int d = (*h)(a, c); + int d = f (a, c); // a = -100; From 7994fb532d18495c9c42aa09c43dff2fe85aa07e Mon Sep 17 00:00:00 2001 From: ge94riv Date: Fri, 27 Feb 2026 15:36:00 +0100 Subject: [PATCH 21/29] cleanup and added configuration option - removed files with old versions of the backwards analysis - removed old unused code from files *bidirConstrains.ml* and *control.ml* - added config option "wp_run" in *options.schema.json* and *control.ml* --- src/config/options.schema.json | 7 + src/framework/bidirConstrains.ml | 1 - src/framework/constraints_wp.ml | 451 ------------ src/framework/control.ml | 1018 ++------------------------ src/framework/oldBidirConstraints.ml | 691 ----------------- src/goblint.ml | 2 - 6 files changed, 69 insertions(+), 2101 deletions(-) delete mode 100644 src/framework/constraints_wp.ml delete mode 100644 src/framework/oldBidirConstraints.ml diff --git a/src/config/options.schema.json b/src/config/options.schema.json index 02e634d9e7..1697ecc9c9 100644 --- a/src/config/options.schema.json +++ b/src/config/options.schema.json @@ -1298,6 +1298,13 @@ } }, "additionalProperties": false + }, + "wp_run": { + "title": "ana.wp_run", + "description": + "Do a wp analysis, in this case the liveness analysis.", + "type": "boolean", + "default": false } }, "additionalProperties": false diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 642d8bef36..08fd20efe5 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -74,7 +74,6 @@ struct failwith "no arbitrary" end - module BidirFromSpec (S_forw:Spec) (S_backw:BackwSpec with type D_forw.t = S_forw.D.t and type G_forw.t = S_forw.G.t and type C.t = S_forw.C.t and type V_forw.t = S_forw.V.t) (Cfg:CfgBidir) (I:Increment) : sig module LVar : Goblint_constraint.ConstrSys.VarType with type t = [ `L_forw of VarF(S_forw.C).t | `L_backw of VarF(S_forw.C).t ] diff --git a/src/framework/constraints_wp.ml b/src/framework/constraints_wp.ml deleted file mode 100644 index f45c6131a4..0000000000 --- a/src/framework/constraints_wp.ml +++ /dev/null @@ -1,451 +0,0 @@ -(** Construction of a {{!Goblint_constraint} constraint system} from an {{!Analyses.Spec} analysis specification} and {{!MyCFG.CfgBackward} CFGs}. - Transformatons of analysis specifications as functors. *) - -open Batteries -open GoblintCil -open MyCFG -open Analyses -open Goblint_constraint.ConstrSys -open GobConfig - - -type Goblint_backtrace.mark += TfLocation of location - -let () = Goblint_backtrace.register_mark_printer (function - | TfLocation loc -> - Some ("transfer function at " ^ CilType.Location.show loc) - | _ -> None (* for other marks *) - ) - - -module type Increment = -sig - val increment: increment_data option -end - - -(** The main point of this file---generating a [DemandGlobConstrSys] from a [Spec]. *) -module FromSpec (S:Spec) (Cfg:CfgBidir) - : sig - include DemandGlobConstrSys with module LVar = VarF (S.C) - and module GVar = GVarF (S.V) - and module D = S.D - and module G = GVarG (S.G) (S.C) - end -= -struct - type lv = MyCFG.node * S.C.t - (* type gv = varinfo *) - type ld = S.D.t - (* type gd = S.G.t *) - module LVar = VarF (S.C) - module GVar = GVarF (S.V) - module D = S.D - module G = GVarG (S.G) (S.C) - - (* Two global invariants: - 1. S.V -> S.G -- used for Spec - 2. fundec -> set of S.C -- used for IterSysVars Node *) - - let sync man = - match man.prev_node, Cfg.next man.prev_node with - | _, _ :: _ :: _ -> (* Join in CFG. *) - 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 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_man var edge prev_node pval (getl:lv -> ld) sidel demandl 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 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 - ; control_context = snd var |> Obj.obj - ; context = snd var |> Obj.obj - ; edge = edge - ; local = pval - ; global = (fun g -> G.spec (getg (GVar.spec g))) - ; spawn = spawn - ; split = (fun (d:D.t) es -> assert (List.is_empty es); r := d::!r) - ; sideg = (fun g d -> sideg (GVar.spec g) (G.create_spec d)) - } - and spawn ?(multiple=false) lval f args = - (* TODO: adjust man node/edge? *) - (* TODO: don't repeat for all paths that spawn same *) - 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 man fd d in - sidel (FunctionEntry fd, c) d; - demandl (Function fd, c) - | exception Not_found -> - (* unknown function *) - M.error ~category:Imprecise ~tags:[Category Unsound] "Created a thread from unknown function %s" f.vname; - (* actual implementation (e.g. invalidation) is done by threadenter *) - (* must still sync for side effects, e.g., old sync-based none privatization soundness in 02-base/51-spawn-special *) - let rec sync_man = - { man with - ask = (fun (type a) (q: a Queries.t) -> S.query sync_man q); - local = d; - prev_node = Function dummyFunDec; - } - in - (* TODO: more accurate man? *) - ignore (sync sync_man) - ) ds - in - (* ... nice, right! *) - 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 man d spawns = - if List.is_empty spawns then - d - else - 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 fman = - { man with - ask = (fun (type a) (q: a Queries.t) -> S.query fman q) - ; local = fd - } - in - S.threadspawn man' ~multiple lval f args fman - in - bigsqcup (List.map one_spawn spawns) - - let common_join man d splits spawns = - thread_spawns man (bigsqcup (d :: 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 demandl getg sideg d = - let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 demandl getg sideg d = - let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 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 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 demandl getg sideg d = - let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 man sideg - else normal_return ret fd man sideg - in - common_join man d !r !spawns - - let tf_entry var edge prev_node fd getl sidel demandl 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 man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 demandl getg sideg d = - let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 - - (*TODO: THIS HAS TO BE BACKWARDS*) - let tf_normal_call man lv e (f:fundec) args getl sidel demandl 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; - - Logs.debug "combine: local: %a" S.D.pretty cd; - Logs.debug "combine: function: %a" S.D.pretty fd; - - let rec cd_man = - { man with - ask = (fun (type a) (q: a Queries.t) -> S.query cd_man q); - local = cd; - } - in - 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_man), simulate it here for fd. *) - (* TODO: don't do this extra sync here *) - 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*) - prev_node = FunctionEntry f; - } - in - (* 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_man - in - let r = List.fold_left (fun acc fd1 -> - 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_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_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; - Logs.debug "combined local: %a" S.D.pretty r; - r - in - let paths = - Logs.debug "manager info at call to %a" Node.pretty man.node; - S.enter man lv f args in - (* Wollen eig vorwärts-kontext benutzen *) - 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; *) - List.iter (fun (c,fc,v) -> if not (S.D.is_bot v) then sidel (Function 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; *) - (* *) - let paths = List.map (fun (c,fc,v) -> (c, fc, if S.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in - - (* Don't filter bot paths, otherwise LongjmpLifter is not called. *) - (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) - let paths = List.map (Tuple3.map2 Option.some) paths in - if M.tracing then M.traceli "combine" "combining"; - Logs.debug "combining"; - let paths = List.map combine paths in - let r = List.fold_left D.join (D.bot ()) paths in - if M.tracing then M.traceu "combine" "combined: %a" S.D.pretty r; - Logs.debug "combined: %a" S.D.pretty r; - r - - (*TODO: HERE AS WELL*) - let rec tf_proc var edge prev_node lv e args getl sidel demandl getg sideg d = - let tf_special_call man f = - let once once_control init_routine = - (* Executes leave event for new local state d if it is not bottom *) - let leave_once d = - if not (S.D.is_bot d) then - let rec man' = - { man with - ask = (fun (type a) (q: a Queries.t) -> S.query man' q); - local = d; - } - in - S.event man' (Events.LeaveOnce { once_control }) man' - else - S.D.bot () - in - let first_call = - let d' = S.event man (Events.EnterOnce { once_control; ran = false }) man in - tf_proc var edge prev_node None init_routine [] getl sidel demandl getg sideg d' - in - let later_call = S.event man (Events.EnterOnce { once_control; ran = true }) man in - D.join (leave_once first_call) (leave_once later_call) - in - let is_once = LibraryFunctions.find ~nowarn:true f in - (* If the prototpye for a library function is wrong, this will throw an exception. Such exceptions are usually unrelated to pthread_once, it is just that the call to `is_once.special` raises here *) - match is_once.special args with - | Once { once_control; init_routine } -> once once_control init_routine - | _ -> S.special man lv f args - in - let man, r, spawns = common_man var edge prev_node d getl sidel demandl getg sideg in - let functions = - match e with - | Lval (Var v, NoOffset) -> - (* Handle statically known function call directly. - Allows deactivating base. *) - [v] - | _ -> - (* Depends on base for query. *) - let ad = man.ask (Queries.EvalFunvar e) in - Queries.AD.to_var_may ad (* TODO: don't convert, handle UnknownPtr below *) - (*PROBLEM: Pointer. Brauche Ergebnisse der anderen Analysen*) - in - let one_function f = - match Cil.unrollType f.vtype with - | TFun (_, params, var_arg, _) -> - let arg_length = List.length args in - let p_length = Option.map_default List.length 0 params in - (* Check whether number of arguments fits. *) - (* If params is None, the function or its parameters are not declared, so we still analyze the unknown function call. *) - if Option.is_none params || p_length = arg_length || (var_arg && arg_length >= p_length) then - let d = - (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 man f - | fd -> - tf_normal_call man lv e fd args getl sidel demandl getg sideg - | exception Not_found -> - tf_special_call man f) - in - Some d - else begin - let geq = if var_arg then ">=" else "" in - M.warn ~category:Unsound ~tags:[Category Call; CWE 685] "Potential call to function %a with wrong number of arguments (expected: %s%d, actual: %d). This call will be ignored." CilType.Varinfo.pretty f geq p_length arg_length; - None - end - | _ -> - M.warn ~category:Call "Something that is not a function (%a) is called." CilType.Varinfo.pretty f; - None - in - let funs = List.filter_map one_function functions in - 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 man funs !r !spawns - - let tf_asm var edge prev_node getl sidel demandl getg sideg d = - let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 demandl getg sideg d = - let man, r, spawns = common_man var edge prev_node d getl sidel demandl 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 demandl getg sideg prev_node edge d = - begin match edge with - | Assign (lv,rv) -> tf_assign var edge prev_node lv rv - | VDecl (v) -> tf_vdecl var edge prev_node v - | Proc (r,f,ars) -> tf_proc var edge prev_node r f ars - | Entry f -> tf_entry var edge prev_node f - | Ret (r,fd) -> tf_ret var edge prev_node r fd - | Test (p,b) -> tf_test var edge prev_node p b - | ASM (_, _, _) -> tf_asm var edge prev_node (* TODO: use ASM fields for something? *) - | Skip -> tf_skip var edge prev_node - end getl sidel demandl getg sideg d - - let tf var getl sidel demandl getg sideg prev_node (_,edge) d (f,t) = - let old_loc = !Goblint_tracing.current_loc in - let old_loc2 = !Goblint_tracing.next_loc in - Goblint_tracing.current_loc := f; - Goblint_tracing.next_loc := t; - Goblint_backtrace.protect ~mark:(fun () -> TfLocation f) ~finally:(fun () -> - Goblint_tracing.current_loc := old_loc; - Goblint_tracing.next_loc := old_loc2 - ) (fun () -> - let d = tf var getl sidel demandl getg sideg prev_node edge d in - d - ) - - let tf (v,c) (edges, u) getl sidel demandl getg sideg = - let pval = getl (u,c) in - let _, locs = List.fold_right (fun (f,e) (t,xs) -> f, (f,t)::xs) edges (Node.location v,[]) in - List.fold_left2 (|>) pval (List.map (tf (v,Obj.repr (fun () -> c)) getl sidel demandl getg sideg u) edges) locs - - let tf (v,c) (e,u) getl sidel demandl getg sideg = - let old_node = !current_node in - let old_fd = Option.map Node.find_fundec old_node |? Cil.dummyFunDec in - let new_fd = Node.find_fundec v in - if not (CilType.Fundec.equal old_fd new_fd) then - Timing.Program.enter new_fd.svar.vname; - let old_context = !M.current_context in - current_node := Some u; - M.current_context := Some (Obj.magic c); (* magic is fine because Spec is top-level Control Spec *) - Fun.protect ~finally:(fun () -> - current_node := old_node; - M.current_context := old_context; - if not (CilType.Fundec.equal old_fd new_fd) then - Timing.Program.exit new_fd.svar.vname - ) (fun () -> - let d = tf (v,c) (e,u) getl sidel demandl getg sideg in - d - ) - - let system (v,c) = - let wrap (v,c) = - match v with - | FunctionEntry _ -> - let tf getl sidel demandl getg sideg = - let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in - let xs = List.map tf' (Cfg.next v) in - List.fold_left S.D.join (S.D.bot ()) xs - in - Some tf - | Function _ -> - None - | _ -> - let tf getl sidel demandl getg sideg = - let tf' eu = tf (v,c) eu getl sidel demandl getg sideg in - let xs = List.map tf' (Cfg.next v) in - List.fold_left S.D.join (S.D.bot ()) xs - in - - Some tf - - in - - (* Logs.debug "# Creating transfer function for %s" (Node.show v); - Logs.debug " Number of nexts: %d" (List.length (Cfg.next v)) ; - Logs.debug " Number of prevs: %d" (List.length (Cfg.prev v)) ; *) - wrap (v,c) - - - (* what does this do? *) - let iter_vars getl getg vq fl fg = - failwith "iter_vars not implemented in WP" - - - let sys_change getl getg = - failwith "sys_change not implemented in WP" - - (*What does this do?*) - let postmortem = function - | FunctionEntry fd, c -> [(Function fd, c)] - | _ -> [] -end diff --git a/src/framework/control.ml b/src/framework/control.ml index 0802092193..dad2229509 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -17,839 +17,53 @@ open BidirConstrains module type S2S = Spec2Spec -(** Module that takes a Spec and a Context Domain type C and returns a Spec using this context instead. This is purely for type-signature reasons. - * The context-related functions in the returned (backwards-)Spec should not be used.*) -module ContextOverride (S: Spec) (S_forw: Spec) : Spec with module C = S_forw.C = -struct - module D = S.D - module G = S.G - module C = S_forw.C - module V = S.V - module P = S.P - - let name = S.name - - type marshal = S.marshal - let init = S.init - let finalize = S.finalize - - let startstate = S.startstate - let morphstate = S.morphstate - let exitstate = S.exitstate - - let coerce_man (man: (D.t, G.t, C.t, V.t) man) : (D.t, G.t, S.C.t, V.t) man = - Obj.magic man - - let context man fd d = - (* let man_forw = S_forw.context man fd d in *) - Obj.magic (S.context (coerce_man man) fd d) - let startcontext () = Obj.magic (S.startcontext ()) - - let sync man k = S.sync (coerce_man man) k - let query man q = S.query (coerce_man man) q - - let assign man lv e = S.assign (coerce_man man) lv e - let vdecl man v = S.vdecl (coerce_man man) v - let branch man e b = S.branch (coerce_man man) e b - let body man fd = S.body (coerce_man man) fd - let return man r fd = S.return (coerce_man man) r fd - let asm man = S.asm (coerce_man man) - let skip man = S.skip (coerce_man man) - let special man lv f args = S.special (coerce_man man) lv f args - let enter man lv f args = S.enter (coerce_man man) lv f args - let event man ev man2 = S.event (coerce_man man) ev (coerce_man man2) - - let combine_env man lv e f args c d ask = - S.combine_env (coerce_man man) lv e f args (Obj.magic c) d ask - let combine_assign man lv e f args c d ask = - S.combine_assign (coerce_man man) lv e f args (Obj.magic c) d ask - - let paths_as_set man = S.paths_as_set (coerce_man man) - let threadenter man ~multiple lv f args = S.threadenter (coerce_man man) ~multiple lv f args - let threadspawn man ~multiple lv f args fman = - S.threadspawn (coerce_man man) ~multiple lv f args (coerce_man fman) -end - - -(* spec is lazy, so HConsed table in Hashcons lifters is preserved between analyses in server mode *) -let spec_module: (module Spec) Lazy.t = lazy ( - GobConfig.building_spec := true; - let arg_enabled = get_bool "exp.arg.enabled" in - let termination_enabled = List.mem "termination" (get_string_list "ana.activated") in (* check if loop termination analysis is enabled*) - (* apply functor F on module X if opt is true *) - let lift opt (module F : S2S) (module X : Spec) = (module (val if opt then (module F (X)) else (module X) : Spec) : Spec) in - let module S1 = - (val - (module MCP.MCP2 : Spec) - |> lift (get_int "ana.context.gas_value" >= 0) (ContextGasLifter.get_gas_lifter ()) - |> lift true (module WidenContextLifterSide) (* option checked in functor *) - |> lift (get_int "ana.widen.delay.local" > 0) (module WideningDelay.DLifter) - (* hashcons before witness to reduce duplicates, because witness re-uses contexts in domain and requires tag for PathSensitive3 *) - |> lift (get_bool "ana.opt.hashcons" || arg_enabled) (module HashconsContextLifter) - |> lift (get_bool "ana.opt.hashcached") (module HashCachedContextLifter) - |> lift arg_enabled (module HashconsLifter) - |> lift arg_enabled (module ArgConstraints.PathSensitive3) - |> lift (not arg_enabled) (module PathSensitive2) - |> lift (get_bool "ana.dead-code.branches") (module DeadBranchLifter) - |> lift true (module DeadCodeLifter) - |> lift (get_bool "dbg.slice.on") (module LevelSliceLifter) - |> lift (get_bool "ana.opt.equal" && not (get_bool "ana.opt.hashcons")) (module OptEqual) - |> lift (get_bool "ana.opt.hashcons") (module HashconsLifter) - (* Widening tokens must be outside of hashcons, because widening token domain ignores token sets for identity, so hashcons doesn't allow adding tokens. - Also must be outside of deadcode, because deadcode splits (like mutex lock event) don't pass on tokens. *) - |> lift (get_bool "ana.widen.tokens") (module WideningTokenLifter.Lifter) - |> lift true (module LongjmpLifter.Lifter) - |> lift termination_enabled (module RecursionTermLifter.Lifter) (* Always activate the recursion termination analysis, when the loop termination analysis is activated*) - |> lift (get_int "ana.widen.delay.global" > 0) (module WideningDelay.GLifter) - ) - in - GobConfig.building_spec := false; - ControlSpecC.control_spec_c := (module S1.C); - (module S1) -) - -(** gets Spec for current options *) -let get_spec (): (module Spec) = - Lazy.force spec_module - -let current_node_state_json : (Node.t -> Yojson.Safe.t option) ref = ref (fun _ -> None) - -let current_varquery_global_state_json: (Goblint_constraint.VarQuery.t option -> Yojson.Safe.t) ref = ref (fun _ -> `Null) - -(** Given a [Cfg], a [Spec], and an [Inc], computes the solution to [MCP.Path] *) -module AnalyzeCFG (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = -struct - - module SpecSys: SpecSys with module Spec = Spec = - struct - (* Must be created in module, because cannot be wrapped in a module later. *) - module Spec = Spec - - (* The Equation system *) - module EQSys = FromSpec (Spec) (Cfg) (Inc) - - (* Hashtbl for locals *) - module LHT = BatHashtbl.Make (EQSys.LVar) - (* Hashtbl for globals *) - module GHT = BatHashtbl.Make (EQSys.GVar) - end - - open SpecSys - - (* The solver *) - module PostSolverArg = - struct - let should_prune = true - let should_verify = get_bool "verify" - let should_warn = get_string "warn_at" <> "never" - let should_save_run = - (* copied from solve_and_postprocess *) - let gobview = get_bool "gobview" in - let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in - save_run <> "" - end - module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) - (* The comparator *) - module CompareGlobSys = CompareConstraints.CompareGlobSys (SpecSys) - - (* Triple of the function, context, and the local value. *) - module RT = AnalysisResult.ResultType2 (Spec) - (* Set of triples [RT] *) - module LT = SetDomain.HeadlessSet (RT) - (* Analysis result structure---a hashtable from program points to [LT] *) - module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis" end) - module ResultOutput = AnalysisResultOutput.Make (Result) - - module Query = ResultQuery.Query (SpecSys) - - (* print out information about dead code *) - let print_dead_code (xs:Result.t) uncalled_fn_loc = - let module NH = Hashtbl.Make (Node) in - let live_nodes : unit NH.t = NH.create 10 in - let count = ref 0 in (* Is only populated if "ana.dead-code.lines" or "ana.dead-code.branches" is true *) - let module StringMap = BatMap.Make (String) in - let live_lines = ref StringMap.empty in - let dead_lines = ref StringMap.empty in - let module FunSet = Hashtbl.Make (CilType.Fundec) in - let live_funs: unit FunSet.t = FunSet.create 13 in - let add_one n v = - match n with - | Statement s when Cilfacade.(StmtH.mem pseudo_return_to_fun s) -> - (* Exclude pseudo returns from dead lines counting. No user code at "}". *) - () - | _ -> - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let l = UpdateCil.getLoc n in - let f = Node.find_fundec n in - FunSet.replace live_funs f (); - let add_fun = BatISet.add l.line in - let add_file = StringMap.modify_def BatISet.empty f.svar.vname add_fun in - let is_dead = LT.for_all (fun (_,x,f) -> Spec.D.is_bot x) v in - if is_dead then ( - dead_lines := StringMap.modify_def StringMap.empty l.file add_file !dead_lines - ) else ( - live_lines := StringMap.modify_def StringMap.empty l.file add_file !live_lines; - NH.add live_nodes n () - ); - in - Result.iter add_one xs; - let live_count = StringMap.fold (fun _ file_lines acc -> - StringMap.fold (fun _ fun_lines acc -> - acc + ISet.cardinal fun_lines - ) file_lines acc - ) !live_lines 0 - in - let live file fn = - try StringMap.find fn (StringMap.find file !live_lines) - with Not_found -> BatISet.empty - in - if List.mem "termination" @@ get_string_list "ana.activated" then ( - (* check if we have upjumping gotos *) - let open Cilfacade in - let warn_for_upjumps fundec gotos = - if FunSet.mem live_funs fundec then ( - (* set nortermiantion flag *) - AnalysisState.svcomp_may_not_terminate := true; - (* iterate through locations to produce warnings *) - LocSet.iter (fun l _ -> - M.warn ~loc:(M.Location.CilLocation l) ~category:Termination "The program might not terminate! (Upjumping Goto)" - ) gotos - ) - in - FunLocH.iter warn_for_upjumps funs_with_upjumping_gotos - ); - dead_lines := StringMap.mapi (fun fi -> StringMap.mapi (fun fu ded -> BatISet.diff ded (live fi fu))) !dead_lines; - dead_lines := StringMap.map (StringMap.filter (fun _ x -> not (BatISet.is_empty x))) !dead_lines; - dead_lines := StringMap.filter (fun _ x -> not (StringMap.is_empty x)) !dead_lines; - let warn_func file f xs = - let warn_range b e = - count := !count + (e - b + 1); (* for total count below *) - let doc = - if b = e then - Pretty.dprintf "on line %d" b - else - Pretty.dprintf "on lines %d..%d" b e - in - let loc: Cil.location = { - file; - line = b; - column = -1; (* not shown *) - byte = 0; (* wrong, but not shown *) - endLine = e; - endColumn = -1; (* not shown *) - endByte = 0; (* wrong, but not shown *) - synthetic = false; - } - in - (doc, Some (Messages.Location.CilLocation loc)) (* CilLocation is fine because always printed from scratch *) - in - let msgs = - BatISet.fold_range (fun b e acc -> - warn_range b e :: acc - ) xs [] - in - let msgs = List.rev msgs in (* lines in ascending order *) - M.msg_group Warning ~category:Deadcode "Function '%s' has dead code" f msgs (* TODO: function location for group *) - in - let warn_file f = StringMap.iter (warn_func f) in - if get_bool "ana.dead-code.lines" then ( - StringMap.iter warn_file !dead_lines; (* populates count by side-effect *) - let severity: M.Severity.t = if StringMap.is_empty !dead_lines then Info else Warning in - let dead_total = !count + uncalled_fn_loc in - let total = live_count + dead_total in (* We can only give total LoC if we counted dead code *) - M.msg_group severity ~category:Deadcode "Logical lines of code (LLoC) summary" [ - (Pretty.dprintf "live: %d" live_count, None); - (Pretty.dprintf "dead: %d%s" dead_total (if uncalled_fn_loc > 0 then Printf.sprintf " (%d in uncalled functions)" uncalled_fn_loc else ""), None); - (Pretty.dprintf "total lines: %d" total, None); - ] - ); - NH.mem live_nodes - - (* convert result that can be out-put *) - let solver2source_result h : Result.t = - (* processed result *) - let res = Result.create 113 in - - (* Adding the state at each system variable to the final result *) - let add_local_var (n,es) state = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let loc = UpdateCil.getLoc n in - if loc <> locUnknown then try - let fundec = Node.find_fundec n in - if Result.mem res n then - (* If this source location has been added before, we look it up - * and add another node to it information to it. *) - let prev = Result.find res n in - Result.replace res n (LT.add (es,state,fundec) prev) - else - Result.add res n (LT.singleton (es,state,fundec)) - (* If the function is not defined, and yet has been included to the - * analysis result, we generate a warning. *) - with Not_found -> - Messages.debug ~category:Analyzer ~loc:(CilLocation loc) "Calculated state for undefined function: unexpected node %a" Node.pretty_trace n - in - LHT.iter add_local_var h; - res - - (** The main function to preform the selected analyses. *) - let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = - let module FileCfg: FileCfg = - struct - let file = file - module Cfg = Cfg - end - in - - AnalysisState.should_warn := false; (* reset for server mode *) - - (* exctract global xml from result *) - let make_global_fast_xml f g = - let open Printf in - let print_globals k v = - fprintf f "\n%s%a" (XmlUtil.escape (EQSys.GVar.show k)) EQSys.G.printXml v; - in - GHT.iter print_globals g - in - - (* add extern variables to local state *) - 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 - | _ -> s - in - let vars = foldGlobals file add_glob VS.empty in - let set_bad v st = - Spec.assign {man with local = st} (var v) MyCFG.unknown_exp - in - let is_std = function - | {vname = ("__tzname" | "__daylight" | "__timezone"); _} (* unix time.h *) - | {vname = ("tzname" | "daylight" | "timezone"); _} (* unix time.h *) - | {vname = "getdate_err"; _} (* unix time.h, but somehow always in MacOS even without include *) - | {vname = ("stdin" | "stdout" | "stderr"); _} (* standard stdio.h *) - | {vname = ("optarg" | "optind" | "opterr" | "optopt" ); _} (* unix unistd.h *) - | {vname = ("__environ"); _} -> (* Linux Standard Base Core Specification *) - true - | _ -> false - in - let add_externs s = function - | GVarDecl (v,_) when not (VS.mem v vars || isFunctionType v.vtype) && not (get_bool "exp.hide-std-globals" && is_std v) -> set_bad v s - | _ -> s - in - foldGlobals file add_externs (Spec.startstate MyCFG.dummy_func.svar) - in - - (* Simulate globals before analysis. *) - (* TODO: make extern/global inits part of constraint system so all of this would be unnecessary. *) - let gh = GHT.create 13 in - let getg v = GHT.find_default gh v (EQSys.G.bot ()) in - let sideg v d = - if M.tracing then M.trace "global_inits" "sideg %a = %a" EQSys.GVar.pretty v EQSys.G.pretty d; - GHT.replace gh v (EQSys.G.join (getg v) d) - in - (* Old-style global function for context. - * This indirectly prevents global initializers from depending on each others' global side effects, which would require proper solving. *) - let getg v = EQSys.G.bot () in - - (* analyze cil's global-inits function to get a starting state *) - let do_global_inits (file: file) : Spec.D.t * fundec list = - 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 () -> 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))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") - ; split = (fun _ -> failwith "Global initializers trying to split paths.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let edges = CfgTools.getGlobalInits file in - Logs.debug "Executing %d assigns." (List.length edges); - let funs = ref [] in - (*let count = ref 0 in*) - let transfer_func (st : Spec.D.t) (loc, edge) : Spec.D.t = - if M.tracing then M.trace "con" "Initializer %a" CilType.Location.pretty loc; - (*incr count; - if (get_bool "dbg.verbose")&& (!count mod 1000 = 0) then Printf.printf "%d %!" !count; *) - match edge with - | MyCFG.Entry func -> - if M.tracing then M.trace "global_inits" "Entry %a" d_lval (var func.svar); - 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 - | (Var v,o), (AddrOf (Var f,NoOffset)) - when v.vstorage <> Static && isFunctionType f.vtype -> - (try funs := Cilfacade.find_varinfo_fundec f :: !funs with Not_found -> ()) - | _ -> () - end; - 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 {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 transfer_func st (loc, edge) = - let old_loc = !Goblint_tracing.current_loc in - Goblint_tracing.current_loc := loc; - (* TODO: next_loc? *) - Goblint_backtrace.protect ~mark:(fun () -> Constraints.TfLocation loc) ~finally:(fun () -> - Goblint_tracing.current_loc := old_loc; - ) (fun () -> - transfer_func st (loc, edge) - ) - 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 result : Spec.D.t = List.fold_left transfer_func with_externs edges in - if M.tracing then M.trace "global_inits" "startstate: %a" Spec.D.pretty result; - result, !funs - in - - let print_globals glob = - let out = M.get_out (Spec.name ()) !M.out in - let print_one v st = - ignore (Pretty.fprintf out "%a -> %a\n" EQSys.GVar.pretty_trace v EQSys.G.pretty st) - in - GHT.iter print_one glob - in - - (* real beginning of the [analyze] function *) - if get_bool "ana.sv-comp.enabled" then - Witness.init (module FileCfg); (* TODO: move this out of analyze_loop *) - YamlWitness.init (); - - AnalysisState.global_initialization := true; - GobConfig.earlyglobs := get_bool "exp.earlyglobs"; - let marshal: Spec.marshal option = - if get_string "load_run" <> "" then - Some (Serialize.unmarshal Fpath.(v (get_string "load_run") / "spec_marshal")) - else if Serialize.results_exist () && get_bool "incremental.load" then - Some (Serialize.Cache.(get_data AnalysisData)) - else - None - in - - (* Some happen in init, so enable this temporarily (if required by option). *) - AnalysisState.should_warn := PostSolverArg.should_warn; - Spec.init marshal; - Access.init file; - AnalysisState.should_warn := false; - - let test_domain (module D: Lattice.S): unit = - let module DP = DomainProperties.All (D) in - Logs.debug "domain testing...: %s" (D.name ()); - let errcode = QCheck_base_runner.run_tests DP.tests in - if (errcode <> 0) then - failwith "domain tests failed" - in - let _ = - if (get_bool "dbg.test.domain") then ( - Logs.debug "domain testing analysis...: %s" (Spec.name ()); - test_domain (module Spec.D); - test_domain (module Spec.G); - ) - in - - let startstate, more_funs = - Logs.debug "Initializing %d globals." (CfgTools.numGlobals file); - Timing.wrap "global_inits" do_global_inits file - in - - let otherfuns = if get_bool "kernel" then otherfuns @ more_funs else otherfuns in - - let enter_with st fd = - let st = st fd.svar in - 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec.startcontext - ; edge = MyCFG.Skip - ; local = st - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let args = List.map (fun x -> MyCFG.unknown_exp) fd.sformals in - let ents = Spec.enter man None fd args in - List.map (fun (_,s) -> fd, s) ents - in - - (try MyCFG.dummy_func.svar.vdecl <- (List.hd otherfuns).svar.vdecl with Failure _ -> ()); - - let startvars = - if startfuns = [] - then [[MyCFG.dummy_func, startstate]] - else - let morph f = Spec.morphstate f startstate in - List.map (enter_with morph) startfuns - in - - let exitvars = List.map (enter_with Spec.exitstate) exitfuns in - let otherstate st v = - 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 () -> 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))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - (* TODO: don't hd *) - 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 *) - let othervars = List.map (enter_with (otherstate prestartstate)) otherfuns in - let startvars = List.concat (startvars @ exitvars @ othervars) in - if startvars = [] then - failwith "BUG: Empty set of start variables; may happen if enter_func of any analysis returns an empty list."; - - AnalysisState.global_initialization := false; - - 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 () -> man_failwith "enter_with has no control_context.") - ; context = Spec.startcontext - ; edge = MyCFG.Skip - ; local = e - ; global = (fun g -> EQSys.G.spec (getg (EQSys.GVar.spec g))) - ; spawn = (fun ?(multiple=false) _ -> failwith "Bug1: Using enter_func for toplevel functions with 'otherstate'.") - ; split = (fun _ -> failwith "Bug2: Using enter_func for toplevel functions with 'otherstate'.") - ; sideg = (fun g d -> sideg (EQSys.GVar.spec g) (EQSys.G.create_spec d)) - } - in - let startvars' = - if get_bool "exp.forward" then - 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 (man e) n 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 - - let solve_and_postprocess () = - let lh, gh = - let solver_data = - match Inc.increment with - | Some {solver_data; server; _} -> - if server then - Some (Slvr.copy_marshal solver_data) (* Copy, so that we can abort and reuse old data unmodified. *) - else if GobConfig.get_bool "ana.opt.hashcons" then - Some (Slvr.relift_marshal solver_data) - else - Some solver_data - | None -> None - in - Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); - AnalysisState.should_warn := get_string "warn_at" = "early"; - - let log_analysis_inputs () = - Logs.debug "=== Analysis Inputs ==="; - - (* Log entrystates *) - Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); - List.iteri (fun i ((node, ctx), state) -> - Logs.debug "EntryState %d:" (i + 1); - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec.C.pretty ctx; - Logs.debug " State: %a" Spec.D.pretty state; - ) entrystates; - - (* Log entrystates_global *) - Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); - List.iteri (fun i (gvar, gstate) -> - Logs.debug "GlobalEntryState %d:" (i + 1); - Logs.debug " GVar: %a" EQSys.GVar.pretty gvar; - Logs.debug " GState: %a" EQSys.G.pretty gstate; - ) entrystates_global; - - (* Log startvars' *) - Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); - List.iteri (fun i (node, ctx) -> - Logs.debug "StartVar %d:" (i + 1); - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec.C.pretty ctx; - ) startvars'; - - (* Log startvars (without apostrophe) *) - Logs.debug "--- Start Variables (no apostrophe) (count: %d) ---" (List.length startvars); - List.iteri (fun i (node, state) -> - Logs.debug "StartVar (no apostrophe) %d:" (i + 1); - Logs.debug " Node: %a" CilType.Fundec.pretty node; - Logs.debug " State: (of type EQSys.D.t) %a" Spec.D.pretty state; - ) startvars; - - Logs.debug "=== End Analysis Inputs ===" - in - log_analysis_inputs (); - - - let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in - if GobConfig.get_bool "incremental.save" then - Serialize.Cache.(update_data SolverData solver_data); - lh, gh - - in - - (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) - AnalysisState.should_warn := PostSolverArg.should_warn; - - let insrt k _ s = match k with - | (MyCFG.Function fn,_) -> if not (get_bool "exp.forward") then Set.Int.add fn.svar.vid s else s - | (MyCFG.FunctionEntry fn,_) -> if (get_bool "exp.forward") then Set.Int.add fn.svar.vid s else s - | _ -> s - in - (* set of ids of called functions *) - let calledFuns = LHT.fold insrt lh Set.Int.empty in - let is_bad_uncalled fn loc = - not (Set.Int.mem fn.vid calledFuns) && - not (Str.last_chars loc.file 2 = ".h") && - not (LibraryFunctions.is_safe_uncalled fn.vname) && - not (Cil.hasAttribute "goblint_stub" fn.vattr) - in - - let print_and_calculate_uncalled = function - | GFun (fn, loc) when is_bad_uncalled fn.svar loc-> - let cnt = Cilfacade.countLoc fn in - uncalled_dead := !uncalled_dead + cnt; - if get_bool "ana.dead-code.functions" then - M.warn ~loc:(CilLocation loc) ~category:Deadcode "Function '%a' is uncalled: %d LLoC" CilType.Fundec.pretty fn cnt (* CilLocation is fine because always printed from scratch *) - | _ -> () - in - List.iter print_and_calculate_uncalled file.globals; - - (* check for dead code at the last state: *) - let main_sol = try LHT.find lh (List.hd startvars') with Not_found -> Spec.D.bot () in - if Spec.D.is_bot main_sol then - M.warn_noloc ~category:Deadcode "Function 'main' does not return"; - - if get_bool "dump_globs" then - print_globals gh; - - (* run activated transformations with the analysis result *) - let active_transformations = get_string_list "trans.activated" in - if active_transformations <> [] then ( - - (* Most transformations use the locations of statements, since they run using Cil visitors. - Join abstract values once per location and once per node. *) - let joined_by_loc, joined_by_node = - let open Enum in - let node_values = LHT.enum lh |> map (Tuple2.map1 fst) in (* drop context from key *) (* nosemgrep: batenum-enum *) - let hashtbl_size = if fast_count node_values then count node_values else 123 in - let by_loc, by_node = Hashtbl.create hashtbl_size, NodeH.create hashtbl_size in - iter (fun (node, v) -> - let loc = match node with - | Statement s -> Cil.get_stmtLoc s.skind (* nosemgrep: cilfacade *) (* Must use CIL's because syntactic search is in CIL. *) - | FunctionEntry _ | Function _ -> Node.location node - in - (* join values once for the same location and once for the same node *) - let join = Option.some % function None -> v | Some v' -> Spec.D.join v v' in - Hashtbl.modify_opt loc join by_loc; - NodeH.modify_opt node join by_node; - ) node_values; - by_loc, by_node - in - - let ask ?(node = MyCFG.dummy_node) loc = - let f (type a) (q : a Queries.t) : a = - match Hashtbl.find_option joined_by_loc loc with - | None -> Queries.Result.bot q - | Some local -> Query.ask_local_node gh node local q - in - ({ f } : Queries.ask) - in - - (* A node is dead when its abstract value is bottom in all contexts; - it holds that: bottom in all contexts iff. bottom in the join of all contexts. - Therefore, we just answer whether the (stored) join is bottom. *) - let must_be_dead node = - NodeH.find_option joined_by_node node - (* nodes that didn't make it into the result are definitely dead (hence for_all) *) - |> GobOption.for_all Spec.D.is_bot - in - - let must_be_uncalled fd = not @@ BatSet.Int.mem fd.svar.vid calledFuns in - - let skipped_statements from_node edge to_node = - try - Cfg.skippedByEdge from_node edge to_node - with Not_found -> - [] - in - - Transform.run_transformations file active_transformations - { ask ; must_be_dead ; must_be_uncalled ; - cfg_forward = Cfg.next ; cfg_backward = Cfg.prev ; skipped_statements }; - ); - - lh, gh - in - - (* Use "normal" constraint solving *) - let timeout_reached () = - M.error "Timeout reached!"; - (* let module S = Generic.SolverStats (EQSys) (LHT) in *) - (* Can't call Generic.SolverStats...print_stats :( - print_stats is triggered by dbg.solver-signal, so we send that signal to ourself in maingoblint before re-raising Timeout. - The alternative would be to catch the below Timeout, print_stats and re-raise in each solver (or include it in some functor above them). *) - raise Timeout.Timeout - in - let timeout = get_string "dbg.timeout" |> TimeUtil.seconds_of_duration_string in - let lh, gh = Timeout.wrap solve_and_postprocess () (float_of_int timeout) timeout_reached in - let module SpecSysSol: SpecSysSol with module SpecSys = SpecSys = - struct - module SpecSys = SpecSys - let lh = lh - let gh = gh - end - in - let module R: ResultQuery.SpecSysSol2 with module SpecSys = SpecSys = ResultQuery.Make (FileCfg) (SpecSysSol) in - - let local_xml = solver2source_result lh in - current_node_state_json := (fun node -> Option.map LT.to_yojson (Result.find_option local_xml node)); - - current_varquery_global_state_json := (fun vq_opt -> - let iter_vars f = match vq_opt with - | None -> GHT.iter (fun v _ -> f v) gh - | Some vq -> - EQSys.iter_vars - (fun x -> try LHT.find lh x with Not_found -> EQSys.D.bot ()) - (fun x -> try GHT.find gh x with Not_found -> EQSys.G.bot ()) - vq - (fun _ -> ()) - f - in - (* TODO: optimize this once server has a way to properly convert vid -> varinfo *) - let vars = GHT.create 113 in - iter_vars (fun x -> - GHT.replace vars x () - ); - let assoc = GHT.fold (fun x g acc -> - if GHT.mem vars x then - (EQSys.GVar.show x, EQSys.G.to_yojson g) :: acc - else - acc - ) gh [] - in - `Assoc assoc - ); - - let liveness = - if get_bool "ana.dead-code.lines" || get_bool "ana.dead-code.branches" then - print_dead_code local_xml !uncalled_dead - else - fun _ -> true (* TODO: warn about conflicting options *) - in - - if get_bool "exp.cfgdot" then - CfgTools.dead_code_cfg ~path:(Fpath.v "cfgs") (module FileCfg) liveness; - - let warn_global g v = - (* Logs.debug "warn_global %a %a" EQSys.GVar.pretty_trace g EQSys.G.pretty v; *) - match g with - | `Left g -> (* Spec global *) - R.ask_global (WarnGlobal (Obj.repr g)) - | `Right _ -> (* contexts global *) - () - in - Timing.wrap "warn_global" (GHT.iter warn_global) gh; - - if get_bool "exp.arg.enabled" then ( - let module ArgTool = ArgTools.Make (R) in - let module Arg = (val ArgTool.create entrystates) in - let arg_dot_path = get_string "exp.arg.dot.path" in - if arg_dot_path <> "" then ( - let module NoLabelNodeStyle = - struct - type node = Arg.Node.t - let extra_node_styles node = - match GobConfig.get_string "exp.arg.dot.node-label" with - | "node" -> [] - | "empty" -> ["label=\"_\""] (* can't have empty string because graph-easy will default to node ID then... *) - | _ -> assert false - end - in - let module ArgDot = ArgTools.Dot (Arg) (NoLabelNodeStyle) in - Out_channel.with_open_text arg_dot_path (fun oc -> - let ppf = Stdlib.Format.formatter_of_out_channel oc in - ArgDot.dot ppf; - Format.pp_print_flush ppf () - ) - ); - ArgTools.current_arg := Some (module Arg); - ); - - (* Before SV-COMP, so result can depend on YAML witness validation. *) - let yaml_validate_result = - if get_string "witness.yaml.validate" <> "" then ( - let module YWitness = YamlWitness.Validator (R) in - Some (YWitness.validate ()) - ) - else - None - in - - let svcomp_result = - if get_bool "ana.sv-comp.enabled" then ( - (* SV-COMP and witness generation *) - let module WResult = Witness.Result (R) in - Some (WResult.write yaml_validate_result entrystates) - ) - else - None - in +(* spec is lazy, so HConsed table in Hashcons lifters is preserved between analyses in server mode *) +let spec_module: (module Spec) Lazy.t = lazy ( + GobConfig.building_spec := true; + let arg_enabled = get_bool "exp.arg.enabled" in + let termination_enabled = List.mem "termination" (get_string_list "ana.activated") in (* check if loop termination analysis is enabled*) + (* apply functor F on module X if opt is true *) + let lift opt (module F : S2S) (module X : Spec) = (module (val if opt then (module F (X)) else (module X) : Spec) : Spec) in + let module S1 = + (val + (module MCP.MCP2 : Spec) + |> lift (get_int "ana.context.gas_value" >= 0) (ContextGasLifter.get_gas_lifter ()) + |> lift true (module WidenContextLifterSide) (* option checked in functor *) + |> lift (get_int "ana.widen.delay.local" > 0) (module WideningDelay.DLifter) + (* hashcons before witness to reduce duplicates, because witness re-uses contexts in domain and requires tag for PathSensitive3 *) + |> lift (get_bool "ana.opt.hashcons" || arg_enabled) (module HashconsContextLifter) + |> lift (get_bool "ana.opt.hashcached") (module HashCachedContextLifter) + |> lift arg_enabled (module HashconsLifter) + |> lift arg_enabled (module ArgConstraints.PathSensitive3) + |> lift (not arg_enabled) (module PathSensitive2) + |> lift (get_bool "ana.dead-code.branches") (module DeadBranchLifter) + |> lift true (module DeadCodeLifter) + |> lift (get_bool "dbg.slice.on") (module LevelSliceLifter) + |> lift (get_bool "ana.opt.equal" && not (get_bool "ana.opt.hashcons")) (module OptEqual) + |> lift (get_bool "ana.opt.hashcons") (module HashconsLifter) + (* Widening tokens must be outside of hashcons, because widening token domain ignores token sets for identity, so hashcons doesn't allow adding tokens. + Also must be outside of deadcode, because deadcode splits (like mutex lock event) don't pass on tokens. *) + |> lift (get_bool "ana.widen.tokens") (module WideningTokenLifter.Lifter) + |> lift true (module LongjmpLifter.Lifter) + |> lift termination_enabled (module RecursionTermLifter.Lifter) (* Always activate the recursion termination analysis, when the loop termination analysis is activated*) + |> lift (get_int "ana.widen.delay.global" > 0) (module WideningDelay.GLifter) + ) + in + GobConfig.building_spec := false; + ControlSpecC.control_spec_c := (module S1.C); + (module S1) +) - if get_bool "witness.yaml.enabled" then ( - let module YWitness = YamlWitness.Make (R) in - YWitness.write ~svcomp_result - ); +(** gets Spec for current options *) +let get_spec (): (module Spec) = + Lazy.force spec_module - let marshal = Spec.finalize () in - (* copied from solve_and_postprocess *) - let gobview = get_bool "gobview" in - let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in - if save_run <> "" then ( - Serialize.marshal marshal Fpath.(v save_run / "spec_marshal") - ); - if get_bool "incremental.save" then ( - Serialize.Cache.(update_data AnalysisData marshal); - if not (get_bool "server.enabled") then - Serialize.Cache.store_data () - ); - if get_string "result" <> "none" then Logs.debug "Generating output: %s" (get_string "result"); +let current_node_state_json : (Node.t -> Yojson.Safe.t option) ref = ref (fun _ -> None) - Messages.finalize (); - Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg) -end +let current_varquery_global_state_json: (Goblint_constraint.VarQuery.t option -> Yojson.Safe.t) ref = ref (fun _ -> `Null) -module AnalyzeCFG_backw (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = +(** Given a [Cfg], a [Spec], and an [Inc], computes the solution to [MCP.Path] *) +module AnalyzeCFG (Cfg:CfgBidirSkip) (Spec:Spec) (Inc:Increment) = struct module SpecSys: SpecSys with module Spec = Spec = @@ -858,7 +72,7 @@ struct module Spec = Spec (* The Equation system *) - module EQSys = Constraints_wp.FromSpec (Spec) (Cfg) + module EQSys = FromSpec (Spec) (Cfg) (Inc) (* Hashtbl for locals *) module LHT = BatHashtbl.Make (EQSys.LVar) @@ -872,7 +86,7 @@ struct module PostSolverArg = struct let should_prune = true - let should_verify = true (*get_bool "verify"*) + let should_verify = get_bool "verify" let should_warn = get_string "warn_at" <> "never" let should_save_run = (* copied from solve_and_postprocess *) @@ -889,7 +103,7 @@ struct (* Set of triples [RT] *) module LT = SetDomain.HeadlessSet (RT) (* Analysis result structure---a hashtable from program points to [LT] *) - module Result = AnalysisResult.Result (LT) (struct let result_name = "wp_analysis" end) + module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis" end) module ResultOutput = AnalysisResultOutput.Make (Result) module Query = ResultQuery.Query (SpecSys) @@ -1025,7 +239,7 @@ struct LHT.iter add_local_var h; res - (** [analyze file startfuns exitfuns otherfuns] is the main function to preform the selected analyses.*) + (** The main function to preform the selected analyses. *) let analyze (file: file) (startfuns, exitfuns, otherfuns: Analyses.fundecs) = let module FileCfg: FileCfg = struct @@ -1034,18 +248,6 @@ struct end in - let () = - let log_fun_list name funs = - let fun_names = List.map (fun f -> f.svar.vname) funs in - Logs.debug "%s functions: %s" name (String.concat ", " fun_names) - in - Logs.debug "================= Analysis Setup ================"; - log_fun_list "Start" startfuns; - log_fun_list "Exit" exitfuns; - log_fun_list "Other" otherfuns; - Logs.debug "================================================"; - in - AnalysisState.should_warn := false; (* reset for server mode *) (* exctract global xml from result *) @@ -1287,22 +489,19 @@ struct } in let startvars' = - (* if get_bool "exp.forward" then *) - if true then (*does this deside which variables I query?*) + if get_bool "exp.forward" then 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 (man e) n e)) startvars in - (* let entrystates = List.clearmap (fun (n,e) -> (MyCFG.FunctionEntry n, Spec.context (man e) n e), e) startvars in *) - let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec.context (man 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 let solve_and_postprocess () = let lh, gh = - (*Solver data??*) let solver_data = match Inc.increment with | Some {solver_data; server; _} -> @@ -1312,15 +511,11 @@ struct Some (Slvr.relift_marshal solver_data) else Some solver_data - | None -> None + | None -> None in Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); + AnalysisState.should_warn := get_string "warn_at" = "early"; - - (*######################### START OF ACTUAL SOLVING ##########################*) - - (*### START OF LOG ###*) - (*print set of entrystates, entrystatex_global and startvars'*) let log_analysis_inputs () = Logs.debug "=== Analysis Inputs ==="; @@ -1360,16 +555,13 @@ struct Logs.debug "=== End Analysis Inputs ===" in log_analysis_inputs (); - (*### END OF LOG ###*) - AnalysisState.should_warn := get_string "warn_at" = "early"; + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in if GobConfig.get_bool "incremental.save" then Serialize.Cache.(update_data SolverData solver_data); lh, gh - (*######################### END OF ACTUAL SOLVING ##########################*) - in (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) @@ -1477,7 +669,6 @@ struct in let timeout = get_string "dbg.timeout" |> TimeUtil.seconds_of_duration_string in let lh, gh = Timeout.wrap solve_and_postprocess () (float_of_int timeout) timeout_reached in - let module SpecSysSol: SpecSysSol with module SpecSys = SpecSys = struct module SpecSys = SpecSys @@ -1601,89 +792,7 @@ struct if get_string "result" <> "none" then Logs.debug "Generating output: %s" (get_string "result"); Messages.finalize (); - (* Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg); *) - - (*Iterating through elements of lh and Logging the contents*) - let log_lh_contents lh = - Messages.warn "=== LHT Contents ==="; let count = ref 0 in - - Logs.debug "--- Full entry details ---"; - LHT.iter (fun (node, ctx) state -> - incr count; - Logs.debug "Entry %d:" !count; - Logs.debug " Node: %a" Node.pretty_trace node; - - (* Test context pretty printing *) - (try - Logs.debug " Context: %a" Spec.C.pretty ctx - with e -> - Logs.debug " Context: ERROR - %s" (Printexc.to_string e) - ); - - (* Check state properties *) - (* Logs.debug " State is_top: %b" (Spec.D.is_top state); - Logs.debug " State is_bot: %b" (Spec.D.is_bot state); *) - - (* Test state pretty printing with exception handling *) - (try - Logs.debug " State: %a" Spec.D.pretty state - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - ) lh; - Logs.debug "Total entries in LHT: %d" !count; - Logs.debug "=== End LHT Contents ===" - in - log_lh_contents lh; - - (*Script adding these results to the already existing node xml files*) - let output_wp_results_to_xml lh = - (* iterate through all nodes and update corresponding .xml in result/nodes *) - LHT.iter (fun (node, ctx) state -> - try - (* Get node ID as string *) - (* let node_id_str = match node with - | MyCFG.Statement stmt -> string_of_int stmt.sid - | MyCFG.FunctionEntry fundec -> string_of_int fundec.svar.vid - | _ -> raise Not_found (* Skip non-statement nodes *) - in *) - let node_id_str = Node.show_id node in - - let xml_path = Filename.concat "./result/nodes" (node_id_str ^ ".xml") in - if Sys.file_exists xml_path then ( - (* Read existing XML *) - let ic = Stdlib.open_in xml_path in - let content = Stdlib.really_input_string ic (Stdlib.in_channel_length ic) in - Stdlib.close_in ic; - - (* Create WP analysis data *) - let wp_res = Pretty.sprint 100 (Spec.D.pretty () state) in - let wp_data = - "\n\n\n\n" ^ wp_res ^" \n\n\n\n\n" - in - - (* Insert before *) - let close_pattern = "" in - let updated_content = - try - let insert_pos = Str.search_backward (Str.regexp_string close_pattern) content (String.length content) in - let before = String.sub content 0 insert_pos in - let after = String.sub content insert_pos (String.length content - insert_pos) in - before ^ wp_data ^ after - with Not_found -> - content ^ wp_data - in - - (* Write back *) - let oc = Stdlib.open_out xml_path in - Stdlib.output_string oc updated_content; - Stdlib.close_out oc; - Logs.debug "Updated XML file for node %s" node_id_str - ) - with _ -> () (* Skip errors silently *) - ) lh - in - output_wp_results_to_xml lh; + Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg) end (** Given a [Cfg], a [Spec_forw], [Spec_back], and an unused [Inc], computes the solution] *) @@ -2460,21 +1569,18 @@ end cannot swap the functor parameter from inside [AnalyzeCFG]. *) let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = try - let (module Spec) = get_spec () in - let module A = AnalyzeCFG (CFG) (Spec) (struct let increment = change_info end) in - let module DummyWPSPec = Wp_test.Spec in - (* let module B = AnalyzeCFG_backw (CFG) (DummyWPSPec) (struct let increment = change_info end) in *) + let (module Spec) = get_spec () in - let module DummyWPSPec = ContextOverride (DummyWPSPec) (Spec) in - let module LivenesSpec = Wp_test.BackwSpec in - let module C = AnalyzeCFG_bidir (CFG) (Spec) (LivenesSpec) (struct let increment = change_info end) in + if (GobConfig.get_bool "ana.wp_run") then ( + let module LivenesSpec = Wp_test.BackwSpec in + let module A = AnalyzeCFG_bidir (CFG) (Spec) (LivenesSpec) (struct let increment = change_info end) in + GobConfig.with_immutable_conf (fun () -> A.analyze file fs) + ) else ( + let module A = AnalyzeCFG (CFG) (Spec) (struct let increment = change_info end) in + GobConfig.with_immutable_conf (fun () -> A.analyze file fs) + ) - GobConfig.with_immutable_conf (fun () -> - (* A.analyze file fs; - B.analyze file fs; *) - C.analyze file fs - ) with Refinement.RestartAnalysis -> (* Tail-recursively restart the analysis again, when requested. All solving starts from scratch. diff --git a/src/framework/oldBidirConstraints.ml b/src/framework/oldBidirConstraints.ml deleted file mode 100644 index 357e68696d..0000000000 --- a/src/framework/oldBidirConstraints.ml +++ /dev/null @@ -1,691 +0,0 @@ -open Batteries -open GoblintCil -open MyCFG -open Analyses -open Goblint_constraint.ConstrSys -open GobConfig - -module type Increment = -sig - val increment: increment_data option -end - -module GVarF2 (V_forw: SpecSysVar) (V_backw : SpecSysVar) : -sig - include VarType with type t = [ `G_forw of GVarF(V_forw).t | `G_backw of GVarF(V_backw).t ] - include SpecSysVar with type t := t -end -= -struct - module GV_forw = GVarF (V_forw) - module GV_backw = GVarF (V_backw) - type t = [ `G_forw of GV_forw.t | `G_backw of GV_backw.t ] [@@deriving eq, ord, hash] - let name () = "BidirFromSpec" - - let tag _ = failwith "Std: no tag" - - let relift = function - | `G_forw x -> `G_forw (GV_forw.relift x) - | `G_backw x -> `G_backw (GV_backw.relift x) - - let pretty_trace () = function - | `G_forw a -> GoblintCil.Pretty.dprintf "G_forw:%a" GV_forw.pretty_trace a - | `G_backw a -> GoblintCil.Pretty.dprintf "G_backw:%a" GV_backw.pretty_trace a - - let printXml f = function - | `G_forw a -> GV_forw.printXml f a - | `G_backw a -> GV_backw.printXml f a - - let node = function - | `G_forw a -> GV_forw.node a - | `G_backw a -> GV_backw.node a - - let is_write_only = function - | `G_forw a -> GV_forw.is_write_only a - | `G_backw a -> GV_backw.is_write_only a - - let show = function - | `G_forw a -> GV_forw.show a - | `G_backw a -> GV_backw.show a - - let pretty () = function - | `G_forw a -> GV_forw.pretty () a - | `G_backw a -> GV_backw.pretty () a - let to_yojson = function - | `G_forw a -> GV_forw.to_yojson a - | `G_backw a -> GV_backw.to_yojson a - - let spec = function - | `G_forw a -> GV_forw.spec a - | `G_backw a -> GV_backw.spec a - - let contexts = function - | `G_forw a -> GV_forw.contexts a - | `G_backw a -> GV_backw.contexts a - - let var_id = show - - let arbitrary () = - failwith "no arbitrary" -end - - -module BidirFromSpec (S_forw:Spec) (S_backw:Spec with type C.t = S_forw.C.t ) (Cfg:CfgBidir) (I:Increment) - : sig - module LVar : Goblint_constraint.ConstrSys.VarType with type t = [ `L_forw of VarF(S_forw.C).t | `L_backw of VarF(S_forw.C).t ] - module GVar : (module type of GVarF2(S_forw.V)(S_backw.V)) - include DemandGlobConstrSys with module LVar := LVar - and module GVar := GVar - and module D = Lattice.Lift2(S_forw.D)(S_backw.D) - and module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) - end -= -struct - (* type lv = [ `lv_forw of MyCFG.node * S_forw.C.t | `lv_back of MyCFG.node * S_forw.C.t] *) - (* type ld = Lattice.Lift2(S_forw.D)(S_backw.D).t *) - - module LV = VarF (S_forw.C) - module LVar = - struct - type t = [ `L_forw of LV.t | `L_backw of LV.t ] [@@deriving eq, ord, hash] - - let relift = function - | `L_forw x -> `L_forw (LV.relift x) - | `L_backw x -> `L_backw (LV.relift x) - - let pretty_trace () = function - | `L_forw a -> GoblintCil.Pretty.dprintf "L_forw:%a" LV.pretty_trace a - | `L_backw a -> GoblintCil.Pretty.dprintf "L_backw:%a" LV.pretty_trace a - - let printXml f = function - | `L_forw a -> LV.printXml f a - | `L_backw a -> LV.printXml f a - - let var_id = function - | `L_forw a -> LV.var_id a - | `L_backw a -> LV.var_id a - - let node = function - | `L_forw a -> LV.node a - | `L_backw a -> LV.node a - - let is_write_only = function - | `L_forw a -> LV.is_write_only a - | `L_backw a -> LV.is_write_only a - end - - module D = Lattice.Lift2(S_forw.D)(S_backw.D) - module GV_forw = GVarF (S_forw.V) - module GV_backw = GVarF (S_backw.V) - module GVar = GVarF2(S_forw.V)(S_backw.V) - - module G_forw = GVarG (S_forw.G) (S_forw.C) - module G_backw = GVarG (S_backw.G) (S_forw.C) - module G = GVarG (Lattice.Lift2(S_forw.G)(S_backw.G)) (S_forw.C) - - module Forward = Constraints.FromSpec (S_forw) (Cfg) (I) - module Backward = Constraints_wp.FromSpec (S_backw) (Cfg) - - (* functions for converting between forwards and backwards types*) - let getl_backw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_backw.D.t = - match getl (`L_backw v) with - | `Lifted2 d -> d - | `Bot -> S_backw.D.bot () - | `Top -> S_backw.D.top () - | `Lifted1 _ -> failwith "bidirConstrains: backward local got forward value" - - let getl_forw_wrapper (getl: LVar.t -> D.t) (v: node * S_forw.C.t) : S_forw.D.t = - match getl (`L_forw v) with - | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" - | `Bot -> S_forw.D.bot () - | `Top -> S_forw.D.top () - | `Lifted1 d -> d - - let lv_of_backw ((n,c): Backward.LVar.t) : LV.t = (n, Obj.magic c) - - let to_l_backw (v:LVar.t) = - match v with - | `L_forw (n, l) -> `L_backw (n, l) - | `L_backw (n, l) -> `L_backw (n, l) - - let cset_to_forw c = - G.CSet.fold (fun x acc -> Forward.G.CSet.add x acc) c (Forward.G.CSet.empty ()) - - let cset_of_forw c = - Forward.G.CSet.fold (fun x acc -> G.CSet.add x acc) c (G.CSet.empty ()) - - let cset_to_backw c = - G.CSet.fold (fun x acc -> G_backw.CSet.add (Obj.magic x) acc) c (G_backw.CSet.empty ()) - - let cset_of_backw c = - G_backw.CSet.fold (fun x acc -> G.CSet.add (Obj.magic x) acc) c (G.CSet.empty ()) - - let to_forw_d (d: D.t) : S_forw.D.t = - match d with - | `Lifted1 d -> d - | `Bot -> S_forw.D.bot () - | `Top -> S_forw.D.top () - | `Lifted2 _ -> failwith "bidirConstrains: forward local got backward value" - - let to_backw_d (d: D.t) : S_backw.D.t = - match d with - | `Lifted2 d -> d - | `Bot -> S_backw.D.bot () - | `Top -> S_backw.D.top () - | `Lifted1 _ -> failwith "bidirConstrains: backward local got forward value" - - let of_forw_d (d: S_forw.D.t) : D.t = `Lifted1 d - let of_backw_d (d: S_backw.D.t) : D.t = `Lifted2 d - - let to_forw_g (g: G.t) : Forward.G.t = - match g with - | `Lifted1 (`Lifted1 g) -> `Lifted1 g - | `Lifted1 `Bot -> `Bot - | `Lifted1 `Top -> `Top - | `Lifted1 (`Lifted2 _) -> failwith "bidirConstrains: forward global got backward value" - | `Lifted2 c -> `Lifted2 (cset_to_forw c) - | `Bot -> `Bot - | `Top -> `Top - - let to_backw_g (g: G.t) : G_backw.t = - match g with - | `Lifted1 (`Lifted2 g) -> `Lifted1 g - | `Lifted1 `Bot -> `Bot - | `Lifted1 `Top -> `Top - | `Lifted1 (`Lifted1 _) -> failwith "bidirConstrains: backward global got forward value" - | `Lifted2 c -> `Lifted2 (cset_to_backw c) - | `Bot -> `Bot - | `Top -> `Top - - let of_forw_g (g: Forward.G.t) : G.t = - match g with - | `Lifted1 g -> `Lifted1 (`Lifted1 g) - | `Lifted2 c -> `Lifted2 (cset_of_forw c) - | `Bot -> `Bot - | `Top -> `Top - - let of_backw_g (g: G_backw.t) : G.t = - match g with - | `Lifted1 g -> `Lifted1 (`Lifted2 g) - | `Lifted2 c -> `Lifted2 (cset_of_backw c) - | `Bot -> `Bot - | `Top -> `Top - - - (* actually relevant (transfer) functions*) - let sync_backw man = - match man.prev_node, Cfg.next man.prev_node with - | _, _ :: _ :: _ -> (* Join in CFG. *) - S_backw.sync man `Join - | FunctionEntry f, _ -> (* Function entry, also needs sync because partial contexts joined by solver, see 00-sanity/35-join-contexts. *) - S_backw.sync man (`JoinCall f) - | _, _ -> S_backw.sync man `Normal - - let side_context_backw sideg f c = - if !AnalysisState.postsolving then - sideg (GV_backw.contexts f) (G_backw.create_contexts (G_backw.CSet.singleton c)) - - let common_man_backw var edge prev_node pval getl sidel demandl getg sideg : (S_backw.D.t, S_backw.G.t, S_backw.C.t, S_backw.V.t) man * S_backw.D.t list ref * (lval option * varinfo * exp list * S_backw.D.t * bool) list ref = - let r = ref [] in - let spawns = ref [] in - (* now watch this ... *) - let rec man = - { ask = (fun (type a) (q: a Queries.t) -> S_backw.query man q) - ; emit = (fun _ -> failwith "emit outside MCP") - ; node = fst var - ; prev_node = prev_node - ; control_context = snd var |> Obj.obj - ; context = snd var |> Obj.obj - ; edge = edge - ; local = pval - ; global = (fun g -> G_backw.spec (getg (GV_backw.spec g))) - ; spawn = spawn - ; split = (fun (d:S_backw.D.t) es -> assert (List.is_empty es); r := d::!r) - ; sideg = (fun g d -> sideg (GV_backw.spec g) (G_backw.create_spec d)) - } - and spawn ?(multiple=false) lval f args = - (* TODO: adjust man node/edge? *) - (* TODO: don't repeat for all paths that spawn same *) - - (* TODO: This needs to be changed for backwards!! Context is created using S_backw.context*) - let ds = S_backw.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_backw.context man fd d in - sidel (FunctionEntry fd, c) d; - demandl (Function fd, c) - | exception Not_found -> - (* unknown function *) - M.error ~category:Imprecise ~tags:[Category Unsound] "Created a thread from unknown function %s" f.vname; - (* actual implementation (e.g. invalidation) is done by threadenter *) - (* must still sync for side effects, e.g., old sync-based none privatization soundness in 02-base/51-spawn-special *) - let rec sync_man = - { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man q); - local = d; - prev_node = Function dummyFunDec; - } - in - (* TODO: more accurate man? *) - ignore (sync_backw sync_man) - ) ds - in - (* ... nice, right! *) - let pval = sync_backw man in - { man with local = pval }, r, spawns - - let rec bigsqcup_backw = function - | [] -> S_backw.D.bot () - | [x] -> x - | x::xs -> S_backw.D.join x (bigsqcup_backw xs) - - let thread_spawns_backws man d spawns = - if List.is_empty spawns then - d - else - let rec man' = - { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' q) - ; local = d - } - in - (* TODO: don't forget path dependencies *) - let one_spawn (lval, f, args, fd, multiple) = - let rec fman = - { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query fman q) - ; local = fd - } - in - S_backw.threadspawn man' ~multiple lval f args fman - in - bigsqcup_backw (List.map one_spawn spawns) - - let common_join_backw man d splits spawns = - thread_spawns_backws man (bigsqcup_backw (d :: splits)) spawns - - let common_joins_backw man ds splits spawns = common_join_backw man (bigsqcup_backw ds) splits spawns - - let tf_assign_backw var edge prev_node lv e getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.assign man lv e in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns - - let tf_vdecl_backw var edge prev_node v getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.vdecl man v in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns - - let normal_return_backw r fd man sideg = - let spawning_return = S_backw.return man r fd in - let nval = S_backw.sync { man with local = spawning_return } `Return in - nval - - let toplevel_kernel_return_backw r fd man sideg = - let st = if fd.svar.vname = MyCFG.dummy_func.svar.vname then man.local else S_backw.return man r fd in - let spawning_return = S_backw.return {man with local = st} None MyCFG.dummy_func in - let nval = S_backw.sync { man with local = spawning_return } `Return in - nval - - let tf_ret_backw var edge prev_node ret fd getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl 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_backw ret fd man sideg - else normal_return_backw ret fd man sideg - in - common_join_backw man d !r !spawns - - let tf_entry_backw var edge prev_node fd getl getl_forw sidel demandl 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_forw.C.t = snd var |> Obj.obj in - side_context_backw sideg fd (c ()); - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.body man fd in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns - - let tf_test_backw var edge prev_node e tv getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.branch man e tv in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns - - (*TODO: THIS HAS TO BE BACKWARDS*) (*forward context not implemented yet*) - let tf_normal_call_backw man lv e (f:fundec) args getl getl_forw sidel demandl getg sideg = - let combine (cd, fc, fd) = - if M.tracing then M.traceli "combine" "local: %a" S_backw.D.pretty cd; - if M.tracing then M.trace "combine" "function: %a" S_backw.D.pretty fd; - - (* Logs.debug "combine: local: %a" S_backw.D.pretty cd; - Logs.debug "combine: function: %a" S_backw.D.pretty fd; *) - - let rec cd_man = - { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query cd_man q); - local = cd; - } - in - 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_man), simulate it here for fd. *) - (* TODO: don't do this extra sync here *) - let rec sync_man = - { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query sync_man q); - local = fd; - (*prev_node = Function f*) - prev_node = FunctionEntry f; - } - in - (* TODO: more accurate man? *) - let synced = sync_backw sync_man in - let rec fd_man = - { sync_man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd_man q); - local = synced; - } - in - fd_man - in - let r = List.fold_left (fun acc fd1 -> - let rec fd1_man = - { fd_man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query fd1_man q); - local = fd1; - } - in - let combine_enved = S_backw.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_backw.query combine_assign_man q); - local = combine_enved; - } - in - S_backw.D.join acc (S_backw.combine_assign combine_assign_man lv e f args fc fd1_man.local (Analyses.ask_of_man fd1_man)) - ) (S_backw.D.bot ()) (S_backw.paths_as_set fd_man) - in - if M.tracing then M.traceu "combine" "combined local: %a" S_backw.D.pretty r; - (* Logs.debug "combined local: %a" S_backw.D.pretty r; *) - r - in - let paths = - Logs.debug "manager info at call to %a" Node.pretty man.node; - S_backw.enter man lv f args in - (* Wollen eig vorwärts-kontext benutzen *) - (* getl_forw should query the corresopoding unknown from the forward analysis *) - (* context = S_forw.context (S_forw.enter (getl_forw [this_node_, this_context])) *) - - let r = ref [] in - let rec man_forw = - { ask = (fun (type a) (q: a Queries.t) -> failwith "manager for calculating context does not support queries") - ; emit = (fun _ -> failwith "emit outside MCP") - ; node = man.node - ; prev_node = man.prev_node (* this is problematic, as this is backwards *) - ; control_context = man.control_context - ; context = man.context - ; edge = man.edge - ; local = (getl_forw (man.node, man.context ())) - ; global = (fun _ -> failwith "manager for calculating context does not have globals") - ; spawn = (fun ?multiple _ _ _ -> failwith "manager for calculating context does not support spawn") - ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) - ; sideg = (fun _ _ -> failwith "manager for calculating context does not support sideg") - } in - - let paths_forw = - Logs.debug "forward manager info at call to %a" Node.pretty man_forw.node; - S_forw.enter man_forw lv f args in - - let paths = List.combine paths paths_forw in - - (* filter paths were the forward analysis found out they are unreachable*) - let paths = List.filter (fun ((c,v),(_,b)) -> not (S_forw.D.is_bot b)) paths in - - - (* this list now uses forward contexts*) - let paths = List.map (fun ((c,v),(_,b)) -> (c, S_forw.context man_forw f b, v)) paths in - (* List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; *) - - List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (Function f, fc) v) paths; - (* let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (Function f, fc))) paths; *) - (* *) - let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in - - (* Don't filter bot paths, otherwise LongjmpLifter is not called. *) - (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) - let paths = List.map (Tuple3.map2 Option.some) paths in - if M.tracing then M.traceli "combine" "combining"; - (* Logs.debug "combining"; *) - let paths = List.map combine paths in - let r = List.fold_left S_backw.D.join (S_backw.D.bot ()) paths in - if M.tracing then M.traceu "combine" "combined: %a" S_backw.D.pretty r; - (* Logs.debug "combined: %a" S_backw.D.pretty r; *) - r - - (*TODO: HERE AS WELL*) - let rec tf_proc_backw var edge prev_node lv e args getl getl_forw sidel demandl getg sideg d = - let tf_special_call man f = - let once once_control init_routine = - (* Executes leave event for new local state d if it is not bottom *) - let leave_once d = - if not (S_backw.D.is_bot d) then - let rec man' = - { man with - ask = (fun (type a) (q: a Queries.t) -> S_backw.query man' q); - local = d; - } - in - S_backw.event man' (Events.LeaveOnce { once_control }) man' - else - S_backw.D.bot () - in - let first_call = - let d' = S_backw.event man (Events.EnterOnce { once_control; ran = false }) man in - tf_proc_backw var edge prev_node None init_routine [] getl getl_forw sidel demandl getg sideg d' - in - let later_call = S_backw.event man (Events.EnterOnce { once_control; ran = true }) man in - S_backw.D.join (leave_once first_call) (leave_once later_call) - in - let is_once = LibraryFunctions.find ~nowarn:true f in - (* If the prototpye for a library function is wrong, this will throw an exception. Such exceptions are usually unrelated to pthread_once, it is just that the call to `is_once.special` raises here *) - match is_once.special args with - | Once { once_control; init_routine } -> once once_control init_routine - | _ -> S_backw.special man lv f args - in - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let functions = - match e with - | Lval (Var v, NoOffset) -> - (* Handle statically known function call directly. - Allows deactivating base. *) - [v] - | _ -> - (*constructing fake forwards manager s.t. the inforamtion for the pointer information can be retireved*) - let r = ref [] in - let rec man_forw = - { ask = (fun (type a) (q: a Queries.t) -> S_forw.query man_forw q) - ; emit = (fun _ -> failwith "emit outside MCP") - ; node = man.node - ; prev_node = man.prev_node (* this is problematic, as this is backwards *) - ; control_context = man.control_context - ; context = man.context - ; edge = man.edge - ; local = (getl_forw (man.node, man.context ())) (* accessing forward inforkation*) - ; global = (fun _ -> failwith "whoops, query for resolving function pointer depends on globals") - ; spawn = (fun ?multiple _ _ _ -> failwith "manager for resolving function pointer does not support spawn") - ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) (*what is this?*) - ; sideg = (fun _ _ -> failwith "manager for resolving function pointer does not support sideg") - } in - let () = Logs.debug "manager info at call to function pointer %a" Node.pretty man_forw.node in - (* Depends on base for query. *) - let ad = man_forw.ask (Queries.EvalFunvar e) in - let res = Queries.AD.to_var_may ad in (* TODO: don't convert, handle UnknownPtr below *) - (*PROBLEM: Pointer. Brauche Ergebnisse der anderen Analysen*) - (Logs.debug "(!) resolved function pointer to %d functions" (List.length res); - (match res with - | x::xs -> - List.iter (fun vi -> Logs.debug " possible function: %s" vi.vname) res; - | _ -> (); - )); - res - in - let one_function f = - match Cil.unrollType f.vtype with - | TFun (_, params, var_arg, _) -> - let arg_length = List.length args in - let p_length = Option.map_default List.length 0 params in - (* Check whether number of arguments fits. *) - (* If params is None, the function or its parameters are not declared, so we still analyze the unknown function call. *) - if Option.is_none params || p_length = arg_length || (var_arg && arg_length >= p_length) then - let d = - (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 man f - | fd -> - tf_normal_call_backw man lv e fd args getl getl_forw sidel demandl getg sideg - | exception Not_found -> - tf_special_call man f) - in - Some d - else begin - let geq = if var_arg then ">=" else "" in - M.warn ~category:Unsound ~tags:[Category Call; CWE 685] "Potential call to function %a with wrong number of arguments (expected: %s%d, actual: %d). This call will be ignored." CilType.Varinfo.pretty f geq p_length arg_length; - None - end - | _ -> - M.warn ~category:Call "Something that is not a function (%a) is called." CilType.Varinfo.pretty f; - None - in - let funs = List.filter_map one_function functions in - if [] = funs && not (S_backw.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_backw man funs !r !spawns - - let tf_asm_backw var edge prev_node getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.asm man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns - - let tf_skip_backw var edge prev_node getl getl_forw sidel demandl getg sideg d = - let man, r, spawns = common_man_backw var edge prev_node d getl sidel demandl getg sideg in - let d = S_backw.skip man in (* Force transfer function to be evaluated before dereferencing in common_join argument. *) - common_join_backw man d !r !spawns - - let tf_backw var getl getl_forw sidel demandl getg sideg prev_node edge d = - begin match edge with - | Assign (lv,rv) -> tf_assign_backw var edge prev_node lv rv - | VDecl (v) -> tf_vdecl_backw var edge prev_node v - | Proc (r,f,ars) -> tf_proc_backw var edge prev_node r f ars - | Entry f -> tf_entry_backw var edge prev_node f - | Ret (r,fd) -> tf_ret_backw var edge prev_node r fd - | Test (p,b) -> tf_test_backw var edge prev_node p b - | ASM (_, _, _) -> tf_asm_backw var edge prev_node (* TODO: use ASM fields for something? *) - | Skip -> tf_skip_backw var edge prev_node - end getl getl_forw sidel demandl getg sideg d - - (* TODO: Don't call it prev_node when it is actually the next node. *) - let tf_backw var getl getl_forw sidel demandl getg sideg prev_node (_,edge) d (f,t) = - (* let old_loc = !Goblint_tracing.current_loc in - let old_loc2 = !Goblint_tracing.next_loc in - Goblint_tracing.current_loc := f; - Goblint_tracing.next_loc := t; - Goblint_backtrace.protect ~mark:(fun () -> TfLocation f) ~finally:(fun () -> - Goblint_tracing.current_loc := old_loc; - Goblint_tracing.next_loc := old_loc2 - ) (fun () -> - let d = tf_backw var getl sidel demandl getg sideg prev_node edge d in - d - ) *) - tf_backw var getl getl_forw sidel demandl getg sideg prev_node edge d - - let tf_backw (v,c) (edges, u) getl getl_forw sidel demandl getg sideg = - let pval = getl (u,c) in - let _, locs = List.fold_right (fun (f,e) (t,xs) -> f, (f,t)::xs) edges (Node.location v,[]) in - List.fold_left2 (|>) pval (List.map (tf_backw (v,Obj.repr (fun () -> c)) getl getl_forw sidel demandl getg sideg u) edges) locs - - let tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg sideg = - let old_node = !current_node in - let old_fd = Option.map Node.find_fundec old_node |? Cil.dummyFunDec in - let new_fd = Node.find_fundec v in - if not (CilType.Fundec.equal old_fd new_fd) then - Timing.Program.enter new_fd.svar.vname; - let old_context = !M.current_context in - current_node := Some u; - M.current_context := Some (Obj.magic c); (* magic is fine because Spec is top-level Control Spec *) - Fun.protect ~finally:(fun () -> - current_node := old_node; - M.current_context := old_context; - if not (CilType.Fundec.equal old_fd new_fd) then - Timing.Program.exit new_fd.svar.vname - ) (fun () -> - let d = tf_backw (v,c) (e,u) getl getl_forw sidel demandl getg sideg in - d - ) - - let system_backw (v,c) = - - match v with - | FunctionEntry _ -> - let tf_backw getl sidel demandl getg sideg = - let getl_backw = getl_backw_wrapper getl in - let getl_forw = getl_forw_wrapper getl in - let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg sideg in - let xs = List.map tf' (Cfg.next v) in - List.fold_left S_backw.D.join (S_backw.D.bot ()) xs - in - Some tf_backw - | Function _ -> - None - | _ -> - let tf_backw getl sidel demandl getg sideg = - let getl_backw = getl_backw_wrapper getl in - let getl_forw = getl_forw_wrapper getl in - let tf' eu = tf_backw (v,c) eu getl_backw getl_forw sidel demandl getg sideg in - let xs = List.map tf' (Cfg.next v) in - List.fold_left S_backw.D.join (S_backw.D.bot ()) xs - in - Some tf_backw - - (* TODO: non-problematic but weird inconsisteny between forward and backward variable types*) - let system var = - match var with - | `L_forw v -> - Forward.system v - |> Option.map (fun tf getl sidel demandl getg sideg -> - let getl' v = getl (`L_forw v) |> to_forw_d in - let sidel' v d = sidel (`L_forw v) (of_forw_d d) in - let demandl' v = demandl (`L_forw v) in - let getg' v = getg (`G_forw v) |> to_forw_g in - let sideg' v d = sideg (`G_forw v) (of_forw_g d) in - tf getl' sidel' demandl' getg' sideg' |> of_forw_d - ) - | `L_backw v -> - system_backw v - |> Option.map (fun tf getl sidel demandl getg sideg -> - (* let getl' (v : Backward.LVar.t) : (S_backw.D.t) = getl (`L_backw (forw_lv_of_backw v)) |> to_backw_d in *) - let sidel' v d = sidel (`L_backw (lv_of_backw v)) (of_backw_d d) in - let demandl' v = demandl (`L_backw (lv_of_backw v)) in - let getg' v = getg (`G_backw v) |> to_backw_g in - let sideg' v d = sideg (`G_backw v) (of_backw_g d) in - tf getl sidel' demandl' getg' sideg' |> of_backw_d - ) - - let iter_vars getl getg vq fl fg = - failwith "damn" - - let sys_change getl getg = - failwith "damn" - - let postmortem = function - | `L_forw v -> List.map (fun v -> `L_forw v) (Forward.postmortem v) - | `L_backw v -> List.map (fun v -> `L_backw (v)) (Backward.postmortem (v)) -end \ No newline at end of file diff --git a/src/goblint.ml b/src/goblint.ml index 2e8095310b..0eb9a315bd 100644 --- a/src/goblint.ml +++ b/src/goblint.ml @@ -61,8 +61,6 @@ let main () = if get_string "ana.specification" <> "" then AutoSoundConfig.enableAnalysesForSpecification (); if get_bool "ana.autotune.enabled" then AutoTune.chooseConfig file; file |> do_analyze changeInfo; - (*TODO: BACKWARDS ANALYSIS *) - do_gobview file; do_stats (); Goblint_timing.teardown_tef (); From 25845daeb6e0a9077885392cec159d5999fad754 Mon Sep 17 00:00:00 2001 From: ge94riv Date: Fri, 27 Feb 2026 16:48:51 +0100 Subject: [PATCH 22/29] Added tests and improved _wp_test.ml_ --- src/analyses/wp_test.ml | 39 ++++++++----------- .../99-tutorials/05-basic_liveness.c | 17 ++++++++ .../99-tutorials/06-forward_branch_info.c | 14 +++++++ .../99-tutorials/07-basic_function_call.c | 21 ++++++++++ .../08-function_pointer_resolve.c | 23 +++++++++++ .../09-ambigious_function_pointer.c | 39 +++++++++++++++++++ xy_easyprog.c | 2 +- 7 files changed, 131 insertions(+), 24 deletions(-) create mode 100644 tests/regression/99-tutorials/05-basic_liveness.c create mode 100644 tests/regression/99-tutorials/06-forward_branch_info.c create mode 100644 tests/regression/99-tutorials/07-basic_function_call.c create mode 100644 tests/regression/99-tutorials/08-function_pointer_resolve.c create mode 100644 tests/regression/99-tutorials/09-ambigious_function_pointer.c diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_test.ml index 146e54d968..f1d7008240 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_test.ml @@ -262,9 +262,11 @@ struct aux [] e + let assign man man_forw (lval:lval) (rval:exp) = let v = vars_from_lval lval in + (* This is wrong. If the variabes describe a memory location, they should instead all be added to the set of live variables!*) match v with | [] -> D.join man.local (D.of_list (vars_from_expr rval)) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) | v-> @@ -315,7 +317,7 @@ struct in - [man.local, vars] + [man.local, man.local] (* TODO *) let combine_env man man_forw (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = @@ -342,40 +344,31 @@ struct D.join man.local relevant_arg_vars let combine_assign man man_forw (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - (* Logs.debug "=== combine_assign of function %s ===" f.svar.vname; - (*how do I know which args are important? i.e. how do I match the local name of the variable in the function with the passed parameters (if there are several)*) - let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in - Logs.debug " args: %s" args_pretty; *) - + (* SHOULD JUST USE THE SIMPLE ASSIGN I ALREADY IMPLEMENT *) let exp_vars = D.of_list(vars_from_expr fexp) in - + (* Logs.debug "(!) combine_assign: fexp = %s" (CilType.Exp.show fexp); (* Type of the expression:*) let exp_type = Cil.typeOf fexp in Logs.debug "(!) combine_assign: type of fexp = %s" (CilType.Typ.show exp_type); - Logs.debug "(!) combine_assign: exp_vars = %s" (String.concat ", " (List.map (fun v -> v.vname) (D.elements exp_vars))); - - let simple_assign lval exp acc = - let v = vars_from_lval lval - in - match v with - | [] -> acc (*D.join acc (vars_from_expr exp) if I do not know what the value is assigned to, then all RHS-Variables might be relevant *) - | v -> - let l = (D.diff acc (D.of_list v)) in - (* if D.mem v acc then D.join l (vars_from_expr exp) - else l *) - l - in + Logs.debug "(!) combine_assign: exp_vars = %s" (String.concat ", " (List.map (fun v -> v.vname) (D.elements exp_vars))); *) + (* this is problematic. I should only remove the lvar-vars if lval is a simple variable. If it is used to reference memory the variabes are actually wuite important*) match lval with - | Some lval -> D.union (List.fold_right (fun exp acc -> simple_assign lval exp acc) args man.local) exp_vars - | _ -> man.local - + | Some lval -> + let lval_vars = D.of_list (vars_from_lval lval) in + if (D.exists (fun e -> D.mem e man.local) lval_vars) then ( + let a = (D.union man.local exp_vars) in + D.diff a lval_vars) + else man.local + | _ -> man.local (** A transfer function which handles the return statement, i.e., "return exp" or "return" in the passed function (fundec) *) let return man man_forw (exp: exp option) (f:fundec) : D.t = + + (* this does not really work that well, as I pass all live vars which does not generally make the function important *) let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in (*this does not take globals int account, only checks for "temp"*) match exp with diff --git a/tests/regression/99-tutorials/05-basic_liveness.c b/tests/regression/99-tutorials/05-basic_liveness.c new file mode 100644 index 0000000000..d34f6da234 --- /dev/null +++ b/tests/regression/99-tutorials/05-basic_liveness.c @@ -0,0 +1,17 @@ +// SKIP TERM PARAM: --enable ana.wp_run +#include + +int main() +{ + int x = 1; + int y = 2; + int z = 3; + + int a = rand(); + + if (a) { + x = x + y; + } + + return x; +} diff --git a/tests/regression/99-tutorials/06-forward_branch_info.c b/tests/regression/99-tutorials/06-forward_branch_info.c new file mode 100644 index 0000000000..25261df480 --- /dev/null +++ b/tests/regression/99-tutorials/06-forward_branch_info.c @@ -0,0 +1,14 @@ +// SKIP TERM PARAM: --enable ana.wp_run + +int main() +{ + int x = 1; + int y = 2; + int z = 3; + + if (z) { + x = x + y; + } + + return x; +} diff --git a/tests/regression/99-tutorials/07-basic_function_call.c b/tests/regression/99-tutorials/07-basic_function_call.c new file mode 100644 index 0000000000..a34ab11273 --- /dev/null +++ b/tests/regression/99-tutorials/07-basic_function_call.c @@ -0,0 +1,21 @@ +// SKIP TERM PARAM: --enable ana.wp_run + +int f(int a, int b) { + + if (a > 0) { + return a + b; + } else { + return a; + } + +} + +int main() +{ + int x = 1; + int y = 2; + + int z = f(x, y); + + return z; +} diff --git a/tests/regression/99-tutorials/08-function_pointer_resolve.c b/tests/regression/99-tutorials/08-function_pointer_resolve.c new file mode 100644 index 0000000000..cde62825ec --- /dev/null +++ b/tests/regression/99-tutorials/08-function_pointer_resolve.c @@ -0,0 +1,23 @@ +// SKIP TERM PARAM: --enable ana.wp_run + +int f(int a, int b) { + + if (a < 0) { + return a + b; + } else { + return a; + } + +} + +int main() +{ + int x = 1; + int y = 2; + + int (*h) (int, int) = &f; + + int z = h(x, y); + + return z; +} diff --git a/tests/regression/99-tutorials/09-ambigious_function_pointer.c b/tests/regression/99-tutorials/09-ambigious_function_pointer.c new file mode 100644 index 0000000000..6aa5921967 --- /dev/null +++ b/tests/regression/99-tutorials/09-ambigious_function_pointer.c @@ -0,0 +1,39 @@ +// SKIP TERM PARAM: --enable ana.wp_run +#include + +int f(int a, int b) { + + if (a > 0) { + return a + b; + } else { + return a; + } + +} + +int g(int a, int b) { + + if (a < 0) { + return a - b; + } else { + return a; + } + +} + +int main() +{ + int x = 1; + int y = 2; + + int (*h) (int, int) = &f; + + int c; + if (c) { + h = &g; + } + + int z = h(x, y); + + return z; +} diff --git a/xy_easyprog.c b/xy_easyprog.c index 34113915f7..af09bd62e8 100644 --- a/xy_easyprog.c +++ b/xy_easyprog.c @@ -1,4 +1,4 @@ - #include +#include int f(int x, int y) { int i = 2; From 45a201ed9d066192d6dcb973d849bf041430b159 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Sat, 28 Feb 2026 14:39:58 +0100 Subject: [PATCH 23/29] Cleanup - renamed: `src/analyses/wp_test.ml` -> `src/analyses/wp_analyses/liveness.ml` - modified `src/framework/control.ml` by replacing the standard AnalyzeCFG-module with the one from the upstream repository since I meddled in that one --- .../{wp_test.ml => wp_analyses/liveness.ml} | 156 +------------- src/framework/control.ml | 198 +++++++++++------- 2 files changed, 125 insertions(+), 229 deletions(-) rename src/analyses/{wp_test.ml => wp_analyses/liveness.ml} (63%) diff --git a/src/analyses/wp_test.ml b/src/analyses/wp_analyses/liveness.ml similarity index 63% rename from src/analyses/wp_test.ml rename to src/analyses/wp_analyses/liveness.ml index f1d7008240..f95521b7c7 100644 --- a/src/analyses/wp_test.ml +++ b/src/analyses/wp_analyses/liveness.ml @@ -1,160 +1,6 @@ open GoblintCil open Analyses - -module Spec : Analyses.Spec = -struct - let name () = "wp_test" - - (* include Analyses.DefaultBackwSpec *) - - include Analyses.IdentitySpec - (*## context ##*) - (*Idea: make context type passsable, so add parameter.*) - module C = Printable.Unit - - let context man _ _ = () - let startcontext () = () - - (*## end of context ##*) - - - module LiveVariableSet = SetDomain.ToppedSet (Basetype.Variables) (struct let topname = "All variables" end) - module D = LiveVariableSet (*Set of program variables as domain*) - - let startstate v = D.empty() - let exitstate v = D.empty() - - let vars_from_lval (l: lval) = - match l with - | Var v, NoOffset when isIntegralType v.vtype && not (v.vglob || v.vaddrof) -> Some v (* local integer variable whose address is never taken *) - | _, _ -> None (*do not know what to do here yet*) - - let vars_from_expr (e: exp) : D.t= - let rec aux acc e = - match e with - | Lval (Var v, _) -> D.add v acc - | BinOp (_, e1, e2, _) -> - let acc1 = aux acc e1 in - aux acc1 e2 - | UnOp (_, e1, _) -> aux acc e1 - | SizeOfE e1 -> aux acc e1 - | AlignOfE e1 -> aux acc e1 - | Question (e1, e2, e3, _) -> - let acc1 = aux acc e1 in - let acc2 = aux acc1 e2 in - aux acc2 e3 - | CastE (_, e1) -> aux acc e1 - | AddrOf (l1) -> (match vars_from_lval l1 with - | None -> acc - | Some v -> D.add v acc) - | _ -> acc - in - aux (D.empty()) e - - - let assign man (lval:lval) (rval:exp) = - let v = vars_from_lval lval in - - match v with - | None -> D.join man.local (vars_from_expr rval) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) - | Some v -> - let l = (D.diff man.local (D.singleton v)) in - if D.mem v man.local then D.join l (vars_from_expr rval) - else l - - let branch man (exp:exp) (tv:bool) = - D.join man.local (vars_from_expr exp) - - let body man (f:fundec) = - man.local - - let return man (exp:exp option) (f:fundec) = - match exp with - | None -> man.local - | Some e -> D.join man.local (vars_from_expr e) - - (* TODO *) - let enter man (lval: lval option) (f:fundec) (args:exp list) = - (* Logs.debug "=== enter function %s with args %s ===" f.svar.vname - (String.concat ", " (List.map (CilType.Exp.show) args)); *) - - let vars = - match lval with - | None -> man.local - | Some lv -> man.local (*i have to check for every arg ... no wait... I do not care about the args here, i care about those at the combine!!!!*) - - in - - [man.local, vars] - - (* TODO *) - let combine_env man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - (* Logs.debug "=== combine_env of function %s ===" f.svar.vname; - let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in - Logs.debug " args: %s" args_pretty; - - let sformals_pretty = String.concat ", " (List.map (fun v -> v.vname) f.sformals) in - Logs.debug " sformals: %s" sformals_pretty; *) - - (*map relevant sformals in man.local to the corresponding variables contained in the argument*) - let arg_formal_pairs = List.combine args f.sformals in - let relevant_arg_vars = - List.fold_left (fun acc (arg_exp, formal_var) -> - if D.mem formal_var au then - D.join acc (vars_from_expr arg_exp) - else - acc - ) (D.empty()) arg_formal_pairs - in - - (*join relevant*) - D.join man.local relevant_arg_vars - - let combine_assign man (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - (* Logs.debug "=== combine_assign of function %s ===" f.svar.vname; - (*how do I know which args are important? i.e. how do I match the local name of the variable in the function with the passed parameters (if there are several)*) - let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in - Logs.debug " args: %s" args_pretty; *) - - let simple_assign lval exp acc = - let v = vars_from_lval lval in - - match v with - | None -> acc (*D.join acc (vars_from_expr exp) if I do not know what the value is assigned to, then all RHS-Variables might be relevant *) - | Some v -> - let l = (D.diff acc (D.singleton v)) in - (* if D.mem v acc then D.join l (vars_from_expr exp) - else l *) - l - in - - match lval with - | Some lval -> List.fold_right (fun exp acc -> simple_assign lval exp acc) args man.local - | _ -> man.local - - - - (** A transfer function which handles the return statement, i.e., - "return exp" or "return" in the passed function (fundec) *) - let return man (exp: exp option) (f:fundec) : D.t = - let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in (*this does not take globals int account, only checks for "temp"*) - - match exp with - | None -> D.empty() - | Some e -> if return_val_is_important - then D.join (D.empty()) (vars_from_expr e) - else D.empty() - - - let special man (lval: lval option) (f:varinfo) (arglist:exp list) = - man.local - - let threadenter man ~multiple lval f args = [man.local] - let threadspawn man ~multiple lval f args fman = man.local -end - - module BackwSpec : BackwAnalyses.BackwSpecSpec = functor (ForwSpec : Analyses.Spec) -> struct @@ -166,7 +12,7 @@ struct module G_forw = ForwSpec.G module V_forw = ForwSpec.V module P_forw = ForwSpec.P - let name () = "wp_test" + let name () = "liveness" module G = Lattice.Unit module V = EmptyV diff --git a/src/framework/control.ml b/src/framework/control.ml index dad2229509..ad6dd00f82 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -155,7 +155,7 @@ struct let open Cilfacade in let warn_for_upjumps fundec gotos = if FunSet.mem live_funs fundec then ( - (* set nortermiantion flag *) + (* set nontermination flag *) AnalysisState.svcomp_may_not_terminate := true; (* iterate through locations to produce warnings *) LocSet.iter (fun l _ -> @@ -250,7 +250,7 @@ struct AnalysisState.should_warn := false; (* reset for server mode *) - (* exctract global xml from result *) + (* extract global xml from result *) let make_global_fast_xml f g = let open Printf in let print_globals k v = @@ -501,69 +501,120 @@ struct let uncalled_dead = ref 0 in let solve_and_postprocess () = - let lh, gh = - let solver_data = - match Inc.increment with - | Some {solver_data; server; _} -> - if server then - Some (Slvr.copy_marshal solver_data) (* Copy, so that we can abort and reuse old data unmodified. *) - else if GobConfig.get_bool "ana.opt.hashcons" then - Some (Slvr.relift_marshal solver_data) - else - Some solver_data - | None -> None - in - Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); - AnalysisState.should_warn := get_string "warn_at" = "early"; - - let log_analysis_inputs () = - Logs.debug "=== Analysis Inputs ==="; - - (* Log entrystates *) - Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); - List.iteri (fun i ((node, ctx), state) -> - Logs.debug "EntryState %d:" (i + 1); - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec.C.pretty ctx; - Logs.debug " State: %a" Spec.D.pretty state; - ) entrystates; - - (* Log entrystates_global *) - Logs.debug "--- Global Entry States (count: %d) ---" (List.length entrystates_global); - List.iteri (fun i (gvar, gstate) -> - Logs.debug "GlobalEntryState %d:" (i + 1); - Logs.debug " GVar: %a" EQSys.GVar.pretty gvar; - Logs.debug " GState: %a" EQSys.G.pretty gstate; - ) entrystates_global; - - (* Log startvars' *) - Logs.debug "--- Start Variables (count: %d) ---" (List.length startvars'); - List.iteri (fun i (node, ctx) -> - Logs.debug "StartVar %d:" (i + 1); - Logs.debug " Node: %a" Node.pretty_trace node; - Logs.debug " Context: %a" Spec.C.pretty ctx; - ) startvars'; - - (* Log startvars (without apostrophe) *) - Logs.debug "--- Start Variables (no apostrophe) (count: %d) ---" (List.length startvars); - List.iteri (fun i (node, state) -> - Logs.debug "StartVar (no apostrophe) %d:" (i + 1); - Logs.debug " Node: %a" CilType.Fundec.pretty node; - Logs.debug " State: (of type EQSys.D.t) %a" Spec.D.pretty state; - ) startvars; - - Logs.debug "=== End Analysis Inputs ===" - in - log_analysis_inputs (); + (* handle save_run/load_run *) + let solver_file = "solver.marshalled" in + let load_run = get_string "load_run" in + let compare_runs = get_string_list "compare_runs" in + let gobview = get_bool "gobview" in + let save_run_str = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in + + let lh, gh = if load_run <> "" then ( + let module S2' = (GlobSolverFromEqSolver (Goblint_solver.Generic.LoadRunIncrSolver (PostSolverArg))) (EQSys) (LHT) (GHT) in + let (r2, _) = S2'.solve entrystates entrystates_global startvars' None in (* TODO: has incremental data? *) + r2 + ) else if compare_runs <> [] then ( + match compare_runs with + | d1::d2::[] -> (* the directories of the runs *) + if d1 = d2 then Logs.warn "Beware that you are comparing a run with itself! There should be no differences."; + (* instead of rewriting Compare for EqConstrSys, just transform unmarshaled EqConstrSys solutions to GlobConstrSys solutions *) + let module Splitter = GlobConstrSolFromEqConstrSol (EQSys: DemandGlobConstrSys) (LHT) (GHT) in + let module S2 = Splitter.S2 in + let module VH = Splitter.VH in + let (r1, r1'), (r2, r2') = Tuple2.mapn (fun d -> + let vh = Serialize.unmarshal Fpath.(v d / solver_file) in + + let vh' = VH.create (VH.length vh) in + VH.iter (fun k v -> + VH.replace vh' (S2.Var.relift k) (S2.Dom.relift v) + ) vh; + + (Splitter.split_solution vh', vh') + ) (d1, d2) + in + + if get_bool "dbg.compare_runs.globsys" then + CompareGlobSys.compare (d1, d2) r1 r2; + let module CompareEqSys = CompareConstraints.CompareEqSys (EqConstrSysFromDemandConstrSys (S2) ) (VH) in + if get_bool "dbg.compare_runs.eqsys" then + CompareEqSys.compare (d1, d2) r1' r2'; - let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in - if GobConfig.get_bool "incremental.save" then - Serialize.Cache.(update_data SolverData solver_data); - lh, gh + let module CompareGlobal = CompareConstraints.CompareGlobal (EQSys.GVar) (EQSys.G) (GHT) in + if get_bool "dbg.compare_runs.global" then + CompareGlobal.compare (d1, d2) (snd r1) (snd r2); + let module CompareNode = CompareConstraints.CompareNode (Spec.C) (EQSys.D) (LHT) in + if get_bool "dbg.compare_runs.node" then + CompareNode.compare (d1, d2) (fst r1) (fst r2); + + r1 (* return the result of the first run for further options -- maybe better to exit early since compare_runs is its own mode. Only excluded verify below since it's on by default. *) + | _ -> failwith "Currently only two runs can be compared!"; + ) else ( + let solver_data = + match Inc.increment with + | Some {solver_data; server; _} -> + if server then + Some (Slvr.copy_marshal solver_data) (* Copy, so that we can abort and reuse old data unmodified. *) + else if GobConfig.get_bool "ana.opt.hashcons" then + Some (Slvr.relift_marshal solver_data) + else + Some solver_data + | None -> None + in + Logs.debug "%s" ("Solving the constraint system with " ^ get_string "solver" ^ ". Solver statistics are shown every " ^ string_of_int (get_int "dbg.solver-stats-interval") ^ "s or by signal " ^ get_string "dbg.solver-signal" ^ "."); + AnalysisState.should_warn := get_string "warn_at" = "early" || gobview; + let (lh, gh), solver_data = Timing.wrap "solving" (Slvr.solve entrystates entrystates_global startvars') solver_data in + if GobConfig.get_bool "incremental.save" then + Serialize.Cache.(update_data SolverData solver_data); + if save_run_str <> "" then ( + let save_run = Fpath.v save_run_str in + let analyses = Fpath.(save_run / "analyses.marshalled") in + let config = Fpath.(save_run / "config.json") in + let meta = Fpath.(save_run / "meta.json") in + let solver_stats = Fpath.(save_run / "solver_stats.csv") in (* see Generic.SolverStats... *) + let cil = Fpath.(save_run / "cil.marshalled") in + let warnings = Fpath.(save_run / "warnings.marshalled") in + let stats = Fpath.(save_run / "stats.marshalled") in + Logs.Format.debug "Saving the current configuration to %a, meta-data about this run to %a, and solver statistics to %a" Fpath.pp config Fpath.pp meta Fpath.pp solver_stats; + GobSys.mkdir_or_exists save_run; + GobConfig.write_file config; + let module Meta = struct + type t = { command : string; version: string; timestamp : float; localtime : string } [@@deriving to_yojson] + let json = to_yojson { command = GobSys.command_line; version = Goblint_build_info.version; timestamp = Unix.time (); localtime = GobUnix.localtime () } + end + in + (* Yojson.Safe.to_file meta Meta.json; *) + Out_channel.with_open_text (Fpath.to_string meta) (fun oc -> + Yojson.Safe.pretty_to_channel oc Meta.json (* the above is compact, this is pretty-printed *) + ); + if gobview then ( + Logs.Format.debug "Saving the analysis table to %a, the CIL state to %a, the warning table to %a, and the runtime stats to %a" Fpath.pp analyses Fpath.pp cil Fpath.pp warnings Fpath.pp stats; + Serialize.marshal MCPRegistry.registered_name analyses; + Serialize.marshal (file, Cabs2cil.environment) cil; + Serialize.marshal !Messages.Table.messages_list warnings; + ); + GobSys.(self_signal (signal_of_string (get_string "dbg.solver-signal"))); (* write solver_stats after solving (otherwise no rows if faster than dbg.solver-stats-interval). TODO better way to write solver_stats without terminal output? *) + ); + lh, gh + ) in + if get_string "comparesolver" <> "" then ( + let compare_with (module S2 : DemandEqIncrSolver) = + let module PostSolverArg2 = + struct + include PostSolverArg + let should_warn = false (* we already warn from main solver *) + let should_save_run = false (* we already save main solver *) + end + in + let module S2' = (GlobSolverFromEqSolver (S2 (PostSolverArg2))) (EQSys) (LHT) (GHT) in + let (r2, _) = S2'.solve entrystates entrystates_global startvars' None in (* TODO: has incremental data? *) + CompareGlobSys.compare (get_string "solver", get_string "comparesolver") (lh,gh) (r2) + in + compare_with (Goblint_solver.Selector.choose_solver (get_string "comparesolver")) + ); + (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) AnalysisState.should_warn := PostSolverArg.should_warn; @@ -580,7 +631,6 @@ struct not (LibraryFunctions.is_safe_uncalled fn.vname) && not (Cil.hasAttribute "goblint_stub" fn.vattr) in - let print_and_calculate_uncalled = function | GFun (fn, loc) when is_bad_uncalled fn.svar loc-> let cnt = Cilfacade.countLoc fn in @@ -795,7 +845,7 @@ struct Timing.wrap "result output" (ResultOutput.output (lazy local_xml) liveness gh make_global_fast_xml) (module FileCfg) end -(** Given a [Cfg], a [Spec_forw], [Spec_back], and an unused [Inc], computes the solution] *) +(** Given a [Cfg], a [Spec_forw], [Spec_back], and an unused [Inc], computes the solution*) module AnalyzeCFG_bidir (Cfg:CfgBidirSkip) (Spec_forw:Spec) (BackwSpecSpec : BackwAnalyses.BackwSpecSpec) (Inc:Increment) = struct module Spec_backw = BackwSpecSpec (Spec_forw) @@ -1313,7 +1363,7 @@ struct let startvars' = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_backw.context (man e) n e)) startvars in let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec_backw.context (man e) n e), e) startvars in *) - (* Using dummy contexts which will be replaced by the contextx of the forward functions*) + (* Using dummy contexts which will be replaced by the contexts of the forward functions*) let startvars' = List.map (fun (n,e) -> (MyCFG.FunctionEntry n, Spec_forw.startcontext ())) startvars in let entrystates = List.map (fun (n,e) -> (MyCFG.Function n, Spec_forw.startcontext ()), e) startvars in @@ -1454,10 +1504,10 @@ struct in log_lh_contents lh; - let joined_by_loc_backw, joined_by_node_backw = - let open Enum in - let node_values = LHT.enum lh in - let node_backw_values = filter_map ( + (* let joined_by_loc_backw, joined_by_node_backw = + let open Enum in + let node_values = LHT.enum lh in + let node_backw_values = filter_map ( fun (key, d) -> match key with | `L_forw (_,_) -> None @@ -1466,10 +1516,10 @@ struct | `Lifted2 d -> Some (node, d) | _ -> None) ) node_values - in - let hashtbl_size = if fast_count node_values then count node_values else 123 in - let by_loc, by_node = Hashtbl.create hashtbl_size, NodeH.create hashtbl_size in - iter (fun (node, v) -> + in + let hashtbl_size = if fast_count node_values then count node_values else 123 in + let by_loc, by_node = Hashtbl.create hashtbl_size, NodeH.create hashtbl_size in + iter (fun (node, v) -> let loc = match node with | Statement s -> Cil.get_stmtLoc s.skind (* nosemgrep: cilfacade *) (* Must use CIL's because syntactic search is in CIL. *) | FunctionEntry _ | Function _ -> Node.location node @@ -1479,8 +1529,8 @@ struct Hashtbl.modify_opt loc join by_loc; NodeH.modify_opt node join by_node; ) node_backw_values; - by_loc, by_node - in + by_loc, by_node + in *) (* NodeH.iter (fun node d -> match node with @@ -1573,7 +1623,7 @@ let rec analyze_loop (module CFG : CfgBidirSkip) file fs change_info = let (module Spec) = get_spec () in if (GobConfig.get_bool "ana.wp_run") then ( - let module LivenesSpec = Wp_test.BackwSpec in + let module LivenesSpec = Liveness.BackwSpec in let module A = AnalyzeCFG_bidir (CFG) (Spec) (LivenesSpec) (struct let increment = change_info end) in GobConfig.with_immutable_conf (fun () -> A.analyze file fs) ) else ( From 48e53bc3b98c566d0c01eceaa742a45854b80e32 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Sat, 28 Feb 2026 14:53:26 +0100 Subject: [PATCH 24/29] Cleanup of analyses --- src/framework/analyses.ml | 104 +------------------------------------- 1 file changed, 1 insertion(+), 103 deletions(-) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index 8edd23dc65..22db9d4031 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -262,108 +262,6 @@ sig 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 BackwSpec = - sig - module D : Lattice.S - module G : Lattice.S - module C : Printable.S - module V: SpecSysVar (** Global constraint variables. *) - module P: DisjointDomain.Representative with type elt := D.t (** Path-representative. *) - - module D_forw: Lattice.S - module G_forw: Lattice.S - module V_forw: SpecSysVar (** Global constraint variables. *) - module P_forw: DisjointDomain.Representative with type elt := D_forw.t (** Path-representative. *) - val name : unit -> string - - (** Auxiliary data (outside of solution domains) that needs to be marshaled and unmarshaled. - This includes: - * hashtables, - * varinfos (create_var), - * RichVarinfos. *) - type marshal - - (** Initialize using unmarshaled auxiliary data (if present). *) - val init : marshal option -> unit - - (** Finalize and return auxiliary data to be marshaled. *) - val finalize : unit -> marshal - (* val finalize : G.t -> unit *) - - val startstate : varinfo -> D.t - val morphstate : varinfo -> D.t -> D.t - val exitstate : varinfo -> D.t - - val context: (D.t, G.t, C.t, V.t) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> fundec -> D.t -> C.t - val startcontext: unit -> C.t - - val sync : (D.t, G.t, C.t, V.t) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> [`Normal | `Join | `JoinCall of CilType.Fundec.t | `Return] -> D.t - val query : (D.t, G.t, C.t, V.t) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> lval option -> fundec -> exp list -> (D.t * D.t) list - - (* Combine is split into two steps: *) - - (** Combine environment (global variables, mutexes, etc) - 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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> D.t list - - (** Returns initial state for created thread. *) - val threadenter : (D.t, G.t, C.t, V.t) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.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) man -> (ForwSpec.D.t, ForwSpec.D.t, ForwSpec.C.t, ForwSpec.V.t) man -> Events.t -> (D.t, G.t, C.t, V.t) man -> D.t - end *) - - module type Spec2Spec = functor (S: Spec) -> Spec module type MCPA = @@ -545,4 +443,4 @@ sig val gh: EQSys.G.t GHT.t val lh: SpecSys.Spec.D.t LHT.t (* explicit SpecSys to avoid spurious module cycle *) -end +end \ No newline at end of file From 1a84c57d97175c820f455f7a7b93ea0158335f5f Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Tue, 3 Mar 2026 17:43:08 +0100 Subject: [PATCH 25/29] Cleanup - Remove unused code and comments from liveness analysis and bidirectional constraints modules. - Update the control module to properly escape WP analysis results before inserting them into XML (still very shady though) - corrected test --- src/analyses/wp_analyses/liveness.ml | 15 ++-- src/common/util/cilfacade.ml | 4 +- src/framework/backwAnalyses.ml | 2 - src/framework/bidirConstrains.ml | 24 +++--- src/framework/control.ml | 86 ++++--------------- .../99-tutorials/06-forward_branch_info.c | 2 +- 6 files changed, 40 insertions(+), 93 deletions(-) diff --git a/src/analyses/wp_analyses/liveness.ml b/src/analyses/wp_analyses/liveness.ml index f95521b7c7..772ebd444f 100644 --- a/src/analyses/wp_analyses/liveness.ml +++ b/src/analyses/wp_analyses/liveness.ml @@ -146,22 +146,17 @@ struct let body man man_forw (f:fundec) = man.local - let return man man_forw (exp:exp option) (f:fundec) = - match exp with - | None -> man.local - | Some e -> D.join man.local (D.of_list(vars_from_expr e)) - (* TODO *) let enter man man_forw (lval: lval option) (f:fundec) (args:exp list) = (* Logs.debug "=== enter function %s with args %s ===" f.svar.vname (String.concat ", " (List.map (CilType.Exp.show) args)); *) - let vars = - match lval with - | None -> man.local - | Some lv -> man.local (*i have to check for every arg ... no wait... I do not care about the args here, i care about those at the combine!!!!*) + (* let vars = + match lval with + | None -> man.local + | Some lv -> man.local (*i have to check for every arg ... no wait... I do not care about the args here, i care about those at the combine!!!!*) - in + in *) [man.local, man.local] diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index 2efa343d2e..452d0297a5 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -91,8 +91,8 @@ let init () = RmUnused.keepUnused := true; print_CIL_Input := true; Cabs2cil.allowDuplication := false; (* needed for ARG uncilling, maybe something else as well? *) - Cabs2cil.silenceLongDoubleWarning := true -(* Cabs2cil.addLoopConditionLabels := true *) + Cabs2cil.silenceLongDoubleWarning := true; + Cabs2cil.addLoopConditionLabels := true let current_file = ref dummyFile diff --git a/src/framework/backwAnalyses.ml b/src/framework/backwAnalyses.ml index e32a4e3e34..bfa83a4cbb 100644 --- a/src/framework/backwAnalyses.ml +++ b/src/framework/backwAnalyses.ml @@ -1,6 +1,4 @@ open GoblintCil -open Pretty -open GobConfig open Analyses module M = Messages diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 08fd20efe5..2e0698854a 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -202,14 +202,14 @@ struct { ask = (fun (type a) (q: a Queries.t) -> S_forw.query man_forw q) ; emit = (fun _ -> failwith "emit outside MCP") ; node = fst var - ; prev_node = prev_node (*This is a bit problematic, as prev node is actually the next node!!*) - ; control_context = (fun () -> failwith "control context not implemented yet for forward manager") (*TODO*) + ; prev_node = MyCFG.dummy_node (*I do not have *) + ; control_context = (fun () -> failwith "control context not implemented (yet) for forward manager.") ; context = context ; edge = edge - ; local = getl_forw (node, context()) (*getl_forw (fst var, (snd var |> Obj.obj))*) - ; global = (fun g -> Logs.debug "(!) getg_forw was usccesfully used"; G_forw.spec (getg_forw (GVar.GV_forw.spec g))) (*(fun _ -> failwith "getg_forw not implemented yet") TODO*) + ; local = getl_forw (node, context()) + ; global = (fun g -> G_forw.spec (getg_forw (GVar.GV_forw.spec g))) (*(fun _ -> failwith "getg_forw not implemented yet") TODO*) ; spawn = (fun ?multiple _ _ _ -> failwith "spawn should not be called from forward manager") - ; split = (fun _ _ -> failwith "split? what does this do?") (*(fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) What does this do?*) + ; split = (fun _ _ -> failwith "split? what does this do?") ; sideg = (fun _ _ -> failwith "sideg should not be called from forward manager") } in @@ -424,7 +424,7 @@ struct (* context = S_forw.context (S_forw.enter (getl_forw [this_node_, this_context])) *) let r = ref [] in - let rec man_forw = + let man_forw = { ask = (fun (type a) (q: a Queries.t) -> failwith "manager for calculating context does not support queries") ; emit = (fun _ -> failwith "emit outside MCP") ; node = man.node @@ -674,14 +674,16 @@ struct ) let iter_vars getl getg vq fl fg = - failwith "damn" + failwith "iter_vars not implemented for bidirectional constraint system." let sys_change getl getg = - failwith "damn" + failwith "sys_change not implemented for bidirectional constraint system." - let postmortem_backw = function - | FunctionEntry fd, c -> [(Function fd, c)] - | _ -> [] + let postmortem_backw v = + failwith "postmortem not implemented for backward analysis" + (* match v with + | Function fd, c -> [(FunctionEntry fd, c)] + | _ -> [] *) let postmortem = function | `L_forw v -> List.map (fun v -> `L_forw v) (Forward.postmortem v) diff --git a/src/framework/control.ml b/src/framework/control.ml index ad6dd00f82..b7dec1a049 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -861,7 +861,7 @@ struct module PostSolverArg = struct let should_prune = true - let should_verify = true (*get_bool "verify"*) + let should_verify = get_bool "verify" let should_warn = get_string "warn_at" <> "never" let should_save_run = (* copied from solve_and_postprocess *) @@ -890,7 +890,7 @@ struct module ResultOutput = AnalysisResultOutput.Make (Result) end - (** this function converts the LHT to two Results of type forwards and backwards *) + (** this function converts the LHT to two Results of forward type*) let solver2source_result h = let res_forw = ResBundle_forw.Result.create 113 in (* let res_backw = ResBundle_backw.Result.create 113 in *) @@ -967,21 +967,14 @@ struct let sideg v d = GHT.replace gh v (EQSys.G.join (getg v) d) in - (* the intit globals should not depend on each other*) - let getg v = EQSys.G.bot () in - (** this function calculates and returns [startvars'_forw] and [entrystates_forw] *) let do_forward_inits () : (node * Spec_forw.C.t) list * ((node * Spec_forw.C.t) * Spec_forw.D.t) list = (* wrapping functions accessing and modifying global variables *) let sideg_forw v d = sideg (`Forw (v)) ((`Lifted1 d)) in - let getg_forw v = - match EQSys.G.spec (getg (`Forw v)) with - | `Lifted1 g -> G_forw.create_spec g - | `Bot -> failwith "Unexpected global state" (*G_forw.bot (); *) - | `Top -> failwith "Unexpected global state" (*G_forw.top ()*) - | `Lifted2 _ -> failwith "Unexpected backward global state" - in + + (* the intit globals should not depend on each other*) + let getg_forw v = G_forw.bot () in let do_extern_inits_forw man (file: file) : Spec_forw.D.t = let module VS = Set.Make (Basetype.Variables) in @@ -1022,7 +1015,7 @@ struct ; context = (fun () -> man_failwith "Global initializers have no context.") ; edge = MyCFG.Skip ; local = Spec_forw.D.top () - ; global = (fun g -> G_forw.spec (getg (GV_forw.spec g))) + ; global = (fun g -> G_forw.spec (getg_forw (GV_forw.spec g))) ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") ; split = (fun _ -> failwith "Global initializers trying to split paths.") ; sideg = (fun g d -> sideg_forw (GV_forw.spec g) (G_forw.create_spec d)) @@ -1150,13 +1143,9 @@ struct let do_backward_inits () : (node * Spec_backw.C.t) list * ((node * Spec_forw.C.t) * Spec_backw.D.t) list = let sideg_backw v d = sideg (`Backw v) (EQSys.G.create_spec (`Lifted2 d)) in - let getg_backw v = - match EQSys.G.spec (getg (`Backw v)) with - | `Lifted1 _ -> failwith "Unexpected backward global state" - | `Bot -> G_backw.bot () - | `Top -> G_backw.top () - | `Lifted2 g -> G_backw.create_spec g - in + + (* the intit globals should not depend on each other*) + let getg_backw v = G_backw.bot () in let do_extern_inits_backw man man_forw (file: file) : Spec_backw.D.t = let module VS = Set.Make (Basetype.Variables) in @@ -1197,7 +1186,7 @@ struct ; context = (fun () -> man_failwith "Global initializers have no context.") ; edge = MyCFG.Skip ; local = Spec_backw.D.top () - ; global = (fun _ -> Spec_backw.G.bot ()) + ; global = (fun g -> G_backw.spec (getg_backw (GV_backw.spec g))) ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") ; split = (fun _ -> failwith "Global initializers trying to split paths.") ; sideg = (fun g d -> sideg_backw (GV_backw.spec g) d) @@ -1212,7 +1201,7 @@ struct ; control_context = (fun () -> man_failwith "Global initializers have no context.") ; context = (fun () -> man_failwith "Global initializers have no context.") ; edge = MyCFG.Skip - ; local = Spec_forw.D.top () (*TODO: SOULD I GET THE VALUE FROM THE FORWARD INITIALIZATION?*) + ; local = Spec_forw.D.top () (*Should probably use local from already initialized forward variable.*) ; global = (fun _ -> Spec_forw.G.bot ()) ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") ; split = (fun _ -> failwith "Global initializers trying to split paths.") @@ -1272,12 +1261,12 @@ struct { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) ; emit = (fun _ -> failwith "Cannot \"emit\" in global initializer context.") ; node = man.node - ; prev_node = MyCFG.dummy_node (* SHOULD I USE DUMMY NODES HERE IN GENERAL? I PROBABLY SHOULÖD*) + ; prev_node = MyCFG.dummy_node ; control_context = (fun () -> man_failwith "Global initializers have no context.") ; context = man.context ; edge = MyCFG.Skip - ; local = Spec_forw.D.top () (*TODO: SOULD I GET THE VALUE FROM THE FORWARD INITIALIZATION?*) - ; global = (fun _ -> Spec_forw.G.bot ()) (*TODO: SHOULD I ALLOW TO ASK FOR GLOBALS?*) + ; local = Spec_forw.D.top () (*Should probably use local from already initialized forward variable.*) + ; global = (fun _ -> Spec_forw.G.bot ()) ; spawn = (fun ?(multiple=false) _ -> failwith "Global initializers should never spawn threads. What is going on?") ; split = (fun _ -> failwith "Global initializers trying to split paths.") ; sideg = (fun _ _ -> failwith "forw_man in the backwards initialization should not be used to sideeffect globals.") @@ -1386,7 +1375,7 @@ struct let startvars'_forw, entrystates_forw = do_forward_inits () in let startvars'_backw, entrystates_backw = do_backward_inits () in - (* Let's assume there is onyl one entrystate and startvar each. In what examples is this not the case?*) + (* Let's assume there is only one entrystate and startvar each. In what examples is this not the case?*) let forward_context = match startvars'_forw with | (_, ctx) :: _ -> ctx | [] -> failwith "No startvars from forward analysis" @@ -1504,43 +1493,6 @@ struct in log_lh_contents lh; - (* let joined_by_loc_backw, joined_by_node_backw = - let open Enum in - let node_values = LHT.enum lh in - let node_backw_values = filter_map ( - fun (key, d) -> - match key with - | `L_forw (_,_) -> None - | `L_backw (node, context) -> - (match d with - | `Lifted2 d -> Some (node, d) - | _ -> None) - ) node_values - in - let hashtbl_size = if fast_count node_values then count node_values else 123 in - let by_loc, by_node = Hashtbl.create hashtbl_size, NodeH.create hashtbl_size in - iter (fun (node, v) -> - let loc = match node with - | Statement s -> Cil.get_stmtLoc s.skind (* nosemgrep: cilfacade *) (* Must use CIL's because syntactic search is in CIL. *) - | FunctionEntry _ | Function _ -> Node.location node - in - (* join values once for the same location and once for the same node *) - let join = Option.some % function None -> v | Some v' -> Spec_backw.D.join v v' in - Hashtbl.modify_opt loc join by_loc; - NodeH.modify_opt node join by_node; - ) node_backw_values; - by_loc, by_node - in *) - - (* NodeH.iter (fun node d -> - match node with - | Statement s -> ( - match s. with - | _ -> () - ) - | _ -> () - ) joined_by_node_backw; *) - let make_global_fast_xml f g = let open Printf in let print_globals k v = @@ -1554,9 +1506,8 @@ struct let local_xml_forw = solver2source_result lh in ResBundle_forw.ResultOutput.output (lazy local_xml_forw) liveness gh make_global_fast_xml (module FileCfg); - (* ResBundle_backw.ResultOutput.output (lazy local_xml_backw) liveness gh make_global_fast_xml (module FileCfg) *) - (*This is disgusting, but I have more imprtant things to do right now*) + (*This is disgusting, but I have more important things to do right now.*) let output_wp_results_to_xml lh = (* iterate through all nodes and update corresponding .xml in result/nodes *) LHT.iter (fun v state -> @@ -1578,9 +1529,10 @@ struct Stdlib.close_in ic; (* Create WP analysis data *) - let wp_res = Pretty.sprint 100 (Spec_backw.D.pretty () state) in + let wp_res = Pretty.sprint ~width:100 (Spec_backw.D.pretty () state) in + let wp_res_escaped = XmlUtil.escape wp_res in let wp_data = - "\n\n\n\n" ^ wp_res ^" \n\n\n\n\n" + "\n\n\n\n" ^ wp_res_escaped ^" \n\n\n\n\n" in (* Insert before *) diff --git a/tests/regression/99-tutorials/06-forward_branch_info.c b/tests/regression/99-tutorials/06-forward_branch_info.c index 25261df480..d4c83da58f 100644 --- a/tests/regression/99-tutorials/06-forward_branch_info.c +++ b/tests/regression/99-tutorials/06-forward_branch_info.c @@ -4,7 +4,7 @@ int main() { int x = 1; int y = 2; - int z = 3; + int z = 0; if (z) { x = x + y; From f02c447cd924ba343caef754f4d25d11a431e7b5 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Tue, 3 Mar 2026 17:58:45 +0100 Subject: [PATCH 26/29] Removed CastE in liveness analysis since it seems to couse prblems with jobs --- src/analyses/wp_analyses/liveness.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/analyses/wp_analyses/liveness.ml b/src/analyses/wp_analyses/liveness.ml index 772ebd444f..4922fea505 100644 --- a/src/analyses/wp_analyses/liveness.ml +++ b/src/analyses/wp_analyses/liveness.ml @@ -66,7 +66,7 @@ struct let acc1 = aux acc e1 in let acc2 = aux acc1 e2 in aux acc2 e3 - | CastE (_, e1) -> aux acc e1 + (* | CastE (_, e1) -> aux acc e1 This appeaers to make problems when building for jobs*) | AddrOf (l1) -> (match vars_from_lval l1 with | [] -> acc | v -> (v @ acc) From 9a0fa2caf893f7ec52632ef885680ca54943a004 Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Wed, 4 Mar 2026 19:39:20 +0100 Subject: [PATCH 27/29] Work on liveness analysis and tests - Improved liveness analysis, now support (some kind of) handeling of pointers. This might just be to bad and to imprecise (possibly unsound), but it does now handle some cases properly - Modified and added tests, also added annpotations what the expected warnings are and why. This should make it easier to understand the tests and also to add new ones in the future. --- src/analyses/wp_analyses/liveness.ml | 174 +++++++----------- src/framework/bidirConstrains.ml | 30 ++- .../99-tutorials/05-basic_liveness.c | 3 +- .../99-tutorials/06-forward_branch_info.c | 4 +- .../99-tutorials/07-basic_function_call.c | 4 +- .../08-function_pointer_resolve.c | 2 +- .../09-ambigious_function_pointer.c | 4 +- .../10-function_call_complex_attributes.c | 25 +++ .../11-function_call_return_val_mem.c | 24 +++ .../99-tutorials/12-memory_write_in_call.c | 18 ++ .../regression/99-tutorials/13-pointer_used.c | 19 ++ 11 files changed, 179 insertions(+), 128 deletions(-) create mode 100644 tests/regression/99-tutorials/10-function_call_complex_attributes.c create mode 100644 tests/regression/99-tutorials/11-function_call_return_val_mem.c create mode 100644 tests/regression/99-tutorials/12-memory_write_in_call.c create mode 100644 tests/regression/99-tutorials/13-pointer_used.c diff --git a/src/analyses/wp_analyses/liveness.ml b/src/analyses/wp_analyses/liveness.ml index 4922fea505..8a5c150fec 100644 --- a/src/analyses/wp_analyses/liveness.ml +++ b/src/analyses/wp_analyses/liveness.ml @@ -24,38 +24,45 @@ struct let startstate v = D.empty() let exitstate v = D.empty() - let rec vars_from_lval (l: lval) : varinfo list = + let rec vars_from_lval (l: lval) man_forw : varinfo list = let vars_written_to = match l with | Var v, _ -> ( if (Cil.isFunctionType v.vtype) then [] else [v] (*I do not want functions in the set of live variables*) ) - | Mem m, _ -> vars_from_expr m + | Mem exp, _ -> (*If a pointer may point to a variable, these variables are live as well...*) + let may_point_to = Queries.AD.to_var_may (man_forw.ask (MayPointTo exp)) in + if may_point_to = [] then ( + M.warn ~category:MessageCategory.Unsound "The expression %a may point to an unknown variable. This makes the analysis unsound." d_exp exp; (*UNSOUND: I do not think that this check is enough. Maybe I should just exclude analyzing programs with variables whose address is taken.*) + vars_from_expr exp man_forw ) + else ( + Logs.debug "(!) The expression %a may point to the variables %s" d_exp exp (String.concat ", " (List.map (fun v -> v.vname) may_point_to)); + may_point_to @ vars_from_expr exp man_forw) in let vars_in_offset = match l with - | Var _, off -> vars_from_offset off - | Mem _, off -> Logs.debug "(!) vars_in_offset used"; vars_from_offset off + | Var _, off -> vars_from_offset off man_forw + | Mem _, off -> vars_from_offset off man_forw in (vars_written_to @ vars_in_offset) - and vars_from_offset (off: offset) : varinfo list = + and vars_from_offset (off: offset) man_forw : varinfo list = match off with | NoOffset -> [] - | Field (_, off) -> vars_from_offset off (* what to do with fieldinfo?*) + | Field (_, off) -> vars_from_offset off man_forw (* what to do with fieldinfo?*) | Index (e, off) -> - let vars_in_e = vars_from_expr e in - let vars_in_off = vars_from_offset off in + let vars_in_e = vars_from_expr e man_forw in + let vars_in_off = vars_from_offset off man_forw in (match vars_in_off with | [] -> [] | vars_in_off -> (vars_in_e @ vars_in_off)) - and vars_from_expr (e: exp) : varinfo list = + and vars_from_expr (e: exp) man_forw : varinfo list = let rec aux acc e = match e with - | Lval v -> vars_from_lval v @ acc + | Lval v -> vars_from_lval v man_forw @ acc | BinOp (_, e1, e2, _) -> let acc1 = aux acc e1 in aux acc1 e2 @@ -66,64 +73,37 @@ struct let acc1 = aux acc e1 in let acc2 = aux acc1 e2 in aux acc2 e3 - (* | CastE (_, e1) -> aux acc e1 This appeaers to make problems when building for jobs*) - | AddrOf (l1) -> (match vars_from_lval l1 with + | CastE (_, e1) -> aux acc e1 (*This appears to make problems when building for jobs*) + | AddrOf (l1) -> (match vars_from_lval l1 man_forw with | [] -> acc | v -> (v @ acc) ) - (* | AddrOfLabel _ -> Logs.debug "(!) Expression of type AddrOfLabel"; acc - | StartOf l1 -> Logs.debug "(!) Expression of type StartOf"; acc - | Const _ ->Logs.debug "(!) Expression of type Const"; acc - | Real _ -> Logs.debug "(!) Expression of type Real"; acc - | Imag _ -> Logs.debug "(!) Expression of type Imag"; acc - | SizeOf _ -> Logs.debug "(!) Expression of type SizeOf"; acc - | AlignOf _ -> Logs.debug "(!) Expression of type AlignOf"; acc - | SizeOfStr _ -> Logs.debug "(!) Expression of type SizeOfStr"; acc *) | _ -> acc in - - (* let give_exp_type e = - match e with - | Const _ -> Logs.debug "(!) Expression of type Const" - | Lval _ -> Logs.debug "(!) Expression of type Lval" - | SizeOf _ -> Logs.debug "(!) Expression of type SizeOf" - | Real _ -> Logs.debug "(!) Expression of type Real" - | Imag _ -> Logs.debug "(!) Expression of type Imag" - | SizeOfE _ -> Logs.debug "(!) Expression of type SizeOfE" - | SizeOfStr _ -> Logs.debug "(!) Expression of type SizeOfSTr" - | AlignOf _ -> Logs.debug "(!) Expression of type AlignOf" - | AlignOfE _ -> Logs.debug "(!) Expression of type AlignOfE" - | UnOp _ -> Logs.debug "(!) Expression of type UnOp" - | BinOp _ -> Logs.debug "(!) Expression of type BinOp" - | Question _ -> Logs.debug "(!) Expression of type Question" - | CastE _ -> Logs.debug "(!) Expression of type CastE" - | AddrOf _ -> Logs.debug "(!) Expression of type AddrOf" - | AddrOfLabel _ -> Logs.debug "(!) Expression of type AddrOfLabel" - | StartOf _ -> Logs.debug "(!) Expression of type StartOf" - | _ -> Logs.debug "(!) Impossible: Expression of unknown type" - in - give_exp_type e; *) - aux [] e - - - let assign man man_forw (lval:lval) (rval:exp) = - let v = vars_from_lval lval in - - (* This is wrong. If the variabes describe a memory location, they should instead all be added to the set of live variables!*) - match v with - | [] -> D.join man.local (D.of_list (vars_from_expr rval)) (*if I do not know what the value is assigned to, then all RHS-Variables might be relevant*) - | v-> - let l = (D.diff man.local (D.of_list v)) in - if (List.exists (fun elem -> D.mem elem man.local) v) then D.join l (D.of_list (vars_from_expr rval)) (*if anything on the rhs is important, this is live now*) - else ( + let rec assign man man_forw (lval:lval) (rval:exp) = + match lval with + | Var v, _ -> + if (D.mem v man.local || v.vglob) then ( (* Global variables are considered live when writing to them. *) + let rval_vars = D.of_list (vars_from_expr rval man_forw) + in + D.union rval_vars (D.diff man.local (D.singleton v)) + ) else ( let loc = M.Location.Node man.node in - (match v with - | v::_ -> M.warn ~loc:loc "Unnecessary assignment to variable %s, as it is not live at this program point" v.vname - | [] -> () (*this case is already handled above*) - ); l) + M.warn ~loc:loc ~category:MessageCategory.Program "Unnecessary assignment to variable '%s', as it is not live at this program point." v.vname; + man.local + ) + | Mem exp, _ -> + let may_point_to = Queries.AD.to_var_may (man_forw.ask (MayPointTo exp)) in + let lval_vars = D.of_list (vars_from_expr exp man_forw) in + let rval_vars = D.of_list (vars_from_expr rval man_forw) in + + match may_point_to with (*POSSIBLY UNSOUND: could also be an overapproximation, depending on whether assumption is true*) + | [v] -> + D.union (assign man man_forw (Var v, NoOffset) rval) lval_vars (* We assume that if it my only point to one variable, we can treat this as if we just assigned to that variable*) + | _ -> D.union rval_vars (D.union lval_vars man.local) let branch man man_forw (exp:exp) (tv:bool) = (* This just randomly asks whether all loops terimante to use getg_forw utilized in man.global *) @@ -140,42 +120,32 @@ struct | `Top -> false ) in - if branch_irrelevant then (D.of_list (vars_from_expr exp)) - else D.join man.local (D.of_list (vars_from_expr exp)) + if branch_irrelevant then (D.of_list (vars_from_expr exp man_forw)) + else D.join man.local (D.of_list (vars_from_expr exp man_forw)) let body man man_forw (f:fundec) = man.local - (* TODO *) let enter man man_forw (lval: lval option) (f:fundec) (args:exp list) = - (* Logs.debug "=== enter function %s with args %s ===" f.svar.vname - (String.concat ", " (List.map (CilType.Exp.show) args)); *) - - (* let vars = - match lval with - | None -> man.local - | Some lv -> man.local (*i have to check for every arg ... no wait... I do not care about the args here, i care about those at the combine!!!!*) - in *) - - [man.local, man.local] + match lval with + | Some (Var v, _) -> + if (D.mem v man.local) then ( + [man.local, (D.singleton v)] + ) else ( + [man.local, D.empty()] + ) + | Some (Mem exp, _) -> [man.local, D.of_list (vars_from_expr exp man_forw)] + | None -> [man.local, D.empty()] - (* TODO *) let combine_env man man_forw (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - (* Logs.debug "=== combine_env of function %s ===" f.svar.vname; - let args_pretty = String.concat ", " (List.map CilType.Exp.show args) in - Logs.debug " args: %s" args_pretty; - - let sformals_pretty = String.concat ", " (List.map (fun v -> v.vname) f.sformals) in - Logs.debug " sformals: %s" sformals_pretty; *) - - (*map relevant sformals in man.local to the corresponding variables contained in the argument*) + (* map relevant sformals in man.local to the corresponding variables contained in the argument*) let arg_formal_pairs = List.combine args f.sformals in let relevant_arg_vars = List.fold_left (fun acc (arg_exp, formal_var) -> if D.mem formal_var au then - D.join acc (D.of_list(vars_from_expr arg_exp)) + D.join acc (D.of_list(vars_from_expr arg_exp man_forw)) else acc ) (D.empty()) arg_formal_pairs @@ -184,43 +154,37 @@ struct (*join relevant*) D.join man.local relevant_arg_vars - let combine_assign man man_forw (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = - (* SHOULD JUST USE THE SIMPLE ASSIGN I ALREADY IMPLEMENT *) - let exp_vars = D.of_list(vars_from_expr fexp) in - (* - Logs.debug "(!) combine_assign: fexp = %s" (CilType.Exp.show fexp); - (* Type of the expression:*) - let exp_type = Cil.typeOf fexp in - Logs.debug "(!) combine_assign: type of fexp = %s" (CilType.Typ.show exp_type); - Logs.debug "(!) combine_assign: exp_vars = %s" (String.concat ", " (List.map (fun v -> v.vname) (D.elements exp_vars))); *) - - (* this is problematic. I should only remove the lvar-vars if lval is a simple variable. If it is used to reference memory the variabes are actually wuite important*) + let combine_assign man man_forw (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = match lval with - | Some lval -> - let lval_vars = D.of_list (vars_from_lval lval) in - if (D.exists (fun e -> D.mem e man.local) lval_vars) then ( - let a = (D.union man.local exp_vars) in - D.diff a lval_vars) - else man.local - | _ -> man.local - + | None -> man.local + | Some l -> assign man man_forw l fexp (** A transfer function which handles the return statement, i.e., "return exp" or "return" in the passed function (fundec) *) let return man man_forw (exp: exp option) (f:fundec) : D.t = - (* this does not really work that well, as I pass all live vars which does not generally make the function important *) - let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in (*this does not take globals int account, only checks for "temp"*) + let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in match exp with | None -> D.empty() | Some e -> if return_val_is_important - then D.of_list (vars_from_expr e) + then D.of_list (vars_from_expr e man_forw) else D.empty() let special man man_forw (lval: lval option) (f:varinfo) (arglist:exp list) = - man.local + (* log when called *) + Logs.debug "(!) Called special for function %s with arguments %s" f.vname (String.concat ", " (List.map (fun e -> Pretty.sprint ~width:80 (d_exp () e)) arglist)); + + let desc = LibraryFunctions.find f in + match desc.special arglist with + (* Could have some special handeling of library functions here *) + | _ -> + let argvars = List.fold_left (fun acc arg -> D.union acc (D.of_list (vars_from_expr arg man_forw))) (D.empty()) arglist in + match lval with + | None -> D.union man.local argvars + | Some (Var v, _) -> D.union (D.diff man.local (D.singleton(v))) argvars + | Some (Mem exp, _) -> D.union (D.union argvars (D.of_list (vars_from_expr exp man_forw))) man.local let threadenter man man_forw ~multiple lval f args = [man.local] let threadspawn man man_forw ~multiple lval f args fman = man.local diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 2e0698854a..50ea5c2337 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -207,7 +207,7 @@ struct ; context = context ; edge = edge ; local = getl_forw (node, context()) - ; global = (fun g -> G_forw.spec (getg_forw (GVar.GV_forw.spec g))) (*(fun _ -> failwith "getg_forw not implemented yet") TODO*) + ; global = (fun g -> G_forw.spec (getg_forw (GVar.GV_forw.spec g))) ; spawn = (fun ?multiple _ _ _ -> failwith "spawn should not be called from forward manager") ; split = (fun _ _ -> failwith "split? what does this do?") ; sideg = (fun _ _ -> failwith "sideg should not be called from forward manager") @@ -416,26 +416,23 @@ struct (* Logs.debug "combined local: %a" S_backw.D.pretty r; *) r in - let paths = - Logs.debug "manager info at call to %a" Node.pretty man.node; - S_backw.enter man man_forw lv f args in - (* Wollen eig vorwärts-kontext benutzen *) + let paths = S_backw.enter man man_forw lv f args in + (* getl_forw should query the corresopoding unknown from the forward analysis *) (* context = S_forw.context (S_forw.enter (getl_forw [this_node_, this_context])) *) - let r = ref [] in let man_forw = { ask = (fun (type a) (q: a Queries.t) -> failwith "manager for calculating context does not support queries") ; emit = (fun _ -> failwith "emit outside MCP") ; node = man.node - ; prev_node = man.prev_node (* this is problematic, as this is backwards *) + ; prev_node = MyCFG.dummy_node ; control_context = man.control_context ; context = man.context ; edge = man.edge ; local = (getl_forw (man.node, man.context ())) - ; global = (fun _ -> failwith "manager for calculating context does not have globals") + ; global = (fun g -> G_forw.spec (getg_forw (GVar.GV_forw.spec g))) ; spawn = (fun ?multiple _ _ _ -> failwith "manager for calculating context does not support spawn") - ; split = (fun (d:S_forw.D.t) es -> assert (List.is_empty es); r := d::!r) + ; split = (fun _ _ -> failwith "manager for calculating context does not support split") ; sideg = (fun _ _ -> failwith "manager for calculating context does not support sideg") } in @@ -448,15 +445,17 @@ struct (* filter paths were the forward analysis found out they are unreachable*) let paths = List.filter (fun ((c,v),(_,b)) -> not (S_forw.D.is_bot b)) paths in - (* this list now uses forward contexts*) let paths = List.map (fun ((c,v),(_,b)) -> (c, S_forw.context man_forw f b, v)) paths in - (* List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (FunctionEntry f, fc) v) paths; *) - List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (Function f, fc) v) paths; - (* let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (Function f, fc))) paths; *) - (* *) - let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in + (* The two lines below is what I should use. *) + (* List.iter (fun (c,fc,v) -> if not (S_backw.D.is_bot v) then sidel (Function f, fc) v) paths; *) + (* let paths = List.map (fun (c,fc,v) -> (c, fc, if S_backw.D.is_bot v then v else getl (FunctionEntry f, fc))) paths in *) + + (* A problem with my liveness analysis is that D.empty = D.bot, but I still need to evaluate a function since variables might become live inside. This is not optimal and the liveness analysis should be changed.*) + List.iter (fun (c,fc,v) -> sidel (Function f, fc) v) paths; + let paths = List.map (fun (c,fc,v) -> (c, fc, getl (FunctionEntry f, fc))) paths in + (* Don't filter bot paths, otherwise LongjmpLifter is not called. *) (* let paths = List.filter (fun (c,fc,v) -> not (D.is_bot v)) paths in *) @@ -469,7 +468,6 @@ struct (* Logs.debug "combined: %a" S_backw.D.pretty r; *) r - (*TODO: HERE AS WELL*) let rec tf_proc_backw var edge prev_node lv e args getl (getl_forw: node * S_forw.C.t -> S_forw.D.t) sidel demandl getg getg_forw sideg d = let tf_special_call man man_forw f = let once once_control init_routine = diff --git a/tests/regression/99-tutorials/05-basic_liveness.c b/tests/regression/99-tutorials/05-basic_liveness.c index d34f6da234..6b886e91af 100644 --- a/tests/regression/99-tutorials/05-basic_liveness.c +++ b/tests/regression/99-tutorials/05-basic_liveness.c @@ -5,7 +5,7 @@ int main() { int x = 1; int y = 2; - int z = 3; + int z = 3; // this assignment should yield a warning int a = rand(); @@ -15,3 +15,4 @@ int main() return x; } + diff --git a/tests/regression/99-tutorials/06-forward_branch_info.c b/tests/regression/99-tutorials/06-forward_branch_info.c index d4c83da58f..b5a377c7f4 100644 --- a/tests/regression/99-tutorials/06-forward_branch_info.c +++ b/tests/regression/99-tutorials/06-forward_branch_info.c @@ -3,8 +3,8 @@ int main() { int x = 1; - int y = 2; - int z = 0; + int y = 2; // this assignment should yield a warning, as the path where y is used is never taken + int z = 0; if (z) { x = x + y; diff --git a/tests/regression/99-tutorials/07-basic_function_call.c b/tests/regression/99-tutorials/07-basic_function_call.c index a34ab11273..99d6702f96 100644 --- a/tests/regression/99-tutorials/07-basic_function_call.c +++ b/tests/regression/99-tutorials/07-basic_function_call.c @@ -2,7 +2,7 @@ int f(int a, int b) { - if (a > 0) { + if (a < 0) { return a + b; } else { return a; @@ -13,7 +13,7 @@ int f(int a, int b) { int main() { int x = 1; - int y = 2; + int y = 2; // this assignment should yield a warning, as y is not used in the path taken in the called function int z = f(x, y); diff --git a/tests/regression/99-tutorials/08-function_pointer_resolve.c b/tests/regression/99-tutorials/08-function_pointer_resolve.c index cde62825ec..ba7a3fcafe 100644 --- a/tests/regression/99-tutorials/08-function_pointer_resolve.c +++ b/tests/regression/99-tutorials/08-function_pointer_resolve.c @@ -13,7 +13,7 @@ int f(int a, int b) { int main() { int x = 1; - int y = 2; + int y = 2; // this assignment should yield a warning, as y is not used in the path taken in the called function int (*h) (int, int) = &f; diff --git a/tests/regression/99-tutorials/09-ambigious_function_pointer.c b/tests/regression/99-tutorials/09-ambigious_function_pointer.c index 6aa5921967..976a1c1ecf 100644 --- a/tests/regression/99-tutorials/09-ambigious_function_pointer.c +++ b/tests/regression/99-tutorials/09-ambigious_function_pointer.c @@ -28,7 +28,7 @@ int main() int (*h) (int, int) = &f; - int c; + int c = rand(); if (c) { h = &g; } @@ -37,3 +37,5 @@ int main() return z; } + +// no warnings here, since we cannot determine which function is called and y is used if h evaluates to f, so we have to assume that y is used \ No newline at end of file diff --git a/tests/regression/99-tutorials/10-function_call_complex_attributes.c b/tests/regression/99-tutorials/10-function_call_complex_attributes.c new file mode 100644 index 0000000000..a838d779ce --- /dev/null +++ b/tests/regression/99-tutorials/10-function_call_complex_attributes.c @@ -0,0 +1,25 @@ +// SKIP TERM PARAM: --enable ana.wp_run +#include + +int f(int a, int b) { + + if (a > 0) { + return a + b; + } else { + return a; + } + +} + + +int main() +{ + int x = 1; + int y = 2; + + int z = f(x + (y * y), 0); + + return z; +} + +// now warnings here. Both variables are relevant as they are used in an expression passed to a live parameter of the function call. \ No newline at end of file diff --git a/tests/regression/99-tutorials/11-function_call_return_val_mem.c b/tests/regression/99-tutorials/11-function_call_return_val_mem.c new file mode 100644 index 0000000000..0bb813110f --- /dev/null +++ b/tests/regression/99-tutorials/11-function_call_return_val_mem.c @@ -0,0 +1,24 @@ +// SKIP TERM PARAM: --enable ana.wp_run +#include + +int f(int a, int b) { + + if (a > 0) { + return a + b; + } else { + return a; + } + +} + +int main() +{ + int i = 1; + int x = -1; + int y = 2; + int *p = malloc(sizeof(int) * i); + + p[0] = f(x, y); + + return x; +} diff --git a/tests/regression/99-tutorials/12-memory_write_in_call.c b/tests/regression/99-tutorials/12-memory_write_in_call.c new file mode 100644 index 0000000000..a6eeef997d --- /dev/null +++ b/tests/regression/99-tutorials/12-memory_write_in_call.c @@ -0,0 +1,18 @@ +// SKIP TERM PARAM: --enable ana.wp_run +#include + +int f(int a, int* b) { + b[0] = a ; + return 0; +} + + +int main() +{ + int x = 1; + int *p = malloc(sizeof(int)); + + f(x, p); + + return x; +} diff --git a/tests/regression/99-tutorials/13-pointer_used.c b/tests/regression/99-tutorials/13-pointer_used.c new file mode 100644 index 0000000000..e40d102982 --- /dev/null +++ b/tests/regression/99-tutorials/13-pointer_used.c @@ -0,0 +1,19 @@ +// SKIP TERM PARAM: --enable ana.wp_run +#include + + +int main() +{ + int x = 1; + int y = 2; + + int *p = &x; + + *p = 3; // x is now 3 and should not be live before this point anymore + int z = 2 * (*p); + + return z; +} + +/* This only works if we assume that if the query MayPointTo returns a single variable, then this variable is definietely the one pointed to. + */ \ No newline at end of file From e676dd1217398c4a1ffa3719e11af5e3e95a6d0b Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Thu, 9 Apr 2026 20:02:25 +0200 Subject: [PATCH 28/29] Queries and Correct Warnings for Live Variable analysis - added a query to check if an assignment to lval may be dead - added query to check if a variable is dead - added pass in control after solving that checks if assignment is dead ind all contexts and if so, adds a warning - added test cases for the above --- src/analyses/wp_analyses/liveness.ml | 48 ++++- src/domains/queries.ml | 10 + src/framework/bidirConstrains.ml | 8 + src/framework/control.ml | 174 +++++++++++++----- .../99-tutorials/14-motivating_example.c | 34 ++++ .../15-same_proc_different_results.c | 24 +++ 6 files changed, 254 insertions(+), 44 deletions(-) create mode 100644 tests/regression/99-tutorials/14-motivating_example.c create mode 100644 tests/regression/99-tutorials/15-same_proc_different_results.c diff --git a/src/analyses/wp_analyses/liveness.ml b/src/analyses/wp_analyses/liveness.ml index 8a5c150fec..4da4cf1bb3 100644 --- a/src/analyses/wp_analyses/liveness.ml +++ b/src/analyses/wp_analyses/liveness.ml @@ -91,8 +91,8 @@ struct in D.union rval_vars (D.diff man.local (D.singleton v)) ) else ( - let loc = M.Location.Node man.node in - M.warn ~loc:loc ~category:MessageCategory.Program "Unnecessary assignment to variable '%s', as it is not live at this program point." v.vname; + (* let loc = M.Location.Node man.node in *) + (* M.warn ~loc:loc ~category:MessageCategory.Program "Unnecessary assignment to variable '%s', as it is not live at this program point." v.vname; *) man.local ) | Mem exp, _ -> @@ -188,4 +188,48 @@ struct let threadenter man man_forw ~multiple lval f args = [man.local] let threadspawn man man_forw ~multiple lval f args fman = man.local + + let query man (type a) man_forw (q: a Queries.t): a Queries.result = + + (* Die recursion ist nicht sauber durchdacht *) + let rec is_dead_assign man man_forw (lval:lval) (rval:exp) (is_dead:bool) : (D.t * bool) = + + match lval with + | Var v, _ -> + Logs.debug "D.mem v man.local is %b" (D.mem v man.local); + Logs.debug "v.glob is %b" v.vglob; + if (D.mem v man.local || v.vglob) then + let rval_vars = D.of_list (vars_from_expr rval man_forw) + in + (D.union rval_vars (D.diff man.local (D.singleton v)), false) + else ( + Logs.debug "Variable '%s' is not live at this program point." v.vname; + (man.local, true) + ) + | Mem exp, _ -> ( + Logs.debug "lval is expression"; + let may_point_to = Queries.AD.to_var_may (man_forw.ask (MayPointTo exp)) in + let lval_vars = D.of_list (vars_from_expr exp man_forw) in + let rval_vars = D.of_list (vars_from_expr rval man_forw) in + + match may_point_to with (*POSSIBLY UNSOUND: could also be an overapproximation, depending on whether assumption is true*) + | [v] -> + let rec_assign_result, is_dead = + match (is_dead_assign man man_forw (Var v, NoOffset) rval is_dead) with + | (res, new_is_dead) -> res, new_is_dead + in + (D.union rec_assign_result lval_vars, is_dead)(* We assume that if it my only point to one variable, we can treat this as if we just assigned to that variable*) + | _ -> ((D.union rval_vars (D.union lval_vars man.local)), is_dead) + ) + in + + let open Queries in + + match q with + | IsDeadVar v -> not (D.mem v man.local) + | MayBeDeadAssignment lval -> ( + Logs.debug "Checking if assignment to lval %a may be dead at node %a with local state %a" d_lval lval Node.pretty_trace man.node D.pretty man.local; + match is_dead_assign man man_forw lval (Const (CInt (Z.zero, IInt, None))) false with + | (_, is_dead) -> Logs.debug "isdead is %b" is_dead ; is_dead ) + | _ -> Result.top q end diff --git a/src/domains/queries.ml b/src/domains/queries.ml index 31e93dd0b2..ad36fad1ff 100644 --- a/src/domains/queries.ml +++ b/src/domains/queries.ml @@ -146,6 +146,8 @@ type _ t = | YamlEntryGlobal: Obj.t * YamlWitnessType.Task.t -> YS.t t (** YAML witness entries for a global unknown ([Obj.t] represents [Spec.V.t]) and YAML witness task. *) | GhostVarAvailable: WitnessGhostVar.t -> MayBool.t t | InvariantGlobalNodes: NS.t t (** Nodes where YAML witness flow-insensitive invariants should be emitted as location invariants (if [witness.invariant.flow_insensitive-as] is configured to do so). *) (* [Spec.V.t] argument (as [Obj.t]) could be added, if this should be different for different flow-insensitive invariants. *) + | IsDeadVar: varinfo -> MayBool.t t (* Whether a variable is dead at a program point, i.e., not read afterwards. *) + | MayBeDeadAssignment: lval -> MayBool.t t (* Whether an assignment is dead, i.e., the assigned variable is not read afterwards. *) type 'a result = 'a @@ -221,6 +223,8 @@ struct | YamlEntryGlobal _ -> (module YS) | GhostVarAvailable _ -> (module MayBool) | InvariantGlobalNodes -> (module NS) + | IsDeadVar _ -> (module MayBool) + | MayBeDeadAssignment _ -> (module MayBool) (** Get bottom result for query. *) let bot (type a) (q: a t): a result = @@ -295,6 +299,8 @@ struct | YamlEntryGlobal _ -> YS.top () | GhostVarAvailable _ -> MayBool.top () | InvariantGlobalNodes -> NS.top () + | IsDeadVar _ -> MayBool.top () + | MayBeDeadAssignment _ -> MayBool.top () end (* The type any_query can't be directly defined in Any as t, @@ -366,6 +372,8 @@ struct | Any (MustProtectingLocks _) -> 61 | Any (GhostVarAvailable _) -> 62 | Any InvariantGlobalNodes -> 63 + | Any (IsDeadVar _) -> 64 + | Any (MayBeDeadAssignment _) -> 65 let rec compare a b = let r = Stdlib.compare (order a) (order b) in @@ -540,6 +548,8 @@ struct | Any (GasExhausted f) -> Pretty.dprintf "GasExhausted %a" CilType.Fundec.pretty f | Any (GhostVarAvailable v) -> Pretty.dprintf "GhostVarAvailable %a" WitnessGhostVar.pretty v | Any InvariantGlobalNodes -> Pretty.dprintf "InvariantGlobalNodes" + | Any (IsDeadVar v) -> Pretty.dprintf "IsDeadVar %a" CilType.Varinfo.pretty v + | Any (MayBeDeadAssignment s) -> Pretty.dprintf "MayBeDeadAssignment %a" CilType.Lval.pretty s end let to_value_domain_ask (ask: ask) = diff --git a/src/framework/bidirConstrains.ml b/src/framework/bidirConstrains.ml index 50ea5c2337..3c3cf17938 100644 --- a/src/framework/bidirConstrains.ml +++ b/src/framework/bidirConstrains.ml @@ -651,6 +651,14 @@ struct Some tf_backw let system var = + + (* let log () = + match var with + | `L_forw (v, _) -> Logs.debug "(*) Creating tf for forward variable %a" Node.pretty v + | `L_backw (v, _) -> Logs.debug "(*) Creating tf for backward variable %a" Node.pretty v + in + log(); *) + match var with | `L_forw v -> Forward.system v diff --git a/src/framework/control.ml b/src/framework/control.ml index b7dec1a049..ffca50ade7 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -1385,18 +1385,20 @@ struct (* Lifting and combining the startvars and entrystates from forwards and backwards analysis*) let startvars' = List. append (List.map (fun v -> `L_forw v) startvars'_forw) (List.map (fun v -> `L_backw v) startvars'_backw) in + (* let startvars' = List. append (List.map (fun v -> `L_backw v) startvars'_backw) (List.map (fun v -> `L_forw v) startvars'_forw) in *) let entrystates = List.append (List.map (fun (v, d) -> (`L_forw v, `Lifted1 d)) entrystates_forw) (List.map (fun (v, d) -> (`L_backw v, `Lifted2 d)) entrystates_backw) in startvars', entrystates, entrystates_global in + (** solves constraint system*) let solve () = let solver_data = None in let startvars', entrystates, entrystates_global = calculate_solver_input () in let log_analysis_inputs () = - Logs.debug "=== Analysis Inputs ==="; + Logs.debug "================= Analysis Inputs ================"; (* Log entrystates *) Logs.debug "--- Entry States (count: %d) ---" (List.length entrystates); @@ -1441,57 +1443,145 @@ struct Logs.debug " Context: %a" Spec_forw.C.pretty ctx ) *) ) startvars'; - - Logs.debug "=== End Analysis Inputs ===" + Logs.debug "=============== End Analysis Inputs ==============" in log_analysis_inputs (); + AnalysisState.should_warn := true; + let (lh, gh), solver_data = Slvr.solve entrystates entrystates_global startvars' solver_data in let log_lh_contents lh = let print_forw_entries : bool = false in - let print_backw_entries : bool = true in + let print_backw_entries : bool = false in + + if print_forw_entries || print_backw_entries then ( + + Logs.debug "================= LHT Contents ==================="; + Logs.debug "LHT size: %d" (LHT.length lh); + let count = ref 0 in + + Logs.debug "--- Full entry details ---"; + LHT.iter (fun v state -> + incr count; + Logs.debug "Entry %d:" !count; + if (match v with `L_forw _ -> print_forw_entries | `L_backw _ -> print_backw_entries) + then ( + Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; + Logs.debug " Context: %a" Spec_forw.C.pretty (match v with + | `L_forw (_, ctx) + | `L_backw (_, ctx) -> ctx); + (match state with + | `Lifted1 d -> + (try + Logs.debug " State:%a" Spec_forw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e)) + | `Lifted2 d -> + (try + Logs.debug " State: %a" Spec_backw.D.pretty d + with e -> + Logs.debug " State: ERROR - %s" (Printexc.to_string e) + ); + | `Top -> + Logs.debug " State kind: Top"; + | `Bot -> + Logs.debug " State kind: Bot" + ); + ) else ( + Logs.debug " (Entry skipped in log)" + ) + ) + lh; + Logs.debug "Total entries in LHT: %d" !count; + Logs.debug "=============== End LHT Contents ================="; + ) else (); + in + log_lh_contents lh; - Logs.debug "=== LHT Contents ==="; - Logs.debug "LHT size: %d" (LHT.length lh); - let count = ref 0 in + (* To check for unnacessary assigns, one has to take the join over all variables for that programm point*) + let warn_unnecessary_assignments () = + let post_backward_states_for_node (node: Node.t) : Spec_backw.D.t list = + let succ_nodes = List.map snd (Cfg.next node) in + LHT.fold (fun key state acc -> + match key, state with + | `L_backw (node', _), `Lifted2 d when List.exists (Node.equal node') succ_nodes -> d :: acc + | _ -> acc + ) lh [] + in - Logs.debug "--- Full entry details ---"; - LHT.iter (fun v state -> - incr count; - Logs.debug "Entry %d:" !count; - if (match v with `L_forw _ -> print_forw_entries | `L_backw _ -> print_backw_entries) - then ( - Logs.debug " Var: %a" EQSys.LVar.pretty_trace v; - Logs.debug " Context: %a" Spec_forw.C.pretty (match v with - | `L_forw (_, ctx) - | `L_backw (_, ctx) -> ctx); - (match state with - | `Lifted1 d -> - (try - Logs.debug " State:%a" Spec_forw.D.pretty d - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e)) - | `Lifted2 d -> - (try - Logs.debug " State: %a" Spec_backw.D.pretty d - with e -> - Logs.debug " State: ERROR - %s" (Printexc.to_string e) - ); - | `Top -> - Logs.debug " State kind: Top"; - | `Bot -> - Logs.debug " State kind: Bot" - ); - ) else ( - Logs.debug " (Entry skipped in log)" + let may_be_dead_assignment_in_state (node: Node.t) (state: Spec_backw.D.t) (lv: lval) : bool = + (* log *) + (* Logs.debug "Checking if assignment may be dead at node %a in state %a" Node.pretty_trace node Spec_backw.D.pretty state; *) + + let man_backw = + { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) + ; emit = (fun _ -> failwith "Cannot \"emit\" in dead-assignment query helper.") + ; node = node + ; prev_node = MyCFG.dummy_node + ; control_context = (fun () -> man_failwith "dead-assignment query helper has no control_context.") + ; context = (fun () -> man_failwith "dead-assignment query helper has no context.") + ; edge = MyCFG.Skip + ; local = state + ; global = (fun _ -> Spec_backw.G.bot ()) + ; spawn = (fun ?(multiple=false) _ -> failwith "dead-assignment query helper cannot spawn threads.") + ; split = (fun _ -> failwith "dead-assignment query helper cannot split paths.") + ; sideg = (fun _ _ -> failwith "dead-assignment query helper cannot side-effect globals.") + } + in + let man_forw = + { ask = (fun (type a) (q: a Queries.t) -> Queries.Result.top q) + ; emit = (fun _ -> failwith "Cannot \"emit\" in dead-assignment query helper.") + ; node = node + ; prev_node = MyCFG.dummy_node + ; control_context = (fun () -> man_failwith "dead-assignment query helper has no control_context.") + ; context = (fun () -> man_failwith "dead-assignment query helper has no context.") + ; edge = MyCFG.Skip + ; local = Spec_forw.D.top () + ; global = (fun _ -> Spec_forw.G.bot ()) + ; spawn = (fun ?(multiple=false) _ -> failwith "dead-assignment query helper cannot spawn threads.") + ; split = (fun _ -> failwith "dead-assignment query helper cannot split paths.") + ; sideg = (fun _ _ -> failwith "dead-assignment query helper cannot side-effect globals.") + } + in + Spec_backw.query man_backw man_forw (Queries.MayBeDeadAssignment lv) + in + + let assigned_lvals_of_stmt (s: stmt) : lval list = + match s.skind with + | Instr instrs -> + List.fold_left (fun acc instr -> + match instr with + | Set (lv, _, _, _) -> lv :: acc + | Call (Some lv, _, _, _, _) -> lv :: acc + | _ -> acc + ) [] instrs + | _ -> [] + in + + let warn_assignment_stmt (s: stmt) = + let node = Statement s in + let assigned_lvals = assigned_lvals_of_stmt s in + match assigned_lvals with + | [] -> () + | _ -> + let states = post_backward_states_for_node node in + if states <> [] then ( + List.iter (fun lv -> + let dead_in_all_contexts = + List.for_all (fun st -> may_be_dead_assignment_in_state node st lv) states + in + if dead_in_all_contexts then + M.warn ~loc:(M.Location.Node node) ~category:MessageCategory.Program "Unnecessary assignment: this assignment may be dead in every post-assignment context." + ) assigned_lvals ) - ) - lh; - Logs.debug "Total entries in LHT: %d" !count; - Logs.debug "=== End LHT Contents ==="; + in + List.iter (function + | GFun (fd, _) -> List.iter warn_assignment_stmt fd.sallstmts + | _ -> () + ) file.globals in - log_lh_contents lh; + warn_unnecessary_assignments (); let make_global_fast_xml f g = let open Printf in @@ -1551,7 +1641,7 @@ struct let oc = Stdlib.open_out xml_path in Stdlib.output_string oc updated_content; Stdlib.close_out oc; - Logs.debug "Updated XML file for node %s" node_id_str + (* Logs.debug "Updated XML file for node %s" node_id_str *) ) with _ -> () (* Skip errors silently *) ) diff --git a/tests/regression/99-tutorials/14-motivating_example.c b/tests/regression/99-tutorials/14-motivating_example.c new file mode 100644 index 0000000000..d7a98140b5 --- /dev/null +++ b/tests/regression/99-tutorials/14-motivating_example.c @@ -0,0 +1,34 @@ +// SKIP TERM PARAM: --enable ana.wp_run + +int f(int a, int b) +{ + if (a < 0) { + return a + b; + } else { + return a; + } +} + +int g(int a, int b) +{ + if (a > 0) { + return a - b; + } else { + return a; + } +} +int main() +{ + int x = 0; + int y = 1; + int *c = &x; + int (*h) (int, int) = &f; + + if (*c) { + h = &g; + } + + *c = 2; + int z = h(x, y); + return z; +} diff --git a/tests/regression/99-tutorials/15-same_proc_different_results.c b/tests/regression/99-tutorials/15-same_proc_different_results.c new file mode 100644 index 0000000000..4967a2c1b1 --- /dev/null +++ b/tests/regression/99-tutorials/15-same_proc_different_results.c @@ -0,0 +1,24 @@ +// SKIP TERM PARAM: --enable ana.wp_run + +int f(int a) +{ + int b = 3; // no warning, as b is used in one call of f + + if (a < 5) { + return a + b; + } else { + return a; + } +} + +int main() +{ + int x = 0; + + int u = f (x); + + x = 10; + + int v = f (x); + return u + v; +} From 39a493c217cec7c6db9c399a87d3a5fbd370d70f Mon Sep 17 00:00:00 2001 From: Emil Winterhalder Date: Thu, 30 Apr 2026 12:30:24 +0200 Subject: [PATCH 29/29] Liveness analysis: soundly overapproximate partial updates to structs and arrays - This commit modifies the liveness analysis to handle partial updates to structs and arrays more soundly. - Also tests are added and modified --- src/analyses/wp_analyses/liveness.ml | 105 ++++++++++++------ src/framework/control.ml | 1 - .../99-tutorials/14-motivating_example.c | 13 +-- .../99-tutorials/16-global_variables.c | 14 +++ .../99-tutorials/17-global_func_pointer_mod.c | 23 ++++ .../99-tutorials/18-pointer_to_partial_obj.c | 8 ++ .../99-tutorials/19-struct_partial_update.c | 14 +++ .../20-struct_ptr_partial_update.c | 17 +++ 8 files changed, 153 insertions(+), 42 deletions(-) create mode 100644 tests/regression/99-tutorials/16-global_variables.c create mode 100644 tests/regression/99-tutorials/17-global_func_pointer_mod.c create mode 100644 tests/regression/99-tutorials/18-pointer_to_partial_obj.c create mode 100644 tests/regression/99-tutorials/19-struct_partial_update.c create mode 100644 tests/regression/99-tutorials/20-struct_ptr_partial_update.c diff --git a/src/analyses/wp_analyses/liveness.ml b/src/analyses/wp_analyses/liveness.ml index 4da4cf1bb3..fc442d9c29 100644 --- a/src/analyses/wp_analyses/liveness.ml +++ b/src/analyses/wp_analyses/liveness.ml @@ -66,7 +66,7 @@ struct | BinOp (_, e1, e2, _) -> let acc1 = aux acc e1 in aux acc1 e2 - | UnOp (_, e1, _) -> aux acc e1 + | UnOp (_, e1, _) -> aux acc e1 | SizeOfE e1 -> aux acc e1 | AlignOfE e1 -> aux acc e1 | Question (e1, e2, e3, _) -> @@ -85,25 +85,51 @@ struct let rec assign man man_forw (lval:lval) (rval:exp) = match lval with - | Var v, _ -> - if (D.mem v man.local || v.vglob) then ( (* Global variables are considered live when writing to them. *) - let rval_vars = D.of_list (vars_from_expr rval man_forw) + | Var v, offset -> + if (D.mem v man.local) then ( (* Global variables are considered live when writing to them -> No, not anymore. This of course does not wark with concurrent programs, but I am already excluding those. *) + let rval_vars = D.of_list (vars_from_expr rval man_forw)in + let rval_vars = D.filter (fun v -> not (Cil.isFunctionType v.vtype)) rval_vars in (*remove variables that are just function names*) + + let offset_vars = D.of_list (vars_from_offset offset man_forw) in + let base_live = + match offset with + | NoOffset -> D.diff man.local (D.singleton v) + | _ -> man.local in - D.union rval_vars (D.diff man.local (D.singleton v)) + + D.union rval_vars (D.union offset_vars base_live) ) else ( (* let loc = M.Location.Node man.node in *) (* M.warn ~loc:loc ~category:MessageCategory.Program "Unnecessary assignment to variable '%s', as it is not live at this program point." v.vname; *) man.local ) - | Mem exp, _ -> - let may_point_to = Queries.AD.to_var_may (man_forw.ask (MayPointTo exp)) in + | Mem exp, off -> + let ad = man_forw.ask (MayPointTo exp) in let lval_vars = D.of_list (vars_from_expr exp man_forw) in let rval_vars = D.of_list (vars_from_expr rval man_forw) in - - match may_point_to with (*POSSIBLY UNSOUND: could also be an overapproximation, depending on whether assumption is true*) - | [v] -> - D.union (assign man man_forw (Var v, NoOffset) rval) lval_vars (* We assume that if it my only point to one variable, we can treat this as if we just assigned to that variable*) - | _ -> D.union rval_vars (D.union lval_vars man.local) + let rval_vars = D.filter (fun v -> not (Cil.isFunctionType v.vtype)) rval_vars in (*remove variables that are just function names*) + + let strong_target = + match off, Queries.AD.to_mval ad with + | NoOffset, [(v, `NoOffset)] when Queries.AD.is_element (Queries.AD.Addr.of_mval (v, `NoOffset)) ad -> Some v + | _ -> None + in + + + let log_this ()= + Logs.debug "(!) Assignment to memory location %a with may-point-to set [?]" d_exp exp; + Logs.debug "Variables in the lval: %s" (String.concat ", " (List.map (fun v -> v.vname) (D.elements lval_vars))); + Logs.debug "Variables in the rval: %s" (String.concat ", " (List.map (fun v -> v.vname) (D.elements rval_vars))); + match strong_target with + | Some v -> Logs.debug "Strong target variable: %s" v.vname + | None -> Logs.debug "No strong target variable identified" + in + log_this (); + + match strong_target with + | Some v -> + D.union (assign man man_forw (Var v, NoOffset) rval) lval_vars + | None -> D.union rval_vars (D.union lval_vars man.local) let branch man man_forw (exp:exp) (tv:bool) = (* This just randomly asks whether all loops terimante to use getg_forw utilized in man.global *) @@ -128,15 +154,22 @@ struct let enter man man_forw (lval: lval option) (f:fundec) (args:exp list) = - match lval with - | Some (Var v, _) -> - if (D.mem v man.local) then ( - [man.local, (D.singleton v)] - ) else ( - [man.local, D.empty()] - ) - | Some (Mem exp, _) -> [man.local, D.of_list (vars_from_expr exp man_forw)] - | None -> [man.local, D.empty()] + let global_vars_in_d = D.filter (fun v -> v.vglob) man.local in + + let callee_d = + match lval with + | Some (Var v, _) -> + if (D.mem v man.local) then ( + (D.singleton v) + ) else ( + D.empty() + ) + | Some (Mem exp, _) -> D.of_list (vars_from_expr exp man_forw) + | None -> D.empty() + in + + [man.local, (D.union callee_d global_vars_in_d)] + let combine_env man man_forw (lval:lval option) fexp (f:fundec) (args:exp list) fc au (f_ask: Queries.ask) = @@ -166,10 +199,10 @@ struct let return_val_is_important = (not (D.is_bot man.local)) || (String.equal f.svar.vname "main") in match exp with - | None -> D.empty() + | None -> man.local | Some e -> if return_val_is_important - then D.of_list (vars_from_expr e man_forw) - else D.empty() + then D.of_list (vars_from_expr e man_forw) |> D.union man.local + else man.local let special man man_forw (lval: lval option) (f:varinfo) (arglist:exp list) = @@ -198,28 +231,34 @@ struct | Var v, _ -> Logs.debug "D.mem v man.local is %b" (D.mem v man.local); Logs.debug "v.glob is %b" v.vglob; - if (D.mem v man.local || v.vglob) then + if (D.mem v man.local) then ( (*I used to care whether a variable is global, I no longer do.*) let rval_vars = D.of_list (vars_from_expr rval man_forw) in (D.union rval_vars (D.diff man.local (D.singleton v)), false) - else ( + )else ( Logs.debug "Variable '%s' is not live at this program point." v.vname; (man.local, true) ) - | Mem exp, _ -> ( + | Mem exp, off -> ( Logs.debug "lval is expression"; - let may_point_to = Queries.AD.to_var_may (man_forw.ask (MayPointTo exp)) in + let ad = man_forw.ask (MayPointTo exp) in let lval_vars = D.of_list (vars_from_expr exp man_forw) in let rval_vars = D.of_list (vars_from_expr rval man_forw) in - match may_point_to with (*POSSIBLY UNSOUND: could also be an overapproximation, depending on whether assumption is true*) - | [v] -> + let strong_target = + match off, Queries.AD.to_mval ad with + | NoOffset, [(v, `NoOffset)] when Queries.AD.is_element (Queries.AD.Addr.of_mval (v, `NoOffset)) ad -> Some v + | _ -> None + in + + match strong_target with + | Some v -> let rec_assign_result, is_dead = - match (is_dead_assign man man_forw (Var v, NoOffset) rval is_dead) with + match (is_dead_assign man man_forw (Var v, NoOffset) rval is_dead) with | (res, new_is_dead) -> res, new_is_dead in - (D.union rec_assign_result lval_vars, is_dead)(* We assume that if it my only point to one variable, we can treat this as if we just assigned to that variable*) - | _ -> ((D.union rval_vars (D.union lval_vars man.local)), is_dead) + (D.union rec_assign_result lval_vars, is_dead) + | None -> ((D.union rval_vars (D.union lval_vars man.local)), is_dead) ) in diff --git a/src/framework/control.ml b/src/framework/control.ml index ffca50ade7..d9fd6a79bb 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -1647,7 +1647,6 @@ struct ) ) lh in - output_wp_results_to_xml lh; in diff --git a/tests/regression/99-tutorials/14-motivating_example.c b/tests/regression/99-tutorials/14-motivating_example.c index d7a98140b5..d3f1196972 100644 --- a/tests/regression/99-tutorials/14-motivating_example.c +++ b/tests/regression/99-tutorials/14-motivating_example.c @@ -2,11 +2,7 @@ int f(int a, int b) { - if (a < 0) { - return a + b; - } else { - return a; - } + return a + b; } int g(int a, int b) @@ -17,10 +13,11 @@ int g(int a, int b) return a; } } + int main() { - int x = 0; - int y = 1; + int x = 1; + int y = 2; int *c = &x; int (*h) (int, int) = &f; @@ -28,7 +25,7 @@ int main() h = &g; } - *c = 2; + *c = 0; int z = h(x, y); return z; } diff --git a/tests/regression/99-tutorials/16-global_variables.c b/tests/regression/99-tutorials/16-global_variables.c new file mode 100644 index 0000000000..c26763d2d8 --- /dev/null +++ b/tests/regression/99-tutorials/16-global_variables.c @@ -0,0 +1,14 @@ +// SKIP TERM PARAM: --enable ana.wp_run + +int x = 0; + +int f() +{ + x ++; +} + +int main() +{ + f(); + return 0; +} diff --git a/tests/regression/99-tutorials/17-global_func_pointer_mod.c b/tests/regression/99-tutorials/17-global_func_pointer_mod.c new file mode 100644 index 0000000000..b33f06422a --- /dev/null +++ b/tests/regression/99-tutorials/17-global_func_pointer_mod.c @@ -0,0 +1,23 @@ +// SKIP TERM PARAM: --enable ana.wp_run +int (*h) (int); + +int g(int a) +{ + return 0; +} + +int f(int a) +{ + h = &g; + return a; +} + +int main() +{ + int x = 1; + h = &f; + + int y = h(x); + + return y; +} diff --git a/tests/regression/99-tutorials/18-pointer_to_partial_obj.c b/tests/regression/99-tutorials/18-pointer_to_partial_obj.c new file mode 100644 index 0000000000..eb63006c90 --- /dev/null +++ b/tests/regression/99-tutorials/18-pointer_to_partial_obj.c @@ -0,0 +1,8 @@ +// SKIP TERM PARAM: --enable ana.wp_run +int main() +{ + int x[] = {1, 2, 3}; + x [0] = 0; + + return x[1]; +} diff --git a/tests/regression/99-tutorials/19-struct_partial_update.c b/tests/regression/99-tutorials/19-struct_partial_update.c new file mode 100644 index 0000000000..69c14d3c46 --- /dev/null +++ b/tests/regression/99-tutorials/19-struct_partial_update.c @@ -0,0 +1,14 @@ +// SKIP TERM PARAM: --enable ana.wp_run + +struct Pair { + int a; + int b; +}; + +int main() +{ + struct Pair p; + p.b = 42; + p.a = 1; + return p.b; +} diff --git a/tests/regression/99-tutorials/20-struct_ptr_partial_update.c b/tests/regression/99-tutorials/20-struct_ptr_partial_update.c new file mode 100644 index 0000000000..d916c19d60 --- /dev/null +++ b/tests/regression/99-tutorials/20-struct_ptr_partial_update.c @@ -0,0 +1,17 @@ +// SKIP TERM PARAM: --enable ana.wp_run + +struct Pair { + int a; + int b; +}; + +int main() +{ + struct Pair p; + struct Pair *pp = &p; + + pp->b = 42; + pp->a = 1; + + return p.b; +}