From 5637aa7a72f67628e6c96053083abfe8e33eae4c Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Sat, 6 Jul 2024 02:32:52 +0800 Subject: [PATCH 01/59] GPS-related modifications --- duet/cra.ml | 110 ++++--- duet/gps.ml | 687 +++++++++++++++++++++++++++++++++++++++++++ duet/reachTree.ml | 710 +++++++++++++++++++++++++++++++++++++++++++++ duet/reachTree.mli | 137 +++++++++ 4 files changed, 1606 insertions(+), 38 deletions(-) create mode 100644 duet/gps.ml create mode 100644 duet/reachTree.ml create mode 100644 duet/reachTree.mli diff --git a/duet/cra.ml b/duet/cra.ml index cedbebca..afed1833 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -90,45 +90,79 @@ let map_value f = function | VPos v -> VPos (f v) | VWidth v -> VWidth (f v) -module V = struct - module I = struct - type t = value [@@deriving ord] - let pp formatter = function - | VVal v -> Var.pp formatter v - | VWidth v -> Format.fprintf formatter "%a@@width" Var.pp v - | VPos v -> Format.fprintf formatter "%a@@pos" Var.pp v - let show = SrkUtil.mk_show pp - let equal x y = compare x y = 0 - let hash = function - | VVal v -> Hashtbl.hash (Var.hash v, 0) - | VPos v -> Hashtbl.hash (Var.hash v, 1) - | VWidth v -> Hashtbl.hash (Var.hash v, 2) - end - include I - - let sym_to_var = Hashtbl.create 991 - let var_to_sym = ValueHT.create 991 - - let typ v = tr_typ (Var.get_type (var_of_value v)) - - let symbol_of var = - if ValueHT.mem var_to_sym var then - ValueHT.find var_to_sym var - else begin - let sym = Ctx.mk_symbol ~name:(show var) (typ var) in - ValueHT.add var_to_sym var sym; - Hashtbl.add sym_to_var sym var; - sym + module V = struct + module I = struct + type t = value [@@deriving ord] + let pp formatter = function + | VVal v -> Var.pp formatter v + | VWidth v -> Format.fprintf formatter "%a@@width" Var.pp v + | VPos v -> Format.fprintf formatter "%a@@pos" Var.pp v + let show = SrkUtil.mk_show pp + let equal x y = compare x y = 0 + let hash = function + | VVal v -> Hashtbl.hash (Var.hash v, 0) + | VPos v -> Hashtbl.hash (Var.hash v, 1) + | VWidth v -> Hashtbl.hash (Var.hash v, 2) end - - let of_symbol sym = - if Hashtbl.mem sym_to_var sym then - Some (Hashtbl.find sym_to_var sym) - else - None - - let is_global = Var.is_global % var_of_value -end + include I + + + + let sym_to_var = Hashtbl.create 991 + let var_to_sym = ValueHT.create 991 + let prophecy_vars = ValueHT.create 991 (* var -> var mapping *) + let var_of_prophecy_vars = ValueHT.create 991 (* reverse mapping of prophecy_vars *) + + let typ v = tr_typ (Var.get_type (var_of_value v)) + + let symbol_of var = + if ValueHT.mem var_to_sym var then + ValueHT.find var_to_sym var + else begin + let sym = Ctx.mk_symbol ~name:(show var) (typ var) in + ValueHT.add var_to_sym var sym; + Hashtbl.add sym_to_var sym var; + sym + end + + let of_symbol sym = + if Hashtbl.mem sym_to_var sym then + Some (Hashtbl.find sym_to_var sym) + else + None + + let is_global = Var.is_global % var_of_value + + let make_var sym is_global = + let v = + begin match is_global with + | true -> + Varinfo.mk_global (Syntax.show_symbol srk sym) (Concrete (Int 8)) + | false -> + Varinfo.mk_local (Syntax.show_symbol srk sym) (Concrete (Int 8)) + end |> Var.mk + in + Hashtbl.add sym_to_var sym (VVal v); + ValueHT.add var_to_sym (VVal v) sym; + VVal v + + let prophesize var = + let sym = symbol_of var in + let sym_name = (Syntax.show_symbol srk sym) ^ "_prophecy" in + let sym' = Syntax.mk_symbol srk ~name:sym_name (Syntax.typ_symbol srk sym) in + let var' = make_var sym' false in + ValueHT.add prophecy_vars var var'; + ValueHT.add var_of_prophecy_vars var' var; + var' + + let var_of_prophecy_var var' = ValueHT.find_opt var_of_prophecy_vars var' + let prophecy_var_of_var var = ValueHT.find_opt prophecy_vars var + let is_prophecy_var v = + match var_of_prophecy_var v with + | Some _ -> true + | None -> false + end + module K = struct module Tr = Transition.Make(Ctx)(V) diff --git a/duet/gps.ml b/duet/gps.ml new file mode 100644 index 00000000..346a8cff --- /dev/null +++ b/duet/gps.ml @@ -0,0 +1,687 @@ +open Core +open Srk +open CfgIr +open BatPervasives +open Cra + +(*module RG = Interproc.RG +module WG = WeightedGraph +module TLLRF = TerminationLLRF +module TDTA = TerminationDTA +module TPRF = TerminationPRF +module G = RG.G +(*module Ctx = Syntax.MakeSimplifyingContext ()*) +module Int = SrkUtil.Int +module TF = TransitionFormula*) +module TS = TransitionSystem.Make(Ctx)(V)(K) + + +module ProcName = struct + type t = int * int + + let make ((u, v) : TS.vertex * TS.vertex) : t = (u, v) + + let string_of (p: t) = + let u, v = p in Printf.sprintf "%d:%d" u v + + let of_string (s: string) = + match String.split_on_char ':' s with + | [ us ; vs ] -> (make ((int_of_string us), (int_of_string vs))) + | _ -> failwith @@ Printf.sprintf "illegal procedure identifier %s" s + + (* lexicographic comparison using Stdlib.compare *) + let compare (p1: t) (p2: t) = Stdlib.compare p1 p2 +end + +module ProcMap = BatMap.Make(ProcName) +module IntMap = BatMap.Make(Int) +module StringMap = BatMap.Make(String) +module ISet = BatSet.Make(Int) +module DQ = BatDeque +module ARR = Batteries.DynArray +type cfg_t = TSG.t +type idq_t = int BatDeque.t +type state_formula = Ctx.t Syntax.formula +exception Mexception of string +let mk_true () = Syntax.mk_true Ctx.context +let mk_false () = Syntax.mk_false Ctx.context +let mk_query ts entry = TS.mk_query ts entry (if !monotone then (module MonotoneDom) else (module TransitionDom)) + +let log_formulas prefix formulas = + List.iteri (fun i f -> logf ~level:`always "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr srk) f) formulas + +let log_weights prefix weights = + List.iteri (fun i f -> logf ~level:`always "[weight] %s(%i): %a\n" prefix i K.pp f) weights + + +let log_model prefix model = + logf ~level:`always "[model] %s: %a\n" prefix Interpretation.pp model + +(* +let assert_i = ref 0 +let new_assert_var cond = + let i = !assert_i in + let name = "__assert" ^ (string_of_int i) in + let v = Varinfo.mk_global name (Concrete (Int 8)) |> Var.mk in + let assert_var = Syntax.mk_symbol srk ~name:name `TyInt in + let assert_term = Syntax.mk_const srk assert_var in + assert_i := !assert_i + 1; + K.assign v cond + +let process_interproc_assertion (ts: cfg_t) (phi: Ctx.formula) v = + let a_var, a_term = new_assert_var @@ Ctx.mk_not phi in + +*) + +(* Convert assertion checking problem to vertex reachability problem. *) +let make_ts_assertions_unreachable (ts : cfg_t) assertions = + let largest = ref (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in + let pts = ref ts in + let new_vertices = ref [] in + assertions |> SrkUtil.Int.Map.iter ( + fun v (phi, _, _) -> + (* For each assertion, create new vertex after the assertion state + * with edge into the vertex being the negated condition. *) + let u = !largest + 1 in + largest := (!largest) + 1; + pts := WG.add_vertex !pts u ; + pts := WG.add_edge !pts v (Weight (K.assume (Ctx.mk_not phi))) u ; + let s = Printf.sprintf " Adding assertion node %d -> %d for label " v u in + log_formulas s [ Ctx.mk_not phi ] ; + new_vertices := u :: !new_vertices + ); !pts, !new_vertices + +let instrument_with_gas (ts: cfg_t) = + let mk_int k = Ctx.mk_real (QQ.of_int k) in + let largest = ref (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in + let new_vtx () = + largest := !largest + 1; !largest in + let gas_var = Var.mk (Varinfo.mk_global "__duet_gas" (Concrete (Int 8))) in + let gas_var_sym = Syntax.mk_symbol srk ~name:"__duet_gas" `TyInt in + let gas_var_term = Syntax.mk_const srk gas_var_sym in + let gasexpr = + let open Syntax.Infix(Ctx) in + let assume_positive = K.assume (Syntax.mk_lt srk (mk_int 0) gas_var_term) in + let decr_by_one = Syntax.mk_sub srk gas_var_term (mk_int 1) |> K.assign (VVal gas_var) in + K.mul assume_positive decr_by_one in + Hashtbl.add V.sym_to_var gas_var_sym (VVal gas_var); + ValueHT.add V.var_to_sym (VVal gas_var) gas_var_sym; + (* for each call-edge, u->v, add new predecessor edge x->u->v where x->u is an instrumented edge. *) + let loop_headers = + let module L = Loop.Make(TSG) in + List.map (fun loop -> L.header loop) @@ L.all_loops (L.loop_nest ts) in + let call_edge_headers = + WG.fold_edges (fun (u, w, _) ls -> + match w with + | Call _ -> u :: ls + | _ -> ls) ts [] in + let modify ts u = + let g = ref ts in + (* step 1: add new in-edge to (u, v) *) + let x = new_vtx () in + g := WG.add_vertex !g x; + (* step 2: add weighted edge x-(gasexpr)->u *) + g := WG.add_edge !g x (Weight gasexpr) u; + (* step 3: redirect every p->u to be y->x->u *) + WG.iter_pred_e (fun (p, weight, _) -> + g := WG.add_edge !g p weight x; + g := WG.remove_edge !g p u + ) ts u; + !g in + let g = ref ts in + List.iter (fun u -> g := modify !g u) (loop_headers @ call_edge_headers); + !g + +module Summarizer = + struct + module SMap = BatMap.Make(ProcName) + type t = { + graph: cfg_t; + src: int; + query: TS.query; + mutable underapprox: K.t SMap.t + } + + let init (graph: cfg_t) (src: int) : t = + let q = mk_query graph src in + { graph = graph; src = src; query = q; underapprox = SMap.empty } + + (** retrieve over-approximate procedure summary *) + let over_proc_summary (ctx: t) ((u, v) : ProcName.t) = + TS.get_summary ctx.query (u, v) + |> K.exists (V.is_global) + + (** set over-approximate procedure summary *) + let set_over_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) = + TS.set_summary ctx.query (u, v) w + + (** retrieve under-approximate procedure summary *) + let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = + SMap.find_default K.zero (u, v) ctx.underapprox + |> K.exists (V.is_global) + + (** set under-approximate procedure summary *) + let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = + ctx.underapprox <- SMap.add (u, v) w ctx.underapprox + + (** refinement of procedure summaries using a two-voc transition formula *) + let refine_over_summary (ctx: t) ((u, v): ProcName.t) (rfn: K.t) = + over_proc_summary ctx (u, v) + |> K.conjunct rfn + |> set_over_proc_summary ctx (u, v) + + let refine_under_summary (ctx: t) ((u, v): ProcName.t) (w:K.t) : unit = + let summary = under_proc_summary ctx (u, v) in + let summary' = K.add summary w in + log_weights "under-approx summary refined to " [summary']; + set_under_proc_summary ctx (u, v) summary' + + let path_weight_intra (ctx: t) (src: int) (dst: int) = + TS.intra_path_summary ctx.query src dst + + let path_weight_inter (ctx: t) (src: int) (dst: int) = + TS.inter_path_summary ctx.query src dst + end + + + type path_type = + | OverApprox + | UnderApprox + +let log_labelled_weights s uu prefix weights = + List.iteri + (fun i f -> + match f with + | Call (u, v)-> + let p = + begin match uu with + | OverApprox -> Summarizer.over_proc_summary s (ProcName.make (u, v)) + | UnderApprox -> Summarizer.under_proc_summary s (ProcName.make (u, v)) + end in + logf ~level:`always "[labelled weight] %s(%i, call(%d,%d)): %a\n" prefix i u v K.pp p + | Weight w -> + logf ~level:`always "[labelled weight] %s(%i): %a\n" prefix i K.pp w) weights + +let srk = Ctx.context + +module GPS = struct + (* vertex names module *) + module VN = struct + let to_vertex (v : int) : TS.vertex = v + let of_vertex (v : TS.vertex) : int = v + end + (* we need to augment the `TS` module to include some extra stuff. *) + module TS' = struct + include TS + let iter_succ_e (f: (TS.vertex * (TS.transition label) * TS.vertex) -> unit) (g: TS.t) (v: TS.vertex) = WG.iter_succ_e f g v + + let fold_succ_e (f : (TS.vertex * (TS.transition label) * TS.vertex) -> 'b -> 'b) (g: TS.t) (u: TS.vertex) (s: 'b) = + WG.fold_succ_e f g u s + + let edge_weight g u v = WG.edge_weight g u v + end + (* ART module *) + module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer) + + (* to print the reachability tree (+ worklist), or not *) + let print_tree = false + + type global_context = { + interproc: Summarizer.t; + } + and mc_result = + | Safe of K.t + | Unsafe of K.t + + + (* contextual information maintained by GPS algorithm. *) + (* intraprocedural context *) + type intra_context = { + id : ProcName.t; + ts : cfg_t; + recurse_level : int; + precondition : K.t; + pre_state : Ctx.t Syntax.formula; + equalities: value ValueHT.t; + mutable art : ReachTree.t ref; + mutable worklist : ReachTree.node DQ.t; + mutable execlist : (ReachTree.node * Ctx.t Interpretation.interpretation) DQ.t; + global_ctx : global_context ref; + } + (* global context *) + (** some helper functions that operate on the context *) + + + let demote_precondition (precondition: K.t) = + let pre_guard, pre_transform = K.guard precondition, K.transform precondition in + let pre_state = ref @@ pre_guard in + let equalities = ValueHT.create 991 in + BatEnum.iter (fun (var, asgn) -> + let prophecy_var = V.prophesize var in + let prophecy_sym = V.symbol_of prophecy_var in + let prophecy_term = Syntax.mk_const srk prophecy_sym in + ValueHT.add equalities var prophecy_var; + pre_state := Syntax.mk_and srk [!pre_state; (Syntax.mk_eq srk prophecy_term asgn)]) pre_transform; + !pre_state, equalities + + + (* promote an arbitrary state formula (not necessarily the pre-state) to a transition formula. *) + (* To do so, we substitute in fresh skolem symbols for all prophecy variables inside [f], and *) + (* create a transform map, treating the substituted formula as guard. *) + let promote (f : Ctx.t Syntax.formula) = + let sym_map = ValueHT.create 991 in + let substitute = Memo.memo (fun sym -> + match V.of_symbol sym with + | Some v -> + begin match V.var_of_prophecy_var v with + | Some original_var -> + let fresh_skolem = Syntax.mk_symbol srk (Syntax.typ_symbol srk sym) in + let term = Syntax.mk_const srk fresh_skolem in + ValueHT.add sym_map original_var term; + term + | None -> Syntax.mk_const srk sym + end + | None -> Syntax.mk_const srk sym) in + K.construct (Syntax.substitute_const srk substitute f) (ValueHT.to_seq sym_map |> List.of_seq) + + + let mk_intra_context (gctx: global_context ref) (id: ProcName.t) (ts: cfg_t) (recurse_level: int) (precondition: K.t) (entry: int) (err_loc: int) = + let pre_state, equalities = demote_precondition precondition in + ref { + id = id; + ts = ts; + recurse_level = recurse_level; + precondition = precondition; + pre_state = pre_state; + equalities = equalities; + worklist = DQ.empty; + execlist = DQ.empty; + art = ReachTree.make ts entry err_loc pre_state !gctx.interproc; + global_ctx = gctx; + } + and mk_mc_context (global_cfg: cfg_t) (global_src: int) = + ref { + interproc = Summarizer.init global_cfg global_src; + } + + (** place an element in front of the deque (worklist) *) + let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i + + let get_summarizer intra_ctx = + !(!intra_ctx.global_ctx).interproc + + let make_equalities (ctx: intra_context ref) = + ValueHT.fold (fun k v acc -> + let s = V.symbol_of k |> Syntax.mk_const srk in + let s' = V.symbol_of v |> Syntax.mk_const srk in + Syntax.mk_eq srk s s' :: acc) !ctx.equalities [Syntax.mk_true srk] + |> Syntax.mk_and srk + + let oracle ctx u v= + if !ctx.recurse_level = 0 then Summarizer.path_weight_inter (get_summarizer ctx) u v + else Summarizer.path_weight_intra (get_summarizer ctx) u v + + let rec art_cfg_path_pair (ctx: intra_context ref) (p: ReachTree.node list) = + match p with + | u :: v :: t -> + let u_vtx = ReachTree.maps_to !ctx.art u in + let v_vtx = ReachTree.maps_to !ctx.art v in + (u, (u_vtx, v_vtx), v) :: (art_cfg_path_pair ctx (v :: t)) + | _ -> [] + + (* turn tree path into a sequence of CFG edges. *) + let rec cfg_path (ctx: intra_context ref) (p : ReachTree.node list) = + art_cfg_path_pair ctx p + |> List.map (fun (_, (u, v), _) -> (u, v)) + + (* CFG path condition from art.src -> art.v *) + let path_condition (ctx: intra_context ref) condition_type (v: ReachTree.node) = + let art = !ctx.art in + let summarizer = get_summarizer ctx in + let cfg = !ctx.ts in + let art_nodes = ReachTree.tree_path art v in + let cfg_nodes = List.map (fun x -> ReachTree.maps_to art x) art_nodes in + let rec to_weights l : K.t label list = + match l with + | a :: b :: t -> + WG.edge_weight cfg a b :: (to_weights (b :: t)) + | _ -> [] + in + let pathcond = List.map (fun (weight: K.t label) -> + match weight with + | Call (src, dst) -> + begin match condition_type with + | OverApprox -> Summarizer.over_proc_summary summarizer (ProcName.make (src, dst)) + | UnderApprox -> Summarizer.under_proc_summary summarizer (ProcName.make (src, dst)) + end + | Weight w -> w) (to_weights cfg_nodes) in + Printf.printf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); + let l = (K.assume !ctx.pre_state) :: pathcond in + log_weights "path conditions " l; l + + let mk_post (ctx: intra_context ref) (v: ReachTree.node) (sink: TS.vertex) = + let art = !ctx.art in + let post_path_summary = oracle ctx (ReachTree.maps_to art v) sink in + let equalities = make_equalities ctx |> K.assume in + log_weights "\npost_path_summary: " [post_path_summary]; + log_weights "\nequalities: " [equalities]; + Printf.printf "\n"; + K.guard (K.mul post_path_summary equalities) + + (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) + let interpolate_or_get_model (ctx: intra_context ref) (src : ReachTree.node) (sink: TS.vertex) = + let suffix = mk_post ctx src sink |> Syntax.mk_not srk in + let prefix = path_condition ctx OverApprox src in + log_weights "\nprefix " prefix; + log_formulas "\nsuffix " [suffix]; + Printf.printf "\n"; + K.interpolate_or_concrete_model prefix suffix + + let get_global_ctx (ctx: intra_context ref) = (!ctx.global_ctx) + + (* refine path to (tree) node v. + Returns `Failure (u, m) with (u, m) being a new item to the concolic worklist if unable to refine. + Returns `Success if refine is able to refine. *) + let mc_refine (ctx: intra_context ref) (v: ReachTree.node) = + let handle_failure v m = + logf ~level:`always " *********************** REFINEMENT FAILED *************************\n"; + let path_condition = path_condition ctx OverApprox v + in `Failure (m, path_condition) + in let art = !ctx.art in + let path = ReachTree.tree_path art v in + match interpolate_or_get_model ctx v @@ ReachTree.get_err_loc art with + `Invalid v_model -> + logf ~level:`always "Unable to refine but got model\n"; + (* v is no longer a frontier node. *) + handle_failure v v_model + | `Unknown -> failwith "mc_refine: got UNKNOWN as a result for interpolate_or_get_model" + | `Valid interpolants -> + logf ~level:`always "--- mc_refine: interpolation succeeded. path length %d, interpolant length %d" (List.length path) (List.length interpolants); + ReachTree.refine art path interpolants + |> List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist); + `Success + + (* concolic phase of our model checking algorithm *) + let concolic_phase (ctx: intra_context ref) = + let round ctx = + match DQ.front (!ctx.execlist) with + | Some ((u, u_model), w) -> + if print_tree then + ReachTree.log_art !ctx.art; + logf ~level:`always " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); + !ctx.execlist <- w; + if (ReachTree.maps_to !ctx.art u) = (ReachTree.get_err_loc !ctx.art) then + begin match Smt.is_sat srk (make_equalities ctx) with + | `Sat -> + `ErrorReached u + | _ -> !ctx.worklist <- worklist_push u !ctx.worklist; `Continue + end + else begin + logf ~level:`always "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); + log_model "" u_model; + let new_concolic_nodes, new_frontier_nodes = ReachTree.expand !ctx.recurse_level !ctx.art u u_model in + List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; + List.iter (fun frontier_node -> !ctx.worklist <- worklist_push frontier_node !ctx.worklist) new_frontier_nodes; + `Continue + end + | None -> failwith "err: concolic_phase is reading from empty execution worklist" (* cannot happen *) + in + let rtn = ref `Continue in + while !rtn = `Continue && ((DQ.size !ctx.execlist) > 0) do + rtn := round ctx + done; + match !rtn with + | `Continue -> `Safe + | `ErrorReached u -> `Unsafe u + + + (* refinement phase of our model checking algorithm *) + let refinement_phase (ctx: intra_context ref) = + let worklist_push_all ls = + List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist) ls in + match DQ.front (!ctx.worklist) with + | Some (u, w) -> + if print_tree then + ReachTree.log_art !ctx.art; + !ctx.worklist <- w; + (* Fetched tree node u from work list. First attempt to close it. *) + if not (ReachTree.is_covered !ctx.art u) then + begin + logf ~level:`always " uncovered. try close\n"; + begin match ReachTree.lclose !ctx.art u with (* Close succeeded. No need to further explore it. *) + | true, leaves -> + logf ~level:`always "Close succeeded.\n"; + worklist_push_all leaves; + `Continue + | false, leaves -> (* u is uncovered. *) + worklist_push_all leaves; + begin match mc_refine ctx u with + | `Success -> (* refinement succeeded *) + logf ~level:`always "refinement_phase: refinement succeeded\n"; + (* for every node along path of refinement try close *) + let path = ReachTree.tree_path !ctx.art u in + List.iter + (fun x -> let (_, ls) = ReachTree.close !ctx.art x in + worklist_push_all ls) path; + `Continue + | `Failure (u_m, _) -> + !ctx.execlist <- worklist_push (u, u_m) !ctx.execlist; (* put u onto execlist since it now has a model. *) + (* for every node along path of refinement try close *) + let path = ReachTree.tree_path !ctx.art u in + List.iter (fun x -> let (_, ls) = ReachTree.close !ctx.art x in + worklist_push_all ls) path + ; `Continue + end + end + end + else begin + logf ~level:`always "refinement_phase: %d is covered\n" (ReachTree.of_node u); + `Continue + end + | None -> failwith "refinement_phase: encountered an empty worklist for refinement\n" (* cannot happen *) + + + let extract_refinement (ctx: intra_context ref) = + let art = !ctx.art in + let rfn = ReachTree.label art ReachTree.root |> promote in + K.exists (fun v -> V.is_global v) rfn + + let seq = List.fold_left K.mul K.one (* sequentially multiply, left-right *) + + + let rec handle_path_to_error ctx left curr right dir err_leaf : [`Unsafe of K.t | `Safe] = + let handle_right_case caller_id = + let f = List.map (fun (_, w, _) -> w) in + let left = f left in + let right = f right in + match K.project (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with + | `Sat t -> `Unsafe t + | _ -> + Printf.printf " ------------------------ handle_path_to_error debug info: called by case %s ------------------\n" caller_id; + log_weights "faulty weight: " (path_condition ctx UnderApprox err_leaf); + Printf.printf "\nlength of left path: %d" (List.length left); + Printf.printf "\nlength of right path: %d" (List.length right); + Printf.printf "\nPrinting left path... \n"; + log_labelled_weights (get_summarizer ctx) UnderApprox "left path - " left; + failwith "error: handle_path_to_error: cannot project path condition" in + let handle_left_case caller_id = + Printf.printf "handle_path_to_error: %s\n" caller_id; + `Safe in + match curr with + | (_, Weight _, _) -> + begin match left, dir, right with + | [], `Left, _ -> + handle_left_case "reached leftmost item, `curr` variable is NOT a call-edge" + | _, `Right, [] -> + handle_right_case "reached rightmost item, `curr` variable is NOT a call-edge" + | a :: left', `Left, _ -> handle_path_to_error ctx left' a (curr :: right) dir err_leaf + | _, `Right, a :: right' -> handle_path_to_error ctx (curr :: left) a right' dir err_leaf + end + | (u, (Call (src, dst)), _) -> + let prefix = path_condition ctx UnderApprox u |> seq in + let suffix = + List.map (fun (_, ew, _) -> + match ew with + | Weight w -> w + | Call (s, t) -> Summarizer.over_proc_summary (get_summarizer ctx) (ProcName.make (s, t))) + right + |> seq in + let summary = Summarizer.over_proc_summary (get_summarizer ctx) (ProcName.make (src, dst)) in + begin match K.contextualize prefix summary suffix with + | `Sat query -> + let answer = + mk_intra_context (!ctx.global_ctx) (ProcName.make (src, dst)) !ctx.ts (!ctx.recurse_level + 1) query src dst + |> intraproc_check + in begin match answer with + | Safe r -> + Summarizer.refine_over_summary (get_summarizer ctx) (ProcName.make (src, dst)) r; + handle_path_to_error ctx left curr right dir err_leaf + | Unsafe trs -> + begin match trs |> K.project (V.is_global) with + | `Sat tr -> + Summarizer.refine_under_summary (get_summarizer ctx) (ProcName.make (src, dst)) tr; + begin match right with + | a :: right' -> + handle_path_to_error ctx (curr::left) a right' `Right err_leaf + | [] -> (* we're done *) + handle_right_case "rightmost edge is call-edge, underapproximation successful" + end + | _ -> failwith "error: cannot do mbp on returned error trace in handle_path_to_error" + end + end + | `Unsat -> (* procedure summary at `curr` is UNSAT, so backtrack *) + begin match left with + | a :: left' -> + handle_path_to_error ctx left' a (curr :: right) `Left err_leaf + | [] -> (* at the very left. we're done *) + handle_left_case "at the leftmost edge, is a call-edge, done" + end + end + + + and intraproc_check (ctx: intra_context ref) : mc_result = + logf ~level:`always " *********************************************** recurse_level: %d\n" !ctx.recurse_level; + let continue = ref true in + let state = ref `Continue in + !ctx.worklist <- worklist_push (ReachTree.root) !ctx.worklist; + while !continue && (DQ.size (!ctx.worklist) > 0 || DQ.size (!ctx.execlist) > 0) do + if DQ.size (!ctx.execlist) > 0 then begin + (* concolic phase *) + begin match concolic_phase ctx with + | `Unsafe w -> + logf ~level:`always "--- concolic_mcmillan_execute: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to !ctx.art w); + let path_to_w = + ReachTree.tree_path !ctx.art w + |> art_cfg_path_pair ctx + |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight !ctx.ts u_vtx v_vtx, v)) in + begin match path_to_w with + | curr :: right -> + begin match handle_path_to_error ctx [] curr right `Right w with + | `Safe -> (* path-to-error concretization failed. frontier_node is the src node of a call-edge. *) + (* we can mark `w` as a frontier node to be refined, and continue. *) + !ctx.worklist <- worklist_push w !ctx.worklist; + continue := true + | `Unsafe pathcond -> + logf ~level:`always "--- conoclic_mcmilan_execute: managed to concretize an intraprocedural path-to-error. returning... "; + state := `Concretized (pathcond); + continue := false + end + | [] -> + (* corner case: the path to error is of length 0. *) + state := `Concretized (K.one) + end + | `Safe -> + state := `Continue + end + end else begin + (* refinement phase *) + state := refinement_phase ctx + end + done; + match !state with + | `Continue -> Safe (extract_refinement ctx) + | `Concretized cond -> Unsafe (cond) + + + let execute (ts : cfg_t) (entry : int) (err_loc : int) : mc_result = + (** + * Set up data structures used by the algorithm: worklist, + * vtxcnt (keeps track of largest unused vertex number in tree), + * ptt is a pointer to the reachability tree. + *) + let global_context = mk_mc_context ts entry in + logf ~level:`always "executing concolic mcmillan's algorithm\n"; + (*let ts_with_gas = instrument_with_gas ts in *) + let main_context = mk_intra_context global_context (entry, err_loc) ts 0 K.one entry err_loc in + intraproc_check main_context + end + + +module BM = BatMap.Make(Int) + +let analyze_concolic_mcl file = + let open Srk.Iteration in + populate_offset_table file; + K.domain := (module (Split(Product(LinearRecurrenceInequation)(PolyhedronGuard)))); + match file.entry_points with + | [main] -> begin + let rg = Interproc.make_recgraph file in + let entry = (RG.block_entry rg main).did in + let (ts, assertions) = make_transition_system true rg in + let ts, new_vertices = make_ts_assertions_unreachable ts assertions in + TSDisplay.display ts; + Printf.printf "\nentry: %d\n" entry; + List.iter (fun err_loc -> + Printf.printf "testing reachability of location %d\n" err_loc ; + Printf.printf "------------------------------\n"; + match GPS.execute ts entry err_loc with + | Safe _ -> Printf.printf " proven safe\n"; + | Unsafe _ -> Printf.printf " proven unsafe\n"; + Printf.printf "------------------------------\n" + ) new_vertices + end + | _ -> assert false + + + + +let analyze_concolic_mcl file = + let open Srk.Iteration in + populate_offset_table file; + K.domain := (module (Split(Product(LinearRecurrenceInequation)(PolyhedronGuard)))); + match file.entry_points with + | [main] -> begin + let rg = Interproc.make_recgraph file in + let entry = (RG.block_entry rg main).did in + let (ts, assertions) = make_transition_system true rg in + let ts, new_vertices = make_ts_assertions_unreachable ts assertions in + TSDisplay.display ts; + Printf.printf "\nentry: %d\n" entry; + List.iter (fun err_loc -> + Printf.printf "testing reachability of location %d\n" err_loc ; + Printf.printf "------------------------------\n"; + match GPS.execute ts entry err_loc with + | Safe _ -> Printf.printf " proven safe\n"; + | Unsafe _ -> Printf.printf " proven unsafe\n"; + Printf.printf "------------------------------\n" + ) new_vertices + end + | _ -> assert false + +(** dump simplified CFG before doing model checking / CRA / concolic execution *) +let dump_cfg simplify file = + populate_offset_table file; + match file.entry_points with + | [main] -> + begin + let rg = Interproc.make_recgraph file in + let _ (* entry *) = (RG.block_entry rg main).did in + let (ts, assertions) = make_transition_system simplify rg in + let ts, _ = make_ts_assertions_unreachable ts assertions in + TSDisplay.display ts + end + | _ -> assert false + +let _ = + CmdLine.register_pass + ("-mcl-concolic", analyze_concolic_mcl, " GPS model checking algorithm"); diff --git a/duet/reachTree.ml b/duet/reachTree.ml new file mode 100644 index 00000000..2c8ab75f --- /dev/null +++ b/duet/reachTree.ml @@ -0,0 +1,710 @@ +open Core +(** reachability tree module *) + +open Srk +open CfgIr +open BatPervasives +open Syntax +module RG = Interproc.RG +module WG = Srk.WeightedGraph +module G = RG.G +module Int = SrkUtil.Int +module TF = TransitionFormula + +module TransitionSystem = Srk.TransitionSystem +module Syntax = Srk.Syntax +module Interpretation = Srk.Interpretation + + +include Log.Make (struct + let name = "reachTree" +end) + +type equery = OverApprox | UnderApprox + +module ART + (Ctx : Srk.Syntax.Context) + (K : sig + type t + type var + + val pp : Format.formatter -> t -> unit + val guard : t -> Ctx.t formula + val transform : t -> (var * Ctx.t arith_term) BatEnum.t + val mem_transform : var -> t -> bool + val get_transform : var -> t -> Ctx.t arith_term + val assume : Ctx.t formula -> t + val mul : t -> t -> t + val conjunct : t -> t -> t + val add : t -> t -> t + val zero : t + val one : t + val star : t -> t + val exists : (var -> bool) -> t -> t + val contains_havoc : t -> bool + val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] + val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula + -> [`Valid of Ctx.t Syntax.formula list + | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] + + val get_post_model : + Ctx.t Interpretation.interpretation -> + t -> + Ctx.t Interpretation.interpretation option + end) + (TS : sig + type vertex + type transition = K.t + type t + type query + + val empty : t + val path_weight : query -> vertex -> transition + val call_weight : query -> vertex * vertex -> transition + val set_summary : query -> vertex * vertex -> transition -> unit + val get_summary : query -> vertex * vertex -> transition + val inter_path_summary : query -> vertex -> vertex -> transition + val intra_path_summary : query -> vertex -> vertex -> transition + + val omega_path_weight : + query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b + + val remove_temporaries : t -> t + + val forward_invariants_ivl : + t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list + + val forward_invariants_ivl_pa : + Ctx.t Srk.Syntax.formula list -> + t -> + vertex -> + (vertex * Ctx.t Srk.Syntax.formula) list + + val simplify : (vertex -> bool) -> t -> t + + val iter_succ_e : + (vertex * transition TransitionSystem.label * vertex -> unit) -> + t -> + vertex -> + unit + + val edge_weight : t -> vertex -> vertex -> K.t Srk.TransitionSystem.label + + val fold_succ_e : + (vertex * K.t Srk.TransitionSystem.label * vertex -> 'b -> 'b) -> + t -> + vertex -> + 'b -> + 'b + end) + (PN : sig + type t + + val make : TS.vertex * TS.vertex -> t + val string_of : t -> string + val of_string : string -> t + + (* lexicographic comparison using Stdlib.compare *) + val compare : t -> t -> int + end) + (VN : sig + val to_vertex : int -> TS.vertex + val of_vertex : TS.vertex -> int + end) + (Summarizer : sig + type t + val init : TS.t -> TS.vertex -> t + val over_proc_summary : t -> PN.t -> K.t + val under_proc_summary : t -> PN.t -> K.t + val set_over_proc_summary : t -> PN.t -> K.t -> unit + val set_under_proc_summary : t -> PN.t -> K.t -> unit + val refine_over_summary : t -> PN.t -> K.t -> unit + val refine_under_summary : t -> PN.t -> K.t -> unit + val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t + val path_weight_inter : t -> TS.vertex -> TS.vertex -> K.t + end) = +struct + (* type for a tree node *) + type node = int + + module ProcMap = BatMap.Make (PN) + module IntMap = BatMap.Make (Int) + module StringMap = BatMap.Make (String) + module ISet = BatSet.Make (Int) + module DQ = BatDeque + module ARR = Batteries.DynArray + + type idq_t = int BatDeque.t + type state_formula = Ctx.t Syntax.formula + + exception Mexception of string + + let mk_true () = Syntax.mk_true Ctx.context + let mk_false () = Syntax.mk_false Ctx.context + + let log_formulas prefix formulas = + List.iteri + (fun i f -> + logf ~level:`always "[formula] %s(%i): %a\n" prefix i + (Syntax.pp_expr Ctx.context) + f) + formulas + + let log_weights prefix weights = + List.iteri + (fun i f -> logf ~level:`always "[weight] %s(%i): %a\n" prefix i K.pp f) + weights + + let log_model prefix model = + logf ~level:`always "[model] %s: %a\n" prefix Interpretation.pp model + + type t = { + graph : TS.t; + entry : TS.vertex; + err_loc : TS.vertex; + mutable vtxcnt : int; + mutable cfg_vertex : TS.vertex IntMap.t; + mutable parents : int IntMap.t; + mutable labels : Ctx.t Syntax.formula IntMap.t; + mutable covers : int IntMap.t; + mutable children : int list IntMap.t; + (* also maintain reverse map for each y, storing (x, y) that are in cover. *) + (* i.e. reverse_covers[y] returns all x such that (x,y) is in the cover. *) + mutable reverse_covers : ISet.t IntMap.t; + (* precedent_nodes[v] stores all tree nodes mapping to CFG vertex v. Used in mc_close. *) + mutable precedent_nodes : ISet.t IntMap.t; + interproc : Summarizer.t; + } + + let root = 0 + + let make (g : TS.t) (entry : TS.vertex) (err_loc : TS.vertex) (pre_state: state_formula) interproc = + ref + { + graph = g; + entry; + err_loc; + vtxcnt = 1; + cfg_vertex = IntMap.add 0 entry IntMap.empty; + parents = IntMap.add 0 (-1) IntMap.empty; + labels = IntMap.add 0 pre_state IntMap.empty; + children = IntMap.add 0 [] IntMap.empty; + covers = IntMap.empty; (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) + reverse_covers = IntMap.empty; (* for each v, store the v's that cover it: i.e. cover[v] *) + precedent_nodes = IntMap.empty; + interproc; + } + + let get_summarizer (art : t ref) = !art.interproc + let get_err_loc (art : t ref) = !art.err_loc + let get_entry (art: t ref) = !art.entry + + (** [print_tree t ident v] prints an ART t with indentation `ident` rooted at node v *) + let print_tree (art : t ref) (indent : string) (v : node) = + let rec print_tree_ (art : t ref) indent v = + logf ~level:`always "%s|" indent; + logf ~level:`always "%s+-%d(%d)" indent v + (IntMap.find v !art.cfg_vertex |> VN.of_vertex); + List.iter + (fun x -> print_tree_ art (indent ^ " ") x) + (IntMap.find_default [] v !art.children) + in + logf ~level:`always "*"; + print_tree_ art indent v + + (* [parent t i] gets parent of node i in tree t. *) + let parent (art : t ref) (i : node) : node = IntMap.find i !art.parents + + (* [t %-> i]: get CFG vertex mapped by node i in tree t. *) + let maps_to (art : t ref) (i : node) : TS.vertex = + try IntMap.find i !art.cfg_vertex + with _ -> failwith @@ Printf.sprintf "maps_to: not found tree node %d\n" i + + (* deprecated: + (* [cfg_edge_weight t mode u v] returns the edge weight of edge (u, v) in ART t. + If (u, v) maps to a call-edge (x, y) in the CFG, return the over-approximate summary if + `mode` is set to `OverApprox`, and return an under-approximate summary otherwise. *) + let edge_weight (art : t ref) (mode : equery) (u : node) (v : node) = + let t = !art in + match TS.edge_weight t.graph (maps_to art u) (maps_to art v) with + | TransitionSystem.Weight w -> w + | TransitionSystem.Call (a, b) -> ( + (* (a, b) is a pair of CFG vertices that uniquely identify a call *) + let a, b = (VN.to_vertex a, VN.to_vertex b) in + match mode with + | OverApprox -> Summarizer.over_proc_summary t.interproc (PN.make (a, b)) + | UnderApprox -> + Summarizer.under_proc_summary t.interproc (PN.make (a, b))) + + let edge_weight (art : t ref) (mode : equery) (u : node) (v : node) = + let t = !art in + match TS.edge_weight t.graph (maps_to art u) (maps_to art v) with + | TransitionSystem.Weight w -> w + | TransitionSystem.Call (a, b) -> ( + (* (a, b) is a pair of CFG vertices that uniquely identify a call *) + let a, b = (VN.to_vertex a, VN.to_vertex b) in + match mode with + | OverApprox -> Summarizer.over_proc_summary t.interproc (PN.make (a, b)) + | UnderApprox -> + Summarizer.under_proc_summary t.interproc (PN.make (a, b))) + + + *) + (* [tree_path t u] returns list of tree nodes that form the corrsp. tree path from root of t to tree node u *) + let tree_path (art : t ref) ?(src=root) (u : node) : node list = + let rec tree_path_rev art u = + if u = root || u = src then [ u ] + else u :: tree_path_rev art (parent art u) + in + List.rev @@ tree_path_rev art u + + (* [children t v] returns children of tree node v in tree t. *) + let children (art : t ref) (v : node) : node list = + IntMap.find v !art.children + + (* [descendants t v] returns descendants of tree node v in tree t in DFS order. *) + let rec descendants (art : t ref) (v : node) : node list = + let v_children = children art v in + v :: List.fold_left (fun l ch -> descendants art ch @ l) [] v_children + + (* return leaves of subtree rooted at v. *) + let rec leaves (art : t ref) (v : node) : node list = + let chs = children art v in + if List.length chs == 0 then [ v ] + else + List.fold_left + (fun child_leaves ch -> leaves art ch @ child_leaves) + [] chs + + (* is a node in tree a leaf? *) + let is_leaf (art : t ref) (v : node) : bool = + let chs = children art v in + List.length chs == 0 + + (* [label t v] returns the node label of tree node v in tree t. *) + let label (art : t ref) (v : node) : state_formula = IntMap.find v !art.labels + + (* (replaces) sets a label at v *) + let set_label (art : t ref) (v : node) (lbl : state_formula) = + !art.labels <- IntMap.add v lbl !art.labels + + (* [get_precedent_nodes t v] retrieves a sequence of precedent nodes of tree node vin preorder in tree t. *) + (* the list of precedent nodes for a cfg vertex is a list of tree nodes which map to the same cfg location, ordered by < on integers. *) + let get_precedent_nodes (art : t ref) (v : node) = + let cfg_vertex = maps_to art v in + let precedents_set = + IntMap.find_default ISet.empty (VN.of_vertex cfg_vertex) + !art.precedent_nodes + in + ISet.elements precedents_set + + (* deprecated: + (* [path_condition t mode u] returns a list of edge weights that form the path condition from root of t to tree node u. *) + (* if `cutoff` is specified to a non-zero value, then [path_condition] will try to stop at intermediate ancestor `cutoff`. *) + (* Over-approximate summaries are substituted in for call-edge locations if mode = `OverApprox`, and under-approximate *) + (* summaries are substituted in otherwise. *) + let path_condition (art : t ref) (mode : equery) ?(cutoff = 0) (u : node) = + if u == 0 || cutoff = u then [] + else + let rec visit (art : t ref) (u : node) = + let v = parent art u in + if v = 0 then [ edge_weight art mode 0 u ] + else if v = cutoff then + (* v=0 case is already handled above *) + [ edge_weight art mode cutoff u ] + else edge_weight art mode v u :: visit art v + in + List.rev (visit art u) + *) + + (** retrieves a new ART node ID, ensuring all ART nodes have distinct IDs in increasing order according to their creation *) + let get_id (art : t ref) : node = + let new_id = !art.vtxcnt in + !art.vtxcnt <- !art.vtxcnt + 1; + new_id + + (* Add new tree leaf mapping to CFG vertex v and with parent tree node p. *) + let add_tree_vertex (art : t ref) ?(label = mk_true ()) (v : TS.vertex) + (p : int) = + (* sequentially add v to the lists, indexed by !vtxcnt *) + let new_vertex = get_id art in + (* note that new_vertex refers to a new tree vertex, where as v is a corresp. cfg location. *) + !art.cfg_vertex <- IntMap.add new_vertex v !art.cfg_vertex; + !art.parents <- IntMap.add new_vertex p !art.parents; + !art.labels <- IntMap.add new_vertex label !art.labels; + !art.children <- IntMap.add new_vertex [] !art.children; + (* set children of parent to be !vtxcnt :: children. *) + if p >= 0 then + !art.children <- + IntMap.add p (new_vertex :: IntMap.find p !art.children) !art.children; + (* Add v to precedent_nodes. *) + let precedent_nodes = + IntMap.find_default ISet.empty (VN.of_vertex v) !art.precedent_nodes + |> ISet.add new_vertex + in + !art.precedent_nodes <- + IntMap.add (VN.of_vertex v) precedent_nodes !art.precedent_nodes; + new_vertex + + (** expand: + for every out-neighbor y of v, first try deriving a post-state model of v-> y, if successful, put it + on the concolic execution worklist. Otherwise, it is a frontier node, and put it on the + refinement worklist. *) + + (* returns (new nodes on concolic worklist, new nodes on frontier worklist) *) + (* a newly expanded node (leaf) is deemed a _concolic node_ if it can inherit + a post-state model from its parent by means of symbol substitution. It is deemed + a _frontier node_ if concrete execution cannot reach it from its parent node. A + frontier node does not have a model associated with it and is in need of refinement. *) + let expand recurse_level (art : t ref) (v : node) (m: Ctx.t Interpretation.interpretation)= + let oracle = + if recurse_level = 0 then Summarizer.path_weight_inter + else Summarizer.path_weight_intra + in + let vg = maps_to art v in + let new_concolic_nodes, new_frontier_nodes = (ref [], ref []) in + (* visit out neighbors of v *) + TS.iter_succ_e + (fun (_, weight, y) -> + let weight = + match weight with + | TransitionSystem.Weight w -> + if K.contains_havoc w then + (* w /\ guard (summary from y -> error location) *) + K.mul w + (K.assume + @@ K.guard (oracle !art.interproc y !art.err_loc)) + else w + | TransitionSystem.Call (u, v) -> + let proc = (VN.to_vertex u, VN.to_vertex v) |> PN.make in + Summarizer.over_proc_summary !art.interproc proc + in + match K.get_post_model m weight with + | Some y_model -> + let new_vtx = add_tree_vertex art y v in + new_concolic_nodes := (new_vtx, y_model) :: !new_concolic_nodes + | None -> + let new_node = add_tree_vertex art y v in + new_frontier_nodes := new_node :: !new_frontier_nodes) + !art.graph vg; + (* make it FIFO *) + (List.rev !new_concolic_nodes, List.rev !new_frontier_nodes) + + (** maintenance of coverings *) + + (* for w that is an ancestor/precedent of v, *) + (* Adds (v -> w) to covering relation if possible and returns true, false otherwise. *) + (* note that (v, w) in covering if stateLabel(v) IMPLIES stateLabel(w) *) + let cover (art : t ref) v w = + let v_label = label art v in + let w_label = label art w in + if maps_to art v <> maps_to art w then + failwith + @@ Printf.sprintf "error: %d->%d but %d->%d\n" v + (maps_to art v |> VN.of_vertex) + w + (maps_to art w |> VN.of_vertex); + match Smt.entails Ctx.context v_label w_label with + | `Yes -> + logf ~level:`always " cover success (v=%d, w=%d). \n" v w; + log_formulas " v label " [ v_label ]; + log_formulas " w label " [ w_label ]; + let reverse_covers_w = + IntMap.find_default ISet.empty w !art.reverse_covers + in + !art.covers <- IntMap.add v w !art.covers; + !art.reverse_covers <- + IntMap.add w (ISet.add v reverse_covers_w) !art.reverse_covers; + true + | `No | `Unknown -> false + + + (* it returns (`true`, wl) iff covering succeeds at v and wl is a worklist of nodes to be refined. *) + + (** [close art v] visits precedents of v in tree and attempts to derive covering relations from v. *) + let close (art : t ref) (v : node) = + (* A _precedent_ of v in tree is any vertex u + if status || w == v || w > v (* preorder constraint *) then + (status, wl) + else + (* try to "cover v" by deciding if v --> w. If so, no need to further explore v. *) + (* cover v using w *) + let cover_success = cover art v w in + let wl' = ref wl in + (if cover_success then + (* remove, for each descendant of v, nodes that are sinks of covers. *) + let v_descendants = descendants art v in + List.iter + (fun y -> + (* Find relations (x,y) in covering relation where y is descendant of v. *) + if y <> v then ( + (* xs = {x | x -> y} *) + let xs = + IntMap.find_default ISet.empty y !art.reverse_covers + in + (* Iterate through and remove pairs (x, y) from covering relation. *) + (* Step 1: Remove (x |-> y) from !ptt.covers. *) + ISet.iter + (fun x -> !art.covers <- IntMap.remove x !art.covers) + xs; + (* Step 2: Remove (y |-> xs) from !pthit.reverse_covers. *) + !art.reverse_covers <- IntMap.remove y !art.reverse_covers; + (* Step 3: add xs to worklist. *) + ISet.iter + (fun x -> + (* add x's subtree leaves back to the worklist. *) + let x_leaves = leaves art x in + List.iter + (fun x_leaf -> + logf ~level:`always + " close: adding %d back to worklist \n" + x_leaf; + wl' := x_leaf :: !wl') + x_leaves) + xs)) + v_descendants); + (cover_success, !wl')) + precedents (false, []) + in + result + + (* Checks if tree node v is covered. It is covered if its ancestors or it is in covering relation. *) + let rec is_covered (art : t ref) v = + match IntMap.find_opt v !art.covers with + | None -> if v == 0 then false else is_covered art (parent art v) + | Some u -> + logf ~level:`always " | covered by %d\n" u; + true + + (* refine the label of each tree node u along path from tree root to v. *) + let refine (art : t ref) path interpolants : node list = + let worklist = ref [] in + List.iter2 + (fun u interpolant -> + let u_label = label art u in + let u_label' = Syntax.mk_and Ctx.context [ u_label; interpolant ] in + log_formulas + (Printf.sprintf "[relabelling %d CFG vertex %d] to label: " u + (maps_to art u |> VN.of_vertex)) + [ u_label' ]; + set_label art u u_label'; + (* remove ( * -> u) in covering relation; we just refined label(u) so implications of form label(y)->label(u) + might not hold anymore. *) + match IntMap.find_opt u !art.reverse_covers with + | None -> () + | Some l -> + (* remove covers (List.iter (fun x -> Printf.printf " (%d->%d)" x u) l *) + let u_coverers = + ISet.fold + (fun x coverers -> + (* test if label(x) --> new label(u)*) + let x_label = label art x in + let u_label = label art u in + match Smt.entails Ctx.context x_label u_label with + | `No | `Unknown -> + (* remove (x, u) from covering. *) + logf ~level:`always " refine: removing cover (%d->%d)\n" + x u; + !art.covers <- IntMap.remove x !art.covers; + (* add x's subtree leaves back to the worklist. *) + let x_leaves = leaves art x in + List.iter + (fun x_leaf -> + logf ~level:`always + " refine: adding %d back to worklist \n" + x_leaf; + worklist := x_leaf :: !worklist) + x_leaves; + l + | `Yes -> + logf ~level:`always + " refine: cover (x %d-> u %d) still holds\n" x u; + log_formulas " x label: " [ x_label ]; + log_formulas " u label: " [ u_label ]; + ISet.add x coverers (* unchanged. *)) + l ISet.empty + in + !art.reverse_covers <- IntMap.add u u_coverers !art.reverse_covers) + path interpolants; + !worklist + + + let rec glue l = + match l with + | a :: b :: t -> (a, b) :: (glue (b :: t)) + | _ -> [] + + + + (* for w that is an ancestor of v, cover[v] stores w *) + let remove_from_cover art v w = + match IntMap.find_opt v !art.covers with + | Some u -> + begin if u <> w then failwith "remove_from_cover: node pair to remove not in cover" + else + !art.covers <- IntMap.remove v !art.covers; + let w_coverers = IntMap.find w !art.reverse_covers |> ISet.remove v in + !art.reverse_covers <- IntMap.add w w_coverers !art.reverse_covers; + end + | None -> failwith "remove_from_cover: node pair to remove not in cover ()" + + let add_to_cover art v w = + match IntMap.find_opt v !art.covers with + | Some r -> remove_from_cover art v r + | None -> (); + !art.covers <- IntMap.add v w !art.covers; + !art.reverse_covers <- + IntMap.add w + (IntMap.find_default ISet.empty w !art.reverse_covers + |> ISet.add v) !art.reverse_covers + + + (* convention: w is an ancestor of v. returns true if we can add (v, w) to covers such that label(v) |= label(w) *) + let force_cover (art : t ref) v w = (* check if v_label -> w_label where v is an ancestor at w *) + if maps_to art v <> maps_to art w then (false, []) + else begin + (* let v_label = label art v in *) + let w_label = label art w in + let artpath = tree_path art ~src:w v in + let path_weights = + artpath + |> glue + |> List.map (fun (x, y) -> TS.edge_weight !art.graph (maps_to art x) (maps_to art y)) + |> List.map + (fun weight -> + match weight with + | TransitionSystem.Call (src, dst) -> + Summarizer.over_proc_summary !art.interproc @@ PN.make (VN.to_vertex src, VN.to_vertex dst) + | TransitionSystem.Weight wht -> wht) in + match K.interpolate_or_concrete_model ((K.assume w_label) :: path_weights) (Syntax.mk_not Ctx.context w_label) with + | `Valid itps -> + let new_frontiers = refine art artpath (List.tl itps) in + begin match Smt.entails Ctx.context (label art v) (label art w) with + | `Yes -> + + (true, new_frontiers) + | _ -> failwith "error: force_cover is buggy!" + end + | `Invalid _ -> (false, []) + | `Unknown -> failwith "force_cover: interpolation failed with status UNKNOWN." + end + + + (** a more lightweight version of close *) + let lclose (art: t ref) v = + let rec go u = + if u = -1 then (false, []) + else begin + if maps_to art u <> maps_to art v then + try let p = parent art u in go p + with Not_found -> (false, []) + else match force_cover art v u with + | (true, frontiers) -> (true, frontiers) + | (false, _) -> + try + let p = parent art u in go p + with Not_found -> (false, []) + end + in + match v with + | 0 -> (false, []) + | _ -> go (parent art v) + + + (** TODO: [deprecated] procedures for lightweight verification of ART invariants *) + + let verify_well_labelled_tree (t : t ref) = + let rec aux v = + let children = children t v in + match children with + | [] (* leaf node *) -> ( + match IntMap.find_opt v !t.covers with + | None -> + logf ~level:`always "!!! found uncovered leaf: %d\n" v; + TS.fold_succ_e + (fun (x, _, y) _ -> + logf ~level:`always + " ERROR ERROR ERROR: mapped cfg vertex %d has \ + out-neighbor %d\n" + (VN.of_vertex x) (VN.of_vertex y); + false) + !t.graph (maps_to t v) true + | Some _ -> true) + | _ -> ( + match IntMap.find_opt v !t.covers with + | None -> + logf ~level:`always "node %d uncovered\n" v; + List.fold_left (fun acc u -> aux u && acc) true children + | Some u -> + logf ~level:`always "node %d covered by %d\n" v u; + true) + in + logf ~level:`always "verifying well-labelledness of ART...\n"; + let r = aux 0 in + logf ~level:`always "...done verifying well-labelledness of ART\n"; + r + + let check_covering_welformedness (t : t ref) = + logf ~level:`always "checking welformedness of covering relations\n"; + IntMap.iter + (fun dst covered_from -> + ISet.iter + (fun src -> + logf ~level:`always "checking if (%d, %d) in covering\n" src dst; + match IntMap.find_opt src !t.covers with + | Some dst' -> + if dst' <> dst then + failwith + @@ Printf.sprintf "ERROR: (%d, %d) in covering\n" src dst' + | None -> failwith "ERROR: not in covering") + covered_from) + !t.reverse_covers; + logf ~level:`always "performing a reverse check\n"; + IntMap.iter + (fun src dst -> + match IntMap.find_opt dst !t.reverse_covers with + | Some reverse_covers -> ( + match ISet.mem src reverse_covers with + | false -> + failwith + @@ Printf.sprintf + "ERROR: (%d, %d) in t.covers but %d not in %d's \ + reverse_covers\n" + src dst src dst + | true -> ()) + | None -> + failwith + @@ Printf.sprintf + "ERROR: (%d, %d) in t.covers but no list found in \ + reverse_covers\n" + src dst) + !t.covers; + logf ~level:`always "...done checking welformedness of covering relations\n" + + (** pretty-printing functionalities *) + let tree_printer_get_name (art : t ref) i = + match IntMap.find_opt i !art.covers with + | None -> Printf.sprintf "%d(%d)" i (maps_to art i |> VN.of_vertex) + | Some j -> + Printf.sprintf "[%d(%d)]->%d" i (maps_to art i |> VN.of_vertex) j + + let log_art (art : t ref) = + logf ~level:`always " +----------------- ART ----------------+\n"; + let string_of_art = + Tree_printer.to_string ~line_prefix:"* " + ~get_name:(tree_printer_get_name art) + ~get_children:(children art) 0 + in + logf ~level:`always "%s" string_of_art; + logf ~level:`always " +----------------- ART ----------------+\n" + + let log_node u = + logf ~level:`always " node: visit %d\n" u + + let of_node u = u +end diff --git a/duet/reachTree.mli b/duet/reachTree.mli new file mode 100644 index 00000000..a9a7504b --- /dev/null +++ b/duet/reachTree.mli @@ -0,0 +1,137 @@ +module TransitionSystem = Srk.TransitionSystem +module Syntax = Srk.Syntax +module Interpretation = Srk.Interpretation + +type equery = OverApprox | UnderApprox +module ART : + functor + (Ctx: Srk.Syntax.Context) + (** transition formula algebra *) + (K : sig + type t + type var + val pp : Format.formatter -> t -> unit + val guard : t -> Ctx.t Srk.Syntax.formula + val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t + val mem_transform : var -> t -> bool + val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term + val assume : Ctx.t Srk.Syntax.formula -> t + val mul : t -> t -> t + val add : t -> t -> t + val conjunct : t -> t -> t + val zero : t + val one : t + val star : t -> t + val exists : (var -> bool) -> t -> t + val contains_havoc : t -> bool + val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] + val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula + -> [`Valid of Ctx.t Syntax.formula list + | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] + + val get_post_model : + Ctx.t Srk.Interpretation.interpretation -> + t -> Ctx.t Srk.Interpretation.interpretation option + end) + (** transition system with edge weights from K *) + (TS : sig + type vertex + type transition = K.t + type t + type query + val empty : t + val path_weight : query -> vertex -> transition + val call_weight : query -> vertex * vertex -> transition + val set_summary : query -> vertex * vertex -> transition -> unit + val get_summary : query -> vertex * vertex -> transition + val inter_path_summary : query -> vertex -> vertex -> transition + val intra_path_summary : query -> vertex -> vertex -> transition + val omega_path_weight : + query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b + val remove_temporaries : t -> t + val forward_invariants_ivl : + t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list + val forward_invariants_ivl_pa : + Ctx.t Srk.Syntax.formula list -> + t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list + val simplify : (vertex -> bool) -> t -> t + val iter_succ_e : + ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit + val edge_weight : + t -> vertex -> vertex -> K.t Srk.TransitionSystem.label + + val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b + end) + (** a module giving a procedure name type. Procedures are implicitly represented by pairs of CFG vertices in Duet. + Here we give them a type. *) + (PN : sig + type t + val make : TS.vertex * TS.vertex -> t + val string_of : t -> string + val of_string : string -> t + val compare : t -> t -> int + end) + (** a module giving a vertex name type. Vertices are integers in Duet, here we give them a type. *) + (VN : sig + val to_vertex : int -> TS.vertex + val of_vertex : TS.vertex -> int + end) + (** a module giving an interface for accessing over/under-approximate procedure summaries. *) + (Summarizer : sig + type t + (** [init g s] returns a Summarizer.t type for a given transition system, source vertex pair (g, s). *) + val init : TS.t -> TS.vertex -> t + (** [over_proc_summary s n] returns the over-approximate procedure summary for procedure `n`. *) + val over_proc_summary : t -> PN.t -> K.t + (** [under_proc_summary s n] returns the under-approximate procedure summary (initially `false`) for procedure `n`. *) + val under_proc_summary : t -> PN.t -> K.t + (** [set_over_proc_summary s n w] sets the over-approximate procedure summary to be `w` at procedure `n`. *) + val set_over_proc_summary : t -> PN.t -> K.t -> unit + (** [set_under_proc_summary s n w] sets the under-approximate procedure summary to be `w` at procedure `n`. *) + val set_under_proc_summary : t -> PN.t -> K.t -> unit + (** [refine s n pre post] refines the over-approximate procedure summary at `n` by conjuncting on (pre) /\ (post') *) + val refine_over_summary : t -> PN.t -> K.t -> unit + (** [refine_under s n tr] refines the under-approximate procedure summary at `n` by adding `tr` as a disjunct. *) + val refine_under_summary : t -> PN.t -> K.t -> unit + (** [path_weight_intra s u v] gives the weighted path summary between (u, v) on an intraprocedural CFG *) + val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t + (** [path_weight_inter s u v] gives the inter-procedural path weight between (u, v) *) + val path_weight_inter : t -> TS.vertex -> TS.vertex -> K.t + end) + -> + sig + type node + type t + type state_formula = Ctx.t Srk.Syntax.formula + exception Mexception of string + val make : TS.t -> TS.vertex -> TS.vertex -> state_formula -> Summarizer.t -> t ref + val get_entry : t ref -> TS.vertex + val get_err_loc : t ref -> TS.vertex + val get_summarizer : t ref -> Summarizer.t + val print_tree : t ref -> string -> node -> unit + val parent : t ref -> node -> node + val maps_to : t ref -> node -> TS.vertex + val tree_path : t ref -> ?src:node -> node -> node list + val children : t ref -> node -> node list + val descendants : t ref -> node -> node list + val leaves : t ref -> node -> node list + val is_leaf : t ref -> node -> bool + val label : t ref -> node -> state_formula + val set_label : t ref -> node -> state_formula -> unit + val get_precedent_nodes : t ref -> node -> node list + val get_id : t ref -> node + val add_tree_vertex : + t ref -> ?label:Ctx.t Srk.Syntax.formula -> TS.vertex -> int -> node + val expand : + int -> t ref -> node -> Ctx.t Interpretation.interpretation -> (node * Ctx.t Interpretation.interpretation) list * node list + val cover : t ref -> node -> node -> bool + val close : t ref -> node -> (bool * node list) + val force_cover : t ref -> node -> node -> (bool * node list) + val lclose : t ref -> node -> (bool * node list) + val is_covered : t ref -> node -> bool + val refine: t ref -> node list -> Ctx.t Syntax.formula list -> node list + val log_art : t ref -> unit + val log_node : node -> unit + val of_node : node -> int + val root : node + end From 9e830979a3e4882257fe217fd581297b693412e5 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 11 Jul 2024 01:31:41 +0800 Subject: [PATCH 02/59] update API of srk --- Makefile | 2 +- duet/duet.ml | 1 + duet/reachTree.ml | 2 -- duet/tree_printer.ml | 39 ++++++++++++++++++++++++++++++++++++ duet/tree_printer.mli | 16 +++++++++++++++ srk/src/syntax.mli | 3 +++ srk/src/transitionSystem.ml | 12 +++++++++++ srk/src/transitionSystem.mli | 8 ++++++++ srk/src/weightedGraph.mli | 1 + 9 files changed, 81 insertions(+), 3 deletions(-) create mode 100644 duet/tree_printer.ml create mode 100644 duet/tree_printer.mli diff --git a/Makefile b/Makefile index d1fef2f4..c2735148 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ all: build build: - dune build duet + dune build --profile release duet clean: dune clean diff --git a/duet/duet.ml b/duet/duet.ml index 02971557..505f2d1f 100644 --- a/duet/duet.ml +++ b/duet/duet.ml @@ -11,6 +11,7 @@ open! Cra open! Proofspace open! Dependence open! Categorize +open! Gps let usage_msg = "Duet program analyzer\nUsage: duet [OPTIONS] file.[c|bp]" diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 2c8ab75f..55fc6323 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -1,8 +1,6 @@ -open Core (** reachability tree module *) open Srk -open CfgIr open BatPervasives open Syntax module RG = Interproc.RG diff --git a/duet/tree_printer.ml b/duet/tree_printer.ml new file mode 100644 index 00000000..543fa6d7 --- /dev/null +++ b/duet/tree_printer.ml @@ -0,0 +1,39 @@ +open Printf + +let rec iter f = function + | [] -> () + | [x] -> + f true x + | x :: tl -> + f false x; + iter f tl + +let to_buffer ?(line_prefix = "") ~get_name ~get_children buf x = + let rec print_root indent x = + bprintf buf "%s\n" (get_name x); + let children = get_children x in + iter (print_child indent) children + and print_child indent is_last x = + let line = + if is_last then + "└── " + else + "├── " + in + bprintf buf "%s%s" indent line; + let extra_indent = + if is_last then + " " + else + "│ " + in + print_root (indent ^ extra_indent) x + in + Buffer.add_string buf line_prefix; + print_root line_prefix x + +let to_string ?line_prefix ~get_name ~get_children x = + let buf = Buffer.create 1000 in + to_buffer ?line_prefix ~get_name ~get_children buf x; + Buffer.contents buf + diff --git a/duet/tree_printer.mli b/duet/tree_printer.mli new file mode 100644 index 00000000..74711f9f --- /dev/null +++ b/duet/tree_printer.mli @@ -0,0 +1,16 @@ +(* + Print a tree or a DAG as tree, similarly to the 'tree' command. + Source: https://gist.github.com/mjambon/75f54d3c9f1a352b38a8eab81880a735 +*) + +val to_buffer : + ?line_prefix: string -> + get_name: ('a -> string) -> + get_children: ('a -> 'a list) -> + Buffer.t -> 'a -> unit + +val to_string : + ?line_prefix: string -> + get_name: ('a -> string) -> + get_children: ('a -> 'a list) -> + 'a -> string \ No newline at end of file diff --git a/srk/src/syntax.mli b/srk/src/syntax.mli index e9bdade4..f96232fd 100644 --- a/srk/src/syntax.mli +++ b/srk/src/syntax.mli @@ -559,6 +559,9 @@ val pp_smtlib2 : ?env:(string Env.t) -> 'a context -> val pp_expr_unnumbered : ?env:(string Env.t) -> 'a context -> Format.formatter -> ('a, 'b) expr -> unit +val pp_expr : ?env:(string Env.t) -> 'a context -> + Format.formatter -> ('a, 'b) expr -> unit + module Formula : sig type 'a t = 'a formula val equal : 'a formula -> 'a formula -> bool diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index 63c434fc..28773562 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -149,6 +149,18 @@ module Make (add_symbols (symbols (T.guard tr)) VarSet.empty) (T.transform tr) + + let set_summary q (u, v) summary = + WG.RecGraph.set_summary q (u, v) summary + + let get_summary q (u, v) = + WG.RecGraph.get_summary q (u, v) + + let inter_path_summary = WG.RecGraph.inter_path_summary + + let intra_path_summary = WG.RecGraph.intra_path_summary + + (* Variables whose abstract values may change as the result of a transition *) let abstract_defs tr = diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index 03cd48ca..4c77a22a 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -72,6 +72,14 @@ module Make only by that transition. *) val remove_temporaries : t -> t + + (** Set procedure summary; delegates call to WG.RecGraph.set_summary *) + val set_summary : query -> (vertex * vertex) -> transition -> unit + + (** Get procedure summary; delegates call to WG.RecGraph.get_summary *) + val get_summary : query -> (vertex * vertex) -> transition + + (** Compute interval invariants for each loop header of a transition system. The invariant computed for a loop is defined only over the variables read or written to by the loop. *) diff --git a/srk/src/weightedGraph.mli b/srk/src/weightedGraph.mli index 97d7febd..624a7688 100644 --- a/srk/src/weightedGraph.mli +++ b/srk/src/weightedGraph.mli @@ -61,6 +61,7 @@ val cut_graph : 'a t -> vertex list -> 'a t (** Remove a vertex from a graph. *) val remove_vertex : 'a t -> vertex -> 'a t +val remove_edge : 'a t -> vertex -> vertex -> 'a t (** [contract g v] removes vertex [v] from [g] while preserving all weighted paths among remaining vertices. That is, for each pair of edges [p -pw-> From c1de851e674f4392be6377b69faac276820de75a Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Tue, 27 Aug 2024 23:23:30 -0400 Subject: [PATCH 03/59] Various updates --- duet/cra.ml | 2 + duet/gps.ml | 14 +- srk/src/interpretation.ml | 4 + srk/src/interpretation.mli | 3 + srk/src/smt.ml | 4 + srk/src/smt.mli | 4 + srk/src/srkZ3.ml | 13 + srk/src/srkZ3.mli | 6 + srk/src/transition.ml | 514 ++++++++++++++++++++++++++++++++--- srk/src/transition.mli | 35 ++- srk/src/transitionSystem.mli | 4 + srk/src/weightedGraph.ml | 29 ++ srk/src/weightedGraph.mli | 5 +- 13 files changed, 592 insertions(+), 45 deletions(-) diff --git a/duet/cra.ml b/duet/cra.ml index afed1833..13a943cf 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -246,6 +246,8 @@ module K = struct Log.time "cra:star" star x let project = exists V.is_global + + let project_custom v = exists v end type ptr_term = diff --git a/duet/gps.ml b/duet/gps.ml index 346a8cff..3858b54b 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -494,7 +494,7 @@ module GPS = struct let f = List.map (fun (_, w, _) -> w) in let left = f left in let right = f right in - match K.project (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with + match K.project_mbp (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with | `Sat t -> `Unsafe t | _ -> Printf.printf " ------------------------ handle_path_to_error debug info: called by case %s ------------------\n" caller_id; @@ -537,7 +537,7 @@ module GPS = struct Summarizer.refine_over_summary (get_summarizer ctx) (ProcName.make (src, dst)) r; handle_path_to_error ctx left curr right dir err_leaf | Unsafe trs -> - begin match trs |> K.project (V.is_global) with + begin match trs |> K.project_mbp (V.is_global) with | `Sat tr -> Summarizer.refine_under_summary (get_summarizer ctx) (ProcName.make (src, dst)) tr; begin match right with @@ -622,12 +622,12 @@ module BM = BatMap.Make(Int) let analyze_concolic_mcl file = let open Srk.Iteration in populate_offset_table file; - K.domain := (module (Split(Product(LinearRecurrenceInequation)(PolyhedronGuard)))); + K.domain := (module (Split(Product(LossyTranslation)(PolyhedronGuard)))); match file.entry_points with | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system true rg in + let (ts, assertions) = make_transition_system rg in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts; Printf.printf "\nentry: %d\n" entry; @@ -648,12 +648,12 @@ let analyze_concolic_mcl file = let analyze_concolic_mcl file = let open Srk.Iteration in populate_offset_table file; - K.domain := (module (Split(Product(LinearRecurrenceInequation)(PolyhedronGuard)))); + K.domain := (module (Split(Product(LossyTranslation)(PolyhedronGuard)))); match file.entry_points with | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system true rg in + let (ts, assertions) = make_transition_system rg in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts; Printf.printf "\nentry: %d\n" entry; @@ -676,7 +676,7 @@ let dump_cfg simplify file = begin let rg = Interproc.make_recgraph file in let _ (* entry *) = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system simplify rg in + let (ts, assertions) = make_transition_system rg in let ts, _ = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts end diff --git a/srk/src/interpretation.ml b/srk/src/interpretation.ml index 328d3f50..4e1a806c 100644 --- a/srk/src/interpretation.ml +++ b/srk/src/interpretation.ml @@ -453,3 +453,7 @@ let select_ite interp ?(env=Env.empty) expr = in let expr' = rewrite interp.srk ~down:rewriter expr in (expr', !conditions) + + +let restrict (f : symbol -> bool) interp = + {interp with map = SM.filter (fun k _ -> f k) interp.map} diff --git a/srk/src/interpretation.mli b/srk/src/interpretation.mli index 8bc69590..baa28298 100644 --- a/srk/src/interpretation.mli +++ b/srk/src/interpretation.mli @@ -67,6 +67,9 @@ val select_ite : 'a interpretation -> ('a,'b) expr -> (('a,'b) expr) * ('a formula list) +val restrict : (symbol -> bool) -> 'a interpretation -> 'a interpretation + + val destruct_atom : 'a context -> 'a formula -> [ `ArithComparison of ([`Lt | `Leq | `Eq] * 'a arith_term * 'a arith_term) diff --git a/srk/src/smt.ml b/srk/src/smt.ml index 79896a66..37a28d41 100644 --- a/srk/src/smt.ml +++ b/srk/src/smt.ml @@ -92,6 +92,10 @@ module Solver = struct let push s = s.s_push () let pop s = s.s_pop + + let get_unsat_core srk solver assumptions = failwith "" + let get_unsat_core_or_model ?(symbols=[]) srk solver assumptions = failwith "" + let make srk = match get_theory srk with | `LIRA -> diff --git a/srk/src/smt.mli b/srk/src/smt.mli index 81a2f1f2..5187c82b 100644 --- a/srk/src/smt.mli +++ b/srk/src/smt.mli @@ -25,6 +25,10 @@ module StdSolver : sig val get_unsat_core : 'a t -> ('a formula) list -> [ `Sat | `Unsat of ('a formula) list | `Unknown ] + val get_unsat_core_or_model : ?symbols:symbol list -> 'a t -> + [ `Sat of 'a interpretation + | `Unsat of ('a formula) list + | `Unknown ] end module Model : sig diff --git a/srk/src/srkZ3.ml b/srk/src/srkZ3.ml index d1a6db92..5605975b 100644 --- a/srk/src/srkZ3.ml +++ b/srk/src/srkZ3.ml @@ -574,6 +574,19 @@ module Solver = struct | `Unsat -> `Unsat (List.map solver.formula_of (Z3.Solver.get_unsat_core solver.s)) + let get_unsat_core_or_model ?(symbols=[]) solver = + let srk = solver.srk in + let z3 = solver.z3 in + match check solver with + | `Sat -> + begin match Z3.Solver.get_model solver.s with + | Some m -> `Sat (Interpretation.wrap ~symbols srk (model_get_value srk z3 m)) + | None -> `Unknown + end + | `Unknown -> `Unknown + | `Unsat -> + `Unsat (List.map solver.formula_of (Z3.Solver.get_unsat_core solver.s)) + let get_reason_unknown solver = Z3.Solver.get_reason_unknown solver.s end diff --git a/srk/src/srkZ3.mli b/srk/src/srkZ3.mli index c0d4def5..873b9d82 100644 --- a/srk/src/srkZ3.mli +++ b/srk/src/srkZ3.mli @@ -80,6 +80,12 @@ module Solver : sig ('a formula) list -> [ `Sat | `Unsat of ('a formula) list | `Unknown ] + + val get_unsat_core_or_model : ?symbols: symbol list -> 'a t -> + [ `Sat of 'a interpretation + | `Unsat of ('a formula) list + | `Unknown ] + val get_reason_unknown : 'a t -> string end diff --git a/srk/src/transition.ml b/srk/src/transition.ml index 1f8f9152..445df263 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -113,41 +113,48 @@ struct (M.map (substitute_const srk left_subst) right.transform) in { transform; guard } - - let add left right = - let left_eq = ref [] in - let right_eq = ref [] in - let transform = - let merge v x y = - match x, y with - | Some s, Some t when Term.equal s t -> Some s - | _, _ -> - let phi = - mk_symbol srk ~name:("phi_" ^ (Var.show v)) ((Var.typ v) :> typ) - |> mk_const srk - in - let left_term = - match x with - | Some s -> s - | None -> mk_const srk (Var.symbol_of v) - in - let right_term = - match y with - | Some t -> t - | None -> mk_const srk (Var.symbol_of v) - in - left_eq := (mk_eq srk left_term phi)::(!left_eq); - right_eq := (mk_eq srk right_term phi)::(!right_eq); - Some phi + let compose left right ty = + let left_eq = ref [] in + let right_eq = ref [] in + let transform = + let merge v x y = + match x, y with + | Some s, Some t when Term.equal s t -> Some s + | _, _ -> + let phi = + mk_symbol srk ~name:("phi_" ^ (Var.show v)) ((Var.typ v) :> typ) + |> mk_const srk + in + let left_term = + match x with + | Some s -> s + | None -> mk_const srk (Var.symbol_of v) + in + let right_term = + match y with + | Some t -> t + | None -> mk_const srk (Var.symbol_of v) + in + left_eq := (mk_eq srk left_term phi)::(!left_eq); + right_eq := (mk_eq srk right_term phi)::(!right_eq); + Some phi + in + M.merge merge left.transform right.transform in - M.merge merge left.transform right.transform - in - let guard = - mk_or srk [mk_and srk (left.guard::(!left_eq)); - mk_and srk (right.guard::(!right_eq))] - in - { guard; transform } - + let guard = match ty with + | `Add -> + mk_or srk [mk_and srk (left.guard::(!left_eq)); + mk_and srk (right.guard::(!right_eq))] + | `And -> + mk_and srk [mk_and srk (left.guard::(!left_eq)); + mk_and srk (right.guard::(!right_eq))] + in + { guard; transform } + + let add left right = compose left right `Add + let conjunct left right = compose left right `And + + (* Canonical names for post-state symbols. Having canonical names simplifies equality testing and widening. *) let post_symbol = @@ -449,6 +456,431 @@ struct in `Valid (List.tl itp) + + let get_post_model m f = + let f_guard = guard f in + let replacer (sym : Syntax.symbol) = + if Var.of_symbol sym == None then Syntax.mk_const C.context sym + else mk_real C.context @@ Interpretation.real m sym + in + let f_guard' = Syntax.substitute_const C.context replacer f_guard in + let symbols = Syntax.symbols f_guard' |> Symbol.Set.elements in + let post pm = + BatEnum.fold (fun m' (lhs, rhs) -> + let sub_expr = Syntax.substitute_const C.context replacer rhs in + let lhs_symbol = Var.symbol_of lhs in + let sub_val = Interpretation.evaluate_term pm sub_expr in + Interpretation.add lhs_symbol (`Real sub_val) m') + m + (M.enum f.transform) + in + match Formula.destruct srk f_guard' with + | `Fls -> None + | `Tru -> + let zero_model = Interpretation.wrap srk (fun s -> + match typ_symbol srk s with + | `TyInt | `TyReal -> `Real QQ.zero + | `TyBool -> `Bool true + | _ -> assert false) + in + Some (post zero_model) + | _ -> + match Smt.get_model ~symbols:(symbols) C.context f_guard' with + | `Sat skolem_model -> Some (post skolem_model) + | _ -> None + + (* helper method for interpolate/extrapolate procedures. creates fresh copies of skolem variables in tr *) + let rename_skolems tr = + let fresh_skolem = + Memo.memo (fun sym -> + match Var.of_symbol sym with + | Some _ -> mk_const srk sym + | None -> + let name = show_symbol srk sym in + let typ = typ_symbol srk sym in + mk_const srk (mk_symbol srk ~name typ)) + in + { transform = M.map (substitute_const srk fresh_skolem) tr.transform; + guard = substitute_const srk fresh_skolem tr.guard } + + let interpolate_unsat_core trs post guards core = + let core_symbols = + List.fold_left (fun core phi -> + match Formula.destruct srk phi with + | (`Proposition (`App (s, []))) -> Symbol.Set.add s core + | _ -> assert false) + Symbol.Set.empty + core + in + let (itp, _) = + List.fold_right2 (fun tr guard (itp, post) -> + let subst sym = + match Var.of_symbol sym with + | Some var -> + if M.mem var tr.transform then + M.find var tr.transform + else + mk_const srk sym + | None -> mk_const srk sym + in + let post' = substitute_const srk subst post in + let reduced_guard = + List.filter_map (fun (indicator, guard) -> + if Symbol.Set.mem indicator core_symbols then + Some (mk_not srk guard) + else + None) + guard + in + let wp = + (mk_not srk (mk_or srk (post'::reduced_guard))) + |> Quantifier.mbp srk (fun s -> Var.of_symbol s != None) + |> mk_not srk + in + (wp::itp, wp)) + trs + guards + ([Quantifier.mbp srk (fun x -> Var.of_symbol x <> None) post], post) + in `Valid (List.tl itp) + + + let interpolate_query trs post sat_callback unsat_callback = + let solver = Smt.Solver.make C.context in + (* Break guards into conjunctions, associate each conjunct with an indicator *) + let guards = + List.map (fun tr -> + List.map + (fun phi -> (mk_symbol srk `TyBool, phi)) + (destruct_and srk tr.guard)) + trs in + let indicators, indicator_symbols = + List.concat_map (List.map (fun (s, _) -> mk_const srk s)) guards, + List.concat_map (List.map fst) guards |> Symbol.Set.of_list + in + let subscript_tbl = Hashtbl.create 991 in + let ss_inv = Hashtbl.create 991 in + let sst = Hashtbl.create 991 in + let subscript sym = + try + Hashtbl.find subscript_tbl sym + with Not_found -> mk_const srk sym + in + (* Convert tr into a formula, and simultaneously update the subscript + table *) + let to_ss_formula tr guards = + let ss_guards = + List.map (fun (indicator, guard) -> + mk_if srk + (mk_const srk indicator) + (substitute_const srk subscript guard)) + guards + in + let (ss, phis) = + M.fold (fun var term (ss, phis) -> + let var_sym = Var.symbol_of var in + let var_ss_sym = mk_symbol srk (Var.typ var :> typ) in + let var_ss_term = mk_const srk var_ss_sym in + let term_ss = substitute_const srk subscript term in + ((var_sym, var_ss_sym, var_ss_term)::ss, + mk_eq srk var_ss_term term_ss::phis)) + tr.transform + ([], ss_guards) + in + List.iter (fun (k, l, v) -> + Hashtbl.add subscript_tbl k v; + Hashtbl.add ss_inv l k; + Hashtbl.add sst k l) ss; + mk_and srk phis + in + (* gather all symbols into a list, while adding formulas to the solver object *) + let symbols, added_formulas = List.fold_left + (fun (symbols, added_formulas) (tr, guard) -> + let f = to_ss_formula tr guard in + Smt.Solver.add solver [f]; + (Syntax.symbols f) :: symbols, f::added_formulas) + ([], []) (List.combine trs guards) in + let _ = List.iter (fun f -> + let f = substitute_const srk + (fun v -> + match Hashtbl.find_opt ss_inv v with + | None -> Syntax.mk_const srk v + | Some v' -> Syntax.mk_const srk v') f + in logf ~level:`always "added formula: %a\n" (Syntax.pp_expr srk) f) added_formulas + (* subscript the symbols in the `post` formula, as well *) in + let target = substitute_const srk subscript (mk_not srk post) in + let symbols = (Syntax.symbols target) :: symbols + |> List.rev + |> List.map (fun ss -> Symbol.Set.diff ss indicator_symbols) in + Smt.Solver.add solver [target]; + Printf.printf "-----------------------------interpolation---\n"; + List.iter (fun f -> + let f = substitute_const srk + (fun v -> + match Hashtbl.find_opt ss_inv v with + | None -> Syntax.mk_const srk v + | Some v' -> Syntax.mk_const srk v') f + in logf ~level:`always "indicator formula: %a\n" (Syntax.pp_expr srk) f) indicators; + Printf.printf "-------------------interpolation end---\n"; + Printf.printf "--- indicator length %d\n" @@ List.length indicators; + logf ~level:`always "\ntarget formula: %a\n" (Syntax.pp_expr srk) target; + Smt.Solver.add solver indicators; + match Smt.Solver.get_unsat_core_or_model solver with + | `Sat m -> + (sat_callback m symbols sst ss_inv) + | `Unsat core -> (unsat_callback trs post guards core) + | `Unknown -> `Unknown + + + (* let interpolate trs post = + let trs = List.map rename_skolems trs in + interpolate_query trs post (fun _ _ _ _ -> `Invalid) @@ interpolate_unsat_core +*) + let interpolate_or_concrete_model trs post = + (* subst_model: rename skolem constants back to their appropriate names using reverse subscript table *) + let trs = List.map rename_skolems trs in + let sat_model model (symbols: Symbol.Set.t list) ss ss_inv = + let m = + List.fold_left (fun m' symbols -> + Symbol.Set.fold (fun s m -> + (* the provided model is over both subscripted vocabulary and original vocabulary *) + begin match Hashtbl.find_opt ss_inv s with + | Some s' -> (* subscripted variable *) + Interpretation.add s' (Interpretation.value model s) m + | None -> (* non-subscripted; query directly *) + Interpretation.add s (Interpretation.value model s) m + end) symbols m' + ) (Interpretation.wrap srk (fun s -> + match Hashtbl.find_opt ss s with + | Some sss -> Interpretation.value model sss + | None -> `Real (Q.of_int 47))) (*(Interpretation.wrap srk (fun s -> + match Hashtbl.find_opt ss s with + | Some sss -> Interpretation.value model sss + | None -> Interpretation.value model s))*) (*(Interpretation.empty srk)*) symbols in + Printf.printf "hashtable length: %d\n" (Hashtbl.length ss_inv); + Interpretation.pp Format.std_formatter m; + Format.print_flush (); + (* symbols is a list of subscripted symbols arranged in left-to-right order. + folding over this in left-to-right order amounts to forward concrete execution. *) + `Invalid (m + |> Interpretation.restrict + (fun s -> + match Var.of_symbol s with + | Some _ -> true + | None -> false)) + in interpolate_query trs post sat_model @@ interpolate_unsat_core + + + let contextualize t1 t2 t3 : [`Sat of t | `Unsat ] = + let t1 = rename_skolems t1 + in let t2 = rename_skolems t2 + in let t3 = rename_skolems t3 + in let subscript subscript_tbl sym = + try + Hashtbl.find subscript_tbl sym + with Not_found -> + mk_const srk sym + in + (* preprocess each formula to get rid of certain undesirable things *) + let preprocess_formula f = + let nnf_rewriter = Syntax.nnf_rewriter srk in + f |> Syntax.eliminate_ite srk + |> Syntax.eliminate_floor_mod_div srk + |> Syntax.rewrite srk ~down:nnf_rewriter in + (* Convert tr into a formula, and simultaneously update the subscript + table *) + let to_ss_formula tr subscript_tbl reverse_subscript_tbl = + let ss_guard = substitute_const srk (subscript subscript_tbl) (guard tr) + in let (ss, phis) = + M.fold (fun var term (ss, phis) -> + let var_sym = Var.symbol_of var in + let var_ss_sym = mk_symbol srk (Var.typ var :> typ) in + let var_ss_term = mk_const srk var_ss_sym in + let term_ss = substitute_const srk (subscript subscript_tbl) term in + ((var_sym, var_ss_term, var_ss_sym)::ss, + (mk_eq srk var_ss_term term_ss)::phis)) + tr.transform + ([], [ ss_guard ]) + in + List.iter (fun (k, v, l) -> + Hashtbl.add subscript_tbl k v; Hashtbl.add reverse_subscript_tbl l k) ss; + mk_and srk phis |> preprocess_formula, Hashtbl.copy reverse_subscript_tbl + in let subscript_tbl = Hashtbl.create 991 + in let reverse_subscript_tbl = Hashtbl.create 991 + in let ss_t1, reverse_subscript_tbl1 = to_ss_formula t1 subscript_tbl reverse_subscript_tbl + in let ss_t2, reverse_subscript_tbl2 = to_ss_formula t2 subscript_tbl reverse_subscript_tbl + in let ss_t3, _ = to_ss_formula t3 subscript_tbl reverse_subscript_tbl + in let conj = mk_and srk [ss_t1; ss_t2; ss_t3] + in let is_global t x = + try + begin match Var.of_symbol (Hashtbl.find t x) with + | None -> false + | Some v -> + if Var.is_global v then begin + Printf.printf "symbol %s is global\n" (Syntax.show_symbol srk (Hashtbl.find reverse_subscript_tbl x)); true + end else false + end + with Not_found -> false + in let symbols_t1 = Syntax.symbols ss_t1 + in let symbols_t2 = Syntax.symbols ss_t2 + in let symbols_t3 = Syntax.symbols ss_t3 + in let symbols_t1_t2 = + Syntax.symbols ss_t1 (* symbols in t1 that are either globals _and_ in t2 are preserved during projection *) + |> Symbol.Set.filter + (fun x -> (is_global reverse_subscript_tbl1 x)) + in let symbols_t3_t2 = + symbols_t3 (* symbols in t3 that are globals _and_ in t2, t1 are preserved during projection *) + |> Symbol.Set.filter (fun x -> (is_global reverse_subscript_tbl2 x) && (Symbol.Set.mem x symbols_t2)) + in let symbols_conj = Symbol.Set.union symbols_t1 (Symbol.Set.union symbols_t2 symbols_t3) + in + let project srk (f1: 'a formula) (f3: 'a formula) symbols_f1 symbols_f3 all_symbols model = + let open Polyhedron in + (* first do NNF conversion on f1, f3 before computing their implicants *) + (* rjf Mar '24: we do this as part of preprocessing to avoid rewriting the formula after an SMT query to get `model`*) + (*let nnf_rewriter = Syntax.nnf_rewriter srk in + let f1 = Syntax.rewrite srk ~down:(nnf_rewriter) f1 in + let f3 = Syntax.rewrite srk ~down:(nnf_rewriter) f3 in*) + let implicant_o1 = Interpretation.select_implicant model f1 in + let implicant_o2 = Interpretation.select_implicant model f3 in + match implicant_o1, implicant_o2 with + | Some f1, Some f2 -> + let cube = of_cube srk (f1@f2) in + let value_of_coord = (* coord (int) -> x (symbol) -> m[x] (value in R) *) + fun coord -> + Syntax.symbol_of_int coord + |> Interpretation.real model + in let xs = + Symbol.Set.diff all_symbols (Symbol.Set.union symbols_f1 symbols_f3) + |> Symbol.Set.elements + |> List.map Syntax.int_of_symbol + in let projected = local_project value_of_coord xs cube + in cube_of srk projected |> Syntax.mk_and srk + | None, Some f -> + Printf.printf "contextualize: select_implicant failed on left formula: \n"; + logf ~level: `always "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; + logf ~level: `always "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; + List.iteri (fun _ x -> logf ~level: `always "\n -- impicant of right formula:%a\n" (Syntax.pp_expr srk) x) f; + logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + failwith "error extrapolating: select_implicant failed on left formula" + | Some f, None -> + Printf.printf "contextualize: select_implicant failed on right formula: \n"; + logf ~level: `always "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; + List.iteri (fun _ x -> logf ~level: `always "\n -- impicant of left formula:%a\n" (Syntax.pp_expr srk) x) f; + logf ~level: `always "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; + logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + failwith "error extrapolating: select_implicant failed on right formula" + | None, None -> + logf ~level:`always "left: %a\n" (Syntax.pp_expr srk) f1; + Format.print_flush (); + logf ~level:`always "right: %a\n" (Syntax.pp_expr srk) f3; + Format.print_flush (); + logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + Format.print_flush (); + failwith "error extrapolating: select_implicant failed on both formulae" + in + match Smt.get_model ~symbols:(symbols_conj |> Symbol.Set.elements) srk conj with + | `Sat m -> + let prepost = project srk ss_t1 ss_t3 symbols_t1_t2 symbols_t3_t2 symbols_conj m in + let reverse_rename_t1 s = + begin match Hashtbl.find_opt reverse_subscript_tbl1 s with + | Some s' -> mk_const srk s' + | None -> mk_const srk s end in + let r_guard = substitute_const srk (reverse_rename_t1) prepost in + let r_transform = + (* for each skolem symbol in r_guard, see if it can be mapped back to a variable. *) + let r_symbols = Syntax.symbols r_guard |> Symbol.Set.to_list in + List.fold_left (fun m x -> + match Hashtbl.find_opt reverse_subscript_tbl x with + | Some y -> + begin match Var.of_symbol y with + | Some var -> M.add var (mk_const srk x) m + | None -> m + end + | None -> m) M.empty r_symbols in + let r = {transform=r_transform; guard=r_guard} + in + `Sat r + | `Unknown -> failwith "contextualize status unknown" + | `Unsat -> `Unsat + + + + (** underapproximate existential quantification. Given a transition formula tr over vocabulary X, + use model-based projection to project out any variable v in X such that f(v) = false. *) + let project_mbp (f : var -> bool) tr = + let ss_to_sym = Hashtbl.create 991 in + (* preprocessing of a formula *) + let preprocess f = + let nnf_rewriter = Syntax.nnf_rewriter srk in + f |> Syntax.eliminate_ite srk |> Syntax.eliminate_floor_mod_div srk + |> Syntax.rewrite srk ~down:nnf_rewriter in + let phis = + M.fold (fun var term phis -> + let var_sym = Var.symbol_of var in + let var_ss_sym = mk_symbol srk (Var.typ var :> typ) in + let var_ss_term = mk_const srk var_ss_sym in + Hashtbl.add ss_to_sym var_ss_sym var_sym; + (mk_eq srk var_ss_term term)::phis) + tr.transform + [ guard tr ] in + let tr_formula = mk_and srk phis |> preprocess in + let tr_symbols = Syntax.symbols tr_formula in + let tr_symbols_preserved = + tr_symbols + |> Symbol.Set.filter (fun s -> + match Hashtbl.find_opt ss_to_sym s with + | Some sym -> + begin match Var.of_symbol sym with + | Some v -> f v + | None -> false + end + | None -> false (* discard any skolem constants *)) in + let tr_symbols_removed = Symbol.Set.diff tr_symbols tr_symbols_preserved in + let prj formula voc model = + let open Polyhedron in + (* first do NNF conversion on [formula] before computing their implicants *) + (* rjf Mar '24: This is done using the preprocess function defined above.*) + (*let nnf_rewriter = Syntax.nnf_rewriter srk in + let formula' = + formula + |> Syntax.eliminate_ite srk + |> Syntax.eliminate_floor_mod_div srk + |> Syntax.rewrite srk ~down:(nnf_rewriter) in*) + let implicant = Interpretation.select_implicant model formula in + match implicant with + | Some i -> + let cube = of_cube srk i in + let value_of_coord = (* coord (int) -> x (symbol) -> m[x] (value in R) *) + fun coord -> + Syntax.symbol_of_int coord + |> Interpretation.real model + in let xs = (* coordinates to be projected out *) + voc + |> Symbol.Set.elements + |> List.map Syntax.int_of_symbol + in let projected = local_project value_of_coord xs cube + in cube_of srk projected |> Syntax.mk_and srk + | _ -> + logf ~level:`always "\n--select_implicant formula: %a\n" (Syntax.pp_expr srk) formula; + Format.print_flush (); + logf ~level:`always "\n--select_implicant model: %a\n" (Interpretation.pp) model; + Format.print_flush(); + failwith "error projecting: select_implicant returned None" + in match Smt.get_model ~symbols:(tr_symbols |> Symbol.Set.elements) srk tr_formula with + | `Sat m -> + let projected = prj tr_formula tr_symbols_removed m in + let tr_transform = + Hashtbl.fold (fun ss sym acc -> + let ss_term = mk_const srk ss in + match Var.of_symbol sym with + | Some v -> M.add v ss_term acc + | None -> failwith "u_exists: shoul not get here: subscript invariant broken") + ss_to_sym M.empty + in + `Sat {guard=projected;transform=tr_transform} + | `Unknown -> failwith "u_exists: got unknown as a result of get_model" + | _ -> `Unsat + + let valid_triple phi path post = let path_not_post = List.fold_right mul path (assume (mk_not srk post)) in match Smt.is_sat srk (mk_and srk [phi; path_not_post.guard]) with @@ -499,6 +931,20 @@ struct |> rewrite srk ~down:(pos_rewriter srk) |> Abstract.abstract ~exists srk man + + + let contains_havoc tr = + M.fold (fun _ rhs acc -> + if acc then acc + else begin + Symbol.Set.fold + (fun s acc -> + match Var.of_symbol s with + | Some _ -> acc + | None -> true || acc) (Syntax.symbols rhs) false + end + ) tr.transform false + let linearize tr = let (transform, defs) = M.fold (fun var t (transform, defs) -> diff --git a/srk/src/transition.mli b/srk/src/transition.mli index 1c8fcff7..5df1b37c 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -70,6 +70,9 @@ module Make (** Non-deterministically choose between two transitions *) val add : t -> t -> t + (** take conjunction of two transition formulas *) + val conjunct : t -> t -> t + (** Unexecutable transition (unit of [add]). *) val zero : t @@ -110,9 +113,32 @@ module Make support the proof (for each [i], [{ phi_{i-1} } tr_i { phi_i }] holds, where [phi_0] is [true] and [phi_n] implies the post-condition). *) - val interpolate : t list -> C.t formula -> [ `Valid of C.t formula list - | `Invalid - | `Unknown ] + val interpolate : t list -> C.t formula -> [ `Valid of C.t formula list + | `Invalid + | `Unknown ] + + val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] + + (** Same as interpolate, but returns a concrete model if interpllation fails. *) + val interpolate_or_concrete_model : t list -> C.t formula + -> [`Valid of C.t formula list | `Invalid of C.t Interpretation.interpretation | `Unknown ] + + + + (** + transtion : guard, transform + interpretation: M + find a model of the guard where we use M to replace all the pre-state value. + check interpretation.substitute + *) + val get_post_model : C.t Interpretation.interpretation -> t -> (C.t Interpretation.interpretation) option + + + (** Underapproximate existential quantification using model-based projection. + The variables to be preserved are set to `true` in the initial map. + Note the input map specifies variables to be preserved, not removed. *) + val project_mbp : (var -> bool) -> t -> [> `Sat of t | `Unsat] + (** Given a pre-condition [P], a path [path], and a post-condition [Q], determine whether the Hoare triple [{P}path{Q}] is valid. *) @@ -120,6 +146,9 @@ module Make | `Invalid | `Unknown ] + val contains_havoc : t -> bool + + val defines : t -> var list val uses : t -> var list diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index 4c77a22a..47c70334 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -79,6 +79,10 @@ module Make (** Get procedure summary; delegates call to WG.RecGraph.get_summary *) val get_summary : query -> (vertex * vertex) -> transition + (** delegates call to RecGraph.inter_path_summary / RecGraph.intra_path_summary *) + val inter_path_summary : query -> vertex -> vertex -> transition + + val intra_path_summary : query -> vertex -> vertex -> transition (** Compute interval invariants for each loop header of a transition system. The invariant computed for a loop is defined only over the variables diff --git a/srk/src/weightedGraph.ml b/srk/src/weightedGraph.ml index d3fced8e..881c0c08 100644 --- a/srk/src/weightedGraph.ml +++ b/srk/src/weightedGraph.ml @@ -517,6 +517,12 @@ module RecGraph = struct type query = { recgraph : t; + (* The instrumented graph retains the path_graph of recgraph as a + subgraph, and for each call-edge (u,v) to target procedure (src,tgt), + adds an edge (u, src) to the target procedure. *) + instrumented_graph : Pathexpr.simple Pathexpr.t weighted_graph; + + (* The intraprocedural path graph has an edge u->v for each entry vertex u and each vertex v reachable from u, weighted with a path expression for the paths from u to v. *) @@ -590,6 +596,13 @@ module RecGraph = struct |> VertexSet.elements in let intraproc_paths = msat_path_weight rg.path_graph sources in + let instrumented_edges = + M.fold (fun (u, _) (entry, _) acc -> + (u,entry) :: acc + ) rg.call_edges [] + in let instrumented_graph = + List.fold_left (fun acc (u, src) -> + add_edge acc u (Pathexpr.mk_one rg.context) src) rg.path_graph instrumented_edges in let interproc = let intraproc_paths = edge_weight intraproc_paths in List.fold_left (fun interproc_graph src -> @@ -608,6 +621,7 @@ module RecGraph = struct sources in { recgraph = rg; + instrumented_graph = instrumented_graph; intraproc_paths = intraproc_paths; interproc = interproc; interproc_paths = msat_path_weight interproc [src]; @@ -723,6 +737,21 @@ module RecGraph = struct query.changed := CallSet.add call !(query.changed); HT.replace query.summaries call weight + + + let intra_path_summary (wq: 'a weight_query) src tgt = + let q = wq.query in + let g = q.recgraph in + let (table, algebra) = prepare wq in + Pathexpr.eval ~table ~algebra (path_weight g.path_graph src tgt) + + let inter_path_summary (wq: 'a weight_query) src tgt = + let q = wq.query in + let g = q.instrumented_graph in + let (table, algebra) = prepare wq in + Pathexpr.eval ~table ~algebra (path_weight g src tgt) + + let mk_weight_query query algebra = { query = query; summaries = HT.create 991; diff --git a/srk/src/weightedGraph.mli b/srk/src/weightedGraph.mli index 624a7688..62e9e4f2 100644 --- a/srk/src/weightedGraph.mli +++ b/srk/src/weightedGraph.mli @@ -207,10 +207,13 @@ module RecGraph : sig (** Find the sum of weights of all intraprocedural paths through a given call. *) val call_weight : 'a weight_query -> call -> 'a - val get_summary : 'a weight_query -> call -> 'a val set_summary : 'a weight_query -> call -> 'a -> unit + val intra_path_summary : 'a weight_query -> int -> int -> 'a + + val inter_path_summary : 'a weight_query -> int -> int -> 'a + (** Find the sum of weights of all infinite interprocedural paths beginning at the query's source vertex. *) val omega_path_weight : 'a weight_query -> ('a,'b) Pathexpr.omega_algebra -> 'b From c4d2177c4192082cca483293a10d52db3aabc724 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Tue, 27 Aug 2024 23:23:30 -0400 Subject: [PATCH 04/59] Various updates --- duet/cra.ml | 2 + duet/gps.ml | 14 +- srk/src/interpretation.ml | 4 + srk/src/interpretation.mli | 3 + srk/src/smt.ml | 4 + srk/src/smt.mli | 4 + srk/src/srkZ3.ml | 13 + srk/src/srkZ3.mli | 6 + srk/src/transition.ml | 514 ++++++++++++++++++++++++++++++++--- srk/src/transition.mli | 35 ++- srk/src/transitionSystem.mli | 4 + srk/src/weightedGraph.ml | 29 ++ srk/src/weightedGraph.mli | 5 +- 13 files changed, 592 insertions(+), 45 deletions(-) diff --git a/duet/cra.ml b/duet/cra.ml index afed1833..13a943cf 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -246,6 +246,8 @@ module K = struct Log.time "cra:star" star x let project = exists V.is_global + + let project_custom v = exists v end type ptr_term = diff --git a/duet/gps.ml b/duet/gps.ml index 346a8cff..3858b54b 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -494,7 +494,7 @@ module GPS = struct let f = List.map (fun (_, w, _) -> w) in let left = f left in let right = f right in - match K.project (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with + match K.project_mbp (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with | `Sat t -> `Unsafe t | _ -> Printf.printf " ------------------------ handle_path_to_error debug info: called by case %s ------------------\n" caller_id; @@ -537,7 +537,7 @@ module GPS = struct Summarizer.refine_over_summary (get_summarizer ctx) (ProcName.make (src, dst)) r; handle_path_to_error ctx left curr right dir err_leaf | Unsafe trs -> - begin match trs |> K.project (V.is_global) with + begin match trs |> K.project_mbp (V.is_global) with | `Sat tr -> Summarizer.refine_under_summary (get_summarizer ctx) (ProcName.make (src, dst)) tr; begin match right with @@ -622,12 +622,12 @@ module BM = BatMap.Make(Int) let analyze_concolic_mcl file = let open Srk.Iteration in populate_offset_table file; - K.domain := (module (Split(Product(LinearRecurrenceInequation)(PolyhedronGuard)))); + K.domain := (module (Split(Product(LossyTranslation)(PolyhedronGuard)))); match file.entry_points with | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system true rg in + let (ts, assertions) = make_transition_system rg in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts; Printf.printf "\nentry: %d\n" entry; @@ -648,12 +648,12 @@ let analyze_concolic_mcl file = let analyze_concolic_mcl file = let open Srk.Iteration in populate_offset_table file; - K.domain := (module (Split(Product(LinearRecurrenceInequation)(PolyhedronGuard)))); + K.domain := (module (Split(Product(LossyTranslation)(PolyhedronGuard)))); match file.entry_points with | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system true rg in + let (ts, assertions) = make_transition_system rg in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts; Printf.printf "\nentry: %d\n" entry; @@ -676,7 +676,7 @@ let dump_cfg simplify file = begin let rg = Interproc.make_recgraph file in let _ (* entry *) = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system simplify rg in + let (ts, assertions) = make_transition_system rg in let ts, _ = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts end diff --git a/srk/src/interpretation.ml b/srk/src/interpretation.ml index 328d3f50..4e1a806c 100644 --- a/srk/src/interpretation.ml +++ b/srk/src/interpretation.ml @@ -453,3 +453,7 @@ let select_ite interp ?(env=Env.empty) expr = in let expr' = rewrite interp.srk ~down:rewriter expr in (expr', !conditions) + + +let restrict (f : symbol -> bool) interp = + {interp with map = SM.filter (fun k _ -> f k) interp.map} diff --git a/srk/src/interpretation.mli b/srk/src/interpretation.mli index 8bc69590..baa28298 100644 --- a/srk/src/interpretation.mli +++ b/srk/src/interpretation.mli @@ -67,6 +67,9 @@ val select_ite : 'a interpretation -> ('a,'b) expr -> (('a,'b) expr) * ('a formula list) +val restrict : (symbol -> bool) -> 'a interpretation -> 'a interpretation + + val destruct_atom : 'a context -> 'a formula -> [ `ArithComparison of ([`Lt | `Leq | `Eq] * 'a arith_term * 'a arith_term) diff --git a/srk/src/smt.ml b/srk/src/smt.ml index 79896a66..37a28d41 100644 --- a/srk/src/smt.ml +++ b/srk/src/smt.ml @@ -92,6 +92,10 @@ module Solver = struct let push s = s.s_push () let pop s = s.s_pop + + let get_unsat_core srk solver assumptions = failwith "" + let get_unsat_core_or_model ?(symbols=[]) srk solver assumptions = failwith "" + let make srk = match get_theory srk with | `LIRA -> diff --git a/srk/src/smt.mli b/srk/src/smt.mli index 81a2f1f2..5187c82b 100644 --- a/srk/src/smt.mli +++ b/srk/src/smt.mli @@ -25,6 +25,10 @@ module StdSolver : sig val get_unsat_core : 'a t -> ('a formula) list -> [ `Sat | `Unsat of ('a formula) list | `Unknown ] + val get_unsat_core_or_model : ?symbols:symbol list -> 'a t -> + [ `Sat of 'a interpretation + | `Unsat of ('a formula) list + | `Unknown ] end module Model : sig diff --git a/srk/src/srkZ3.ml b/srk/src/srkZ3.ml index d1a6db92..5605975b 100644 --- a/srk/src/srkZ3.ml +++ b/srk/src/srkZ3.ml @@ -574,6 +574,19 @@ module Solver = struct | `Unsat -> `Unsat (List.map solver.formula_of (Z3.Solver.get_unsat_core solver.s)) + let get_unsat_core_or_model ?(symbols=[]) solver = + let srk = solver.srk in + let z3 = solver.z3 in + match check solver with + | `Sat -> + begin match Z3.Solver.get_model solver.s with + | Some m -> `Sat (Interpretation.wrap ~symbols srk (model_get_value srk z3 m)) + | None -> `Unknown + end + | `Unknown -> `Unknown + | `Unsat -> + `Unsat (List.map solver.formula_of (Z3.Solver.get_unsat_core solver.s)) + let get_reason_unknown solver = Z3.Solver.get_reason_unknown solver.s end diff --git a/srk/src/srkZ3.mli b/srk/src/srkZ3.mli index c0d4def5..873b9d82 100644 --- a/srk/src/srkZ3.mli +++ b/srk/src/srkZ3.mli @@ -80,6 +80,12 @@ module Solver : sig ('a formula) list -> [ `Sat | `Unsat of ('a formula) list | `Unknown ] + + val get_unsat_core_or_model : ?symbols: symbol list -> 'a t -> + [ `Sat of 'a interpretation + | `Unsat of ('a formula) list + | `Unknown ] + val get_reason_unknown : 'a t -> string end diff --git a/srk/src/transition.ml b/srk/src/transition.ml index 1f8f9152..445df263 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -113,41 +113,48 @@ struct (M.map (substitute_const srk left_subst) right.transform) in { transform; guard } - - let add left right = - let left_eq = ref [] in - let right_eq = ref [] in - let transform = - let merge v x y = - match x, y with - | Some s, Some t when Term.equal s t -> Some s - | _, _ -> - let phi = - mk_symbol srk ~name:("phi_" ^ (Var.show v)) ((Var.typ v) :> typ) - |> mk_const srk - in - let left_term = - match x with - | Some s -> s - | None -> mk_const srk (Var.symbol_of v) - in - let right_term = - match y with - | Some t -> t - | None -> mk_const srk (Var.symbol_of v) - in - left_eq := (mk_eq srk left_term phi)::(!left_eq); - right_eq := (mk_eq srk right_term phi)::(!right_eq); - Some phi + let compose left right ty = + let left_eq = ref [] in + let right_eq = ref [] in + let transform = + let merge v x y = + match x, y with + | Some s, Some t when Term.equal s t -> Some s + | _, _ -> + let phi = + mk_symbol srk ~name:("phi_" ^ (Var.show v)) ((Var.typ v) :> typ) + |> mk_const srk + in + let left_term = + match x with + | Some s -> s + | None -> mk_const srk (Var.symbol_of v) + in + let right_term = + match y with + | Some t -> t + | None -> mk_const srk (Var.symbol_of v) + in + left_eq := (mk_eq srk left_term phi)::(!left_eq); + right_eq := (mk_eq srk right_term phi)::(!right_eq); + Some phi + in + M.merge merge left.transform right.transform in - M.merge merge left.transform right.transform - in - let guard = - mk_or srk [mk_and srk (left.guard::(!left_eq)); - mk_and srk (right.guard::(!right_eq))] - in - { guard; transform } - + let guard = match ty with + | `Add -> + mk_or srk [mk_and srk (left.guard::(!left_eq)); + mk_and srk (right.guard::(!right_eq))] + | `And -> + mk_and srk [mk_and srk (left.guard::(!left_eq)); + mk_and srk (right.guard::(!right_eq))] + in + { guard; transform } + + let add left right = compose left right `Add + let conjunct left right = compose left right `And + + (* Canonical names for post-state symbols. Having canonical names simplifies equality testing and widening. *) let post_symbol = @@ -449,6 +456,431 @@ struct in `Valid (List.tl itp) + + let get_post_model m f = + let f_guard = guard f in + let replacer (sym : Syntax.symbol) = + if Var.of_symbol sym == None then Syntax.mk_const C.context sym + else mk_real C.context @@ Interpretation.real m sym + in + let f_guard' = Syntax.substitute_const C.context replacer f_guard in + let symbols = Syntax.symbols f_guard' |> Symbol.Set.elements in + let post pm = + BatEnum.fold (fun m' (lhs, rhs) -> + let sub_expr = Syntax.substitute_const C.context replacer rhs in + let lhs_symbol = Var.symbol_of lhs in + let sub_val = Interpretation.evaluate_term pm sub_expr in + Interpretation.add lhs_symbol (`Real sub_val) m') + m + (M.enum f.transform) + in + match Formula.destruct srk f_guard' with + | `Fls -> None + | `Tru -> + let zero_model = Interpretation.wrap srk (fun s -> + match typ_symbol srk s with + | `TyInt | `TyReal -> `Real QQ.zero + | `TyBool -> `Bool true + | _ -> assert false) + in + Some (post zero_model) + | _ -> + match Smt.get_model ~symbols:(symbols) C.context f_guard' with + | `Sat skolem_model -> Some (post skolem_model) + | _ -> None + + (* helper method for interpolate/extrapolate procedures. creates fresh copies of skolem variables in tr *) + let rename_skolems tr = + let fresh_skolem = + Memo.memo (fun sym -> + match Var.of_symbol sym with + | Some _ -> mk_const srk sym + | None -> + let name = show_symbol srk sym in + let typ = typ_symbol srk sym in + mk_const srk (mk_symbol srk ~name typ)) + in + { transform = M.map (substitute_const srk fresh_skolem) tr.transform; + guard = substitute_const srk fresh_skolem tr.guard } + + let interpolate_unsat_core trs post guards core = + let core_symbols = + List.fold_left (fun core phi -> + match Formula.destruct srk phi with + | (`Proposition (`App (s, []))) -> Symbol.Set.add s core + | _ -> assert false) + Symbol.Set.empty + core + in + let (itp, _) = + List.fold_right2 (fun tr guard (itp, post) -> + let subst sym = + match Var.of_symbol sym with + | Some var -> + if M.mem var tr.transform then + M.find var tr.transform + else + mk_const srk sym + | None -> mk_const srk sym + in + let post' = substitute_const srk subst post in + let reduced_guard = + List.filter_map (fun (indicator, guard) -> + if Symbol.Set.mem indicator core_symbols then + Some (mk_not srk guard) + else + None) + guard + in + let wp = + (mk_not srk (mk_or srk (post'::reduced_guard))) + |> Quantifier.mbp srk (fun s -> Var.of_symbol s != None) + |> mk_not srk + in + (wp::itp, wp)) + trs + guards + ([Quantifier.mbp srk (fun x -> Var.of_symbol x <> None) post], post) + in `Valid (List.tl itp) + + + let interpolate_query trs post sat_callback unsat_callback = + let solver = Smt.Solver.make C.context in + (* Break guards into conjunctions, associate each conjunct with an indicator *) + let guards = + List.map (fun tr -> + List.map + (fun phi -> (mk_symbol srk `TyBool, phi)) + (destruct_and srk tr.guard)) + trs in + let indicators, indicator_symbols = + List.concat_map (List.map (fun (s, _) -> mk_const srk s)) guards, + List.concat_map (List.map fst) guards |> Symbol.Set.of_list + in + let subscript_tbl = Hashtbl.create 991 in + let ss_inv = Hashtbl.create 991 in + let sst = Hashtbl.create 991 in + let subscript sym = + try + Hashtbl.find subscript_tbl sym + with Not_found -> mk_const srk sym + in + (* Convert tr into a formula, and simultaneously update the subscript + table *) + let to_ss_formula tr guards = + let ss_guards = + List.map (fun (indicator, guard) -> + mk_if srk + (mk_const srk indicator) + (substitute_const srk subscript guard)) + guards + in + let (ss, phis) = + M.fold (fun var term (ss, phis) -> + let var_sym = Var.symbol_of var in + let var_ss_sym = mk_symbol srk (Var.typ var :> typ) in + let var_ss_term = mk_const srk var_ss_sym in + let term_ss = substitute_const srk subscript term in + ((var_sym, var_ss_sym, var_ss_term)::ss, + mk_eq srk var_ss_term term_ss::phis)) + tr.transform + ([], ss_guards) + in + List.iter (fun (k, l, v) -> + Hashtbl.add subscript_tbl k v; + Hashtbl.add ss_inv l k; + Hashtbl.add sst k l) ss; + mk_and srk phis + in + (* gather all symbols into a list, while adding formulas to the solver object *) + let symbols, added_formulas = List.fold_left + (fun (symbols, added_formulas) (tr, guard) -> + let f = to_ss_formula tr guard in + Smt.Solver.add solver [f]; + (Syntax.symbols f) :: symbols, f::added_formulas) + ([], []) (List.combine trs guards) in + let _ = List.iter (fun f -> + let f = substitute_const srk + (fun v -> + match Hashtbl.find_opt ss_inv v with + | None -> Syntax.mk_const srk v + | Some v' -> Syntax.mk_const srk v') f + in logf ~level:`always "added formula: %a\n" (Syntax.pp_expr srk) f) added_formulas + (* subscript the symbols in the `post` formula, as well *) in + let target = substitute_const srk subscript (mk_not srk post) in + let symbols = (Syntax.symbols target) :: symbols + |> List.rev + |> List.map (fun ss -> Symbol.Set.diff ss indicator_symbols) in + Smt.Solver.add solver [target]; + Printf.printf "-----------------------------interpolation---\n"; + List.iter (fun f -> + let f = substitute_const srk + (fun v -> + match Hashtbl.find_opt ss_inv v with + | None -> Syntax.mk_const srk v + | Some v' -> Syntax.mk_const srk v') f + in logf ~level:`always "indicator formula: %a\n" (Syntax.pp_expr srk) f) indicators; + Printf.printf "-------------------interpolation end---\n"; + Printf.printf "--- indicator length %d\n" @@ List.length indicators; + logf ~level:`always "\ntarget formula: %a\n" (Syntax.pp_expr srk) target; + Smt.Solver.add solver indicators; + match Smt.Solver.get_unsat_core_or_model solver with + | `Sat m -> + (sat_callback m symbols sst ss_inv) + | `Unsat core -> (unsat_callback trs post guards core) + | `Unknown -> `Unknown + + + (* let interpolate trs post = + let trs = List.map rename_skolems trs in + interpolate_query trs post (fun _ _ _ _ -> `Invalid) @@ interpolate_unsat_core +*) + let interpolate_or_concrete_model trs post = + (* subst_model: rename skolem constants back to their appropriate names using reverse subscript table *) + let trs = List.map rename_skolems trs in + let sat_model model (symbols: Symbol.Set.t list) ss ss_inv = + let m = + List.fold_left (fun m' symbols -> + Symbol.Set.fold (fun s m -> + (* the provided model is over both subscripted vocabulary and original vocabulary *) + begin match Hashtbl.find_opt ss_inv s with + | Some s' -> (* subscripted variable *) + Interpretation.add s' (Interpretation.value model s) m + | None -> (* non-subscripted; query directly *) + Interpretation.add s (Interpretation.value model s) m + end) symbols m' + ) (Interpretation.wrap srk (fun s -> + match Hashtbl.find_opt ss s with + | Some sss -> Interpretation.value model sss + | None -> `Real (Q.of_int 47))) (*(Interpretation.wrap srk (fun s -> + match Hashtbl.find_opt ss s with + | Some sss -> Interpretation.value model sss + | None -> Interpretation.value model s))*) (*(Interpretation.empty srk)*) symbols in + Printf.printf "hashtable length: %d\n" (Hashtbl.length ss_inv); + Interpretation.pp Format.std_formatter m; + Format.print_flush (); + (* symbols is a list of subscripted symbols arranged in left-to-right order. + folding over this in left-to-right order amounts to forward concrete execution. *) + `Invalid (m + |> Interpretation.restrict + (fun s -> + match Var.of_symbol s with + | Some _ -> true + | None -> false)) + in interpolate_query trs post sat_model @@ interpolate_unsat_core + + + let contextualize t1 t2 t3 : [`Sat of t | `Unsat ] = + let t1 = rename_skolems t1 + in let t2 = rename_skolems t2 + in let t3 = rename_skolems t3 + in let subscript subscript_tbl sym = + try + Hashtbl.find subscript_tbl sym + with Not_found -> + mk_const srk sym + in + (* preprocess each formula to get rid of certain undesirable things *) + let preprocess_formula f = + let nnf_rewriter = Syntax.nnf_rewriter srk in + f |> Syntax.eliminate_ite srk + |> Syntax.eliminate_floor_mod_div srk + |> Syntax.rewrite srk ~down:nnf_rewriter in + (* Convert tr into a formula, and simultaneously update the subscript + table *) + let to_ss_formula tr subscript_tbl reverse_subscript_tbl = + let ss_guard = substitute_const srk (subscript subscript_tbl) (guard tr) + in let (ss, phis) = + M.fold (fun var term (ss, phis) -> + let var_sym = Var.symbol_of var in + let var_ss_sym = mk_symbol srk (Var.typ var :> typ) in + let var_ss_term = mk_const srk var_ss_sym in + let term_ss = substitute_const srk (subscript subscript_tbl) term in + ((var_sym, var_ss_term, var_ss_sym)::ss, + (mk_eq srk var_ss_term term_ss)::phis)) + tr.transform + ([], [ ss_guard ]) + in + List.iter (fun (k, v, l) -> + Hashtbl.add subscript_tbl k v; Hashtbl.add reverse_subscript_tbl l k) ss; + mk_and srk phis |> preprocess_formula, Hashtbl.copy reverse_subscript_tbl + in let subscript_tbl = Hashtbl.create 991 + in let reverse_subscript_tbl = Hashtbl.create 991 + in let ss_t1, reverse_subscript_tbl1 = to_ss_formula t1 subscript_tbl reverse_subscript_tbl + in let ss_t2, reverse_subscript_tbl2 = to_ss_formula t2 subscript_tbl reverse_subscript_tbl + in let ss_t3, _ = to_ss_formula t3 subscript_tbl reverse_subscript_tbl + in let conj = mk_and srk [ss_t1; ss_t2; ss_t3] + in let is_global t x = + try + begin match Var.of_symbol (Hashtbl.find t x) with + | None -> false + | Some v -> + if Var.is_global v then begin + Printf.printf "symbol %s is global\n" (Syntax.show_symbol srk (Hashtbl.find reverse_subscript_tbl x)); true + end else false + end + with Not_found -> false + in let symbols_t1 = Syntax.symbols ss_t1 + in let symbols_t2 = Syntax.symbols ss_t2 + in let symbols_t3 = Syntax.symbols ss_t3 + in let symbols_t1_t2 = + Syntax.symbols ss_t1 (* symbols in t1 that are either globals _and_ in t2 are preserved during projection *) + |> Symbol.Set.filter + (fun x -> (is_global reverse_subscript_tbl1 x)) + in let symbols_t3_t2 = + symbols_t3 (* symbols in t3 that are globals _and_ in t2, t1 are preserved during projection *) + |> Symbol.Set.filter (fun x -> (is_global reverse_subscript_tbl2 x) && (Symbol.Set.mem x symbols_t2)) + in let symbols_conj = Symbol.Set.union symbols_t1 (Symbol.Set.union symbols_t2 symbols_t3) + in + let project srk (f1: 'a formula) (f3: 'a formula) symbols_f1 symbols_f3 all_symbols model = + let open Polyhedron in + (* first do NNF conversion on f1, f3 before computing their implicants *) + (* rjf Mar '24: we do this as part of preprocessing to avoid rewriting the formula after an SMT query to get `model`*) + (*let nnf_rewriter = Syntax.nnf_rewriter srk in + let f1 = Syntax.rewrite srk ~down:(nnf_rewriter) f1 in + let f3 = Syntax.rewrite srk ~down:(nnf_rewriter) f3 in*) + let implicant_o1 = Interpretation.select_implicant model f1 in + let implicant_o2 = Interpretation.select_implicant model f3 in + match implicant_o1, implicant_o2 with + | Some f1, Some f2 -> + let cube = of_cube srk (f1@f2) in + let value_of_coord = (* coord (int) -> x (symbol) -> m[x] (value in R) *) + fun coord -> + Syntax.symbol_of_int coord + |> Interpretation.real model + in let xs = + Symbol.Set.diff all_symbols (Symbol.Set.union symbols_f1 symbols_f3) + |> Symbol.Set.elements + |> List.map Syntax.int_of_symbol + in let projected = local_project value_of_coord xs cube + in cube_of srk projected |> Syntax.mk_and srk + | None, Some f -> + Printf.printf "contextualize: select_implicant failed on left formula: \n"; + logf ~level: `always "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; + logf ~level: `always "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; + List.iteri (fun _ x -> logf ~level: `always "\n -- impicant of right formula:%a\n" (Syntax.pp_expr srk) x) f; + logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + failwith "error extrapolating: select_implicant failed on left formula" + | Some f, None -> + Printf.printf "contextualize: select_implicant failed on right formula: \n"; + logf ~level: `always "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; + List.iteri (fun _ x -> logf ~level: `always "\n -- impicant of left formula:%a\n" (Syntax.pp_expr srk) x) f; + logf ~level: `always "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; + logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + failwith "error extrapolating: select_implicant failed on right formula" + | None, None -> + logf ~level:`always "left: %a\n" (Syntax.pp_expr srk) f1; + Format.print_flush (); + logf ~level:`always "right: %a\n" (Syntax.pp_expr srk) f3; + Format.print_flush (); + logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + Format.print_flush (); + failwith "error extrapolating: select_implicant failed on both formulae" + in + match Smt.get_model ~symbols:(symbols_conj |> Symbol.Set.elements) srk conj with + | `Sat m -> + let prepost = project srk ss_t1 ss_t3 symbols_t1_t2 symbols_t3_t2 symbols_conj m in + let reverse_rename_t1 s = + begin match Hashtbl.find_opt reverse_subscript_tbl1 s with + | Some s' -> mk_const srk s' + | None -> mk_const srk s end in + let r_guard = substitute_const srk (reverse_rename_t1) prepost in + let r_transform = + (* for each skolem symbol in r_guard, see if it can be mapped back to a variable. *) + let r_symbols = Syntax.symbols r_guard |> Symbol.Set.to_list in + List.fold_left (fun m x -> + match Hashtbl.find_opt reverse_subscript_tbl x with + | Some y -> + begin match Var.of_symbol y with + | Some var -> M.add var (mk_const srk x) m + | None -> m + end + | None -> m) M.empty r_symbols in + let r = {transform=r_transform; guard=r_guard} + in + `Sat r + | `Unknown -> failwith "contextualize status unknown" + | `Unsat -> `Unsat + + + + (** underapproximate existential quantification. Given a transition formula tr over vocabulary X, + use model-based projection to project out any variable v in X such that f(v) = false. *) + let project_mbp (f : var -> bool) tr = + let ss_to_sym = Hashtbl.create 991 in + (* preprocessing of a formula *) + let preprocess f = + let nnf_rewriter = Syntax.nnf_rewriter srk in + f |> Syntax.eliminate_ite srk |> Syntax.eliminate_floor_mod_div srk + |> Syntax.rewrite srk ~down:nnf_rewriter in + let phis = + M.fold (fun var term phis -> + let var_sym = Var.symbol_of var in + let var_ss_sym = mk_symbol srk (Var.typ var :> typ) in + let var_ss_term = mk_const srk var_ss_sym in + Hashtbl.add ss_to_sym var_ss_sym var_sym; + (mk_eq srk var_ss_term term)::phis) + tr.transform + [ guard tr ] in + let tr_formula = mk_and srk phis |> preprocess in + let tr_symbols = Syntax.symbols tr_formula in + let tr_symbols_preserved = + tr_symbols + |> Symbol.Set.filter (fun s -> + match Hashtbl.find_opt ss_to_sym s with + | Some sym -> + begin match Var.of_symbol sym with + | Some v -> f v + | None -> false + end + | None -> false (* discard any skolem constants *)) in + let tr_symbols_removed = Symbol.Set.diff tr_symbols tr_symbols_preserved in + let prj formula voc model = + let open Polyhedron in + (* first do NNF conversion on [formula] before computing their implicants *) + (* rjf Mar '24: This is done using the preprocess function defined above.*) + (*let nnf_rewriter = Syntax.nnf_rewriter srk in + let formula' = + formula + |> Syntax.eliminate_ite srk + |> Syntax.eliminate_floor_mod_div srk + |> Syntax.rewrite srk ~down:(nnf_rewriter) in*) + let implicant = Interpretation.select_implicant model formula in + match implicant with + | Some i -> + let cube = of_cube srk i in + let value_of_coord = (* coord (int) -> x (symbol) -> m[x] (value in R) *) + fun coord -> + Syntax.symbol_of_int coord + |> Interpretation.real model + in let xs = (* coordinates to be projected out *) + voc + |> Symbol.Set.elements + |> List.map Syntax.int_of_symbol + in let projected = local_project value_of_coord xs cube + in cube_of srk projected |> Syntax.mk_and srk + | _ -> + logf ~level:`always "\n--select_implicant formula: %a\n" (Syntax.pp_expr srk) formula; + Format.print_flush (); + logf ~level:`always "\n--select_implicant model: %a\n" (Interpretation.pp) model; + Format.print_flush(); + failwith "error projecting: select_implicant returned None" + in match Smt.get_model ~symbols:(tr_symbols |> Symbol.Set.elements) srk tr_formula with + | `Sat m -> + let projected = prj tr_formula tr_symbols_removed m in + let tr_transform = + Hashtbl.fold (fun ss sym acc -> + let ss_term = mk_const srk ss in + match Var.of_symbol sym with + | Some v -> M.add v ss_term acc + | None -> failwith "u_exists: shoul not get here: subscript invariant broken") + ss_to_sym M.empty + in + `Sat {guard=projected;transform=tr_transform} + | `Unknown -> failwith "u_exists: got unknown as a result of get_model" + | _ -> `Unsat + + let valid_triple phi path post = let path_not_post = List.fold_right mul path (assume (mk_not srk post)) in match Smt.is_sat srk (mk_and srk [phi; path_not_post.guard]) with @@ -499,6 +931,20 @@ struct |> rewrite srk ~down:(pos_rewriter srk) |> Abstract.abstract ~exists srk man + + + let contains_havoc tr = + M.fold (fun _ rhs acc -> + if acc then acc + else begin + Symbol.Set.fold + (fun s acc -> + match Var.of_symbol s with + | Some _ -> acc + | None -> true || acc) (Syntax.symbols rhs) false + end + ) tr.transform false + let linearize tr = let (transform, defs) = M.fold (fun var t (transform, defs) -> diff --git a/srk/src/transition.mli b/srk/src/transition.mli index 1c8fcff7..5df1b37c 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -70,6 +70,9 @@ module Make (** Non-deterministically choose between two transitions *) val add : t -> t -> t + (** take conjunction of two transition formulas *) + val conjunct : t -> t -> t + (** Unexecutable transition (unit of [add]). *) val zero : t @@ -110,9 +113,32 @@ module Make support the proof (for each [i], [{ phi_{i-1} } tr_i { phi_i }] holds, where [phi_0] is [true] and [phi_n] implies the post-condition). *) - val interpolate : t list -> C.t formula -> [ `Valid of C.t formula list - | `Invalid - | `Unknown ] + val interpolate : t list -> C.t formula -> [ `Valid of C.t formula list + | `Invalid + | `Unknown ] + + val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] + + (** Same as interpolate, but returns a concrete model if interpllation fails. *) + val interpolate_or_concrete_model : t list -> C.t formula + -> [`Valid of C.t formula list | `Invalid of C.t Interpretation.interpretation | `Unknown ] + + + + (** + transtion : guard, transform + interpretation: M + find a model of the guard where we use M to replace all the pre-state value. + check interpretation.substitute + *) + val get_post_model : C.t Interpretation.interpretation -> t -> (C.t Interpretation.interpretation) option + + + (** Underapproximate existential quantification using model-based projection. + The variables to be preserved are set to `true` in the initial map. + Note the input map specifies variables to be preserved, not removed. *) + val project_mbp : (var -> bool) -> t -> [> `Sat of t | `Unsat] + (** Given a pre-condition [P], a path [path], and a post-condition [Q], determine whether the Hoare triple [{P}path{Q}] is valid. *) @@ -120,6 +146,9 @@ module Make | `Invalid | `Unknown ] + val contains_havoc : t -> bool + + val defines : t -> var list val uses : t -> var list diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index 4c77a22a..47c70334 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -79,6 +79,10 @@ module Make (** Get procedure summary; delegates call to WG.RecGraph.get_summary *) val get_summary : query -> (vertex * vertex) -> transition + (** delegates call to RecGraph.inter_path_summary / RecGraph.intra_path_summary *) + val inter_path_summary : query -> vertex -> vertex -> transition + + val intra_path_summary : query -> vertex -> vertex -> transition (** Compute interval invariants for each loop header of a transition system. The invariant computed for a loop is defined only over the variables diff --git a/srk/src/weightedGraph.ml b/srk/src/weightedGraph.ml index d3fced8e..881c0c08 100644 --- a/srk/src/weightedGraph.ml +++ b/srk/src/weightedGraph.ml @@ -517,6 +517,12 @@ module RecGraph = struct type query = { recgraph : t; + (* The instrumented graph retains the path_graph of recgraph as a + subgraph, and for each call-edge (u,v) to target procedure (src,tgt), + adds an edge (u, src) to the target procedure. *) + instrumented_graph : Pathexpr.simple Pathexpr.t weighted_graph; + + (* The intraprocedural path graph has an edge u->v for each entry vertex u and each vertex v reachable from u, weighted with a path expression for the paths from u to v. *) @@ -590,6 +596,13 @@ module RecGraph = struct |> VertexSet.elements in let intraproc_paths = msat_path_weight rg.path_graph sources in + let instrumented_edges = + M.fold (fun (u, _) (entry, _) acc -> + (u,entry) :: acc + ) rg.call_edges [] + in let instrumented_graph = + List.fold_left (fun acc (u, src) -> + add_edge acc u (Pathexpr.mk_one rg.context) src) rg.path_graph instrumented_edges in let interproc = let intraproc_paths = edge_weight intraproc_paths in List.fold_left (fun interproc_graph src -> @@ -608,6 +621,7 @@ module RecGraph = struct sources in { recgraph = rg; + instrumented_graph = instrumented_graph; intraproc_paths = intraproc_paths; interproc = interproc; interproc_paths = msat_path_weight interproc [src]; @@ -723,6 +737,21 @@ module RecGraph = struct query.changed := CallSet.add call !(query.changed); HT.replace query.summaries call weight + + + let intra_path_summary (wq: 'a weight_query) src tgt = + let q = wq.query in + let g = q.recgraph in + let (table, algebra) = prepare wq in + Pathexpr.eval ~table ~algebra (path_weight g.path_graph src tgt) + + let inter_path_summary (wq: 'a weight_query) src tgt = + let q = wq.query in + let g = q.instrumented_graph in + let (table, algebra) = prepare wq in + Pathexpr.eval ~table ~algebra (path_weight g src tgt) + + let mk_weight_query query algebra = { query = query; summaries = HT.create 991; diff --git a/srk/src/weightedGraph.mli b/srk/src/weightedGraph.mli index 624a7688..62e9e4f2 100644 --- a/srk/src/weightedGraph.mli +++ b/srk/src/weightedGraph.mli @@ -207,10 +207,13 @@ module RecGraph : sig (** Find the sum of weights of all intraprocedural paths through a given call. *) val call_weight : 'a weight_query -> call -> 'a - val get_summary : 'a weight_query -> call -> 'a val set_summary : 'a weight_query -> call -> 'a -> unit + val intra_path_summary : 'a weight_query -> int -> int -> 'a + + val inter_path_summary : 'a weight_query -> int -> int -> 'a + (** Find the sum of weights of all infinite interprocedural paths beginning at the query's source vertex. *) val omega_path_weight : 'a weight_query -> ('a,'b) Pathexpr.omega_algebra -> 'b From 262d61552786fca6b94d1bc0a2b1a55ba4dd8f61 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Tue, 24 Sep 2024 00:24:28 +0800 Subject: [PATCH 05/59] Update --- duet/gps.ml | 25 +++++++++++++++++++++++-- duet/proofspace.ml | 2 ++ srk/src/transition.ml | 12 +++++++----- srk/src/transition.mli | 1 + 4 files changed, 33 insertions(+), 7 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index 3858b54b..079e3467 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -91,6 +91,24 @@ let make_ts_assertions_unreachable (ts : cfg_t) assertions = new_vertices := u :: !new_vertices ); !pts, !new_vertices +let instrument_with_rets (ts : cfg_t) : cfg_t = + let mk_int k = Ctx.mk_real (QQ.of_int k) in + let largest = ref (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in + let new_vtx () = + largest := !largest + 1; !largest in + let hazard_var = Var.mk (Varinfo.mk_global "__duet_hazard" (Concrete (Int 8))) in + let hazard_var_sym = Syntax.mk_symbol srk ~name:"__duet_hazard" `TyInt in + let hazard_var_term = Syntax.mk_const srk hazard_var_sym in + let open Syntax.Infix(Ctx) in + let assume_true = K.assume (Syntax.mk_eq srk (hazard_var_term) (mk_int 1)) in + let assign_zero = K.assign (VVal hazard_var) (mk_int 0) in + let assign_one = K.assign (VVal hazard_var) (mk_int 1) in + let all_succs u = WG.U.succ u in + let _ = + Hashtbl.add V.sym_to_var hazard_var_sym (VVal hazard_var); + ValueHT.add V.var_to_sym (VVal hazard_var) hazard_var_sym + in ts + let instrument_with_gas (ts: cfg_t) = let mk_int k = Ctx.mk_real (QQ.of_int k) in let largest = ref (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in @@ -645,7 +663,7 @@ let analyze_concolic_mcl file = -let analyze_concolic_mcl file = +let analyze_concolic_mcl enable_gas file = let open Srk.Iteration in populate_offset_table file; K.domain := (module (Split(Product(LossyTranslation)(PolyhedronGuard)))); @@ -654,6 +672,7 @@ let analyze_concolic_mcl file = let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system rg in + let ts = if enable_gas then instrument_with_gas ts else ts in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts; Printf.printf "\nentry: %d\n" entry; @@ -684,4 +703,6 @@ let dump_cfg simplify file = let _ = CmdLine.register_pass - ("-mcl-concolic", analyze_concolic_mcl, " GPS model checking algorithm"); + ("-mcl-concolic", analyze_concolic_mcl false, " GPS model checking algorithm"); + CmdLine.register_pass + ("-mcl-concolic-gas", analyze_concolic_mcl true, " GPS model checking algorithm") diff --git a/duet/proofspace.ml b/duet/proofspace.ml index 6c600e0f..e5ec80f3 100644 --- a/duet/proofspace.ml +++ b/duet/proofspace.ml @@ -64,6 +64,8 @@ module IV = struct Some (Hashtbl.find sym_to_var sym) else None + + let is_global _ = failwith "unimplemented" end module P = struct diff --git a/srk/src/transition.ml b/srk/src/transition.ml index 445df263..dfd84eeb 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -11,6 +11,8 @@ module type Var = sig val compare : t -> t -> int val symbol_of : t -> symbol val of_symbol : symbol -> t option + + val is_global : t -> bool end module Make @@ -545,7 +547,7 @@ struct let interpolate_query trs post sat_callback unsat_callback = - let solver = Smt.Solver.make C.context in + let solver = Smt.StdSolver.make C.context in (* Break guards into conjunctions, associate each conjunct with an indicator *) let guards = List.map (fun tr -> @@ -596,7 +598,7 @@ struct let symbols, added_formulas = List.fold_left (fun (symbols, added_formulas) (tr, guard) -> let f = to_ss_formula tr guard in - Smt.Solver.add solver [f]; + Smt.StdSolver.add solver [f]; (Syntax.symbols f) :: symbols, f::added_formulas) ([], []) (List.combine trs guards) in let _ = List.iter (fun f -> @@ -611,7 +613,7 @@ struct let symbols = (Syntax.symbols target) :: symbols |> List.rev |> List.map (fun ss -> Symbol.Set.diff ss indicator_symbols) in - Smt.Solver.add solver [target]; + Smt.StdSolver.add solver [target]; Printf.printf "-----------------------------interpolation---\n"; List.iter (fun f -> let f = substitute_const srk @@ -623,8 +625,8 @@ struct Printf.printf "-------------------interpolation end---\n"; Printf.printf "--- indicator length %d\n" @@ List.length indicators; logf ~level:`always "\ntarget formula: %a\n" (Syntax.pp_expr srk) target; - Smt.Solver.add solver indicators; - match Smt.Solver.get_unsat_core_or_model solver with + Smt.StdSolver.add solver indicators; + match Smt.StdSolver.get_unsat_core_or_model solver with | `Sat m -> (sat_callback m symbols sst ss_inv) | `Unsat core -> (unsat_callback trs post guards core) diff --git a/srk/src/transition.mli b/srk/src/transition.mli index 5df1b37c..44db141d 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -9,6 +9,7 @@ module type Var = sig val compare : t -> t -> int val symbol_of : t -> symbol val of_symbol : symbol -> t option + val is_global : t -> bool end module Make From e35c6c96af87d74a6d004057427c54f0f7703eb2 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Fri, 25 Oct 2024 12:39:15 -0400 Subject: [PATCH 06/59] Fixed bug: NNF conversion when positive formula is expected --- srk/src/transition.ml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/srk/src/transition.ml b/srk/src/transition.ml index dfd84eeb..19a7db8d 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -684,10 +684,10 @@ struct in (* preprocess each formula to get rid of certain undesirable things *) let preprocess_formula f = - let nnf_rewriter = Syntax.nnf_rewriter srk in + let pos_rewriter = Syntax.pos_rewriter srk in f |> Syntax.eliminate_ite srk |> Syntax.eliminate_floor_mod_div srk - |> Syntax.rewrite srk ~down:nnf_rewriter in + |> Syntax.rewrite srk ~down:pos_rewriter in (* Convert tr into a formula, and simultaneously update the subscript table *) let to_ss_formula tr subscript_tbl reverse_subscript_tbl = @@ -736,11 +736,11 @@ struct in let project srk (f1: 'a formula) (f3: 'a formula) symbols_f1 symbols_f3 all_symbols model = let open Polyhedron in - (* first do NNF conversion on f1, f3 before computing their implicants *) + (* first do POS conversion on f1, f3 before computing their implicants *) (* rjf Mar '24: we do this as part of preprocessing to avoid rewriting the formula after an SMT query to get `model`*) - (*let nnf_rewriter = Syntax.nnf_rewriter srk in - let f1 = Syntax.rewrite srk ~down:(nnf_rewriter) f1 in - let f3 = Syntax.rewrite srk ~down:(nnf_rewriter) f3 in*) + (*let pos_rewriter = Syntax.pos_rewriter srk in + let f1 = Syntax.rewrite srk ~down:(pos_rewriter) f1 in + let f3 = Syntax.rewrite srk ~down:(pos_rewriter) f3 in*) let implicant_o1 = Interpretation.select_implicant model f1 in let implicant_o2 = Interpretation.select_implicant model f3 in match implicant_o1, implicant_o2 with @@ -812,9 +812,9 @@ struct let ss_to_sym = Hashtbl.create 991 in (* preprocessing of a formula *) let preprocess f = - let nnf_rewriter = Syntax.nnf_rewriter srk in + let pos_rewriter = Syntax.pos_rewriter srk in f |> Syntax.eliminate_ite srk |> Syntax.eliminate_floor_mod_div srk - |> Syntax.rewrite srk ~down:nnf_rewriter in + |> Syntax.rewrite srk ~down:pos_rewriter in let phis = M.fold (fun var term phis -> let var_sym = Var.symbol_of var in @@ -839,14 +839,14 @@ struct let tr_symbols_removed = Symbol.Set.diff tr_symbols tr_symbols_preserved in let prj formula voc model = let open Polyhedron in - (* first do NNF conversion on [formula] before computing their implicants *) + (* first do POS conversion on [formula] before computing their implicants *) (* rjf Mar '24: This is done using the preprocess function defined above.*) - (*let nnf_rewriter = Syntax.nnf_rewriter srk in + (*let pos_rewriter = Syntax.pos_rewriter srk in let formula' = formula |> Syntax.eliminate_ite srk |> Syntax.eliminate_floor_mod_div srk - |> Syntax.rewrite srk ~down:(nnf_rewriter) in*) + |> Syntax.rewrite srk ~down:(pos_rewriter) in*) let implicant = Interpretation.select_implicant model formula in match implicant with | Some i -> From 5dadb862eac24f5d3353c4ae33cdfcd47682594d Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Fri, 25 Oct 2024 12:41:21 -0400 Subject: [PATCH 07/59] GPS: display graphs only when enabled on command line --- duet/gps.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index 079e3467..375037b2 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -647,7 +647,7 @@ let analyze_concolic_mcl file = let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system rg in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in - TSDisplay.display ts; + if !CmdLine.display_graphs then TSDisplay.display ts; Printf.printf "\nentry: %d\n" entry; List.iter (fun err_loc -> Printf.printf "testing reachability of location %d\n" err_loc ; @@ -674,7 +674,7 @@ let analyze_concolic_mcl enable_gas file = let (ts, assertions) = make_transition_system rg in let ts = if enable_gas then instrument_with_gas ts else ts in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in - TSDisplay.display ts; + if !CmdLine.display_graphs then TSDisplay.display ts; Printf.printf "\nentry: %d\n" entry; List.iter (fun err_loc -> Printf.printf "testing reachability of location %d\n" err_loc ; From 7ea75bf0b37af89d82e13a9385a865ae90b3f87f Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Fri, 25 Oct 2024 12:53:21 -0400 Subject: [PATCH 08/59] GPS: Suppress trace info by default --- duet/gps.ml | 57 ++++++++++++++++++++++--------------------- duet/reachTree.ml | 52 +++++++++++++++++++-------------------- srk/src/transition.ml | 48 ++++++++++++++++++------------------ 3 files changed, 79 insertions(+), 78 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index 375037b2..d62fbe78 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -15,6 +15,7 @@ module Int = SrkUtil.Int module TF = TransitionFormula*) module TS = TransitionSystem.Make(Ctx)(V)(K) +include Log.Make(struct let name = "gps" end) module ProcName = struct type t = int * int @@ -48,14 +49,14 @@ let mk_false () = Syntax.mk_false Ctx.context let mk_query ts entry = TS.mk_query ts entry (if !monotone then (module MonotoneDom) else (module TransitionDom)) let log_formulas prefix formulas = - List.iteri (fun i f -> logf ~level:`always "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr srk) f) formulas + List.iteri (fun i f -> logf "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr srk) f) formulas let log_weights prefix weights = - List.iteri (fun i f -> logf ~level:`always "[weight] %s(%i): %a\n" prefix i K.pp f) weights + List.iteri (fun i f -> logf "[weight] %s(%i): %a\n" prefix i K.pp f) weights let log_model prefix model = - logf ~level:`always "[model] %s: %a\n" prefix Interpretation.pp model + logf "[model] %s: %a\n" prefix Interpretation.pp model (* let assert_i = ref 0 @@ -216,9 +217,9 @@ let log_labelled_weights s uu prefix weights = | OverApprox -> Summarizer.over_proc_summary s (ProcName.make (u, v)) | UnderApprox -> Summarizer.under_proc_summary s (ProcName.make (u, v)) end in - logf ~level:`always "[labelled weight] %s(%i, call(%d,%d)): %a\n" prefix i u v K.pp p + logf "[labelled weight] %s(%i, call(%d,%d)): %a\n" prefix i u v K.pp p | Weight w -> - logf ~level:`always "[labelled weight] %s(%i): %a\n" prefix i K.pp w) weights + logf "[labelled weight] %s(%i): %a\n" prefix i K.pp w) weights let srk = Ctx.context @@ -373,7 +374,7 @@ module GPS = struct | UnderApprox -> Summarizer.under_proc_summary summarizer (ProcName.make (src, dst)) end | Weight w -> w) (to_weights cfg_nodes) in - Printf.printf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); + logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); let l = (K.assume !ctx.pre_state) :: pathcond in log_weights "path conditions " l; l @@ -383,7 +384,7 @@ module GPS = struct let equalities = make_equalities ctx |> K.assume in log_weights "\npost_path_summary: " [post_path_summary]; log_weights "\nequalities: " [equalities]; - Printf.printf "\n"; + logf "\n"; K.guard (K.mul post_path_summary equalities) (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) @@ -392,7 +393,7 @@ module GPS = struct let prefix = path_condition ctx OverApprox src in log_weights "\nprefix " prefix; log_formulas "\nsuffix " [suffix]; - Printf.printf "\n"; + logf "\n"; K.interpolate_or_concrete_model prefix suffix let get_global_ctx (ctx: intra_context ref) = (!ctx.global_ctx) @@ -402,19 +403,19 @@ module GPS = struct Returns `Success if refine is able to refine. *) let mc_refine (ctx: intra_context ref) (v: ReachTree.node) = let handle_failure v m = - logf ~level:`always " *********************** REFINEMENT FAILED *************************\n"; + logf " *********************** REFINEMENT FAILED *************************\n"; let path_condition = path_condition ctx OverApprox v in `Failure (m, path_condition) in let art = !ctx.art in let path = ReachTree.tree_path art v in match interpolate_or_get_model ctx v @@ ReachTree.get_err_loc art with `Invalid v_model -> - logf ~level:`always "Unable to refine but got model\n"; + logf "Unable to refine but got model\n"; (* v is no longer a frontier node. *) handle_failure v v_model | `Unknown -> failwith "mc_refine: got UNKNOWN as a result for interpolate_or_get_model" | `Valid interpolants -> - logf ~level:`always "--- mc_refine: interpolation succeeded. path length %d, interpolant length %d" (List.length path) (List.length interpolants); + logf "--- mc_refine: interpolation succeeded. path length %d, interpolant length %d" (List.length path) (List.length interpolants); ReachTree.refine art path interpolants |> List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist); `Success @@ -426,7 +427,7 @@ module GPS = struct | Some ((u, u_model), w) -> if print_tree then ReachTree.log_art !ctx.art; - logf ~level:`always " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); + logf " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); !ctx.execlist <- w; if (ReachTree.maps_to !ctx.art u) = (ReachTree.get_err_loc !ctx.art) then begin match Smt.is_sat srk (make_equalities ctx) with @@ -435,7 +436,7 @@ module GPS = struct | _ -> !ctx.worklist <- worklist_push u !ctx.worklist; `Continue end else begin - logf ~level:`always "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); + logf "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); log_model "" u_model; let new_concolic_nodes, new_frontier_nodes = ReachTree.expand !ctx.recurse_level !ctx.art u u_model in List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; @@ -465,17 +466,17 @@ module GPS = struct (* Fetched tree node u from work list. First attempt to close it. *) if not (ReachTree.is_covered !ctx.art u) then begin - logf ~level:`always " uncovered. try close\n"; + logf " uncovered. try close\n"; begin match ReachTree.lclose !ctx.art u with (* Close succeeded. No need to further explore it. *) | true, leaves -> - logf ~level:`always "Close succeeded.\n"; + logf "Close succeeded.\n"; worklist_push_all leaves; `Continue | false, leaves -> (* u is uncovered. *) worklist_push_all leaves; begin match mc_refine ctx u with | `Success -> (* refinement succeeded *) - logf ~level:`always "refinement_phase: refinement succeeded\n"; + logf "refinement_phase: refinement succeeded\n"; (* for every node along path of refinement try close *) let path = ReachTree.tree_path !ctx.art u in List.iter @@ -493,7 +494,7 @@ module GPS = struct end end else begin - logf ~level:`always "refinement_phase: %d is covered\n" (ReachTree.of_node u); + logf "refinement_phase: %d is covered\n" (ReachTree.of_node u); `Continue end | None -> failwith "refinement_phase: encountered an empty worklist for refinement\n" (* cannot happen *) @@ -515,15 +516,15 @@ module GPS = struct match K.project_mbp (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with | `Sat t -> `Unsafe t | _ -> - Printf.printf " ------------------------ handle_path_to_error debug info: called by case %s ------------------\n" caller_id; + logf " ------------------------ handle_path_to_error debug info: called by case %s ------------------\n" caller_id; log_weights "faulty weight: " (path_condition ctx UnderApprox err_leaf); - Printf.printf "\nlength of left path: %d" (List.length left); - Printf.printf "\nlength of right path: %d" (List.length right); - Printf.printf "\nPrinting left path... \n"; + logf "\nlength of left path: %d" (List.length left); + logf "\nlength of right path: %d" (List.length right); + logf "\nPrinting left path... \n"; log_labelled_weights (get_summarizer ctx) UnderApprox "left path - " left; failwith "error: handle_path_to_error: cannot project path condition" in let handle_left_case caller_id = - Printf.printf "handle_path_to_error: %s\n" caller_id; + logf "handle_path_to_error: %s\n" caller_id; `Safe in match curr with | (_, Weight _, _) -> @@ -578,7 +579,7 @@ module GPS = struct and intraproc_check (ctx: intra_context ref) : mc_result = - logf ~level:`always " *********************************************** recurse_level: %d\n" !ctx.recurse_level; + logf " *********************************************** recurse_level: %d\n" !ctx.recurse_level; let continue = ref true in let state = ref `Continue in !ctx.worklist <- worklist_push (ReachTree.root) !ctx.worklist; @@ -587,7 +588,7 @@ module GPS = struct (* concolic phase *) begin match concolic_phase ctx with | `Unsafe w -> - logf ~level:`always "--- concolic_mcmillan_execute: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to !ctx.art w); + logf "--- concolic_mcmillan_execute: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to !ctx.art w); let path_to_w = ReachTree.tree_path !ctx.art w |> art_cfg_path_pair ctx @@ -600,7 +601,7 @@ module GPS = struct !ctx.worklist <- worklist_push w !ctx.worklist; continue := true | `Unsafe pathcond -> - logf ~level:`always "--- conoclic_mcmilan_execute: managed to concretize an intraprocedural path-to-error. returning... "; + logf "--- conoclic_mcmilan_execute: managed to concretize an intraprocedural path-to-error. returning... "; state := `Concretized (pathcond); continue := false end @@ -628,7 +629,7 @@ module GPS = struct * ptt is a pointer to the reachability tree. *) let global_context = mk_mc_context ts entry in - logf ~level:`always "executing concolic mcmillan's algorithm\n"; + logf "executing concolic mcmillan's algorithm\n"; (*let ts_with_gas = instrument_with_gas ts in *) let main_context = mk_intra_context global_context (entry, err_loc) ts 0 K.one entry err_loc in intraproc_check main_context @@ -648,7 +649,7 @@ let analyze_concolic_mcl file = let (ts, assertions) = make_transition_system rg in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; - Printf.printf "\nentry: %d\n" entry; + logf "\nentry: %d\n" entry; List.iter (fun err_loc -> Printf.printf "testing reachability of location %d\n" err_loc ; Printf.printf "------------------------------\n"; @@ -675,7 +676,7 @@ let analyze_concolic_mcl enable_gas file = let ts = if enable_gas then instrument_with_gas ts else ts in let ts, new_vertices = make_ts_assertions_unreachable ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; - Printf.printf "\nentry: %d\n" entry; + logf "\nentry: %d\n" entry; List.iter (fun err_loc -> Printf.printf "testing reachability of location %d\n" err_loc ; Printf.printf "------------------------------\n"; diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 55fc6323..5b7b777f 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -143,18 +143,18 @@ struct let log_formulas prefix formulas = List.iteri (fun i f -> - logf ~level:`always "[formula] %s(%i): %a\n" prefix i + logf "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr Ctx.context) f) formulas let log_weights prefix weights = List.iteri - (fun i f -> logf ~level:`always "[weight] %s(%i): %a\n" prefix i K.pp f) + (fun i f -> logf "[weight] %s(%i): %a\n" prefix i K.pp f) weights let log_model prefix model = - logf ~level:`always "[model] %s: %a\n" prefix Interpretation.pp model + logf "[model] %s: %a\n" prefix Interpretation.pp model type t = { graph : TS.t; @@ -200,14 +200,14 @@ struct (** [print_tree t ident v] prints an ART t with indentation `ident` rooted at node v *) let print_tree (art : t ref) (indent : string) (v : node) = let rec print_tree_ (art : t ref) indent v = - logf ~level:`always "%s|" indent; - logf ~level:`always "%s+-%d(%d)" indent v + logf "%s|" indent; + logf "%s+-%d(%d)" indent v (IntMap.find v !art.cfg_vertex |> VN.of_vertex); List.iter (fun x -> print_tree_ art (indent ^ " ") x) (IntMap.find_default [] v !art.children) in - logf ~level:`always "*"; + logf "*"; print_tree_ art indent v (* [parent t i] gets parent of node i in tree t. *) @@ -404,7 +404,7 @@ struct (maps_to art w |> VN.of_vertex); match Smt.entails Ctx.context v_label w_label with | `Yes -> - logf ~level:`always " cover success (v=%d, w=%d). \n" v w; + logf " cover success (v=%d, w=%d). \n" v w; log_formulas " v label " [ v_label ]; log_formulas " w label " [ w_label ]; let reverse_covers_w = @@ -459,7 +459,7 @@ struct let x_leaves = leaves art x in List.iter (fun x_leaf -> - logf ~level:`always + logf " close: adding %d back to worklist \n" x_leaf; wl' := x_leaf :: !wl') @@ -476,7 +476,7 @@ struct match IntMap.find_opt v !art.covers with | None -> if v == 0 then false else is_covered art (parent art v) | Some u -> - logf ~level:`always " | covered by %d\n" u; + logf " | covered by %d\n" u; true (* refine the label of each tree node u along path from tree root to v. *) @@ -506,21 +506,21 @@ struct match Smt.entails Ctx.context x_label u_label with | `No | `Unknown -> (* remove (x, u) from covering. *) - logf ~level:`always " refine: removing cover (%d->%d)\n" + logf " refine: removing cover (%d->%d)\n" x u; !art.covers <- IntMap.remove x !art.covers; (* add x's subtree leaves back to the worklist. *) let x_leaves = leaves art x in List.iter (fun x_leaf -> - logf ~level:`always + logf " refine: adding %d back to worklist \n" x_leaf; worklist := x_leaf :: !worklist) x_leaves; l | `Yes -> - logf ~level:`always + logf " refine: cover (x %d-> u %d) still holds\n" x u; log_formulas " x label: " [ x_label ]; log_formulas " u label: " [ u_label ]; @@ -623,10 +623,10 @@ struct | [] (* leaf node *) -> ( match IntMap.find_opt v !t.covers with | None -> - logf ~level:`always "!!! found uncovered leaf: %d\n" v; + logf "!!! found uncovered leaf: %d\n" v; TS.fold_succ_e (fun (x, _, y) _ -> - logf ~level:`always + logf " ERROR ERROR ERROR: mapped cfg vertex %d has \ out-neighbor %d\n" (VN.of_vertex x) (VN.of_vertex y); @@ -636,24 +636,24 @@ struct | _ -> ( match IntMap.find_opt v !t.covers with | None -> - logf ~level:`always "node %d uncovered\n" v; + logf "node %d uncovered\n" v; List.fold_left (fun acc u -> aux u && acc) true children | Some u -> - logf ~level:`always "node %d covered by %d\n" v u; + logf "node %d covered by %d\n" v u; true) in - logf ~level:`always "verifying well-labelledness of ART...\n"; + logf "verifying well-labelledness of ART...\n"; let r = aux 0 in - logf ~level:`always "...done verifying well-labelledness of ART\n"; + logf "...done verifying well-labelledness of ART\n"; r let check_covering_welformedness (t : t ref) = - logf ~level:`always "checking welformedness of covering relations\n"; + logf "checking welformedness of covering relations\n"; IntMap.iter (fun dst covered_from -> ISet.iter (fun src -> - logf ~level:`always "checking if (%d, %d) in covering\n" src dst; + logf "checking if (%d, %d) in covering\n" src dst; match IntMap.find_opt src !t.covers with | Some dst' -> if dst' <> dst then @@ -662,7 +662,7 @@ struct | None -> failwith "ERROR: not in covering") covered_from) !t.reverse_covers; - logf ~level:`always "performing a reverse check\n"; + logf "performing a reverse check\n"; IntMap.iter (fun src dst -> match IntMap.find_opt dst !t.reverse_covers with @@ -682,7 +682,7 @@ struct reverse_covers\n" src dst) !t.covers; - logf ~level:`always "...done checking welformedness of covering relations\n" + logf "...done checking welformedness of covering relations\n" (** pretty-printing functionalities *) let tree_printer_get_name (art : t ref) i = @@ -692,17 +692,17 @@ struct Printf.sprintf "[%d(%d)]->%d" i (maps_to art i |> VN.of_vertex) j let log_art (art : t ref) = - logf ~level:`always " +----------------- ART ----------------+\n"; + logf " +----------------- ART ----------------+\n"; let string_of_art = Tree_printer.to_string ~line_prefix:"* " ~get_name:(tree_printer_get_name art) ~get_children:(children art) 0 in - logf ~level:`always "%s" string_of_art; - logf ~level:`always " +----------------- ART ----------------+\n" + logf "%s" string_of_art; + logf " +----------------- ART ----------------+\n" let log_node u = - logf ~level:`always " node: visit %d\n" u + logf " node: visit %d\n" u let of_node u = u end diff --git a/srk/src/transition.ml b/srk/src/transition.ml index 19a7db8d..148e3ac4 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -607,24 +607,24 @@ struct match Hashtbl.find_opt ss_inv v with | None -> Syntax.mk_const srk v | Some v' -> Syntax.mk_const srk v') f - in logf ~level:`always "added formula: %a\n" (Syntax.pp_expr srk) f) added_formulas + in logf "added formula: %a\n" (Syntax.pp_expr srk) f) added_formulas (* subscript the symbols in the `post` formula, as well *) in let target = substitute_const srk subscript (mk_not srk post) in let symbols = (Syntax.symbols target) :: symbols |> List.rev |> List.map (fun ss -> Symbol.Set.diff ss indicator_symbols) in Smt.StdSolver.add solver [target]; - Printf.printf "-----------------------------interpolation---\n"; + logf "-----------------------------interpolation---\n"; List.iter (fun f -> let f = substitute_const srk (fun v -> match Hashtbl.find_opt ss_inv v with | None -> Syntax.mk_const srk v | Some v' -> Syntax.mk_const srk v') f - in logf ~level:`always "indicator formula: %a\n" (Syntax.pp_expr srk) f) indicators; - Printf.printf "-------------------interpolation end---\n"; - Printf.printf "--- indicator length %d\n" @@ List.length indicators; - logf ~level:`always "\ntarget formula: %a\n" (Syntax.pp_expr srk) target; + in logf "indicator formula: %a\n" (Syntax.pp_expr srk) f) indicators; + logf "-------------------interpolation end---\n"; + logf "--- indicator length %d\n" @@ List.length indicators; + logf "\ntarget formula: %a\n" (Syntax.pp_expr srk) target; Smt.StdSolver.add solver indicators; match Smt.StdSolver.get_unsat_core_or_model solver with | `Sat m -> @@ -658,8 +658,8 @@ struct match Hashtbl.find_opt ss s with | Some sss -> Interpretation.value model sss | None -> Interpretation.value model s))*) (*(Interpretation.empty srk)*) symbols in - Printf.printf "hashtable length: %d\n" (Hashtbl.length ss_inv); - Interpretation.pp Format.std_formatter m; + logf "hashtable length: %d\n" (Hashtbl.length ss_inv); + logf "%a" Interpretation.pp m; Format.print_flush (); (* symbols is a list of subscripted symbols arranged in left-to-right order. folding over this in left-to-right order amounts to forward concrete execution. *) @@ -718,7 +718,7 @@ struct | None -> false | Some v -> if Var.is_global v then begin - Printf.printf "symbol %s is global\n" (Syntax.show_symbol srk (Hashtbl.find reverse_subscript_tbl x)); true + logf "symbol %s is global\n" (Syntax.show_symbol srk (Hashtbl.find reverse_subscript_tbl x)); true end else false end with Not_found -> false @@ -757,25 +757,25 @@ struct in let projected = local_project value_of_coord xs cube in cube_of srk projected |> Syntax.mk_and srk | None, Some f -> - Printf.printf "contextualize: select_implicant failed on left formula: \n"; - logf ~level: `always "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; - logf ~level: `always "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; - List.iteri (fun _ x -> logf ~level: `always "\n -- impicant of right formula:%a\n" (Syntax.pp_expr srk) x) f; - logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + logf "contextualize: select_implicant failed on left formula: \n"; + logf "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; + logf "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; + List.iteri (fun _ x -> logf "\n -- impicant of right formula:%a\n" (Syntax.pp_expr srk) x) f; + logf "\n * model: %a\n" (Interpretation.pp) model; failwith "error extrapolating: select_implicant failed on left formula" | Some f, None -> - Printf.printf "contextualize: select_implicant failed on right formula: \n"; - logf ~level: `always "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; - List.iteri (fun _ x -> logf ~level: `always "\n -- impicant of left formula:%a\n" (Syntax.pp_expr srk) x) f; - logf ~level: `always "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; - logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + logf "contextualize: select_implicant failed on right formula: \n"; + logf "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; + List.iteri (fun _ x -> logf "\n -- impicant of left formula:%a\n" (Syntax.pp_expr srk) x) f; + logf "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; + logf "\n * model: %a\n" (Interpretation.pp) model; failwith "error extrapolating: select_implicant failed on right formula" | None, None -> - logf ~level:`always "left: %a\n" (Syntax.pp_expr srk) f1; + logf "left: %a\n" (Syntax.pp_expr srk) f1; Format.print_flush (); - logf ~level:`always "right: %a\n" (Syntax.pp_expr srk) f3; + logf "right: %a\n" (Syntax.pp_expr srk) f3; Format.print_flush (); - logf ~level:`always "\n * model: %a\n" (Interpretation.pp) model; + logf "\n * model: %a\n" (Interpretation.pp) model; Format.print_flush (); failwith "error extrapolating: select_implicant failed on both formulae" in @@ -862,9 +862,9 @@ struct in let projected = local_project value_of_coord xs cube in cube_of srk projected |> Syntax.mk_and srk | _ -> - logf ~level:`always "\n--select_implicant formula: %a\n" (Syntax.pp_expr srk) formula; + logf "\n--select_implicant formula: %a\n" (Syntax.pp_expr srk) formula; Format.print_flush (); - logf ~level:`always "\n--select_implicant model: %a\n" (Interpretation.pp) model; + logf "\n--select_implicant model: %a\n" (Interpretation.pp) model; Format.print_flush(); failwith "error projecting: select_implicant returned None" in match Smt.get_model ~symbols:(tr_symbols |> Symbol.Set.elements) srk tr_formula with From 2850c102324df67b943dab0016807822b6760b8e Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 26 Oct 2024 10:16:50 -0400 Subject: [PATCH 09/59] GPS: only query oracle for non-deterministic transitions --- duet/reachTree.ml | 19 +++++++++++++------ duet/reachTree.mli | 1 + srk/src/transition.ml | 14 ++++++++++++++ srk/src/transition.mli | 6 ++++++ 4 files changed, 34 insertions(+), 6 deletions(-) diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 5b7b777f..a98154ab 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -49,6 +49,7 @@ module ART Ctx.t Interpretation.interpretation -> t -> Ctx.t Interpretation.interpretation option + val is_deterministic : t -> bool end) (TS : sig type vertex @@ -349,6 +350,12 @@ struct on the concolic execution worklist. Otherwise, it is a frontier node, and put it on the refinement worklist. *) + let is_deterministic = + let is_det tr = + not (K.contains_havoc tr) || K.is_deterministic tr + in + Memo.memo is_det + (* returns (new nodes on concolic worklist, new nodes on frontier worklist) *) (* a newly expanded node (leaf) is deemed a _concolic node_ if it can inherit a post-state model from its parent by means of symbol substitution. It is deemed @@ -367,12 +374,12 @@ struct let weight = match weight with | TransitionSystem.Weight w -> - if K.contains_havoc w then - (* w /\ guard (summary from y -> error location) *) - K.mul w - (K.assume - @@ K.guard (oracle !art.interproc y !art.err_loc)) - else w + if is_deterministic w then w + else + K.mul w + (K.assume + @@ K.guard (oracle !art.interproc y !art.err_loc)) + | TransitionSystem.Call (u, v) -> let proc = (VN.to_vertex u, VN.to_vertex v) |> PN.make in Summarizer.over_proc_summary !art.interproc proc diff --git a/duet/reachTree.mli b/duet/reachTree.mli index a9a7504b..b9fc161c 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -32,6 +32,7 @@ module ART : val get_post_model : Ctx.t Srk.Interpretation.interpretation -> t -> Ctx.t Srk.Interpretation.interpretation option + val is_deterministic : t -> bool end) (** transition system with edge weights from K *) (TS : sig diff --git a/srk/src/transition.ml b/srk/src/transition.ml index 148e3ac4..8d4bc50d 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -970,4 +970,18 @@ struct Nonlinear.linearize srk (mk_and srk (tr.guard::defs)) in { transform; guard } + + let is_deterministic tr = + let tr' = rename_skolems tr in + let solver = Smt.Solver.make srk in + let same_post = + M.fold (fun var t rest -> + (mk_eq srk t (M.find var tr'.transform)::rest)) + tr.transform + [] + in + Smt.Solver.add solver [tr.guard; tr'.guard; mk_not srk (mk_and srk same_post)]; + match Smt.Solver.check solver with + | `Unsat -> true + | `Sat | `Unknown -> false end diff --git a/srk/src/transition.mli b/srk/src/transition.mli index 44db141d..8840d4f3 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -161,4 +161,10 @@ module Make val domain : (module Iteration.PreDomain) ref val star : t -> t val linearize : t -> t + + (** If [is_deterministic tr] holds, [tr] is deterministic (at most one + post-state for any given pre-state). If [is_deterministic tr] does not + hold, either [tr] is non-deterministic, or a proof of determinacy could + not be found. *) + val is_deterministic : t -> bool end From bf5d25c9304492a06b47aac1d15ab0a23f3a6a64 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 26 Oct 2024 15:18:07 -0400 Subject: [PATCH 10/59] Fixed build --- duet/gps.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/duet/gps.ml b/duet/gps.ml index d62fbe78..bcdde3a0 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -667,7 +667,8 @@ let analyze_concolic_mcl file = let analyze_concolic_mcl enable_gas file = let open Srk.Iteration in populate_offset_table file; - K.domain := (module (Split(Product(LossyTranslation)(PolyhedronGuard)))); + K.domain := split (product [ PolyhedronGuard.exp + ; LossyTranslation.exp ]); match file.entry_points with | [main] -> begin let rg = Interproc.make_recgraph file in From f91a6a3001b4badc6bea3b2b4a68ec044796c33e Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 26 Oct 2024 15:19:15 -0400 Subject: [PATCH 11/59] Bug fix: eliminate floor, mod, and div before abstraction --- srk/src/iteration.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/srk/src/iteration.ml b/srk/src/iteration.ml index 71266167..269c057e 100644 --- a/srk/src/iteration.ml +++ b/srk/src/iteration.ml @@ -20,7 +20,7 @@ module Solver = struct let preprocess srk = function | `LIRR -> Syntax.eliminate_floor_mod_div srk - | `LIRA -> rewrite srk ~down:(pos_rewriter srk) % (Nonlinear.linearize srk) + | `LIRA -> rewrite srk ~down:(pos_rewriter srk) % (Nonlinear.linearize srk) % Syntax.eliminate_floor_mod_div srk let make srk ?(theory=get_theory srk) tf = let phi = preprocess srk theory (TF.formula tf) in From 932597451f7e1a895ad3ed52ac30d68c8a67fe08 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 26 Oct 2024 15:20:16 -0400 Subject: [PATCH 12/59] GPS: merge all error locations --- duet/gps.ml | 72 ++++++++++++++++------------------------------------- 1 file changed, 21 insertions(+), 51 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index bcdde3a0..f36085e6 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -76,21 +76,17 @@ let process_interproc_assertion (ts: cfg_t) (phi: Ctx.formula) v = (* Convert assertion checking problem to vertex reachability problem. *) let make_ts_assertions_unreachable (ts : cfg_t) assertions = - let largest = ref (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in - let pts = ref ts in - let new_vertices = ref [] in - assertions |> SrkUtil.Int.Map.iter ( - fun v (phi, _, _) -> - (* For each assertion, create new vertex after the assertion state - * with edge into the vertex being the negated condition. *) - let u = !largest + 1 in - largest := (!largest) + 1; - pts := WG.add_vertex !pts u ; - pts := WG.add_edge !pts v (Weight (K.assume (Ctx.mk_not phi))) u ; - let s = Printf.sprintf " Adding assertion node %d -> %d for label " v u in - log_formulas s [ Ctx.mk_not phi ] ; - new_vertices := u :: !new_vertices - ); !pts, !new_vertices + let err_loc = 1 + (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in + let ts = WG.add_vertex ts err_loc in + let ts = + SrkUtil.Int.Map.fold (fun v (phi, _, _) ts -> + let s = Printf.sprintf " Adding assertion node %d -> %d for label " v err_loc in + log_formulas s [ Ctx.mk_not phi ] ; + WG.add_edge ts v (Weight (K.assume (Ctx.mk_not phi))) err_loc) + assertions + ts + in + (ts, err_loc) let instrument_with_rets (ts : cfg_t) : cfg_t = let mk_int k = Ctx.mk_real (QQ.of_int k) in @@ -638,31 +634,6 @@ module GPS = struct module BM = BatMap.Make(Int) -let analyze_concolic_mcl file = - let open Srk.Iteration in - populate_offset_table file; - K.domain := (module (Split(Product(LossyTranslation)(PolyhedronGuard)))); - match file.entry_points with - | [main] -> begin - let rg = Interproc.make_recgraph file in - let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system rg in - let ts, new_vertices = make_ts_assertions_unreachable ts assertions in - if !CmdLine.display_graphs then TSDisplay.display ts; - logf "\nentry: %d\n" entry; - List.iter (fun err_loc -> - Printf.printf "testing reachability of location %d\n" err_loc ; - Printf.printf "------------------------------\n"; - match GPS.execute ts entry err_loc with - | Safe _ -> Printf.printf " proven safe\n"; - | Unsafe _ -> Printf.printf " proven unsafe\n"; - Printf.printf "------------------------------\n" - ) new_vertices - end - | _ -> assert false - - - let analyze_concolic_mcl enable_gas file = let open Srk.Iteration in @@ -674,19 +645,18 @@ let analyze_concolic_mcl enable_gas file = let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system rg in - let ts = if enable_gas then instrument_with_gas ts else ts in - let ts, new_vertices = make_ts_assertions_unreachable ts assertions in + let ts = if enable_gas then instrument_with_gas ts else ts in + let ts, err_loc = make_ts_assertions_unreachable ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; logf "\nentry: %d\n" entry; - List.iter (fun err_loc -> - Printf.printf "testing reachability of location %d\n" err_loc ; - Printf.printf "------------------------------\n"; - match GPS.execute ts entry err_loc with - | Safe _ -> Printf.printf " proven safe\n"; - | Unsafe _ -> Printf.printf " proven unsafe\n"; - Printf.printf "------------------------------\n" - ) new_vertices - end + Printf.printf "testing reachability of location %d\n" err_loc ; + Printf.printf "------------------------------\n"; + begin match GPS.execute ts entry err_loc with + | Safe _ -> Printf.printf " proven safe\n"; + | Unsafe _ -> Printf.printf " proven unsafe\n" + end; + Printf.printf "------------------------------\n" + end | _ -> assert false (** dump simplified CFG before doing model checking / CRA / concolic execution *) From fd183b1df61f6725728821fa61d5d260510eb517 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 2 Nov 2024 07:27:16 -0400 Subject: [PATCH 13/59] GPS: fix force_cover --- duet/reachTree.ml | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/duet/reachTree.ml b/duet/reachTree.ml index a98154ab..94e9afdb 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -579,22 +579,23 @@ struct let path_weights = artpath |> glue - |> List.map (fun (x, y) -> TS.edge_weight !art.graph (maps_to art x) (maps_to art y)) - |> List.map - (fun weight -> - match weight with - | TransitionSystem.Call (src, dst) -> - Summarizer.over_proc_summary !art.interproc @@ PN.make (VN.to_vertex src, VN.to_vertex dst) - | TransitionSystem.Weight wht -> wht) in - match K.interpolate_or_concrete_model ((K.assume w_label) :: path_weights) (Syntax.mk_not Ctx.context w_label) with + |> List.map (fun (x, y) -> + match TS.edge_weight !art.graph (maps_to art x) (maps_to art y) with + | TransitionSystem.Call (src, dst) -> + Summarizer.over_proc_summary + !art.interproc + (PN.make (VN.to_vertex src, VN.to_vertex dst)) + | TransitionSystem.Weight wht -> wht) + in + let w_path_weights = (K.assume w_label) :: path_weights in + match K.interpolate_or_concrete_model w_path_weights w_label with | `Valid itps -> - let new_frontiers = refine art artpath (List.tl itps) in - begin match Smt.entails Ctx.context (label art v) (label art w) with - | `Yes -> - + let new_frontiers = refine art (List.tl artpath) (List.tl itps) in + if cover art v w then (true, new_frontiers) - | _ -> failwith "error: force_cover is buggy!" - end + else + failwith "error: force_cover is buggy!" + | `Invalid _ -> (false, []) | `Unknown -> failwith "force_cover: interpolation failed with status UNKNOWN." end From fc1f1325a1e0fd05ed5278a4608642da3b87d01d Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 2 Nov 2024 08:19:40 -0400 Subject: [PATCH 14/59] GPS: bug fix in gas instrumentation --- duet/gps.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index f36085e6..a04a9e9d 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -114,13 +114,15 @@ let instrument_with_gas (ts: cfg_t) = let gas_var = Var.mk (Varinfo.mk_global "__duet_gas" (Concrete (Int 8))) in let gas_var_sym = Syntax.mk_symbol srk ~name:"__duet_gas" `TyInt in let gas_var_term = Syntax.mk_const srk gas_var_sym in - let gasexpr = - let open Syntax.Infix(Ctx) in - let assume_positive = K.assume (Syntax.mk_lt srk (mk_int 0) gas_var_term) in - let decr_by_one = Syntax.mk_sub srk gas_var_term (mk_int 1) |> K.assign (VVal gas_var) in - K.mul assume_positive decr_by_one in Hashtbl.add V.sym_to_var gas_var_sym (VVal gas_var); ValueHT.add V.var_to_sym (VVal gas_var) gas_var_sym; + let gasexpr = + let assume_positive = K.assume (Syntax.mk_lt srk (mk_int 0) gas_var_term) in + let decr_by_one = + Syntax.mk_sub srk gas_var_term (mk_int 1) |> K.assign (VVal gas_var) + in + K.mul assume_positive decr_by_one + in (* for each call-edge, u->v, add new predecessor edge x->u->v where x->u is an instrumented edge. *) let loop_headers = let module L = Loop.Make(TSG) in From e92366fc16ebb4247c40ec83291fb384b69cc299 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 2 Nov 2024 08:34:51 -0400 Subject: [PATCH 15/59] GPS: restore loop acceleration --- srk/src/transition.ml | 102 +++++++++++++++++++++++++++++++++++ srk/src/transition.mli | 5 ++ srk/src/transitionSystem.ml | 27 ++++++++-- srk/src/transitionSystem.mli | 1 + 4 files changed, 132 insertions(+), 3 deletions(-) diff --git a/srk/src/transition.ml b/srk/src/transition.ml index e30944be..6e28840d 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -977,4 +977,106 @@ struct match Smt.Solver.check solver with | `Unsat -> true | `Sat | `Unknown -> false + + (* Given a guarded translation and a loop counter k, compute a + representation of its k-fold repetition. *) + let cf_translation loop_counter trans guard = + let cf k = (* x + k*v *) + M.mapi (fun var t -> + mk_add srk [mk_const srk (Var.symbol_of var); mk_mul srk [mk_real srk t; k]]) + trans + in + + (* forall subcounter. 0 <= subcounter < loop_counter ==> G(Sx + t*subcounter) *) + let subcounter = mk_symbol srk `TyInt in + let subcounter_term = mk_const srk subcounter in + let prestate sym = Var.of_symbol sym != None in + let guard = Quantifier.mbp srk prestate guard in + let cf_subst = + let sub_cf = cf subcounter_term in + substitute_const srk (fun sym -> + match Var.of_symbol sym with + | Some v -> (try M.find v sub_cf with Not_found -> mk_const srk sym) + | None -> assert false) + in + let guard_tf = + mk_if srk + (mk_and srk [mk_leq srk (mk_int srk 0) subcounter_term; + mk_lt srk subcounter_term loop_counter]) + (cf_subst guard) + |> mk_not srk + |> Quantifier.mbp srk (fun x -> x != subcounter) + |> mk_not srk + in + { transform = cf loop_counter; + guard = mk_and srk [guard_tf; + mk_leq srk (mk_int srk 0) loop_counter] } + + let try_rtc tr = + let solver = Smt.StdSolver.make srk in + let translation_of_model m = + M.fold (fun var rhs trans -> + M.add + var + (QQ.sub + (Interpretation.evaluate_term m rhs) + (Interpretation.real m (Var.symbol_of var))) + trans) + tr.transform + M.empty + in + let translation_formula trans = + M.fold (fun var rhs xs -> + (mk_eq srk + (mk_sub srk rhs (mk_const srk (Var.symbol_of var))) + (mk_real srk (M.find var trans))) + ::xs + ) + tr.transform + [] + |> mk_and srk + in + Smt.StdSolver.add solver [tr.guard]; + match Smt.StdSolver.get_model solver with + | `Unknown -> None + | `Unsat -> Some one + | `Sat m -> + let trans1 = translation_of_model m in + let trans1_formula = translation_formula trans1 in + Smt.StdSolver.add solver [mk_not srk trans1_formula]; + match Smt.StdSolver.get_model solver with + | `Unsat -> + let loop_counter = mk_const srk (mk_symbol srk `TyInt) in + Some (cf_translation loop_counter trans1 tr.guard) + | `Unknown -> None + | `Sat m2 -> + let trans2 = translation_of_model m2 in + let trans2_formula = translation_formula trans2 in + Smt.StdSolver.add solver [mk_not srk trans2_formula]; + match Smt.StdSolver.check solver with + | `Sat | `Unknown -> None + | _ -> + let tr1 = { tr with guard = mk_and srk [ tr.guard; trans1_formula ] } in + let tr2 = { tr with guard = mk_and srk [ tr.guard; trans2_formula ] } in + match Smt.is_sat srk (guard (mul tr1 tr2)), + Smt.is_sat srk (guard (mul tr2 tr1)) + with + | `Unsat, `Sat -> (* 12 UNSAT => (1+2)* = 2*1* *) + let loop_counter1 = mk_const srk (mk_symbol srk `TyInt) in + let loop_counter2 = mk_const srk (mk_symbol srk `TyInt) in + Some (mul + (cf_translation loop_counter2 trans2 tr2.guard) + (cf_translation loop_counter1 trans1 tr1.guard)) + | `Sat, `Unsat -> (* 21 UNSAT => (1+2)* = 1*2* *) + let loop_counter1 = mk_const srk (mk_symbol srk `TyInt) in + let loop_counter2 = mk_const srk (mk_symbol srk `TyInt) in + Some (mul + (cf_translation loop_counter1 trans1 tr1.guard) + (cf_translation loop_counter2 trans2 tr2.guard)) + | `Unsat, `Unsat -> (* 12 & 21 UNSAT => (1+2)* = 1*+2* *) + let loop_counter = mk_const srk (mk_symbol srk `TyInt) in + Some (add + (cf_translation loop_counter trans1 tr1.guard) + (cf_translation loop_counter trans2 tr2.guard)) + | _, _ -> None end diff --git a/srk/src/transition.mli b/srk/src/transition.mli index 79b4fc56..295187ac 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -167,4 +167,9 @@ module Make hold, either [tr] is non-deterministic, or a proof of determinacy could not be found. *) val is_deterministic : t -> bool + + (** Attempt to compute the reflexive transitive closure of the input + transition formula; return [None] of the exact RTC was not successfully + found. *) + val try_rtc : t -> t option end diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index 28773562..fe2b6828 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -41,6 +41,7 @@ module Make val one : t val star : t -> t val exists : (var -> bool) -> t -> t + val try_rtc : t -> t option end) = struct @@ -682,10 +683,30 @@ module Make let ug = WG.forget_weights tg in if (p v || WG.mem_edge tg v v - || WG.U.in_degree ug v != 1 - || WG.U.out_degree ug v != 1) + || (WG.U.in_degree ug v != 1 + && WG.U.out_degree ug v != 1)) then - tg + begin if WG.mem_edge tg v v then + match WG.edge_weight tg v v with + | Weight tr -> + (try begin match T.try_rtc tr with + | Some rtc -> + let u = -1 in + (try + let tg = WG.remove_edge tg v v in + let tg = + WG.contract_vertex (WG.split_vertex tg v (Weight rtc) u) u + in + continue := true; + tg + with _ -> tg) + | None -> tg end + with _ -> tg) + | Call (_, _) -> tg + else + tg + end + else begin try let tg = WG.contract_vertex tg v in diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index 47c70334..cd096e73 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -35,6 +35,7 @@ module Make val one : t val star : t -> t val exists : (var -> bool) -> t -> t + val try_rtc : t -> t option end) : sig type vertex = int From a228968348d173d5636069f905add634a9f58fd6 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 2 Nov 2024 08:46:26 -0400 Subject: [PATCH 16/59] Bugfix in WeightedGraph/path_weight for vertices not reachable from src --- srk/src/weightedGraph.ml | 87 +++++++++++++++++++++------------------- 1 file changed, 46 insertions(+), 41 deletions(-) diff --git a/srk/src/weightedGraph.ml b/srk/src/weightedGraph.ml index 881c0c08..c5a6825c 100644 --- a/srk/src/weightedGraph.ml +++ b/srk/src/weightedGraph.ml @@ -203,9 +203,9 @@ let _solve_dense (wg : 'a weighted_graph) (src : vertex) = v, and reachable is an enumeration of the vertices reachable from src. *) let _path_weight - (wg : 'a t) - (omega : ('a, 'b) omega_algebra) - (src : vertex) = + (wg : 'a t) + (omega : ('a, 'b) omega_algebra) + (src : vertex) = (* Ensure that src has no incoming edges *) let (wg, src) = let start = max_vertex wg + 1 in @@ -225,11 +225,11 @@ let _path_weight if BatHashtbl.mem wg_to_forest v then BatHashtbl.find wg_to_forest v else begin - let r = F.root forest in - BatHashtbl.add wg_to_forest v r; - BatHashtbl.add forest_to_wg r v; - r - end + let r = F.root forest in + BatHashtbl.add wg_to_forest v r; + BatHashtbl.add forest_to_wg r v; + r + end in let find v = BatHashtbl.find forest_to_wg (F.find forest (to_forest v)) @@ -239,6 +239,9 @@ let _path_weight in let eval v = F.eval forest (to_forest v) in let idom = D.compute_idom wg.graph src in + let is_reachable x = + try ignore (idom x); true with Not_found -> false + in let children = D.idom_to_dom_tree wg.graph idom in let rec solve (v : vertex) = let children_omega = List.map solve (children v) in @@ -249,13 +252,15 @@ let _path_weight let sibling_graph = List.fold_left (fun sg child -> - U.fold_pred (fun pred sg -> - let pred = find pred in - if pred = v then sg - else U.add_edge sg pred child) - wg.graph - child - (U.add_vertex sg child)) + U.fold_pred (fun pred sg -> + if is_reachable pred then + let pred = find pred in + if pred = v then sg + else U.add_edge sg pred child + else sg) + wg.graph + child + (U.add_vertex sg child)) U.empty (children v) in @@ -263,32 +268,32 @@ let _path_weight let omega_weight = List.fold_right (fun component omega_weight -> - let component_wg = - List.fold_left (fun component_wg v -> - U.fold_pred (fun p component_wg -> - let weight = mul (eval p) (edge_weight wg p v) in - add_edge component_wg (find p) weight v) - wg.graph - v - component_wg) - (empty wg.algebra) - component - in - let reduced = _solve_dense component_wg v in - List.fold_left (fun omega_weight c -> - let v_to_c = edge_weight reduced v c in - let (omega_weight, weight) = - if U.mem_edge reduced.graph c c then - let c_to_c = edge_weight reduced c c in - let v_c_omega = omega.omega_mul v_to_c (omega.omega c_to_c) in - (omega.omega_add omega_weight v_c_omega, - mul v_to_c (star c_to_c)) - else (omega_weight, v_to_c) - in - link c weight v; - omega_weight) - omega_weight - component) + let component_wg = + List.fold_left (fun component_wg v -> + U.fold_pred (fun p component_wg -> + let weight = mul (eval p) (edge_weight wg p v) in + add_edge component_wg (find p) weight v) + wg.graph + v + component_wg) + (empty wg.algebra) + component + in + let reduced = _solve_dense component_wg v in + List.fold_left (fun omega_weight c -> + let v_to_c = edge_weight reduced v c in + let (omega_weight, weight) = + if U.mem_edge reduced.graph c c then + let c_to_c = edge_weight reduced c c in + let v_c_omega = omega.omega_mul v_to_c (omega.omega c_to_c) in + (omega.omega_add omega_weight v_c_omega, + mul v_to_c (star c_to_c)) + else (omega_weight, v_to_c) + in + link c weight v; + omega_weight) + omega_weight + component) (C.scc_list sibling_graph) (omega.omega wg.algebra.zero) in From 3bd4157e1f6a73cd00e0690a9726c07d48650d06 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 2 Nov 2024 08:46:55 -0400 Subject: [PATCH 17/59] Fix test build --- Makefile | 2 +- srk/test/test_transition.ml | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index c2735148..710daa18 100644 --- a/Makefile +++ b/Makefile @@ -9,7 +9,7 @@ clean: dune clean test: - dune runtest -f + dune runtest --profile release -f install: dune build @install diff --git a/srk/test/test_transition.ml b/srk/test/test_transition.ml index 2627986c..8949ef75 100644 --- a/srk/test/test_transition.ml +++ b/srk/test/test_transition.ml @@ -27,6 +27,7 @@ module V = struct Some (Hashtbl.find rev_sym_table sym) else None + let is_global _ = true end module T = Transition.Make(Ctx)(V) From 9a097abdbd8b0c180382be4457dd0d4dabf74d5a Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 2 Nov 2024 14:37:10 -0400 Subject: [PATCH 18/59] GPS: dualized Tarjan's algorithm --- duet/gps.ml | 28 ++++++---- duet/reachTree.ml | 21 ++++---- duet/reachTree.mli | 11 ++-- srk/src/transitionSystem.ml | 16 +++--- srk/src/transitionSystem.mli | 10 ++-- srk/src/weightedGraph.ml | 99 ++++++++++++++++++++++++++-------- srk/src/weightedGraph.mli | 18 ++++++- srk/test/test_WeightedGraph.ml | 87 ++++++++++++++++++++++++++++++ 8 files changed, 229 insertions(+), 61 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index a04a9e9d..5ae849b5 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -156,12 +156,18 @@ module Summarizer = graph: cfg_t; src: int; query: TS.query; + rev_query: TS.reverse_query; mutable underapprox: K.t SMap.t } - let init (graph: cfg_t) (src: int) : t = - let q = mk_query graph src in - { graph = graph; src = src; query = q; underapprox = SMap.empty } + let init (graph: cfg_t) (src: int) (tgt: int): t = + let q = mk_query graph src in + let rq = TS.mk_reverse_query q tgt in + { graph = graph + ; src = src + ; query = q + ; rev_query = rq + ; underapprox = SMap.empty } (** retrieve over-approximate procedure summary *) let over_proc_summary (ctx: t) ((u, v) : ProcName.t) = @@ -194,10 +200,10 @@ module Summarizer = set_under_proc_summary ctx (u, v) summary' let path_weight_intra (ctx: t) (src: int) (dst: int) = - TS.intra_path_summary ctx.query src dst + TS.exit_summary ctx.rev_query src dst - let path_weight_inter (ctx: t) (src: int) (dst: int) = - TS.inter_path_summary ctx.query src dst + let path_weight_inter (ctx: t) (src: int) = + TS.target_summary ctx.rev_query src end @@ -316,9 +322,9 @@ module GPS = struct art = ReachTree.make ts entry err_loc pre_state !gctx.interproc; global_ctx = gctx; } - and mk_mc_context (global_cfg: cfg_t) (global_src: int) = + and mk_mc_context (global_cfg: cfg_t) (global_src: int) (err_loc: int)= ref { - interproc = Summarizer.init global_cfg global_src; + interproc = Summarizer.init global_cfg global_src err_loc; } (** place an element in front of the deque (worklist) *) @@ -334,8 +340,8 @@ module GPS = struct Syntax.mk_eq srk s s' :: acc) !ctx.equalities [Syntax.mk_true srk] |> Syntax.mk_and srk - let oracle ctx u v= - if !ctx.recurse_level = 0 then Summarizer.path_weight_inter (get_summarizer ctx) u v + let oracle ctx u v = + if !ctx.recurse_level = 0 then Summarizer.path_weight_inter (get_summarizer ctx) u else Summarizer.path_weight_intra (get_summarizer ctx) u v let rec art_cfg_path_pair (ctx: intra_context ref) (p: ReachTree.node list) = @@ -626,7 +632,7 @@ module GPS = struct * vtxcnt (keeps track of largest unused vertex number in tree), * ptt is a pointer to the reachability tree. *) - let global_context = mk_mc_context ts entry in + let global_context = mk_mc_context ts entry err_loc in logf "executing concolic mcmillan's algorithm\n"; (*let ts_with_gas = instrument_with_gas ts in *) let main_context = mk_intra_context global_context (entry, err_loc) ts 0 K.one entry err_loc in diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 94e9afdb..ed4ffd75 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -56,14 +56,18 @@ module ART type transition = K.t type t type query + type reverse_query val empty : t val path_weight : query -> vertex -> transition val call_weight : query -> vertex * vertex -> transition val set_summary : query -> vertex * vertex -> transition -> unit val get_summary : query -> vertex * vertex -> transition - val inter_path_summary : query -> vertex -> vertex -> transition - val intra_path_summary : query -> vertex -> vertex -> transition + + + val mk_reverse_query : query -> vertex -> reverse_query + val exit_summary : reverse_query -> vertex -> vertex -> K.t + val target_summary : reverse_query -> vertex -> K.t val omega_path_weight : query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b @@ -112,7 +116,6 @@ module ART end) (Summarizer : sig type t - val init : TS.t -> TS.vertex -> t val over_proc_summary : t -> PN.t -> K.t val under_proc_summary : t -> PN.t -> K.t val set_over_proc_summary : t -> PN.t -> K.t -> unit @@ -120,7 +123,7 @@ module ART val refine_over_summary : t -> PN.t -> K.t -> unit val refine_under_summary : t -> PN.t -> K.t -> unit val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t - val path_weight_inter : t -> TS.vertex -> TS.vertex -> K.t + val path_weight_inter : t -> TS.vertex -> K.t end) = struct (* type for a tree node *) @@ -362,9 +365,9 @@ struct a _frontier node_ if concrete execution cannot reach it from its parent node. A frontier node does not have a model associated with it and is in need of refinement. *) let expand recurse_level (art : t ref) (v : node) (m: Ctx.t Interpretation.interpretation)= - let oracle = - if recurse_level = 0 then Summarizer.path_weight_inter - else Summarizer.path_weight_intra + let oracle s src tgt = + if recurse_level = 0 then Summarizer.path_weight_inter s src + else Summarizer.path_weight_intra s src tgt in let vg = maps_to art v in let new_concolic_nodes, new_frontier_nodes = (ref [], ref []) in @@ -535,9 +538,9 @@ struct l ISet.empty in !art.reverse_covers <- IntMap.add u u_coverers !art.reverse_covers) - path interpolants; + path + interpolants; !worklist - let rec glue l = match l with diff --git a/duet/reachTree.mli b/duet/reachTree.mli index b9fc161c..5f33f746 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -40,13 +40,16 @@ module ART : type transition = K.t type t type query + type reverse_query val empty : t val path_weight : query -> vertex -> transition val call_weight : query -> vertex * vertex -> transition + val mk_reverse_query : query -> vertex -> reverse_query + val exit_summary : reverse_query -> vertex -> vertex -> K.t + val target_summary : reverse_query -> vertex -> K.t + val set_summary : query -> vertex * vertex -> transition -> unit val get_summary : query -> vertex * vertex -> transition - val inter_path_summary : query -> vertex -> vertex -> transition - val intra_path_summary : query -> vertex -> vertex -> transition val omega_path_weight : query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b val remove_temporaries : t -> t @@ -81,7 +84,7 @@ module ART : (Summarizer : sig type t (** [init g s] returns a Summarizer.t type for a given transition system, source vertex pair (g, s). *) - val init : TS.t -> TS.vertex -> t + val init : TS.t -> TS.vertex -> TS.vertex -> t (** [over_proc_summary s n] returns the over-approximate procedure summary for procedure `n`. *) val over_proc_summary : t -> PN.t -> K.t (** [under_proc_summary s n] returns the under-approximate procedure summary (initially `false`) for procedure `n`. *) @@ -97,7 +100,7 @@ module ART : (** [path_weight_intra s u v] gives the weighted path summary between (u, v) on an intraprocedural CFG *) val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t (** [path_weight_inter s u v] gives the inter-procedural path weight between (u, v) *) - val path_weight_inter : t -> TS.vertex -> TS.vertex -> K.t + val path_weight_inter : t -> TS.vertex -> K.t end) -> sig diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index fe2b6828..b3e19df1 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -50,6 +50,7 @@ module Make type tlabel = T.t label type query = T.t WG.RecGraph.weight_query + type reverse_query = T.t WG.RecGraph.reverse_query let mk_query ?(delay=1) ts source dom = let rg = @@ -151,16 +152,15 @@ module Make (T.transform tr) - let set_summary q (u, v) summary = - WG.RecGraph.set_summary q (u, v) summary + let set_summary q (u, v) summary = + WG.RecGraph.set_summary q (u, v) summary - let get_summary q (u, v) = - WG.RecGraph.get_summary q (u, v) - - let inter_path_summary = WG.RecGraph.inter_path_summary - - let intra_path_summary = WG.RecGraph.intra_path_summary + let get_summary q (u, v) = + WG.RecGraph.get_summary q (u, v) + let mk_reverse_query = WG.RecGraph.mk_reverse_query + let exit_summary = WG.RecGraph.exit_summary + let target_summary = WG.RecGraph.target_summary (* Variables whose abstract values may change as the result of a transition *) diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index cd096e73..afe01b95 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -42,6 +42,7 @@ module Make type transition = T.t type t = (transition label) WeightedGraph.t type query = T.t WeightedGraph.RecGraph.weight_query + type reverse_query = T.t WeightedGraph.RecGraph.reverse_query module VarSet : BatSet.S with type elt = Var.t @@ -69,6 +70,10 @@ module Make starting at a given vertex. *) val omega_path_weight : query -> (transition,'b) Pathexpr.omega_algebra -> 'b + val mk_reverse_query : query -> vertex -> reverse_query + val exit_summary : reverse_query -> vertex -> vertex -> T.t + val target_summary : reverse_query -> vertex -> T.t + (** Project out local variables from each transition that are referenced only by that transition. *) val remove_temporaries : t -> t @@ -80,11 +85,6 @@ module Make (** Get procedure summary; delegates call to WG.RecGraph.get_summary *) val get_summary : query -> (vertex * vertex) -> transition - (** delegates call to RecGraph.inter_path_summary / RecGraph.intra_path_summary *) - val inter_path_summary : query -> vertex -> vertex -> transition - - val intra_path_summary : query -> vertex -> vertex -> transition - (** Compute interval invariants for each loop header of a transition system. The invariant computed for a loop is defined only over the variables read or written to by the loop. *) diff --git a/srk/src/weightedGraph.ml b/srk/src/weightedGraph.ml index c5a6825c..2f8a0dbd 100644 --- a/srk/src/weightedGraph.ml +++ b/srk/src/weightedGraph.ml @@ -564,6 +564,11 @@ module RecGraph = struct (* An algebra for assigning weights to non-call edges and *) algebra : 'a Pathexpr.nested_algebra } + type 'a reverse_query = + { parent : 'a weight_query + ; path_to_exit : Pathexpr.nested Pathexpr.t weighted_graph + ; path_to_target : int -> Pathexpr.nested Pathexpr.t } + let pathexpr_algebra context = { mul = mk_mul context; add = mk_add context; @@ -601,13 +606,6 @@ module RecGraph = struct |> VertexSet.elements in let intraproc_paths = msat_path_weight rg.path_graph sources in - let instrumented_edges = - M.fold (fun (u, _) (entry, _) acc -> - (u,entry) :: acc - ) rg.call_edges [] - in let instrumented_graph = - List.fold_left (fun acc (u, src) -> - add_edge acc u (Pathexpr.mk_one rg.context) src) rg.path_graph instrumented_edges in let interproc = let intraproc_paths = edge_weight intraproc_paths in List.fold_left (fun interproc_graph src -> @@ -626,12 +624,12 @@ module RecGraph = struct sources in { recgraph = rg; - instrumented_graph = instrumented_graph; intraproc_paths = intraproc_paths; interproc = interproc; interproc_paths = msat_path_weight interproc [src]; src = src } + let call_pathexpr query (src, tgt) = (* intraproc_paths is only set when src is an entry vertex *) if not (U.mem_vertex query.interproc.graph src) then @@ -742,20 +740,13 @@ module RecGraph = struct query.changed := CallSet.add call !(query.changed); HT.replace query.summaries call weight - - - let intra_path_summary (wq: 'a weight_query) src tgt = - let q = wq.query in - let g = q.recgraph in - let (table, algebra) = prepare wq in - Pathexpr.eval ~table ~algebra (path_weight g.path_graph src tgt) - - let inter_path_summary (wq: 'a weight_query) src tgt = - let q = wq.query in - let g = q.instrumented_graph in - let (table, algebra) = prepare wq in - Pathexpr.eval ~table ~algebra (path_weight g src tgt) - + let exit_summary rev_query src tgt = + let (table, algebra) = prepare rev_query.parent in + Pathexpr.eval_nested ~table ~algebra (path_weight rev_query.path_to_exit tgt src) + + let target_summary rev_query src = + let (table, algebra) = prepare rev_query.parent in + Pathexpr.eval_nested ~table ~algebra (rev_query.path_to_target src) let mk_weight_query query algebra = { query = query; @@ -764,6 +755,70 @@ module RecGraph = struct table = Pathexpr.mk_table (); algebra = algebra } + let mk_reverse_query weight_query tgt = + let rg = weight_query.query.recgraph in + let context = rg.context in + let reverse f graph = (* Reverse edges in a graph *) + let reverse_algebra = + { mul = (fun x y -> mk_mul context y x); + add = mk_add context; + star = mk_star context; + zero = mk_zero context; + one = mk_one context } + in + let vertices = + fold_vertex + (fun v rev_graph -> add_vertex rev_graph v) + graph + (empty reverse_algebra) + in + fold_edges + (fun (u, w, v) rev_graph -> add_edge rev_graph v (f w) u) + graph + vertices + in + (* rg.path_graph, with each edge reversed *) + let reverse_graph = reverse Pathexpr.promote rg.path_graph in + let callset = + M.fold (fun _ call callset -> + CallSet.add call callset) + rg.call_edges + CallSet.empty + in + let entries, exits = + let entries, exits = + CallSet.fold (fun (entry, exit) (entries, exits) -> + (VertexSet.add entry entries, VertexSet.add exit exits)) + callset + (VertexSet.empty, VertexSet.empty) + in + (VertexSet.elements entries, VertexSet.elements exits) + in + (* Intraprocedural paths from entries to target *) + let (_, entry_to_target, _) = + _path_weight reverse_graph omega_trivial tgt + in + let reverse_interproc = + List.fold_left (fun g entry -> + add_edge g tgt (Pathexpr.mk_segment context (entry_to_target entry)) entry) + (reverse (fun x -> x) weight_query.query.interproc) + entries + in + let (_, entry_to_target, _) = + _path_weight reverse_interproc omega_trivial tgt + in + (* Interprocedural paths from entries to target *) + let instrumented_graph = + M.fold (fun (u, _) (entry, _) acc -> + add_edge acc tgt (entry_to_target entry) u) + rg.call_edges + reverse_graph + in + let (_, path_to_target, _) = _path_weight instrumented_graph omega_trivial tgt in + let path_to_exit = msat_path_weight reverse_graph exits in + { parent = weight_query; path_to_exit; path_to_target } + + let path_weight query tgt = let (table, algebra) = prepare query in Pathexpr.eval_nested ~table ~algebra (pathexpr query.query tgt) diff --git a/srk/src/weightedGraph.mli b/srk/src/weightedGraph.mli index 62e9e4f2..f9b39c78 100644 --- a/srk/src/weightedGraph.mli +++ b/srk/src/weightedGraph.mli @@ -147,6 +147,10 @@ module RecGraph : sig weight queries. *) type 'a weight_query + (** A weight query is an intermediate structure for perfoming + single-destination path weight queries. *) + type 'a reverse_query + exception No_summary of call (** The callgraph of a recursive graph has calls as vertices, and an @@ -193,6 +197,11 @@ module RecGraph : sig weights to call edges. *) val mk_weight_query : query -> 'a Pathexpr.nested_algebra -> 'a weight_query + (** Create a reverse query for the selected destination. The reverse query + shares procedure summaries with the underlying weight query, so + [set_summary] impacts both. *) + val mk_reverse_query : 'a weight_query -> vertex -> 'a reverse_query + (** Build call summaries via successive approximation. *) val summarize_iterative : query -> 'a Pathexpr.nested_algebra -> @@ -210,9 +219,14 @@ module RecGraph : sig val get_summary : 'a weight_query -> call -> 'a val set_summary : 'a weight_query -> call -> 'a -> unit - val intra_path_summary : 'a weight_query -> int -> int -> 'a + (** [exit_summary rq u v] computes the sum of the weights of all + intraprocedural paths beginning at [u] and ending at [v]. The target + vertex [v] is required to be the exit vertex of some procedure. *) + val exit_summary : 'a reverse_query -> vertex -> vertex -> 'a - val inter_path_summary : 'a weight_query -> int -> int -> 'a + (** Find the sum of weights of all interprocedural paths beginning + at the given vertex and ending in the query's target *) + val target_summary : 'a reverse_query -> vertex -> 'a (** Find the sum of weights of all infinite interprocedural paths beginning at the query's source vertex. *) diff --git a/srk/test/test_WeightedGraph.ml b/srk/test/test_WeightedGraph.ml index c85d5994..86e8dbc4 100644 --- a/srk/test/test_WeightedGraph.ml +++ b/srk/test/test_WeightedGraph.ml @@ -363,6 +363,15 @@ module PathlenDomain = struct let widen = ISet.inter end +module TrivialPE = struct + type weight = Pathexpr.simple Pathexpr.t + type abstract_weight = Pathexpr.simple Pathexpr.t + let abstract exp = exp + let concretize exp = exp + let equal = Pathexpr.equiv pe_context + let widen = Pathexpr.mk_add pe_context +end + let mk_pathlen_query edges call_edges src = let open WG in let g = @@ -380,6 +389,40 @@ let mk_pathlen_query edges call_edges src = let query = RecGraph.mk_query g src in RecGraph.summarize_iterative query pathlen_algebra (module PathlenDomain) +let rev_query_test edges call_edges src tgt () = + let open WG in + let g = + List.fold_left + (fun g (u,v) -> RecGraph.add_edge g u v) + (RecGraph.empty ()) + edges + in + let g = + List.fold_left + (fun g (u, (s, t), v) -> RecGraph.add_call_edge g u (s, t) v) + g + call_edges + in + let algebra = function + | `Edge (x, y) -> Pathexpr.mk_edge pe_context x y + | `Add (x, y) -> Pathexpr.mk_add pe_context x y + | `Zero -> Pathexpr.mk_zero pe_context + | `One -> Pathexpr.mk_one pe_context + | `Star x -> Pathexpr.mk_star pe_context x + | `Mul (x, y) -> Pathexpr.mk_mul pe_context x y + | `Segment x -> x + in + let query = + RecGraph.summarize_iterative + (RecGraph.mk_query g src) + algebra + (module TrivialPE) + in + let rev_query = RecGraph.mk_reverse_query query tgt in + assert_equal_pathexpr pe_context + (RecGraph.target_summary rev_query src) + (RecGraph.path_weight query tgt) + let get_cyclelen query = WG.RecGraph.omega_path_weight query pathlen_omega_algebra @@ -567,4 +610,48 @@ let suite = "WeightedGraph" >::: [ assert_equal ~cmp:ISet.equal ~printer:ISet.show (ISet.of_list [2]) (get_cyclelen query)) + + ; "rev_query_simple" >:: + (rev_query_test + [(0, 1); (1, 2); (2, 3); (2, 0); (0, 3)] + [] + 0 + 3) + + ; "rev_query_simple2" >:: + (rev_query_test + [(0, 1); (1, 2); (2, 3); (2, 0); (0, 3)] + [] + 0 + 1) + + ; "rev_query_simple3" >:: + (rev_query_test + [ (89, 95); (95, 16); (16, 94); (94, 73) + ; (73, 95); (94, 95); (73, 96) ] + [] + 73 + 96) + + + ; "rev_query_big" >:: + (rev_query_test + [ (53, 10); (10, 56); (10, 52) + ; (56, 17); (17, 55); (55, 21); (21, 56); (21, 38) + ; (38, 47); (47, 57); (47, 43); (43, 52); (43, 52) + ; (38, 34); (34, 52); (34, 57); (52, 54) ] + [] + 53 + 57) + + ; "rev_query_rec" >:: + (rev_query_test + [(0, 1); (2, 3); (0, 3); + (4, 5); (6, 7); (4, 7); (7, 4)] + [(1, (4, 7), 2); + (5, (0, 3), 6); + (8, (0, 3), 9)] + 8 + 1) ] + From 25ffd6b41722bc7bd7bae20a4d7aba662d248fe6 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Sat, 2 Nov 2024 14:41:00 -0400 Subject: [PATCH 19/59] Fixed build --- srk/src/weightedGraph.ml | 6 ------ 1 file changed, 6 deletions(-) diff --git a/srk/src/weightedGraph.ml b/srk/src/weightedGraph.ml index 2f8a0dbd..f1075ae7 100644 --- a/srk/src/weightedGraph.ml +++ b/srk/src/weightedGraph.ml @@ -522,12 +522,6 @@ module RecGraph = struct type query = { recgraph : t; - (* The instrumented graph retains the path_graph of recgraph as a - subgraph, and for each call-edge (u,v) to target procedure (src,tgt), - adds an edge (u, src) to the target procedure. *) - instrumented_graph : Pathexpr.simple Pathexpr.t weighted_graph; - - (* The intraprocedural path graph has an edge u->v for each entry vertex u and each vertex v reachable from u, weighted with a path expression for the paths from u to v. *) From d0a88c702b6851d9136d853b34a81bee9483948a Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Mon, 4 Nov 2024 19:57:19 -0500 Subject: [PATCH 20/59] Bugfix for TransitionSytem.remove_temporaries transformation --- duet/cra.ml | 17 ++++++++++++++--- duet/reachTree.ml | 2 -- duet/reachTree.mli | 1 - srk/src/transitionSystem.ml | 4 ++-- srk/src/transitionSystem.mli | 7 +++---- 5 files changed, 19 insertions(+), 12 deletions(-) diff --git a/duet/cra.ml b/duet/cra.ml index 5b6e654e..662fbc96 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -791,13 +791,21 @@ let decorate_transition_system predicates ts entry = WG.split_vertex ts v (Weight (K.assume invariant)) fresh_id) ts +module VSet = BatSet.Make(V) let make_transition_system rg = let call_edge block = Call ((RG.block_entry rg block).did, (RG.block_exit rg block).did) in let assertions = ref SrkUtil.Int.Map.empty in - let add_assert v e = - assertions := SrkUtil.Int.Map.add v e (!assertions) + let assert_vars = ref VSet.empty in + let add_assert v (cond, loc, msg) = + assertions := SrkUtil.Int.Map.add v (cond, loc, msg) (!assertions); + let open Syntax in + Symbol.Set.iter (fun (s : Syntax.symbol) -> + match V.of_symbol s with + | Some v -> assert_vars := VSet.add v (!assert_vars) + | None -> ()) + (Syntax.symbols cond) in let ts = BatEnum.fold (fun ts (block, graph) -> @@ -856,8 +864,11 @@ let make_transition_system rg = let point_of_interest v = v = entry || v = exit || SrkUtil.Int.Map.mem v (!assertions) in + let elim_var v = + V.is_global v || VSet.mem v (!assert_vars) + in let tg = TS.simplify point_of_interest tg in - let tg = TS.remove_temporaries tg in + let tg = TS.remove_temporaries elim_var tg in let tg = if !forward_inv_gen then Log.phase "Forward invariant generation" diff --git a/duet/reachTree.ml b/duet/reachTree.ml index ed4ffd75..70d57687 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -72,8 +72,6 @@ module ART val omega_path_weight : query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b - val remove_temporaries : t -> t - val forward_invariants_ivl : t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 5f33f746..0499cfdd 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -52,7 +52,6 @@ module ART : val get_summary : query -> vertex * vertex -> transition val omega_path_weight : query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b - val remove_temporaries : t -> t val forward_invariants_ivl : t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list val forward_invariants_ivl_pa : diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index b3e19df1..03d194f3 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -523,11 +523,11 @@ module Make module VHT = BatHashtbl.Make(Var) (* Remove temporary variables that are referenced by only one transition *) - let remove_temporaries tg = + let remove_temporaries proj tg = (* Map each local variable to the set of transitions that refer to it *) let ref_map = VHT.create 991 in let add_ref var (u, v) = - if not (Var.is_global var) then + if not (proj var) then VHT.modify_def PS.empty var (PS.add (u,v)) ref_map in tg |> WG.iter_edges (fun (u, label, v) -> diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index afe01b95..d1ee10e5 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -74,10 +74,9 @@ module Make val exit_summary : reverse_query -> vertex -> vertex -> T.t val target_summary : reverse_query -> vertex -> T.t - (** Project out local variables from each transition that are referenced - only by that transition. *) - val remove_temporaries : t -> t - + (** Project out variables that do not satisfy the given predicate from each + transition that are referenced only by that transition. *) + val remove_temporaries : (Var.t -> bool) -> t -> t (** Set procedure summary; delegates call to WG.RecGraph.set_summary *) val set_summary : query -> (vertex * vertex) -> transition -> unit From 452304bdd1a08fcca7ee3e5556b6743859b8bf25 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Mon, 4 Nov 2024 21:27:00 -0500 Subject: [PATCH 21/59] GPS: interpolation bug --- srk/src/smt.mli | 3 ++- srk/src/srkZ3.ml | 4 ++-- srk/src/srkZ3.mli | 3 ++- srk/src/transition.ml | 3 +-- 4 files changed, 7 insertions(+), 6 deletions(-) diff --git a/srk/src/smt.mli b/srk/src/smt.mli index 5187c82b..6a3bbd6b 100644 --- a/srk/src/smt.mli +++ b/srk/src/smt.mli @@ -25,7 +25,8 @@ module StdSolver : sig val get_unsat_core : 'a t -> ('a formula) list -> [ `Sat | `Unsat of ('a formula) list | `Unknown ] - val get_unsat_core_or_model : ?symbols:symbol list -> 'a t -> + val get_unsat_core_or_model : ?symbols:symbol list -> 'a t -> + ('a formula) list -> [ `Sat of 'a interpretation | `Unsat of ('a formula) list | `Unknown ] diff --git a/srk/src/srkZ3.ml b/srk/src/srkZ3.ml index 5605975b..5085efe8 100644 --- a/srk/src/srkZ3.ml +++ b/srk/src/srkZ3.ml @@ -574,10 +574,10 @@ module Solver = struct | `Unsat -> `Unsat (List.map solver.formula_of (Z3.Solver.get_unsat_core solver.s)) - let get_unsat_core_or_model ?(symbols=[]) solver = + let get_unsat_core_or_model ?(symbols=[]) solver assumptions = let srk = solver.srk in let z3 = solver.z3 in - match check solver with + match check ~assumptions solver with | `Sat -> begin match Z3.Solver.get_model solver.s with | Some m -> `Sat (Interpretation.wrap ~symbols srk (model_get_value srk z3 m)) diff --git a/srk/src/srkZ3.mli b/srk/src/srkZ3.mli index 873b9d82..510c8d2a 100644 --- a/srk/src/srkZ3.mli +++ b/srk/src/srkZ3.mli @@ -81,7 +81,8 @@ module Solver : sig [ `Sat | `Unsat of ('a formula) list | `Unknown ] - val get_unsat_core_or_model : ?symbols: symbol list -> 'a t -> + val get_unsat_core_or_model : ?symbols: symbol list -> 'a t -> + ('a formula) list -> [ `Sat of 'a interpretation | `Unsat of ('a formula) list | `Unknown ] diff --git a/srk/src/transition.ml b/srk/src/transition.ml index 6e28840d..fdeb6193 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -618,8 +618,7 @@ struct logf "-------------------interpolation end---\n"; logf "--- indicator length %d\n" @@ List.length indicators; logf "\ntarget formula: %a\n" (Syntax.pp_expr srk) target; - Smt.StdSolver.add solver indicators; - match Smt.StdSolver.get_unsat_core_or_model solver with + match Smt.StdSolver.get_unsat_core_or_model solver indicators with | `Sat m -> (sat_callback m symbols sst ss_inv) | `Unsat core -> (unsat_callback trs post guards core) From 5e08662cbca54b9f758ae4df8600ff7f88c76998 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 4 Nov 2024 21:10:25 -0600 Subject: [PATCH 22/59] GPS: new flag that substitutes T/F for summaries --- duet/cra.ml | 4 +- duet/gps.ml | 88 ++++++++++++++++++++++++++++--------- duet/reachTree.mli | 2 +- srk/src/transitionSystem.ml | 7 ++- 4 files changed, 77 insertions(+), 24 deletions(-) diff --git a/duet/cra.ml b/duet/cra.ml index 662fbc96..a69cc339 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -792,7 +792,7 @@ let decorate_transition_system predicates ts entry = ts module VSet = BatSet.Make(V) -let make_transition_system rg = +let make_transition_system ?(simplify=true) rg = let call_edge block = Call ((RG.block_entry rg block).did, (RG.block_exit rg block).did) in @@ -867,7 +867,7 @@ let make_transition_system rg = let elim_var v = V.is_global v || VSet.mem v (!assert_vars) in - let tg = TS.simplify point_of_interest tg in + let tg = if simplify then TS.simplify point_of_interest tg else tg in let tg = TS.remove_temporaries elim_var tg in let tg = if !forward_inv_gen then diff --git a/duet/gps.ml b/duet/gps.ml index 5ae849b5..bf7c4d8b 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -157,42 +157,81 @@ module Summarizer = src: int; query: TS.query; rev_query: TS.reverse_query; - mutable underapprox: K.t SMap.t + mutable underapprox: K.t SMap.t; + mutable overapprox: K.t SMap.t; (* Caution: used only for silent mode where no CRA-generated summaries are used. *) + silent: bool; } - let init (graph: cfg_t) (src: int) (tgt: int): t = + let init (graph: cfg_t) (src: int) (tgt: int) (enable_summary: bool) : t = let q = mk_query graph src in let rq = TS.mk_reverse_query q tgt in { graph = graph ; src = src ; query = q ; rev_query = rq - ; underapprox = SMap.empty } + ; underapprox = SMap.empty + ; overapprox = SMap.empty + ; silent = not enable_summary } + + + let filt_over (ctx: t) x = + if ctx.silent then begin + logf "filt_over: context is silent! \n"; + K.assume @@ mk_true () + end + else begin + logf "filt_over: context isn't silent!\n"; + x end + + let filt_under (ctx: t) x = + if ctx.silent then K.assume @@ mk_false () + else x (** retrieve over-approximate procedure summary *) let over_proc_summary (ctx: t) ((u, v) : ProcName.t) = + if ctx.silent then begin + match SMap.find_opt (u, v) ctx.overapprox with + | Some s -> s + | None -> + let init = K.assume @@ mk_true () in + ctx.overapprox <- SMap.add (u, v) init ctx.overapprox; init + end else TS.get_summary ctx.query (u, v) |> K.exists (V.is_global) - + (** set over-approximate procedure summary *) let set_over_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) = - TS.set_summary ctx.query (u, v) w - + if ctx.silent then begin + match SMap.find_opt (u, v) ctx.overapprox with + | Some s -> + ctx.overapprox <- SMap.add (u, v) (K.conjunct s w) ctx.overapprox + | None -> + ctx.overapprox <- SMap.add (u, v) w ctx.overapprox; + end else + TS.set_summary ctx.query (u, v) w + (** retrieve under-approximate procedure summary *) let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = SMap.find_default K.zero (u, v) ctx.underapprox |> K.exists (V.is_global) - + (** set under-approximate procedure summary *) let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = ctx.underapprox <- SMap.add (u, v) w ctx.underapprox (** refinement of procedure summaries using a two-voc transition formula *) let refine_over_summary (ctx: t) ((u, v): ProcName.t) (rfn: K.t) = - over_proc_summary ctx (u, v) - |> K.conjunct rfn - |> set_over_proc_summary ctx (u, v) - + if ctx.silent then begin + match SMap.find_opt (u, v) ctx.overapprox with + | Some s -> + ctx.overapprox <- SMap.add (u, v) (K.conjunct s rfn) ctx.overapprox + | None -> + ctx.overapprox <- SMap.add (u, v) rfn ctx.overapprox + end else + over_proc_summary ctx (u, v) + |> K.conjunct rfn + |> set_over_proc_summary ctx (u, v) + let refine_under_summary (ctx: t) ((u, v): ProcName.t) (w:K.t) : unit = let summary = under_proc_summary ctx (u, v) in let summary' = K.add summary w in @@ -201,9 +240,12 @@ module Summarizer = let path_weight_intra (ctx: t) (src: int) (dst: int) = TS.exit_summary ctx.rev_query src dst + |> filt_over ctx let path_weight_inter (ctx: t) (src: int) = TS.target_summary ctx.rev_query src + |> filt_over ctx + end @@ -322,9 +364,9 @@ module GPS = struct art = ReachTree.make ts entry err_loc pre_state !gctx.interproc; global_ctx = gctx; } - and mk_mc_context (global_cfg: cfg_t) (global_src: int) (err_loc: int)= + and mk_mc_context (global_cfg: cfg_t) (global_src: int) (err_loc: int) enable_summary = ref { - interproc = Summarizer.init global_cfg global_src err_loc; + interproc = Summarizer.init global_cfg global_src err_loc enable_summary; } (** place an element in front of the deque (worklist) *) @@ -626,13 +668,13 @@ module GPS = struct | `Concretized cond -> Unsafe (cond) - let execute (ts : cfg_t) (entry : int) (err_loc : int) : mc_result = + let execute (ts : cfg_t) (entry : int) (err_loc : int) (enable_summary:bool) : mc_result = (** * Set up data structures used by the algorithm: worklist, * vtxcnt (keeps track of largest unused vertex number in tree), * ptt is a pointer to the reachability tree. *) - let global_context = mk_mc_context ts entry err_loc in + let global_context = mk_mc_context ts entry err_loc enable_summary in logf "executing concolic mcmillan's algorithm\n"; (*let ts_with_gas = instrument_with_gas ts in *) let main_context = mk_intra_context global_context (entry, err_loc) ts 0 K.one entry err_loc in @@ -643,7 +685,7 @@ module GPS = struct module BM = BatMap.Make(Int) -let analyze_concolic_mcl enable_gas file = +let analyze_concolic_mcl enable_gas enable_summary enable_rtc file = let open Srk.Iteration in populate_offset_table file; K.domain := split (product [ PolyhedronGuard.exp @@ -659,7 +701,7 @@ let analyze_concolic_mcl enable_gas file = logf "\nentry: %d\n" entry; Printf.printf "testing reachability of location %d\n" err_loc ; Printf.printf "------------------------------\n"; - begin match GPS.execute ts entry err_loc with + begin match GPS.execute ts entry err_loc enable_summary with | Safe _ -> Printf.printf " proven safe\n"; | Unsafe _ -> Printf.printf " proven unsafe\n" end; @@ -675,7 +717,7 @@ let dump_cfg simplify file = begin let rg = Interproc.make_recgraph file in let _ (* entry *) = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system rg in + let (ts, assertions) = make_transition_system ~simplify:simplify rg in let ts, _ = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts end @@ -683,6 +725,12 @@ let dump_cfg simplify file = let _ = CmdLine.register_pass - ("-mcl-concolic", analyze_concolic_mcl false, " GPS model checking algorithm"); + ("-mcl-concolic", analyze_concolic_mcl false true, " GPS model checking algorithm"); + CmdLine.register_pass + ("-mcl-concolic-gas", analyze_concolic_mcl true true, " GPS model checking algorithm"); + CmdLine.register_pass + ("-mcl-concolic-nosum", analyze_concolic_mcl false false, "GPS without CRA-generated summary"); + CmdLine.register_pass + ("-dump-unsimplified-cfg", dump_cfg false, "dump unsimplified CFG"); CmdLine.register_pass - ("-mcl-concolic-gas", analyze_concolic_mcl true, " GPS model checking algorithm") + ("-dump-simplified-cfg", dump_cfg true, "dump simplified CFG") \ No newline at end of file diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 0499cfdd..0031638e 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -83,7 +83,7 @@ module ART : (Summarizer : sig type t (** [init g s] returns a Summarizer.t type for a given transition system, source vertex pair (g, s). *) - val init : TS.t -> TS.vertex -> TS.vertex -> t + val init : TS.t -> TS.vertex -> TS.vertex -> bool -> t (** [over_proc_summary s n] returns the over-approximate procedure summary for procedure `n`. *) val over_proc_summary : t -> PN.t -> K.t (** [under_proc_summary s n] returns the under-approximate procedure summary (initially `false`) for procedure `n`. *) diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index 03d194f3..9e20e856 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -530,6 +530,7 @@ module Make if not (proj var) then VHT.modify_def PS.empty var (PS.add (u,v)) ref_map in + List.iter (fun x -> VarSet.iter (fun var -> add_ref ) (references x)) assertions; tg |> WG.iter_edges (fun (u, label, v) -> match label with | Call _ -> () @@ -681,11 +682,13 @@ module Make let tg' = WG.fold_vertex (fun v tg -> let ug = WG.forget_weights tg in + Printf.printf "visiting vertex %d\n" v; if (p v || WG.mem_edge tg v v || (WG.U.in_degree ug v != 1 && WG.U.out_degree ug v != 1)) then + let _ = Printf.printf "trying rtc on vertex %d\n " v in begin if WG.mem_edge tg v v then match WG.edge_weight tg v v with | Weight tr -> @@ -693,14 +696,16 @@ module Make | Some rtc -> let u = -1 in (try + Printf.printf "removing edge from %d %d\n" v v; let tg = WG.remove_edge tg v v in let tg = + Printf.printf "success: contracting vertex %d %d\n" v u; WG.contract_vertex (WG.split_vertex tg v (Weight rtc) u) u in continue := true; tg with _ -> tg) - | None -> tg end + | None -> Printf.printf "...failed.\n"; tg end with _ -> tg) | Call (_, _) -> tg else From a18a90c5f1f087ca1c0365c859cefae3ab3dd8e9 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 4 Nov 2024 21:16:25 -0600 Subject: [PATCH 23/59] gps: fixup --- duet/gps.ml | 2 +- srk/src/transitionSystem.ml | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index bf7c4d8b..493ea023 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -685,7 +685,7 @@ module GPS = struct module BM = BatMap.Make(Int) -let analyze_concolic_mcl enable_gas enable_summary enable_rtc file = +let analyze_concolic_mcl enable_gas enable_summary file = let open Srk.Iteration in populate_offset_table file; K.domain := split (product [ PolyhedronGuard.exp diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index 9e20e856..e958db3b 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -530,7 +530,6 @@ module Make if not (proj var) then VHT.modify_def PS.empty var (PS.add (u,v)) ref_map in - List.iter (fun x -> VarSet.iter (fun var -> add_ref ) (references x)) assertions; tg |> WG.iter_edges (fun (u, label, v) -> match label with | Call _ -> () @@ -555,7 +554,7 @@ module Make List.fold_right VarSet.remove (uses tr) (PHT.find tmp_map (u, v)) in Weight (T.exists (fun x -> not (VarSet.mem x tmp)) tr) - with Not_found -> label) + with Not_found -> label) let forward_invariants_ivl tg entry = let init v = From 6e1e8e69596d2371ad72165e152bcbe9a976b84a Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 4 Nov 2024 23:42:27 -0600 Subject: [PATCH 24/59] translate bitwise ops as logical ops + __VERIFIER_nondet_uchar, __VERIFIER_nondet_bool --- duet/translateCil.ml | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/duet/translateCil.ml b/duet/translateCil.ml index 49694d7b..25326314 100644 --- a/duet/translateCil.ml +++ b/duet/translateCil.ml @@ -298,8 +298,8 @@ let rec tr_expr = function | Cil.Mod -> BinaryOp (e1, Mod, e2, typ) | Cil.Shiftlt -> BinaryOp (e1, ShiftL, e2, typ) | Cil.Shiftrt -> BinaryOp (e1, ShiftR, e2, typ) - | Cil.BAnd -> BinaryOp (e1, BAnd, e2, typ) - | Cil.BOr -> BinaryOp (e1, BOr, e2, typ) + | Cil.BAnd -> BoolExpr (And (Bexpr.of_aexpr e1, Bexpr.of_aexpr e2)) (* BinaryOp (e1, BAnd, e2, typ) *) + | Cil.BOr -> BoolExpr (Or (Bexpr.of_aexpr e1, Bexpr.of_aexpr e2)) (* BinaryOp (e1, BOr, e2, typ) *) | Cil.BXor -> BinaryOp (e1, BXor, e2, typ) | Cil.Lt -> BoolExpr (Atom (Lt, e1, e2)) | Cil.Gt -> BoolExpr (Bexpr.gt e1 e2) @@ -396,6 +396,7 @@ let verifier_builtins = "pthread_mutex_lock"; "pthread_mutex_unlock"; "spin_lock"; "spin_unlock"; "pthread_create"; "pthread_create"; "exit"; "abort"; "rand"; "__VERIFIER_nondet_char"; "__VERIFIER_nondet_int"; "__VERIFIER_nondet_long"; + "__VERIFIER_nondet_bool"; "__VERIFIER_nondet_uchar"; "__VERIFIER_nondet_pointer"; "__VERIFIER_nondet_uint"; "__CPROVER_atomic_begin"; "__CPROVER_atomic_end"; "__VERIFIER_atomic_begin"; "__VERIFIER_atomic_end"] @@ -478,6 +479,11 @@ let tr_instr ctx instr = | ("__VERIFIER_nondet_char", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int 1)))) + | ("__VERIFIER_nondet_uchar", Some (Variable v), []) -> + let havoc = mk_def (Assign (v, Havoc (Concrete (Int 1)))) in + let assume = + mk_def (Assume (Atom (Le, Aexpr.zero, AccessPath (Variable v)))) in + mk_seq havoc assume | ("__VERIFIER_nondet_int", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int machine_int_width)))) | ("__VERIFIER_nondet_long", Some (Variable v), []) -> @@ -485,6 +491,13 @@ let tr_instr ctx instr = mk_def (Assign (v, Havoc (Concrete (Int sz)))) | ("__VERIFIER_nondet_pointer", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int pointer_width)))) + | ("__VERIFIER_nondet_bool", Some (Variable v), []) -> + let assume_lb = + mk_def (Assume (Atom (Le, Aexpr.zero, AccessPath (Variable v)))) in (* 0 <= v *) + let assume_ub = + mk_def (Assume (Atom (Le, AccessPath (Variable v), Aexpr.one))) in (* v <= 1 *) + let havoc = mk_def (Assign (v, Havoc (Concrete (Int 1)))) in + mk_seq havoc @@ mk_seq assume_lb assume_ub | ("__VERIFIER_nondet_uint", Some (Variable v), []) -> let havoc = mk_def (Assign (v, Havoc (Concrete (Int unknown_width)))) in let assume = From 9a521f0aadf26ddda32a78e4f7a9ebd3ad5396cd Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Wed, 6 Nov 2024 14:19:09 -0600 Subject: [PATCH 25/59] incremental maintenence of leaf nodes to avoid stack blowup --- duet/reachTree.ml | 25 ++++++++++++++++++++----- duet/translateCil.ml | 6 ++++-- 2 files changed, 24 insertions(+), 7 deletions(-) diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 70d57687..84668a14 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -174,6 +174,7 @@ struct (* precedent_nodes[v] stores all tree nodes mapping to CFG vertex v. Used in mc_close. *) mutable precedent_nodes : ISet.t IntMap.t; interproc : Summarizer.t; + mutable leaves : ISet.t; } let root = 0 @@ -192,6 +193,7 @@ struct covers = IntMap.empty; (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) reverse_covers = IntMap.empty; (* for each v, store the v's that cover it: i.e. cover[v] *) precedent_nodes = IntMap.empty; + leaves = ISet.empty; interproc; } @@ -268,13 +270,15 @@ struct v :: List.fold_left (fun l ch -> descendants art ch @ l) [] v_children (* return leaves of subtree rooted at v. *) - let rec leaves (art : t ref) (v : node) : node list = + (* let rec leaves (art : t ref) (v : node) : node list = let chs = children art v in if List.length chs == 0 then [ v ] else List.fold_left - (fun child_leaves ch -> leaves art ch @ child_leaves) - [] chs + (fun child_leaves ch -> (leaves art ch) @ child_leaves) + [] chs *) + let leaves (art : t ref) (v : node) : node list = + !art.leaves |> ISet.to_list (* is a node in tree a leaf? *) let is_leaf (art : t ref) (v : node) : bool = @@ -323,9 +327,16 @@ struct !art.vtxcnt <- !art.vtxcnt + 1; new_id + (* [update_leaf art x] attempts to update leaf structure; if x is a leaf then x is marked as leaf, otherwise x is unmarked as leaf. *) + let update_leaf (art: t ref) (x: node) = + if is_leaf art x then + !art.leaves <- ISet.add x !art.leaves + else + !art.leaves <- ISet.remove x !art.leaves + (* Add new tree leaf mapping to CFG vertex v and with parent tree node p. *) let add_tree_vertex (art : t ref) ?(label = mk_true ()) (v : TS.vertex) - (p : int) = + (p : node) = (* sequentially add v to the lists, indexed by !vtxcnt *) let new_vertex = get_id art in (* note that new_vertex refers to a new tree vertex, where as v is a corresp. cfg location. *) @@ -344,6 +355,8 @@ struct in !art.precedent_nodes <- IntMap.add (VN.of_vertex v) precedent_nodes !art.precedent_nodes; + update_leaf art p; + update_leaf art new_vertex; new_vertex (** expand: @@ -467,7 +480,8 @@ struct let x_leaves = leaves art x in List.iter (fun x_leaf -> - logf + if not (is_leaf art x_leaf) then failwith "ERR: found non-leaf among leaves set of ART"; + logf " close: adding %d back to worklist \n" x_leaf; wl' := x_leaf :: !wl') @@ -524,6 +538,7 @@ struct logf " refine: adding %d back to worklist \n" x_leaf; + if not (is_leaf art x_leaf) then failwith "ERROR: found a non-leaf node in leaves set of ART"; worklist := x_leaf :: !worklist) x_leaves; l diff --git a/duet/translateCil.ml b/duet/translateCil.ml index 25326314..6492d502 100644 --- a/duet/translateCil.ml +++ b/duet/translateCil.ml @@ -481,9 +481,11 @@ let tr_instr ctx instr = mk_def (Assign (v, Havoc (Concrete (Int 1)))) | ("__VERIFIER_nondet_uchar", Some (Variable v), []) -> let havoc = mk_def (Assign (v, Havoc (Concrete (Int 1)))) in - let assume = + let assume0 = mk_def (Assume (Atom (Le, Aexpr.zero, AccessPath (Variable v)))) in - mk_seq havoc assume + (* let assume1 = TODO: + mk_def (Assume (Atom (Le, AccessPath (Variable v), Constant (CInt (255, 1))))) in *) + mk_seq havoc assume0 | ("__VERIFIER_nondet_int", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int machine_int_width)))) | ("__VERIFIER_nondet_long", Some (Variable v), []) -> From dca0454abee40fab8971684902da1b4a129738c9 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 7 Nov 2024 14:00:21 -0600 Subject: [PATCH 26/59] gps: minor fixes --- duet/gps.ml | 2 ++ duet/translateCil.ml | 6 +++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index 493ea023..e1cb8848 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -730,6 +730,8 @@ let _ = ("-mcl-concolic-gas", analyze_concolic_mcl true true, " GPS model checking algorithm"); CmdLine.register_pass ("-mcl-concolic-nosum", analyze_concolic_mcl false false, "GPS without CRA-generated summary"); + CmdLine.register_pass + ("-mcl-concolic-nosum-nogas", analyze_concolic_mcl true false, "GPS with gas but without CRA-generated summary"); CmdLine.register_pass ("-dump-unsimplified-cfg", dump_cfg false, "dump unsimplified CFG"); CmdLine.register_pass diff --git a/duet/translateCil.ml b/duet/translateCil.ml index 6492d502..ff34ca58 100644 --- a/duet/translateCil.ml +++ b/duet/translateCil.ml @@ -483,9 +483,9 @@ let tr_instr ctx instr = let havoc = mk_def (Assign (v, Havoc (Concrete (Int 1)))) in let assume0 = mk_def (Assume (Atom (Le, Aexpr.zero, AccessPath (Variable v)))) in - (* let assume1 = TODO: - mk_def (Assume (Atom (Le, AccessPath (Variable v), Constant (CInt (255, 1))))) in *) - mk_seq havoc assume0 + let assume1 = + mk_def (Assume (Atom (Le, AccessPath (Variable v), Constant (CInt (255, 1))))) in + mk_seq havoc @@ mk_seq assume0 assume1 | ("__VERIFIER_nondet_int", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int machine_int_width)))) | ("__VERIFIER_nondet_long", Some (Variable v), []) -> From 5faab7da38debb944636e690e091347dbae4545c Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 18 Nov 2024 10:19:39 -0600 Subject: [PATCH 27/59] [gps] perform instrumentation before invariant generation --- duet/cra.ml | 105 ++++++++++++++++++++++++++++++-- duet/gps.ml | 115 +++++++++++++++-------------------- duet/reachTree.ml | 4 +- duet/reachTree.mli | 2 +- srk/src/transition.ml | 17 ++++++ srk/src/transition.mli | 3 + srk/src/transitionSystem.ml | 56 +++++++++-------- srk/src/transitionSystem.mli | 8 +-- 8 files changed, 206 insertions(+), 104 deletions(-) diff --git a/duet/cra.ml b/duet/cra.ml index a69cc339..dce94233 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -787,12 +787,97 @@ let decorate_transition_system predicates ts entry = let invariant = abstract_domain.formula_of (abstract_domain.exists (member live) (inv v)) in + logf "loop header location: %d" v; logf "Found invariant at %d:@;%a" v (Syntax.Formula.pp srk) invariant; + logf "New ID: %d" fresh_id; WG.split_vertex ts v (Weight (K.assume invariant)) fresh_id) ts module VSet = BatSet.Make(V) -let make_transition_system ?(simplify=true) rg = +module ISet = BatSet.Make(Int) + +let create_gas_variable () = + let mk_int k = Ctx.mk_real (QQ.of_int k) in + let gas_var = Var.mk (Varinfo.mk_global "__duet_gas" (Concrete (Int 8))) in + let gas_var_sym = Syntax.mk_symbol srk ~name:"__duet_gas" `TyInt in + let gas_var_term = Syntax.mk_const srk gas_var_sym in + Hashtbl.add V.sym_to_var gas_var_sym (VVal gas_var); + ValueHT.add V.var_to_sym (VVal gas_var) gas_var_sym; + let gasexpr = (Syntax.mk_lt srk (mk_int 0) gas_var_term) in + let gasweight = + let assume_positive = K.assume gasexpr in + let decr_by_one = Syntax.mk_sub srk gas_var_term (mk_int 1) |> K.assign (VVal gas_var) in + K.mul assume_positive decr_by_one in + let initial_gas = K.havoc [ VVal gas_var ] in + (gasweight, gasexpr, initial_gas) + +let new_vtx () = (Def.mk (Assume Bexpr.ktrue)).did + +let instrument_with_gas (ts: TSG.t) (entry: int) gasexpr : TSG.t = + let modify_pre ts u = + Printf.printf " --- %d is call edge\n" u; + let g = ref ts in + (* step 1: add new in-edge to (u, v) *) + let x = new_vtx () in + g := WG.add_vertex !g x; + (* step 2: add weighted edge x-(gasexpr)->u *) + g := WG.add_edge !g x (Weight gasexpr) u; + (* step 3: redirect every p->u to be y->x->u *) + WG.iter_pred_e (fun (p, weight, _) -> + Printf.printf "changing %d->%d to %d->%d->%d\n" p u p x u; + g := WG.add_edge !g p weight x; + g := WG.remove_edge !g p u + ) ts u; + !g in + let modify_post ts u = + Printf.printf " --- %d is loop header\n" u; + let g = ref ts in + let x = new_vtx () in + (* step 1: add new out-edge from u -> x *) + g := WG.add_vertex !g x; + g := WG.add_edge !g u (Weight gasexpr) x; + (* step 2: for each u -> v, make it u -> x -> v *) + WG.iter_succ_e (fun (_, weight, v) -> + Printf.printf "changing %d->%d to %d->%d->%d\n" u v u x v; + g := WG.add_edge !g x weight v; + g := WG.remove_edge !g u v + ) ts u; + !g in + (* for each call-edge, u->v, add new predecessor edge x->u->v where x->u is an instrumented edge. *) + let loop_headers = + let module L = Loop.Make(TSG) in + (List.map (fun loop -> L.header loop) @@ L.all_loops (L.loop_nest ts)) + |> List.map (fun x -> (x, true)) in + let call_edge_headers, callees = + WG.fold_edges (fun (u, w, _) (headers, callees) -> + match w with + | Call (s, _) -> ISet.add u headers, ISet.add s callees + | Weight _ -> (headers, callees)) ts (ISet.empty, ISet.empty) in + + List.fold_left (fun ts (header, is_call_edge) -> + if is_call_edge then + modify_post ts header + else + modify_pre ts header) ts + (loop_headers + @ (List.map (fun x -> (x, false)) @@ ISet.to_list call_edge_headers)) + +let instrument_main tg entry init_gas_expr = + let post_entry = new_vtx () in + (* step 1: add a vertex called post_entry *) + let tg = WG.add_vertex tg post_entry in + (* step 2: remove each edge (entry->v) and make it (post_entry->v) *) + let gg = ref tg in + WG.iter_succ_e (fun (u, w, v) -> + assert (u = entry); + gg := WG.remove_edge !gg entry v; + gg := WG.add_edge !gg post_entry w v + ) tg entry; + (* step 3: add edge from entry->post_entry labeled by init_gas_expr *) + WG.add_edge !gg entry (Weight init_gas_expr) post_entry + +let make_transition_system ?(simplify=true) ?(instr_gas=false) (main_entry: int) rg = + let gasweight, gasexpr, init_gas_weight = create_gas_variable () in let call_edge block = Call ((RG.block_entry rg block).did, (RG.block_exit rg block).did) in @@ -808,8 +893,8 @@ let make_transition_system ?(simplify=true) rg = (Syntax.symbols cond) in let ts = - BatEnum.fold (fun ts (block, graph) -> - let tg = + BatEnum.fold (fun ts (block, graph) -> (* CFG of current function *) + let tg = (* TS of current CFG *) RG.G.fold_vertex (fun def tg -> let tg = WG.add_vertex tg def.did in let label = @@ -867,8 +952,14 @@ let make_transition_system ?(simplify=true) rg = let elim_var v = V.is_global v || VSet.mem v (!assert_vars) in + (* let _ = Printf.printf "Displaying pre-instrumented TG\n"; TSDisplay.display tg in *) + let tg = if (instr_gas && entry = main_entry) then instrument_main tg entry init_gas_weight else tg in + let tg = if instr_gas then instrument_with_gas tg entry gasweight else tg in + (* let _ = Printf.printf "Displaying post-instrumented TG\n"; TSDisplay.display tg in *) + let predicates = if instr_gas then gasexpr :: predicates else predicates in let tg = if simplify then TS.simplify point_of_interest tg else tg in let tg = TS.remove_temporaries elim_var tg in + (*let _ = Printf.printf "Displaying simplified TG\n"; TSDisplay.display tg in *) let tg = if !forward_inv_gen then Log.phase "Forward invariant generation" @@ -876,6 +967,7 @@ let make_transition_system ?(simplify=true) rg = else tg in + (* let _ = Printf.printf "Displaying invariant-generated TG\n"; TSDisplay.display tg in *) WG.fold_edges (fun (src, label, tgt) ts -> match label with | Weight w -> WG.add_edge ts src (Weight w) tgt @@ -903,7 +995,7 @@ let analyze file = | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system rg in + let (ts, assertions) = make_transition_system entry rg in (*TSDisplay.display ts;*) let query = mk_query ts entry in assertions |> SrkUtil.Int.Map.iter (fun v (phi, loc, msg) -> @@ -1140,7 +1232,7 @@ let prove_termination_main file = | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, _) = make_transition_system rg in + let (ts, _) = make_transition_system entry rg in if !CmdLine.display_graphs then TSDisplay.display ts; let query = mk_query ts entry in @@ -1199,7 +1291,8 @@ let resource_bound_analysis file = match file.entry_points with | [main] -> begin let rg = Interproc.make_recgraph file in - let (ts, _) = make_transition_system rg in + let entry = (RG.block_entry rg main).did in + let (ts, _) = make_transition_system entry rg in let entry = (RG.block_entry rg main).did in let query = mk_query ts entry in let cost = diff --git a/duet/gps.ml b/duet/gps.ml index e1cb8848..a44580ec 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -37,7 +37,6 @@ end module ProcMap = BatMap.Make(ProcName) module IntMap = BatMap.Make(Int) module StringMap = BatMap.Make(String) -module ISet = BatSet.Make(Int) module DQ = BatDeque module ARR = Batteries.DynArray type cfg_t = TSG.t @@ -106,49 +105,6 @@ let instrument_with_rets (ts : cfg_t) : cfg_t = ValueHT.add V.var_to_sym (VVal hazard_var) hazard_var_sym in ts -let instrument_with_gas (ts: cfg_t) = - let mk_int k = Ctx.mk_real (QQ.of_int k) in - let largest = ref (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in - let new_vtx () = - largest := !largest + 1; !largest in - let gas_var = Var.mk (Varinfo.mk_global "__duet_gas" (Concrete (Int 8))) in - let gas_var_sym = Syntax.mk_symbol srk ~name:"__duet_gas" `TyInt in - let gas_var_term = Syntax.mk_const srk gas_var_sym in - Hashtbl.add V.sym_to_var gas_var_sym (VVal gas_var); - ValueHT.add V.var_to_sym (VVal gas_var) gas_var_sym; - let gasexpr = - let assume_positive = K.assume (Syntax.mk_lt srk (mk_int 0) gas_var_term) in - let decr_by_one = - Syntax.mk_sub srk gas_var_term (mk_int 1) |> K.assign (VVal gas_var) - in - K.mul assume_positive decr_by_one - in - (* for each call-edge, u->v, add new predecessor edge x->u->v where x->u is an instrumented edge. *) - let loop_headers = - let module L = Loop.Make(TSG) in - List.map (fun loop -> L.header loop) @@ L.all_loops (L.loop_nest ts) in - let call_edge_headers = - WG.fold_edges (fun (u, w, _) ls -> - match w with - | Call _ -> u :: ls - | _ -> ls) ts [] in - let modify ts u = - let g = ref ts in - (* step 1: add new in-edge to (u, v) *) - let x = new_vtx () in - g := WG.add_vertex !g x; - (* step 2: add weighted edge x-(gasexpr)->u *) - g := WG.add_edge !g x (Weight gasexpr) u; - (* step 3: redirect every p->u to be y->x->u *) - WG.iter_pred_e (fun (p, weight, _) -> - g := WG.add_edge !g p weight x; - g := WG.remove_edge !g p u - ) ts u; - !g in - let g = ref ts in - List.iter (fun u -> g := modify !g u) (loop_headers @ call_edge_headers); - !g - module Summarizer = struct module SMap = BatMap.Make(ProcName) @@ -212,8 +168,14 @@ module Summarizer = (** retrieve under-approximate procedure summary *) let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = - SMap.find_default K.zero (u, v) ctx.underapprox - |> K.exists (V.is_global) + match SMap.find_default K.zero (u, v) ctx.underapprox + |> K.project_mbp (V.is_global) + with + | `Sat tr -> tr + | _ -> + log_weights "under_proc_summary: this weight is unsat: " [SMap.find_default K.zero (u, v) ctx.underapprox]; + K.zero + (*failwith "under_proc_summary: cannot model-based project"*) (** set under-approximate procedure summary *) let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = @@ -399,6 +361,19 @@ module GPS = struct art_cfg_path_pair ctx p |> List.map (fun (_, (u, v), _) -> (u, v)) + let print_vocabulary tr = + let g_vocab, l_vocab = K.vocabulary tr in + let vname x = + match V.of_symbol x with + | Some var -> V.show var + | None -> " [havoc] " + in + log_weights " [vocabulary of transition] " [tr]; + logf " ------ globals: ---- {\n"; + List.iter (fun x -> logf " %s %s\n" (Syntax.show_symbol srk x) (vname x)) g_vocab; + logf "}\n ------ locals: ---- {\n"; + List.iter (fun x -> logf " %s %s\n" (Syntax.show_symbol srk x) (vname x)) l_vocab + (* CFG path condition from art.src -> art.v *) let path_condition (ctx: intra_context ref) condition_type (v: ReachTree.node) = let art = !ctx.art in @@ -417,7 +392,11 @@ module GPS = struct | Call (src, dst) -> begin match condition_type with | OverApprox -> Summarizer.over_proc_summary summarizer (ProcName.make (src, dst)) - | UnderApprox -> Summarizer.under_proc_summary summarizer (ProcName.make (src, dst)) + | UnderApprox -> + let under = Summarizer.under_proc_summary summarizer (ProcName.make (src, dst)) in + log_weights "underapproximate summary" [under]; + print_vocabulary under; + under end | Weight w -> w) (to_weights cfg_nodes) in logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); @@ -548,8 +527,9 @@ module GPS = struct let extract_refinement (ctx: intra_context ref) = let art = !ctx.art in - let rfn = ReachTree.label art ReachTree.root |> promote in - K.exists (fun v -> V.is_global v) rfn + let rfn = ReachTree.label art ReachTree.root |> promote in + log_weights "refinement: " [rfn]; + K.exists (fun v -> V.is_global v) (rfn) let seq = List.fold_left K.mul K.one (* sequentially multiply, left-right *) @@ -568,7 +548,8 @@ module GPS = struct logf "\nlength of right path: %d" (List.length right); logf "\nPrinting left path... \n"; log_labelled_weights (get_summarizer ctx) UnderApprox "left path - " left; - failwith "error: handle_path_to_error: cannot project path condition" in + logf "error: handle_path_to_error: cannot project path condition" ; + `Safe in let handle_left_case caller_id = logf "handle_path_to_error: %s\n" caller_id; `Safe in @@ -634,7 +615,7 @@ module GPS = struct (* concolic phase *) begin match concolic_phase ctx with | `Unsafe w -> - logf "--- concolic_mcmillan_execute: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to !ctx.art w); + logf "--- GPS: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to !ctx.art w); let path_to_w = ReachTree.tree_path !ctx.art w |> art_cfg_path_pair ctx @@ -647,7 +628,7 @@ module GPS = struct !ctx.worklist <- worklist_push w !ctx.worklist; continue := true | `Unsafe pathcond -> - logf "--- conoclic_mcmilan_execute: managed to concretize an intraprocedural path-to-error. returning... "; + logf "--- GPS: managed to concretize an intraprocedural path-to-error. returning... "; state := `Concretized (pathcond); continue := false end @@ -675,8 +656,7 @@ module GPS = struct * ptt is a pointer to the reachability tree. *) let global_context = mk_mc_context ts entry err_loc enable_summary in - logf "executing concolic mcmillan's algorithm\n"; - (*let ts_with_gas = instrument_with_gas ts in *) + logf "executing GPS: start\n"; let main_context = mk_intra_context global_context (entry, err_loc) ts 0 K.one entry err_loc in intraproc_check main_context end @@ -685,7 +665,7 @@ module GPS = struct module BM = BatMap.Make(Int) -let analyze_concolic_mcl enable_gas enable_summary file = +let analyze_mc enable_gas enable_summary file = let open Srk.Iteration in populate_offset_table file; K.domain := split (product [ PolyhedronGuard.exp @@ -694,8 +674,7 @@ let analyze_concolic_mcl enable_gas enable_summary file = | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system rg in - let ts = if enable_gas then instrument_with_gas ts else ts in + let (ts, assertions) = make_transition_system ~simplify:true ~instr_gas:enable_gas entry rg in let ts, err_loc = make_ts_assertions_unreachable ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; logf "\nentry: %d\n" entry; @@ -710,14 +689,14 @@ let analyze_concolic_mcl enable_gas enable_summary file = | _ -> assert false (** dump simplified CFG before doing model checking / CRA / concolic execution *) -let dump_cfg simplify file = +let dump_cfg simplify instrument file = populate_offset_table file; match file.entry_points with | [main] -> begin let rg = Interproc.make_recgraph file in - let _ (* entry *) = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system ~simplify:simplify rg in + let entry = (RG.block_entry rg main).did in + let (ts, assertions) = make_transition_system ~simplify:simplify ~instr_gas:instrument entry rg in let ts, _ = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts end @@ -725,14 +704,18 @@ let dump_cfg simplify file = let _ = CmdLine.register_pass - ("-mcl-concolic", analyze_concolic_mcl false true, " GPS model checking algorithm"); + ("-gps", analyze_mc false true, " GPS model checking algorithm"); CmdLine.register_pass - ("-mcl-concolic-gas", analyze_concolic_mcl true true, " GPS model checking algorithm"); + ("-gps-gas", analyze_mc true true, " GPS model checking algorithm"); CmdLine.register_pass - ("-mcl-concolic-nosum", analyze_concolic_mcl false false, "GPS without CRA-generated summary"); + ("-gps-nosum", analyze_mc false false, "GPS without CRA-generated summary"); CmdLine.register_pass - ("-mcl-concolic-nosum-nogas", analyze_concolic_mcl true false, "GPS with gas but without CRA-generated summary"); + ("-gps-nosum-nogas", analyze_mc true false, "GPS with gas but without CRA-generated summary"); + CmdLine.register_pass + ("-dump-unsimplified-cfg", dump_cfg false false, "dump unsimplified CFG"); + CmdLine.register_pass + ("-dump-simplified-cfg", dump_cfg true false, "dump simplified CFG"); CmdLine.register_pass - ("-dump-unsimplified-cfg", dump_cfg false, "dump unsimplified CFG"); + ("-dump-instrumented-unsimplified-cfg", dump_cfg false true, "dump unsimplified CFG"); CmdLine.register_pass - ("-dump-simplified-cfg", dump_cfg true, "dump simplified CFG") \ No newline at end of file + ("-dump-instrumented-simplified-cfg", dump_cfg true true, "dump simplified CFG"); \ No newline at end of file diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 84668a14..065a663e 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -81,7 +81,7 @@ module ART vertex -> (vertex * Ctx.t Srk.Syntax.formula) list - val simplify : (vertex -> bool) -> t -> t + val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t val iter_succ_e : (vertex * transition TransitionSystem.label * vertex -> unit) -> @@ -188,7 +188,7 @@ struct vtxcnt = 1; cfg_vertex = IntMap.add 0 entry IntMap.empty; parents = IntMap.add 0 (-1) IntMap.empty; - labels = IntMap.add 0 pre_state IntMap.empty; + labels = IntMap.add 0 (mk_true ()) IntMap.empty; children = IntMap.add 0 [] IntMap.empty; covers = IntMap.empty; (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) reverse_covers = IntMap.empty; (* for each v, store the v's that cover it: i.e. cover[v] *) diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 0031638e..3c56e882 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -57,7 +57,7 @@ module ART : val forward_invariants_ivl_pa : Ctx.t Srk.Syntax.formula list -> t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list - val simplify : (vertex -> bool) -> t -> t + val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t val iter_succ_e : ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit val edge_weight : diff --git a/srk/src/transition.ml b/srk/src/transition.ml index fdeb6193..ad38e0a6 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -664,6 +664,23 @@ struct in interpolate_query trs post sat_model @@ interpolate_unsat_core + let vocabulary tr = + let tr_guard = guard tr in + let tr_trans = transform tr in + let guard_v = tr_guard |> Syntax.symbols in + let trans_v = BatEnum.fold (fun s (var, term) -> + let s = Symbol.Set.add (Var.symbol_of var) s in + let t = Syntax.symbols term in + Symbol.Set.union s t) Symbol.Set.empty tr_trans in + let v = Symbol.Set.union guard_v trans_v in + let globals = Symbol.Set.filter (fun x -> + match Var.of_symbol x with + | Some var -> Var.is_global var + | None -> false ) v in + let locals = Symbol.Set.diff v globals in + (Symbol.Set.to_list globals, Symbol.Set.to_list locals) + + let contextualize t1 t2 t3 : [`Sat of t | `Unsat ] = let t1 = rename_skolems t1 in let t2 = rename_skolems t2 diff --git a/srk/src/transition.mli b/srk/src/transition.mli index 295187ac..465254f6 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -172,4 +172,7 @@ module Make transition formula; return [None] of the exact RTC was not successfully found. *) val try_rtc : t -> t option + + (** vocabulary of a transition formula, (globals, locals)*) + val vocabulary : t -> ((Syntax.symbol list) * (Syntax.symbol list)) end diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index e958db3b..09fd771d 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -5,15 +5,17 @@ include Log.Make(struct let name = "srk.transitionSystem" end) module WG = WeightedGraph module Int = SrkUtil.Int +module ISet = BatSet.Make(Int) type 'a label = | Weight of 'a | Call of int * int + module Make (C : sig type t - val context : t context + val context : t context end) (Var : sig type t @@ -675,7 +677,8 @@ module Make in List.map invariants (L.all_loops (L.loop_nest tg)) - let simplify p tg = + + let simplify ?(try_rtc=false) p tg = let rec go tg = let continue = ref false in let tg' = @@ -687,30 +690,33 @@ module Make || (WG.U.in_degree ug v != 1 && WG.U.out_degree ug v != 1)) then - let _ = Printf.printf "trying rtc on vertex %d\n " v in - begin if WG.mem_edge tg v v then - match WG.edge_weight tg v v with - | Weight tr -> - (try begin match T.try_rtc tr with - | Some rtc -> - let u = -1 in - (try - Printf.printf "removing edge from %d %d\n" v v; - let tg = WG.remove_edge tg v v in - let tg = - Printf.printf "success: contracting vertex %d %d\n" v u; - WG.contract_vertex (WG.split_vertex tg v (Weight rtc) u) u - in - continue := true; - tg - with _ -> tg) - | None -> Printf.printf "...failed.\n"; tg end - with _ -> tg) - | Call (_, _) -> tg - else - tg + begin if try_rtc then begin + let _ = Printf.printf "trying rtc on vertex %d\n " v in + begin if WG.mem_edge tg v v then + match WG.edge_weight tg v v with + | Weight tr -> + (try begin match T.try_rtc tr with + | Some rtc -> + let u = -1 in + (try + Printf.printf "removing edge from %d %d\n" v v; + let tg = WG.remove_edge tg v v in + let tg = + Printf.printf "success: contracting vertex %d %d\n" v u; + WG.contract_vertex (WG.split_vertex tg v (Weight rtc) u) u + in + continue := true; + tg + with _ -> tg) + | None -> Printf.printf "...failed.\n"; tg end + with _ -> tg) + | Call (_, _) -> tg + else + tg + end + end + else tg end - else begin try let tg = WG.contract_vertex tg v in diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index d1ee10e5..f2aeeef4 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -6,9 +6,9 @@ type 'a label = module Make (C : sig - type t - val context : t Syntax.context - end) + type t + val context : t context + end) (Var : sig type t val pp : Format.formatter -> t -> unit @@ -102,7 +102,7 @@ module Make the given predicate. Simplification does not guarantee that all such vertices are contracted. In particular, simplification will not contract vertices with loops or vertices adjacent to call edges. *) - val simplify : (vertex -> bool) -> t -> t + val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t (** Given a transition system and entry, compute a set of loop headers along with the set of variables that are read within the From adf58dc546d67ef35d86508f70cbe033018c2022 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Tue, 18 Mar 2025 12:34:07 -0500 Subject: [PATCH 28/59] Debugging changes --- duet/gps.ml | 13 ++++++++----- duet/reachTree.ml | 11 ++++++++--- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index a44580ec..3da9ec2a 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -132,11 +132,11 @@ module Summarizer = let filt_over (ctx: t) x = if ctx.silent then begin - logf "filt_over: context is silent! \n"; + (*logf "filt_over: context is silent! \n";*) K.assume @@ mk_true () end else begin - logf "filt_over: context isn't silent!\n"; + (*logf "filt_over: context isn't silent!\n";*) x end let filt_under (ctx: t) x = @@ -251,7 +251,7 @@ module GPS = struct module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer) (* to print the reachability tree (+ worklist), or not *) - let print_tree = false + let print_tree = true type global_context = { interproc: Summarizer.t; @@ -309,7 +309,7 @@ module GPS = struct | None -> Syntax.mk_const srk sym end | None -> Syntax.mk_const srk sym) in - K.construct (Syntax.substitute_const srk substitute f) (ValueHT.to_seq sym_map |> List.of_seq) + K.construct (Syntax.substitute_const srk substitute (Syntax.mk_not srk f)) (ValueHT.to_seq sym_map |> List.of_seq) let mk_intra_context (gctx: global_context ref) (id: ProcName.t) (ts: cfg_t) (recurse_level: int) (precondition: K.t) (entry: int) (err_loc: int) = @@ -427,6 +427,7 @@ module GPS = struct Returns `Failure (u, m) with (u, m) being a new item to the concolic worklist if unable to refine. Returns `Success if refine is able to refine. *) let mc_refine (ctx: intra_context ref) (v: ReachTree.node) = + logf "refining node %d\n" (ReachTree.of_node v); let handle_failure v m = logf " *********************** REFINEMENT FAILED *************************\n"; let path_condition = path_condition ctx OverApprox v @@ -441,6 +442,7 @@ module GPS = struct | `Unknown -> failwith "mc_refine: got UNKNOWN as a result for interpolate_or_get_model" | `Valid interpolants -> logf "--- mc_refine: interpolation succeeded. path length %d, interpolant length %d" (List.length path) (List.length interpolants); + log_formulas "interpolants - " interpolants; ReachTree.refine art path interpolants |> List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist); `Success @@ -491,13 +493,14 @@ module GPS = struct (* Fetched tree node u from work list. First attempt to close it. *) if not (ReachTree.is_covered !ctx.art u) then begin - logf " uncovered. try close\n"; + logf " uncovered. try close %d\n" (ReachTree.of_node u); begin match ReachTree.lclose !ctx.art u with (* Close succeeded. No need to further explore it. *) | true, leaves -> logf "Close succeeded.\n"; worklist_push_all leaves; `Continue | false, leaves -> (* u is uncovered. *) + logf " ... close failed in refining node %d, try refining it\n" (ReachTree.of_node u); worklist_push_all leaves; begin match mc_refine ctx u with | `Success -> (* refinement succeeded *) diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 065a663e..1ee6d764 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -589,6 +589,7 @@ struct let force_cover (art : t ref) v w = (* check if v_label -> w_label where v is an ancestor at w *) if maps_to art v <> maps_to art w then (false, []) else begin + logf "force_cover(%d, %d)\n" v w; (* let v_label = label art v in *) let w_label = label art w in let artpath = tree_path art ~src:w v in @@ -625,17 +626,21 @@ struct if maps_to art u <> maps_to art v then try let p = parent art u in go p with Not_found -> (false, []) - else match force_cover art v u with + else + begin match force_cover art v u with | (true, frontiers) -> (true, frontiers) | (false, _) -> try let p = parent art u in go p with Not_found -> (false, []) end + end in - match v with + let res = match v with | 0 -> (false, []) - | _ -> go (parent art v) + | _ -> go (parent art v) in + let bb, _ = res in + logf " --- lclose result of %d : %b ---\n" v bb ; res (** TODO: [deprecated] procedures for lightweight verification of ART invariants *) From 11c322cea8f6e51562e4bfb8ff09ae448eed2490 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 20 Mar 2025 22:11:24 -0500 Subject: [PATCH 29/59] [GPS] performance fixes and summary-guided testing --- duet/gps.ml | 99 +++++++++---- duet/reachTree.ml | 107 ++++++-------- duet/reachTree.mli | 1 + duet/sgt.ml | 306 +++++++++++++++++++++++++++++++++++++++ duet/summaryProvider.ml | 244 +++++++++++++++++++++++++++++++ duet/summaryProvider.mli | 159 ++++++++++++++++++++ 6 files changed, 828 insertions(+), 88 deletions(-) create mode 100644 duet/sgt.ml create mode 100644 duet/summaryProvider.ml create mode 100644 duet/summaryProvider.mli diff --git a/duet/gps.ml b/duet/gps.ml index 3da9ec2a..1dcb30a0 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -3,16 +3,8 @@ open Srk open CfgIr open BatPervasives open Cra +open Sgt -(*module RG = Interproc.RG -module WG = WeightedGraph -module TLLRF = TerminationLLRF -module TDTA = TerminationDTA -module TPRF = TerminationPRF -module G = RG.G -(*module Ctx = Syntax.MakeSimplifyingContext ()*) -module Int = SrkUtil.Int -module TF = TransitionFormula*) module TS = TransitionSystem.Make(Ctx)(V)(K) include Log.Make(struct let name = "gps" end) @@ -211,7 +203,7 @@ module Summarizer = end - type path_type = +type path_type = | OverApprox | UnderApprox @@ -249,9 +241,15 @@ module GPS = struct end (* ART module *) module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer) + + (** summary-guided testing *) + module SGT = SummaryGuidedTesting(Ctx)(K)(TS')(ProcName)(Summarizer)(ReachTree) (* to print the reachability tree (+ worklist), or not *) - let print_tree = true + (* RF 3/2/25: If you enable this flag, and even if *) + (* the logf output stream is suppressed, it incurs a _huge_ *) + (* performance penalty. *) + let print_tree = false type global_context = { interproc: Summarizer.t; @@ -452,17 +450,19 @@ module GPS = struct let round ctx = match DQ.front (!ctx.execlist) with | Some ((u, u_model), w) -> - if print_tree then + if print_tree then (* XXX: if this is enabled, the performance penalty is huge. *) ReachTree.log_art !ctx.art; logf " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); !ctx.execlist <- w; - if (ReachTree.maps_to !ctx.art u) = (ReachTree.get_err_loc !ctx.art) then + if (ReachTree.maps_to !ctx.art u) = (ReachTree.get_err_loc !ctx.art) then begin + logf " *** found potential path-to-error, checking if prophesized pre-condition is sat...\n"; begin match Smt.is_sat srk (make_equalities ctx) with | `Sat -> - `ErrorReached u + logf " *** SAT, done\n"; + `ErrorReached u | _ -> !ctx.worklist <- worklist_push u !ctx.worklist; `Continue end - else begin + end else begin logf "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); log_model "" u_model; let new_concolic_nodes, new_frontier_nodes = ReachTree.expand !ctx.recurse_level !ctx.art u u_model in @@ -619,12 +619,20 @@ module GPS = struct begin match concolic_phase ctx with | `Unsafe w -> logf "--- GPS: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to !ctx.art w); - let path_to_w = + logf " --- forming path to error... \n"; + let has_calls, path_to_w = ReachTree.tree_path !ctx.art w |> art_cfg_path_pair ctx - |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight !ctx.ts u_vtx v_vtx, v)) in - begin match path_to_w with - | curr :: right -> + |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight !ctx.ts u_vtx v_vtx, v)) + |> List.fold_left (fun (has_call, l) (u, w, v) -> + match w with + | Call _ -> (true, (u, w, v) :: l) + | _ -> (false, (u, w, v) :: l) + ) (false, []) + in + logf " --- finished forming path to error, calling handle_path_to_error ... \n"; + begin match has_calls, path_to_w with + | true, curr :: right -> begin match handle_path_to_error ctx [] curr right `Right w with | `Safe -> (* path-to-error concretization failed. frontier_node is the src node of a call-edge. *) (* we can mark `w` as a frontier node to be refined, and continue. *) @@ -635,9 +643,14 @@ module GPS = struct state := `Concretized (pathcond); continue := false end - | [] -> - (* corner case: the path to error is of length 0. *) - state := `Concretized (K.one) + | false, curr :: right -> + state := `ConcretizedList (path_to_w); + continue := false + | true, [] + | false, [] -> + (* corner case: either no calls along the path, or if the path to error is of length 0. *) + state := `Concretized (K.one); + continue := false end | `Safe -> state := `Continue @@ -649,6 +662,7 @@ module GPS = struct done; match !state with | `Continue -> Safe (extract_refinement ctx) + | `ConcretizedList w -> Unsafe (K.one) (* TODO: fix this *) | `Concretized cond -> Unsafe (cond) @@ -691,6 +705,31 @@ let analyze_mc enable_gas enable_summary file = end | _ -> assert false +let analyze_sgt enable_gas enable_summary file = + let open Srk.Iteration in + populate_offset_table file; + K.domain := split (product [ PolyhedronGuard.exp + ; LossyTranslation.exp ]); + match file.entry_points with + | [main] -> begin + let rg = Interproc.make_recgraph file in + let entry = (RG.block_entry rg main).did in + let (ts, assertions) = make_transition_system ~simplify:true ~instr_gas:enable_gas entry rg in + let ts, err_loc = make_ts_assertions_unreachable ts assertions in + if !CmdLine.display_graphs then TSDisplay.display ts; + logf "\nentry: %d\n" entry; + Printf.printf "testing reachability of location %d\n" err_loc ; + Printf.printf "------------------------------\n"; + begin match GPS.SGT.execute ts entry err_loc (mk_true ()) enable_summary with + | `Safe -> Printf.printf " proven safe\n"; + | `Unsafe -> Printf.printf " proven unsafe\n" + | `Error s -> Printf.printf "ERR: %s\n" s + end; + Printf.printf "------------------------------\n" + end + | _ -> assert false + + (** dump simplified CFG before doing model checking / CRA / concolic execution *) let dump_cfg simplify instrument file = populate_offset_table file; @@ -707,13 +746,21 @@ let dump_cfg simplify instrument file = let _ = CmdLine.register_pass - ("-gps", analyze_mc false true, " GPS model checking algorithm"); + ("-gps", analyze_mc false true, " GPS model checking algorithm, without gas-instrumentation"); + CmdLine.register_pass + ("-gps-gas", analyze_mc true true, " GPS model checking algorithm, with gas-instrumentation (i.e., refutation-complete)"); + CmdLine.register_pass + ("-gps-nosum", analyze_mc false false, "GPS with neither gas nor CRA-generated summary"); + CmdLine.register_pass + ("-gps-nosum-nogas", analyze_mc true false, "GPS with gas but without CRA-generated summary (i.e., refutation-complete)"); + CmdLine.register_pass + ("-sgt", analyze_mc false true, "Summary-guided testing, without gas-instrumentation"); CmdLine.register_pass - ("-gps-gas", analyze_mc true true, " GPS model checking algorithm"); + ("-sgt-gas", analyze_sgt true true, "Summary-guided testing, with gas"); CmdLine.register_pass - ("-gps-nosum", analyze_mc false false, "GPS without CRA-generated summary"); + ("-sgt-nosum", analyze_sgt false false, "Summary-guided testing without CRA-generated summary"); CmdLine.register_pass - ("-gps-nosum-nogas", analyze_mc true false, "GPS with gas but without CRA-generated summary"); + ("-sgt-nosum-nogas", analyze_sgt true false, "Summary-guided testing with gas but without CRA-generated summary"); CmdLine.register_pass ("-dump-unsimplified-cfg", dump_cfg false false, "dump unsimplified CFG"); CmdLine.register_pass diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 1ee6d764..a50b3eeb 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -222,36 +222,6 @@ struct try IntMap.find i !art.cfg_vertex with _ -> failwith @@ Printf.sprintf "maps_to: not found tree node %d\n" i - (* deprecated: - (* [cfg_edge_weight t mode u v] returns the edge weight of edge (u, v) in ART t. - If (u, v) maps to a call-edge (x, y) in the CFG, return the over-approximate summary if - `mode` is set to `OverApprox`, and return an under-approximate summary otherwise. *) - let edge_weight (art : t ref) (mode : equery) (u : node) (v : node) = - let t = !art in - match TS.edge_weight t.graph (maps_to art u) (maps_to art v) with - | TransitionSystem.Weight w -> w - | TransitionSystem.Call (a, b) -> ( - (* (a, b) is a pair of CFG vertices that uniquely identify a call *) - let a, b = (VN.to_vertex a, VN.to_vertex b) in - match mode with - | OverApprox -> Summarizer.over_proc_summary t.interproc (PN.make (a, b)) - | UnderApprox -> - Summarizer.under_proc_summary t.interproc (PN.make (a, b))) - - let edge_weight (art : t ref) (mode : equery) (u : node) (v : node) = - let t = !art in - match TS.edge_weight t.graph (maps_to art u) (maps_to art v) with - | TransitionSystem.Weight w -> w - | TransitionSystem.Call (a, b) -> ( - (* (a, b) is a pair of CFG vertices that uniquely identify a call *) - let a, b = (VN.to_vertex a, VN.to_vertex b) in - match mode with - | OverApprox -> Summarizer.over_proc_summary t.interproc (PN.make (a, b)) - | UnderApprox -> - Summarizer.under_proc_summary t.interproc (PN.make (a, b))) - - - *) (* [tree_path t u] returns list of tree nodes that form the corrsp. tree path from root of t to tree node u *) let tree_path (art : t ref) ?(src=root) (u : node) : node list = let rec tree_path_rev art u = @@ -270,13 +240,6 @@ struct v :: List.fold_left (fun l ch -> descendants art ch @ l) [] v_children (* return leaves of subtree rooted at v. *) - (* let rec leaves (art : t ref) (v : node) : node list = - let chs = children art v in - if List.length chs == 0 then [ v ] - else - List.fold_left - (fun child_leaves ch -> (leaves art ch) @ child_leaves) - [] chs *) let leaves (art : t ref) (v : node) : node list = !art.leaves |> ISet.to_list @@ -302,25 +265,6 @@ struct in ISet.elements precedents_set - (* deprecated: - (* [path_condition t mode u] returns a list of edge weights that form the path condition from root of t to tree node u. *) - (* if `cutoff` is specified to a non-zero value, then [path_condition] will try to stop at intermediate ancestor `cutoff`. *) - (* Over-approximate summaries are substituted in for call-edge locations if mode = `OverApprox`, and under-approximate *) - (* summaries are substituted in otherwise. *) - let path_condition (art : t ref) (mode : equery) ?(cutoff = 0) (u : node) = - if u == 0 || cutoff = u then [] - else - let rec visit (art : t ref) (u : node) = - let v = parent art u in - if v = 0 then [ edge_weight art mode 0 u ] - else if v = cutoff then - (* v=0 case is already handled above *) - [ edge_weight art mode cutoff u ] - else edge_weight art mode v u :: visit art v - in - List.rev (visit art u) - *) - (** retrieves a new ART node ID, ensuring all ART nodes have distinct IDs in increasing order according to their creation *) let get_id (art : t ref) : node = let new_id = !art.vtxcnt in @@ -358,24 +302,63 @@ struct update_leaf art p; update_leaf art new_vertex; new_vertex - - (** expand: - for every out-neighbor y of v, first try deriving a post-state model of v-> y, if successful, put it - on the concolic execution worklist. Otherwise, it is a frontier node, and put it on the - refinement worklist. *) + (* this is a helper primitive *) let is_deterministic = let is_det tr = not (K.contains_havoc tr) || K.is_deterministic tr in Memo.memo is_det + + let get_weight art weight = + match weight with + | TransitionSystem.Weight w -> w + | TransitionSystem.Call (u, v) -> + let proc = (VN.to_vertex u, VN.to_vertex v) |> PN.make in + Summarizer.over_proc_summary !art.interproc proc + + (** expand: + for every out-neighbor y of v, first try deriving a post-state model of v-> y, if successful, put it + on the concolic execution worklist. Otherwise, it is a frontier node, and put it on the + refinement worklist. *) + + + (* New (more general) API for expansion that supports summary-guided testing + * and an IMPACT-style algorithm. The expansion is performed guarded by the pre-image + of [tr], where, in GPS and SGT, [tr] is a single-target path summary, in IMPACT, [tr] + is the identity transition. More specifically, for each out-neighbor u of G(v), we + first test if m /\ tr is SAT, if so, then this out-neighbor is non-frontier. Otherwise, + this out neighbor is a frontier. *) + let guarded_expand (art: t ref) (v: node) (m: Ctx.t Interpretation.interpretation) (tr: K.t) = + let vg = maps_to art v in + let new_concolic_nodes, new_frontier_nodes = (ref [], ref []) in + (* visit out-neighbors of v *) + TS.iter_succ_e + (fun (_, weight, y) -> + let weight = + let w' = get_weight art weight in + if is_deterministic w' then w' else + K.mul w' (K.assume @@ K.guard (tr)) + in + match K.get_post_model m weight with + | Some y_model -> + let new_vtx = add_tree_vertex art y v in + new_concolic_nodes := (new_vtx, y_model) :: !new_concolic_nodes + | None -> + let new_node = add_tree_vertex art y v in + new_frontier_nodes := new_node :: !new_frontier_nodes) + !art.graph vg; + (* make it FIFO *) + (List.rev !new_concolic_nodes, List.rev !new_frontier_nodes) + + (* returns (new nodes on concolic worklist, new nodes on frontier worklist) *) (* a newly expanded node (leaf) is deemed a _concolic node_ if it can inherit a post-state model from its parent by means of symbol substitution. It is deemed a _frontier node_ if concrete execution cannot reach it from its parent node. A frontier node does not have a model associated with it and is in need of refinement. *) - let expand recurse_level (art : t ref) (v : node) (m: Ctx.t Interpretation.interpretation)= + let expand recurse_level (art : t ref) (v : node) (m: Ctx.t Interpretation.interpretation) = let oracle s src tgt = if recurse_level = 0 then Summarizer.path_weight_inter s src else Summarizer.path_weight_intra s src tgt diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 3c56e882..19db6a00 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -127,6 +127,7 @@ module ART : t ref -> ?label:Ctx.t Srk.Syntax.formula -> TS.vertex -> int -> node val expand : int -> t ref -> node -> Ctx.t Interpretation.interpretation -> (node * Ctx.t Interpretation.interpretation) list * node list + val guarded_expand : t ref -> node -> Ctx.t Interpretation.interpretation -> K.t -> (node * Ctx.t Interpretation.interpretation) list * node list val cover : t ref -> node -> node -> bool val close : t ref -> node -> (bool * node list) val force_cover : t ref -> node -> node -> (bool * node list) diff --git a/duet/sgt.ml b/duet/sgt.ml new file mode 100644 index 00000000..bc0aa374 --- /dev/null +++ b/duet/sgt.ml @@ -0,0 +1,306 @@ +open Srk +open Syntax +module RG = Interproc.RG +module WG = Srk.WeightedGraph +module G = RG.G +module Int = SrkUtil.Int +module TF = TransitionFormula + +module TransitionSystem = Srk.TransitionSystem +module Syntax = Srk.Syntax +module Interpretation = Srk.Interpretation + +include Log.Make(struct let name = "sgt" end) +module DQ = BatDeque +module ARR = Batteries.DynArray + + +module SummaryGuidedTesting +(Ctx: Srk.Syntax.Context) +(** transition formula algebra *) +(K : sig + type t + type var + val pp : Format.formatter -> t -> unit + val guard : t -> Ctx.t Srk.Syntax.formula + val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t + val mem_transform : var -> t -> bool + val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term + val assume : Ctx.t Srk.Syntax.formula -> t + val mul : t -> t -> t + val add : t -> t -> t + val conjunct : t -> t -> t + val zero : t + val one : t + val star : t -> t + val exists : (var -> bool) -> t -> t + val contains_havoc : t -> bool + val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] + val interpolate_or_concrete_model : t list -> Ctx.t Srk.Syntax.formula + -> [`Valid of Ctx.t Srk.Syntax.formula list + | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] + + val get_post_model : + Ctx.t Srk.Interpretation.interpretation -> + t -> Ctx.t Srk.Interpretation.interpretation option + val is_deterministic : t -> bool + end) +(TS : sig + type vertex = int + type transition = K.t + type t + type query + type reverse_query + val empty : t + val path_weight : query -> vertex -> transition + val call_weight : query -> vertex * vertex -> transition + val mk_reverse_query : query -> vertex -> reverse_query + val exit_summary : reverse_query -> vertex -> vertex -> K.t + val target_summary : reverse_query -> vertex -> K.t + + val set_summary : query -> vertex * vertex -> transition -> unit + val get_summary : query -> vertex * vertex -> transition + val omega_path_weight : + query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b + val forward_invariants_ivl : + t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list + val forward_invariants_ivl_pa : + Ctx.t Srk.Syntax.formula list -> + t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list + val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t + val iter_succ_e : + ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit + val edge_weight : + t -> vertex -> vertex -> K.t Srk.TransitionSystem.label + + val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b + end) +(PN : sig + type t + val make : TS.vertex * TS.vertex -> t + val string_of : t -> string + val of_string : string -> t + val compare : t -> t -> int +end) +(Summarizer : sig + type t + (** [init g s] returns a Summarizer.t type for a given transition system, source vertex pair (g, s). *) + val init : TS.t -> TS.vertex -> TS.vertex -> bool -> t + (** [over_proc_summary s n] returns the over-approximate procedure summary for procedure `n`. *) + val over_proc_summary : t -> PN.t -> K.t + (** [under_proc_summary s n] returns the under-approximate procedure summary (initially `false`) for procedure `n`. *) + val under_proc_summary : t -> PN.t -> K.t + (** [set_over_proc_summary s n w] sets the over-approximate procedure summary to be `w` at procedure `n`. *) + val set_over_proc_summary : t -> PN.t -> K.t -> unit + (** [set_under_proc_summary s n w] sets the under-approximate procedure summary to be `w` at procedure `n`. *) + val set_under_proc_summary : t -> PN.t -> K.t -> unit + (** [refine s n pre post] refines the over-approximate procedure summary at `n` by conjuncting on (pre) /\ (post') *) + val refine_over_summary : t -> PN.t -> K.t -> unit + (** [refine_under s n tr] refines the under-approximate procedure summary at `n` by adding `tr` as a disjunct. *) + val refine_under_summary : t -> PN.t -> K.t -> unit + (** [path_weight_intra s u v] gives the weighted path summary between (u, v) on an intraprocedural CFG *) + val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t + (** [path_weight_inter s u v] gives the inter-procedural path weight between (u, v) *) + val path_weight_inter : t -> TS.vertex -> K.t +end) +( + PathTree : sig + type node + type t + type state_formula = Ctx.t Srk.Syntax.formula + exception Mexception of string + val make : TS.t -> TS.vertex -> TS.vertex -> state_formula -> Summarizer.t -> t ref + val get_entry : t ref -> TS.vertex + val get_err_loc : t ref -> TS.vertex + val print_tree : t ref -> string -> node -> unit + val parent : t ref -> node -> node + val maps_to : t ref -> node -> TS.vertex + val tree_path : t ref -> ?src:node -> node -> node list + val children : t ref -> node -> node list + val descendants : t ref -> node -> node list + val leaves : t ref -> node -> node list + val is_leaf : t ref -> node -> bool + val get_id : t ref -> node + val add_tree_vertex : + t ref -> ?label:Ctx.t Srk.Syntax.formula -> TS.vertex -> int -> node + val expand : + int -> t ref -> node -> Ctx.t Interpretation.interpretation -> (node * Ctx.t Interpretation.interpretation) list * node list + + val guarded_expand : t ref -> node -> Ctx.t Interpretation.interpretation -> K.t -> (node * Ctx.t Interpretation.interpretation) list * node list + val log_art : t ref -> unit + val log_node : node -> unit + val of_node : node -> int + val root : node + end +) = struct + + module IntMap = BatMap.Make(Int) + module StringMap = BatMap.Make(String) + type cfg_t = TS.t + type idq_t = int BatDeque.t + type state_formula = Ctx.t Syntax.formula + exception Mexception of string + + let mk_true () = Syntax.mk_true Ctx.context + let mk_false () = Syntax.mk_false Ctx.context + + let print_tree = false + + let log_formulas prefix formulas = + List.iteri (fun i f -> logf "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr Ctx.context) f) formulas + + let log_weights prefix weights = + List.iteri (fun i f -> logf "[weight] %s(%i): %a\n" prefix i K.pp f) weights + + + let log_model prefix model = + logf "[model] %s: %a\n" prefix Interpretation.pp model + + + type context = { + ts : cfg_t; + entry : int; + error : int; + sum: Summarizer.t; + pre_state : Ctx.t Syntax.formula; + mutable art : PathTree.t ref; + (* list for frontier nodes *) + mutable worklist : PathTree.node DQ.t; + (* list for executor states *) + mutable execlist : (PathTree.node * Ctx.t Interpretation.interpretation) DQ.t; + } + + let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i + + + let run_test (ctx: context ref) = + let round ctx = + match DQ.front (!ctx.execlist) with + | Some ((u, u_model), w) -> + if print_tree then + PathTree.log_art !ctx.art; + logf " visit %d (%d)\n" (PathTree.of_node u) (PathTree.maps_to !ctx.art u); + !ctx.execlist <- w; + if (PathTree.maps_to !ctx.art u) = (PathTree.get_err_loc !ctx.art) then + `Unsafe u + else begin + logf "model of %d (%d): \n" (PathTree.of_node u) (PathTree.maps_to !ctx.art u); + log_model "" u_model; + let new_concolic_nodes, new_frontier_nodes = PathTree.expand 0 !ctx.art u u_model in + List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; + List.iter (fun frontier_node -> !ctx.worklist <- worklist_push frontier_node !ctx.worklist) new_frontier_nodes; + `Continue + end + | None -> + failwith "err: concolic_phase is reading from empty execution worklist" (* cannot happen *) + in + let rtn = ref `Continue in + while !rtn = `Continue && ((DQ.size !ctx.execlist) > 0) do + rtn := round ctx + done; + match !rtn with + | `Continue -> `Safe + | `Unsafe u -> `Unsafe u + + + let mk_context (ts: cfg_t) (entry: int) (error: int) (pre_state: state_formula) (enable_summary: bool) = + let sum = Summarizer.init ts entry error enable_summary in + ref { + ts = ts; + entry = entry; + error = error; + sum = sum; + pre_state = pre_state; + art = PathTree.make ts entry error pre_state sum; + worklist = DQ.empty; + execlist = DQ.empty; + } + + let path_condition (ctx: context ref) (v: PathTree.node) = + let art = !ctx.art in + let cfg = !ctx.ts in + let art_nodes = PathTree.tree_path art v in + let cfg_nodes = List.map (fun x -> PathTree.maps_to art x) art_nodes in + let rec to_weights l : K.t Cra.label list = + match l with + | a :: b :: t -> + TS.edge_weight cfg a b :: (to_weights (b :: t)) + | _ -> [] + in + let pathcond = List.map (fun (weight: K.t Cra.label) -> + match weight with + | Call (src, dst) -> failwith "encountered call edge" + | Weight w -> w) (to_weights cfg_nodes) in + logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); + let l = (K.assume !ctx.pre_state) :: pathcond in + log_weights "path conditions " l; l + + + let mk_post (ctx: context ref) (v: PathTree.node) (sink: TS.vertex) = + let art = !ctx.art in + let post_path_summary = Summarizer.path_weight_inter (!ctx.sum) (PathTree.maps_to art v) in + log_weights "\npost_path_summary: " [post_path_summary]; + logf "\n"; + K.guard post_path_summary + + + + (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) + let interpolate_or_get_model (ctx: context ref) (src : PathTree.node) (sink: TS.vertex) = + let suffix = mk_post ctx src sink |> Syntax.mk_not Ctx.context in + let prefix = path_condition ctx src in + log_weights "\nprefix " prefix; + log_formulas "\nsuffix " [suffix]; + logf "\n"; + K.interpolate_or_concrete_model prefix suffix + + + let refine (ctx: context ref) (v: PathTree.node) = + logf "refining node %d\n" (PathTree.of_node v); + let handle_failure v m = + logf " *********************** REFINEMENT FAILED *************************\n"; + let path_condition = path_condition ctx v + in `Failure (m, path_condition) + in let art = !ctx.art in + match interpolate_or_get_model ctx v @@ PathTree.get_err_loc art with + `Invalid v_model -> + logf "Unable to refine but got model\n"; + (* v is no longer a frontier node. *) + handle_failure v v_model + | `Unknown -> failwith "mc_refine: got UNKNOWN as a result for interpolate_or_get_model" + | `Valid _ -> + `Success + + + let execute (ts: cfg_t) (entry: int) (error: int) (pre_state: state_formula) (enable_summary: bool) : [`Safe | `Unsafe | `Error of string] = + let ctx = mk_context ts entry error pre_state enable_summary in + let state = ref `Unknown in + !ctx.worklist <- worklist_push (PathTree.root) !ctx.worklist; + while (DQ.size !ctx.worklist > 0 || DQ.size !ctx.execlist > 0) && (!state = `Unknown) do + logf " --- SGT: starting a new test execution phase\n"; + match run_test ctx with + | `Safe -> + begin match DQ.front !ctx.worklist with + | Some (u, worklist') -> + begin match refine ctx u with + | `Failure (m, _) -> + !ctx.execlist <- worklist_push (u, m) !ctx.execlist; + !ctx.worklist <- worklist'; + state := `Unknown + | `Success (* refinement succeeded. *) -> + logf " --- SGT: refinement success\n"; + state := `Unknown + end + | None -> + state := `Safe + end + | `Unsafe _ -> + logf " --- SGT: finished running, found a bug.\n"; + state := `Unsafe + done; + logf " --- SGT: done performing execution.\n"; + match !state with + | `Unsafe -> `Unsafe + | `Unknown | `Safe -> `Safe +end + diff --git a/duet/summaryProvider.ml b/duet/summaryProvider.ml new file mode 100644 index 00000000..56ff7e02 --- /dev/null +++ b/duet/summaryProvider.ml @@ -0,0 +1,244 @@ +open Core +open Srk +open CfgIr +open BatPervasives +open Cra + +(* + +include Log.Make(struct let name = "sgt" end) + +module IntMap = BatMap.Make(Int) +module StringMap = BatMap.Make(String) +module DQ = BatDeque +module ARR = Batteries.DynArray +type idq_t = int BatDeque.t +type state_formula = Ctx.t Syntax.formula +exception Mexception of string + + + + +let log_formulas prefix formulas = + List.iteri (fun i f -> logf "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr srk) f) formulas + +let log_weights prefix weights = + List.iteri (fun i f -> logf "[weight] %s(%i): %a\n" prefix i K.pp f) weights + + +let log_model prefix model = + logf "[model] %s: %a\n" prefix Interpretation.pp model + +module LeftRegularSummaryProvider (Ctx: Srk.Syntax.Context) +(** transition formula algebra *) +(K : sig + type t + type var + val pp : Format.formatter -> t -> unit + val guard : t -> Ctx.t Srk.Syntax.formula + val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t + val mem_transform : var -> t -> bool + val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term + val assume : Ctx.t Srk.Syntax.formula -> t + val mul : t -> t -> t + val add : t -> t -> t + val conjunct : t -> t -> t + val zero : t + val one : t + val star : t -> t + val exists : (var -> bool) -> t -> t + val contains_havoc : t -> bool + val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] + val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula + -> [`Valid of Ctx.t Syntax.formula list + | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] + + val get_post_model : + Ctx.t Srk.Interpretation.interpretation -> + t -> Ctx.t Srk.Interpretation.interpretation option + val is_deterministic : t -> bool + end) + (TS : sig + type vertex + type transition = K.t + type t + type query + type reverse_query + val empty : t + val path_weight : query -> vertex -> transition + val call_weight : query -> vertex * vertex -> transition + val mk_reverse_query : query -> vertex -> reverse_query + val exit_summary : reverse_query -> vertex -> vertex -> K.t + val target_summary : reverse_query -> vertex -> K.t + val set_summary : query -> vertex * vertex -> transition -> unit + val get_summary : query -> vertex * vertex -> transition + val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t + val iter_succ_e : + ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit + val edge_weight : + t -> vertex -> vertex -> K.t Srk.TransitionSystem.label + val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b + end) += +struct + type t = { + graph: TS.t; + src: int; + query: TS.query; + rev_query: TS.reverse_query; + silent: bool; + monotone: bool; + } + let mk_query ts entry = TS.mk_query ts entry (if !monotone then (module MonotoneDom) else (module TransitionDom)) + + let init (graph: TS.t) (src: int) (tgt: int) (enable_summary: bool) : t = + let q = mk_query graph src in + let rq = TS.mk_reverse_query q tgt in + { graph = graph + ; src = src + ; query = q + ; rev_query = rq + ; silent = not enable_summary } + + + let path_weight_intra (ctx: t) (src: int) (dst: int) = + TS.exit_summary ctx.rev_query src dst + + let path_weight_inter (ctx: t) (src: int) = + TS.target_summary ctx.rev_query src + +end + +module InterproceduralSummaryProvider(ProcName : sig + type t = int * int + val make : TS.vertex * TS.vertex -> t + val string_of : t -> string + val of_string : string -> t + val compare : t -> t -> int +end) += + struct + module SMap = BatMap.Make(ProcName) + type t = { + graph: cfg_t; + src: int; + query: TS.query; + rev_query: TS.reverse_query; + mutable underapprox: K.t SMap.t; + mutable overapprox: K.t SMap.t; (* Caution: used only for silent mode where no CRA-generated summaries are used. *) + } + + let init (graph: cfg_t) (src: int) (tgt: int) : t = + let q = mk_query graph src in + let rq = TS.mk_reverse_query q tgt in + { graph = graph + ; src = src + ; query = q + ; rev_query = rq + ; underapprox = SMap.empty + ; overapprox = SMap.empty } + + (** retrieve over-approximate procedure summary *) + let over_proc_summary (ctx: t) ((u, v) : ProcName.t) = + TS.get_summary ctx.query (u, v) + |> K.exists (V.is_global) + + (** set over-approximate procedure summary *) + let set_over_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) = + TS.set_summary ctx.query (u, v) w + + (** retrieve under-approximate procedure summary *) + let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = + match SMap.find_default K.zero (u, v) ctx.underapprox + |> K.project_mbp (V.is_global) + with + | `Sat tr -> tr + | _ -> + log_weights "under_proc_summary: this weight is unsat: " [SMap.find_default K.zero (u, v) ctx.underapprox]; + K.zero + (*failwith "under_proc_summary: cannot model-based project"*) + + (** set under-approximate procedure summary *) + let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = + ctx.underapprox <- SMap.add (u, v) w ctx.underapprox + + (** refinement of procedure summaries using a two-voc transition formula *) + let refine_over_summary (ctx: t) ((u, v): ProcName.t) (rfn: K.t) = + over_proc_summary ctx (u, v) + |> K.conjunct rfn + |> set_over_proc_summary ctx (u, v) + + let refine_under_summary (ctx: t) ((u, v): ProcName.t) (w:K.t) : unit = + let summary = under_proc_summary ctx (u, v) in + let summary' = K.add summary w in + log_weights "under-approx summary refined to " [summary']; + set_under_proc_summary ctx (u, v) summary' + + end + +module SilentSummaryProvider(ProcName : sig + type t = int * int + val make : TS.vertex * TS.vertex -> t + val string_of : t -> string + val of_string : string -> t + val compare : t -> t -> int +end) = +struct + module SMap = BatMap.Make(ProcName) + type t = { + graph: cfg_t; + src: int; + mutable underapprox: K.t SMap.t; + mutable overapprox: K.t SMap.t; (* Caution: used only for silent mode where no CRA-generated summaries are used. *) + } + + let init (graph: cfg_t) (src: int) (tgt: int) : t = + { graph = graph + ; src = src + ; underapprox = SMap.empty + ; overapprox = SMap.empty } + + (** retrieve over-approximate procedure summary *) + let over_proc_summary (ctx: t) ((u, v) : ProcName.t) = + match SMap.find_opt (u, v) ctx.overapprox with + | Some s -> s + | None -> + let init = K.assume @@ mk_true () in + ctx.overapprox <- SMap.add (u, v) init ctx.overapprox; + init + + (** set over-approximate procedure summary *) + let set_over_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) = + match SMap.find_opt (u, v) ctx.overapprox with + | Some s -> + ctx.overapprox <- SMap.add (u, v) (K.conjunct s w) ctx.overapprox + | None -> + ctx.overapprox <- SMap.add (u, v) w ctx.overapprox + + (** retrieve under-approximate procedure summary *) + let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = + match SMap.find_default K.zero (u, v) ctx.underapprox |> K.project_mbp (V.is_global) with + | `Sat tr -> tr + | _ -> + log_weights "under_proc_summary: this weight is unsat: " [SMap.find_default K.zero (u, v) ctx.underapprox]; + K.zero + + (** set under-approximate procedure summary *) + let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = + ctx.underapprox <- SMap.add (u, v) w ctx.underapprox + + (** refinement of procedure summaries using a two-voc transition formula *) + let refine_over_summary (ctx: t) ((u, v): ProcName.t) (rfn: K.t) = + match SMap.find_opt (u, v) ctx.overapprox with + | Some s -> + ctx.overapprox <- SMap.add (u, v) (K.conjunct s rfn) ctx.overapprox + | None -> + ctx.overapprox <- SMap.add (u, v) rfn ctx.overapprox + + let refine_under_summary (ctx: t) ((u, v): ProcName.t) (w:K.t) : unit = + let summary = under_proc_summary ctx (u, v) in + let summary' = K.add summary w in + log_weights "under-approx summary refined to " [summary']; + set_under_proc_summary ctx (u, v) summary' +end +*) \ No newline at end of file diff --git a/duet/summaryProvider.mli b/duet/summaryProvider.mli new file mode 100644 index 00000000..0fe44028 --- /dev/null +++ b/duet/summaryProvider.mli @@ -0,0 +1,159 @@ +(* +module TransitionSystem = Srk.TransitionSystem +module Syntax = Srk.Syntax +module Interpretation = Srk.Interpretation +*) +(* +module LeftRegularSummaryProvider : + functor + (Ctx: Srk.Syntax.Context) + (** transition formula algebra *) + (K : sig + type t + type var + val pp : Format.formatter -> t -> unit + val guard : t -> Ctx.t Srk.Syntax.formula + val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t + val mem_transform : var -> t -> bool + val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term + val assume : Ctx.t Srk.Syntax.formula -> t + val mul : t -> t -> t + val add : t -> t -> t + val conjunct : t -> t -> t + val zero : t + val one : t + val star : t -> t + val exists : (var -> bool) -> t -> t + val contains_havoc : t -> bool + val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] + val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula + -> [`Valid of Ctx.t Syntax.formula list + | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] + + val get_post_model : + Ctx.t Srk.Interpretation.interpretation -> + t -> Ctx.t Srk.Interpretation.interpretation option + val is_deterministic : t -> bool + end) + (TS : sig + type vertex + type transition = K.t + type t + type query + type reverse_query + val empty : t + val path_weight : query -> vertex -> transition + val call_weight : query -> vertex * vertex -> transition + val mk_reverse_query : query -> vertex -> reverse_query + val exit_summary : reverse_query -> vertex -> vertex -> K.t + val target_summary : reverse_query -> vertex -> K.t + val set_summary : query -> vertex * vertex -> transition -> unit + val get_summary : query -> vertex * vertex -> transition + val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t + val iter_succ_e : + ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit + val edge_weight : + t -> vertex -> vertex -> K.t Srk.TransitionSystem.label + val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b + end) + -> sig + type t + val init : TS.t -> int -> int -> bool -> t + val path_weight_intra : t -> int -> int -> TS.transition + val path_weight_inter : t -> int -> TS.transition + end + +module InterproceduralSummaryProvider : +(Ctx: Srk.Syntax.Context) +(K : sig + type t + type var + val pp : Format.formatter -> t -> unit + val guard : t -> Ctx.t Srk.Syntax.formula + val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t + val mem_transform : var -> t -> bool + val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term + val assume : Ctx.t Srk.Syntax.formula -> t + val mul : t -> t -> t + val add : t -> t -> t + val conjunct : t -> t -> t + val zero : t + val one : t + val star : t -> t + val exists : (var -> bool) -> t -> t + val contains_havoc : t -> bool + val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] + val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula + -> [`Valid of Ctx.t Syntax.formula list + | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] + + val get_post_model : + Ctx.t Srk.Interpretation.interpretation -> + t -> Ctx.t Srk.Interpretation.interpretation option + val is_deterministic : t -> bool + end) +(TS : sig + type vertex + type transition = K.t + type t + type query + type reverse_query + val empty : t + val path_weight : query -> vertex -> transition + val call_weight : query -> vertex * vertex -> transition + val mk_reverse_query : query -> vertex -> reverse_query + val exit_summary : reverse_query -> vertex -> vertex -> K.t + val target_summary : reverse_query -> vertex -> K.t + val set_summary : query -> vertex * vertex -> transition -> unit + val get_summary : query -> vertex * vertex -> transition + val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t + val iter_succ_e : + ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit + val edge_weight : + t -> vertex -> vertex -> K.t Srk.TransitionSystem.label + val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b + end) + (ProcName : sig + type t = int * int + val make : int * int -> t + val string_of : t -> string + val of_string : string -> t + val compare : t -> t -> int + end) + -> + sig + type t + val init : TS.t -> int -> int -> t + val over_proc_summary : t -> ProcName.t -> TS.transition + val set_over_proc_summary : t -> ProcName.t -> TS.transition -> unit + val under_proc_summary : t -> ProcName.t -> TS.transition + val set_under_proc_summary : t -> ProcName.t -> TS.transition -> unit + val refine_over_summary : t -> ProcName.t -> TS.transition -> unit + val refine_under_summary : t -> ProcName.t -> TS.transition -> unit + end + +module SilentSummaryProvider : +functor + (TS : sig + type t + type transition + end) + (ProcName : sig + type t = int * int + val make : int * int -> t + val string_of : t -> string + val of_string : string -> t + val compare : t -> t -> int + end) + -> + sig + type t + val init : TS.t -> int -> int -> t + val over_proc_summary : t -> ProcName.t -> TS.transition + val set_over_proc_summary : t -> ProcName.t -> TS.transition -> unit + val under_proc_summary : t -> ProcName.t -> TS.transition + val set_under_proc_summary : t -> ProcName.t -> TS.transition -> unit + val refine_over_summary : t -> ProcName.t -> TS.transition -> unit + val refine_under_summary : t -> ProcName.t -> TS.transition -> unit + end +*) \ No newline at end of file From dbc4babf04059ccff889ee95e7f964780e9a9774 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Fri, 21 Mar 2025 08:35:24 -0500 Subject: [PATCH 30/59] oops --- duet/sgt.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/duet/sgt.ml b/duet/sgt.ml index bc0aa374..698eaa8b 100644 --- a/duet/sgt.ml +++ b/duet/sgt.ml @@ -289,7 +289,8 @@ end) state := `Unknown | `Success (* refinement succeeded. *) -> logf " --- SGT: refinement success\n"; - state := `Unknown + !ctx.worklist <- worklist'; + state := `Unknown; end | None -> state := `Safe From 0010c117de0917de59031e7efdd8b80398585c87 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Sun, 23 Mar 2025 15:07:08 -0500 Subject: [PATCH 31/59] treat free variables as universally quantified in interpolate --- srk/src/transition.ml | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/srk/src/transition.ml b/srk/src/transition.ml index ad38e0a6..2057d49f 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -447,7 +447,11 @@ struct (wp::itp, wp)) trs guards - ([post], post) + ([ + mk_not srk post + |> Quantifier.mbp srk (fun x -> Var.of_symbol x <> None) + |> mk_not srk + ], post) in `Valid (List.tl itp) @@ -535,7 +539,11 @@ struct (wp::itp, wp)) trs guards - ([Quantifier.mbp srk (fun x -> Var.of_symbol x <> None) post], post) + ([ + mk_not srk post + |> Quantifier.mbp srk (fun x -> Var.of_symbol x <> None) + |> mk_not srk + ], post) in `Valid (List.tl itp) From c30b1e1ece9779d96fa5ba6f573686d44d3c27e7 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Fri, 18 Apr 2025 17:21:53 -0400 Subject: [PATCH 32/59] Remove dead code --- Makefile | 2 +- duet/cra.ml | 6 +-- duet/gps.ml | 32 ++++----------- duet/reachTree.ml | 97 +++++----------------------------------------- duet/reachTree.mli | 4 +- duet/sgt.ml | 92 ++++--------------------------------------- srk/src/smt.ml | 4 -- 7 files changed, 31 insertions(+), 206 deletions(-) diff --git a/Makefile b/Makefile index 710daa18..aa3996fe 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ all: build build: - dune build --profile release duet + dune build duet clean: dune clean diff --git a/duet/cra.ml b/duet/cra.ml index dce94233..39b6ef5d 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -813,7 +813,7 @@ let create_gas_variable () = let new_vtx () = (Def.mk (Assume Bexpr.ktrue)).did -let instrument_with_gas (ts: TSG.t) (entry: int) gasexpr : TSG.t = +let instrument_with_gas (ts: TSG.t) gasexpr : TSG.t = let modify_pre ts u = Printf.printf " --- %d is call edge\n" u; let g = ref ts in @@ -848,7 +848,7 @@ let instrument_with_gas (ts: TSG.t) (entry: int) gasexpr : TSG.t = let module L = Loop.Make(TSG) in (List.map (fun loop -> L.header loop) @@ L.all_loops (L.loop_nest ts)) |> List.map (fun x -> (x, true)) in - let call_edge_headers, callees = + let call_edge_headers, _ = WG.fold_edges (fun (u, w, _) (headers, callees) -> match w with | Call (s, _) -> ISet.add u headers, ISet.add s callees @@ -954,7 +954,7 @@ let make_transition_system ?(simplify=true) ?(instr_gas=false) (main_entry: int) in (* let _ = Printf.printf "Displaying pre-instrumented TG\n"; TSDisplay.display tg in *) let tg = if (instr_gas && entry = main_entry) then instrument_main tg entry init_gas_weight else tg in - let tg = if instr_gas then instrument_with_gas tg entry gasweight else tg in + let tg = if instr_gas then instrument_with_gas tg gasweight else tg in (* let _ = Printf.printf "Displaying post-instrumented TG\n"; TSDisplay.display tg in *) let predicates = if instr_gas then gasexpr :: predicates else predicates in let tg = if simplify then TS.simplify point_of_interest tg else tg in diff --git a/duet/gps.ml b/duet/gps.ml index 1dcb30a0..63bb720b 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -79,24 +79,6 @@ let make_ts_assertions_unreachable (ts : cfg_t) assertions = in (ts, err_loc) -let instrument_with_rets (ts : cfg_t) : cfg_t = - let mk_int k = Ctx.mk_real (QQ.of_int k) in - let largest = ref (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in - let new_vtx () = - largest := !largest + 1; !largest in - let hazard_var = Var.mk (Varinfo.mk_global "__duet_hazard" (Concrete (Int 8))) in - let hazard_var_sym = Syntax.mk_symbol srk ~name:"__duet_hazard" `TyInt in - let hazard_var_term = Syntax.mk_const srk hazard_var_sym in - let open Syntax.Infix(Ctx) in - let assume_true = K.assume (Syntax.mk_eq srk (hazard_var_term) (mk_int 1)) in - let assign_zero = K.assign (VVal hazard_var) (mk_int 0) in - let assign_one = K.assign (VVal hazard_var) (mk_int 1) in - let all_succs u = WG.U.succ u in - let _ = - Hashtbl.add V.sym_to_var hazard_var_sym (VVal hazard_var); - ValueHT.add V.var_to_sym (VVal hazard_var) hazard_var_sym - in ts - module Summarizer = struct module SMap = BatMap.Make(ProcName) @@ -243,7 +225,7 @@ module GPS = struct module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer) (** summary-guided testing *) - module SGT = SummaryGuidedTesting(Ctx)(K)(TS')(ProcName)(Summarizer)(ReachTree) + module SGT = SummaryGuidedTesting(Ctx)(K)(TS')(Summarizer)(ReachTree) (* to print the reachability tree (+ worklist), or not *) (* RF 3/2/25: If you enable this flag, and even if *) @@ -321,7 +303,7 @@ module GPS = struct equalities = equalities; worklist = DQ.empty; execlist = DQ.empty; - art = ReachTree.make ts entry err_loc pre_state !gctx.interproc; + art = ReachTree.make ts entry err_loc !gctx.interproc; global_ctx = gctx; } and mk_mc_context (global_cfg: cfg_t) (global_src: int) (err_loc: int) enable_summary = @@ -355,7 +337,7 @@ module GPS = struct | _ -> [] (* turn tree path into a sequence of CFG edges. *) - let rec cfg_path (ctx: intra_context ref) (p : ReachTree.node list) = + let cfg_path (ctx: intra_context ref) (p : ReachTree.node list) = art_cfg_path_pair ctx p |> List.map (fun (_, (u, v), _) -> (u, v)) @@ -627,7 +609,7 @@ module GPS = struct |> List.fold_left (fun (has_call, l) (u, w, v) -> match w with | Call _ -> (true, (u, w, v) :: l) - | _ -> (false, (u, w, v) :: l) + | _ -> (has_call, (u, w, v) :: l) ) (false, []) in logf " --- finished forming path to error, calling handle_path_to_error ... \n"; @@ -643,7 +625,7 @@ module GPS = struct state := `Concretized (pathcond); continue := false end - | false, curr :: right -> + | false, _::_ -> state := `ConcretizedList (path_to_w); continue := false | true, [] @@ -662,7 +644,7 @@ module GPS = struct done; match !state with | `Continue -> Safe (extract_refinement ctx) - | `ConcretizedList w -> Unsafe (K.one) (* TODO: fix this *) + | `ConcretizedList _ -> Unsafe (K.one) (* TODO: fix this *) | `Concretized cond -> Unsafe (cond) @@ -768,4 +750,4 @@ let _ = CmdLine.register_pass ("-dump-instrumented-unsimplified-cfg", dump_cfg false true, "dump unsimplified CFG"); CmdLine.register_pass - ("-dump-instrumented-simplified-cfg", dump_cfg true true, "dump simplified CFG"); \ No newline at end of file + ("-dump-instrumented-simplified-cfg", dump_cfg true true, "dump simplified CFG"); diff --git a/duet/reachTree.ml b/duet/reachTree.ml index a50b3eeb..f18bd6b6 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -24,23 +24,11 @@ module ART (Ctx : Srk.Syntax.Context) (K : sig type t - type var - val pp : Format.formatter -> t -> unit val guard : t -> Ctx.t formula - val transform : t -> (var * Ctx.t arith_term) BatEnum.t - val mem_transform : var -> t -> bool - val get_transform : var -> t -> Ctx.t arith_term val assume : Ctx.t formula -> t val mul : t -> t -> t - val conjunct : t -> t -> t - val add : t -> t -> t - val zero : t - val one : t - val star : t -> t - val exists : (var -> bool) -> t -> t val contains_havoc : t -> bool - val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula -> [`Valid of Ctx.t Syntax.formula list | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] @@ -55,33 +43,6 @@ module ART type vertex type transition = K.t type t - type query - type reverse_query - - val empty : t - val path_weight : query -> vertex -> transition - val call_weight : query -> vertex * vertex -> transition - val set_summary : query -> vertex * vertex -> transition -> unit - val get_summary : query -> vertex * vertex -> transition - - - val mk_reverse_query : query -> vertex -> reverse_query - val exit_summary : reverse_query -> vertex -> vertex -> K.t - val target_summary : reverse_query -> vertex -> K.t - - val omega_path_weight : - query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b - - val forward_invariants_ivl : - t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list - - val forward_invariants_ivl_pa : - Ctx.t Srk.Syntax.formula list -> - t -> - vertex -> - (vertex * Ctx.t Srk.Syntax.formula) list - - val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t val iter_succ_e : (vertex * transition TransitionSystem.label * vertex -> unit) -> @@ -102,8 +63,6 @@ module ART type t val make : TS.vertex * TS.vertex -> t - val string_of : t -> string - val of_string : string -> t (* lexicographic comparison using Stdlib.compare *) val compare : t -> t -> int @@ -115,11 +74,6 @@ module ART (Summarizer : sig type t val over_proc_summary : t -> PN.t -> K.t - val under_proc_summary : t -> PN.t -> K.t - val set_over_proc_summary : t -> PN.t -> K.t -> unit - val set_under_proc_summary : t -> PN.t -> K.t -> unit - val refine_over_summary : t -> PN.t -> K.t -> unit - val refine_under_summary : t -> PN.t -> K.t -> unit val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t val path_weight_inter : t -> TS.vertex -> K.t end) = @@ -134,13 +88,11 @@ struct module DQ = BatDeque module ARR = Batteries.DynArray - type idq_t = int BatDeque.t type state_formula = Ctx.t Syntax.formula exception Mexception of string let mk_true () = Syntax.mk_true Ctx.context - let mk_false () = Syntax.mk_false Ctx.context let log_formulas prefix formulas = List.iteri @@ -150,14 +102,6 @@ struct f) formulas - let log_weights prefix weights = - List.iteri - (fun i f -> logf "[weight] %s(%i): %a\n" prefix i K.pp f) - weights - - let log_model prefix model = - logf "[model] %s: %a\n" prefix Interpretation.pp model - type t = { graph : TS.t; entry : TS.vertex; @@ -179,7 +123,7 @@ struct let root = 0 - let make (g : TS.t) (entry : TS.vertex) (err_loc : TS.vertex) (pre_state: state_formula) interproc = + let make (g : TS.t) (entry : TS.vertex) (err_loc : TS.vertex) interproc = ref { graph = g; @@ -239,8 +183,8 @@ struct let v_children = children art v in v :: List.fold_left (fun l ch -> descendants art ch @ l) [] v_children - (* return leaves of subtree rooted at v. *) - let leaves (art : t ref) (v : node) : node list = + (* return leaves of the tree. *) + let leaves (art : t ref) : node list = !art.leaves |> ISet.to_list (* is a node in tree a leaf? *) @@ -458,9 +402,10 @@ struct !art.reverse_covers <- IntMap.remove y !art.reverse_covers; (* Step 3: add xs to worklist. *) ISet.iter - (fun x -> + (fun _x -> (* add x's subtree leaves back to the worklist. *) - let x_leaves = leaves art x in + (* Zak: TODO: This adds *all* leaves back to the worklist *) + let x_leaves = leaves art in List.iter (fun x_leaf -> if not (is_leaf art x_leaf) then failwith "ERR: found non-leaf among leaves set of ART"; @@ -515,7 +460,8 @@ struct x u; !art.covers <- IntMap.remove x !art.covers; (* add x's subtree leaves back to the worklist. *) - let x_leaves = leaves art x in + (* Zak: TODO: This adds *all* leaves back to the worklist *) + let x_leaves = leaves art in List.iter (fun x_leaf -> logf @@ -545,29 +491,6 @@ struct - (* for w that is an ancestor of v, cover[v] stores w *) - let remove_from_cover art v w = - match IntMap.find_opt v !art.covers with - | Some u -> - begin if u <> w then failwith "remove_from_cover: node pair to remove not in cover" - else - !art.covers <- IntMap.remove v !art.covers; - let w_coverers = IntMap.find w !art.reverse_covers |> ISet.remove v in - !art.reverse_covers <- IntMap.add w w_coverers !art.reverse_covers; - end - | None -> failwith "remove_from_cover: node pair to remove not in cover ()" - - let add_to_cover art v w = - match IntMap.find_opt v !art.covers with - | Some r -> remove_from_cover art v r - | None -> (); - !art.covers <- IntMap.add v w !art.covers; - !art.reverse_covers <- - IntMap.add w - (IntMap.find_default ISet.empty w !art.reverse_covers - |> ISet.add v) !art.reverse_covers - - (* convention: w is an ancestor of v. returns true if we can add (v, w) to covers such that label(v) |= label(w) *) let force_cover (art : t ref) v w = (* check if v_label -> w_label where v is an ancestor at w *) if maps_to art v <> maps_to art w then (false, []) @@ -628,7 +551,7 @@ struct (** TODO: [deprecated] procedures for lightweight verification of ART invariants *) - let verify_well_labelled_tree (t : t ref) = + let _verify_well_labelled_tree (t : t ref) = let rec aux v = let children = children t v in match children with @@ -659,7 +582,7 @@ struct logf "...done verifying well-labelledness of ART\n"; r - let check_covering_welformedness (t : t ref) = + let _check_covering_welformedness (t : t ref) = logf "checking welformedness of covering relations\n"; IntMap.iter (fun dst covered_from -> diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 19db6a00..2acca507 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -107,7 +107,7 @@ module ART : type t type state_formula = Ctx.t Srk.Syntax.formula exception Mexception of string - val make : TS.t -> TS.vertex -> TS.vertex -> state_formula -> Summarizer.t -> t ref + val make : TS.t -> TS.vertex -> TS.vertex -> Summarizer.t -> t ref val get_entry : t ref -> TS.vertex val get_err_loc : t ref -> TS.vertex val get_summarizer : t ref -> Summarizer.t @@ -117,7 +117,7 @@ module ART : val tree_path : t ref -> ?src:node -> node -> node list val children : t ref -> node -> node list val descendants : t ref -> node -> node list - val leaves : t ref -> node -> node list + val leaves : t ref -> node list val is_leaf : t ref -> node -> bool val label : t ref -> node -> state_formula val set_label : t ref -> node -> state_formula -> unit diff --git a/duet/sgt.ml b/duet/sgt.ml index 698eaa8b..c4083c11 100644 --- a/duet/sgt.ml +++ b/duet/sgt.ml @@ -1,5 +1,4 @@ open Srk -open Syntax module RG = Interproc.RG module WG = Srk.WeightedGraph module G = RG.G @@ -20,86 +19,24 @@ module SummaryGuidedTesting (** transition formula algebra *) (K : sig type t - type var val pp : Format.formatter -> t -> unit val guard : t -> Ctx.t Srk.Syntax.formula - val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t - val mem_transform : var -> t -> bool - val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term val assume : Ctx.t Srk.Syntax.formula -> t - val mul : t -> t -> t - val add : t -> t -> t - val conjunct : t -> t -> t - val zero : t - val one : t - val star : t -> t - val exists : (var -> bool) -> t -> t - val contains_havoc : t -> bool - val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] val interpolate_or_concrete_model : t list -> Ctx.t Srk.Syntax.formula -> [`Valid of Ctx.t Srk.Syntax.formula list | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] - - val get_post_model : - Ctx.t Srk.Interpretation.interpretation -> - t -> Ctx.t Srk.Interpretation.interpretation option - val is_deterministic : t -> bool end) (TS : sig type vertex = int - type transition = K.t type t - type query - type reverse_query - val empty : t - val path_weight : query -> vertex -> transition - val call_weight : query -> vertex * vertex -> transition - val mk_reverse_query : query -> vertex -> reverse_query - val exit_summary : reverse_query -> vertex -> vertex -> K.t - val target_summary : reverse_query -> vertex -> K.t - val set_summary : query -> vertex * vertex -> transition -> unit - val get_summary : query -> vertex * vertex -> transition - val omega_path_weight : - query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b - val forward_invariants_ivl : - t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list - val forward_invariants_ivl_pa : - Ctx.t Srk.Syntax.formula list -> - t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list - val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t - val iter_succ_e : - ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit val edge_weight : t -> vertex -> vertex -> K.t Srk.TransitionSystem.label - - val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b end) -(PN : sig - type t - val make : TS.vertex * TS.vertex -> t - val string_of : t -> string - val of_string : string -> t - val compare : t -> t -> int -end) (Summarizer : sig type t (** [init g s] returns a Summarizer.t type for a given transition system, source vertex pair (g, s). *) val init : TS.t -> TS.vertex -> TS.vertex -> bool -> t - (** [over_proc_summary s n] returns the over-approximate procedure summary for procedure `n`. *) - val over_proc_summary : t -> PN.t -> K.t - (** [under_proc_summary s n] returns the under-approximate procedure summary (initially `false`) for procedure `n`. *) - val under_proc_summary : t -> PN.t -> K.t - (** [set_over_proc_summary s n w] sets the over-approximate procedure summary to be `w` at procedure `n`. *) - val set_over_proc_summary : t -> PN.t -> K.t -> unit - (** [set_under_proc_summary s n w] sets the under-approximate procedure summary to be `w` at procedure `n`. *) - val set_under_proc_summary : t -> PN.t -> K.t -> unit - (** [refine s n pre post] refines the over-approximate procedure summary at `n` by conjuncting on (pre) /\ (post') *) - val refine_over_summary : t -> PN.t -> K.t -> unit - (** [refine_under s n tr] refines the under-approximate procedure summary at `n` by adding `tr` as a disjunct. *) - val refine_under_summary : t -> PN.t -> K.t -> unit - (** [path_weight_intra s u v] gives the weighted path summary between (u, v) on an intraprocedural CFG *) - val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t (** [path_weight_inter s u v] gives the inter-procedural path weight between (u, v) *) val path_weight_inter : t -> TS.vertex -> K.t end) @@ -107,28 +44,15 @@ end) PathTree : sig type node type t - type state_formula = Ctx.t Srk.Syntax.formula exception Mexception of string - val make : TS.t -> TS.vertex -> TS.vertex -> state_formula -> Summarizer.t -> t ref - val get_entry : t ref -> TS.vertex + val make : TS.t -> TS.vertex -> TS.vertex -> Summarizer.t -> t ref val get_err_loc : t ref -> TS.vertex - val print_tree : t ref -> string -> node -> unit - val parent : t ref -> node -> node val maps_to : t ref -> node -> TS.vertex val tree_path : t ref -> ?src:node -> node -> node list - val children : t ref -> node -> node list - val descendants : t ref -> node -> node list - val leaves : t ref -> node -> node list - val is_leaf : t ref -> node -> bool - val get_id : t ref -> node - val add_tree_vertex : - t ref -> ?label:Ctx.t Srk.Syntax.formula -> TS.vertex -> int -> node val expand : int -> t ref -> node -> Ctx.t Interpretation.interpretation -> (node * Ctx.t Interpretation.interpretation) list * node list - val guarded_expand : t ref -> node -> Ctx.t Interpretation.interpretation -> K.t -> (node * Ctx.t Interpretation.interpretation) list * node list val log_art : t ref -> unit - val log_node : node -> unit val of_node : node -> int val root : node end @@ -211,7 +135,7 @@ end) error = error; sum = sum; pre_state = pre_state; - art = PathTree.make ts entry error pre_state sum; + art = PathTree.make ts entry error sum; worklist = DQ.empty; execlist = DQ.empty; } @@ -229,14 +153,14 @@ end) in let pathcond = List.map (fun (weight: K.t Cra.label) -> match weight with - | Call (src, dst) -> failwith "encountered call edge" + | Call (_, _) -> failwith "encountered call edge" | Weight w -> w) (to_weights cfg_nodes) in logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); let l = (K.assume !ctx.pre_state) :: pathcond in log_weights "path conditions " l; l - let mk_post (ctx: context ref) (v: PathTree.node) (sink: TS.vertex) = + let mk_post (ctx: context ref) (v: PathTree.node) = let art = !ctx.art in let post_path_summary = Summarizer.path_weight_inter (!ctx.sum) (PathTree.maps_to art v) in log_weights "\npost_path_summary: " [post_path_summary]; @@ -246,8 +170,8 @@ end) (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) - let interpolate_or_get_model (ctx: context ref) (src : PathTree.node) (sink: TS.vertex) = - let suffix = mk_post ctx src sink |> Syntax.mk_not Ctx.context in + let interpolate_or_get_model (ctx: context ref) (src : PathTree.node) = + let suffix = mk_post ctx src |> Syntax.mk_not Ctx.context in let prefix = path_condition ctx src in log_weights "\nprefix " prefix; log_formulas "\nsuffix " [suffix]; @@ -261,8 +185,8 @@ end) logf " *********************** REFINEMENT FAILED *************************\n"; let path_condition = path_condition ctx v in `Failure (m, path_condition) - in let art = !ctx.art in - match interpolate_or_get_model ctx v @@ PathTree.get_err_loc art with + in + match interpolate_or_get_model ctx v with `Invalid v_model -> logf "Unable to refine but got model\n"; (* v is no longer a frontier node. *) diff --git a/srk/src/smt.ml b/srk/src/smt.ml index 37a28d41..79896a66 100644 --- a/srk/src/smt.ml +++ b/srk/src/smt.ml @@ -92,10 +92,6 @@ module Solver = struct let push s = s.s_push () let pop s = s.s_pop - - let get_unsat_core srk solver assumptions = failwith "" - let get_unsat_core_or_model ?(symbols=[]) srk solver assumptions = failwith "" - let make srk = match get_theory srk with | `LIRA -> From bfd475e1a5053cc6f316f7834fcd0a2faf37740c Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Wed, 23 Apr 2025 13:08:56 -0400 Subject: [PATCH 33/59] Refactoring --- duet/gps.ml | 358 ++++++++++++++++++++++++++++----------------- duet/reachTree.ml | 296 ++++++++++++++----------------------- duet/reachTree.mli | 207 +++++++++----------------- duet/sgt.ml | 171 ++++------------------ 4 files changed, 436 insertions(+), 596 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index 63bb720b..7fd4132d 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -3,7 +3,6 @@ open Srk open CfgIr open BatPervasives open Cra -open Sgt module TS = TransitionSystem.Make(Ctx)(V)(K) @@ -23,9 +22,12 @@ module ProcName = struct | _ -> failwith @@ Printf.sprintf "illegal procedure identifier %s" s (* lexicographic comparison using Stdlib.compare *) - let compare (p1: t) (p2: t) = Stdlib.compare p1 p2 + let compare (p1: t) (p2: t) = Stdlib.compare p1 p2 + let hash = Hashtbl.hash + let equal = (=) end +module ProcHT = BatHashtbl.Make(ProcName) module ProcMap = BatMap.Make(ProcName) module IntMap = BatMap.Make(Int) module StringMap = BatMap.Make(String) @@ -83,8 +85,6 @@ module Summarizer = struct module SMap = BatMap.Make(ProcName) type t = { - graph: cfg_t; - src: int; query: TS.query; rev_query: TS.reverse_query; mutable underapprox: K.t SMap.t; @@ -95,9 +95,7 @@ module Summarizer = let init (graph: cfg_t) (src: int) (tgt: int) (enable_summary: bool) : t = let q = mk_query graph src in let rq = TS.mk_reverse_query q tgt in - { graph = graph - ; src = src - ; query = q + { query = q ; rev_query = rq ; underapprox = SMap.empty ; overapprox = SMap.empty @@ -184,48 +182,108 @@ module Summarizer = end - type path_type = | OverApprox | UnderApprox -let log_labelled_weights s uu prefix weights = - List.iteri - (fun i f -> - match f with - | Call (u, v)-> - let p = - begin match uu with - | OverApprox -> Summarizer.over_proc_summary s (ProcName.make (u, v)) - | UnderApprox -> Summarizer.under_proc_summary s (ProcName.make (u, v)) - end in - logf "[labelled weight] %s(%i, call(%d,%d)): %a\n" prefix i u v K.pp p - | Weight w -> - logf "[labelled weight] %s(%i): %a\n" prefix i K.pp w) weights - let srk = Ctx.context module GPS = struct - (* vertex names module *) - module VN = struct - let to_vertex (v : int) : TS.vertex = v - let of_vertex (v : TS.vertex) : int = v - end - (* we need to augment the `TS` module to include some extra stuff. *) - module TS' = struct - include TS - let iter_succ_e (f: (TS.vertex * (TS.transition label) * TS.vertex) -> unit) (g: TS.t) (v: TS.vertex) = WG.iter_succ_e f g v - - let fold_succ_e (f : (TS.vertex * (TS.transition label) * TS.vertex) -> 'b -> 'b) (g: TS.t) (u: TS.vertex) (s: 'b) = - WG.fold_succ_e f g u s + module Graph = struct + type t = + { graph : cfg_t + ; call_summary : ProcName.t -> K.t + ; target_summary : int -> K.t } + + type vertex = TS.vertex + + type weight = K.t + + let edge_label g u v = WG.edge_weight g.graph u v + + let weight g u v = + match WG.edge_weight g.graph u v with + | Call (src, dst) -> + g.call_summary (src, dst) + | Weight w -> w + + let fold_succ f g u acc = + WG.U.fold_succ f (WG.forget_weights g.graph) u acc + + let iter_succ_e f g v = + fold_succ (fun w () -> f (v, weight g v w, w)) g v () + + let summary g src = g.target_summary src + + let compare_vertex = Stdlib.compare + let pp_vertex = Format.pp_print_int +end + +module Label = struct + type t = Ctx.t Syntax.formula + let top = Ctx.mk_true + let bottom = Ctx.mk_false + let meet f g = Ctx.mk_and [f; g] + let leq f g = + match Smt.entails Ctx.context f g with + | `Yes -> true + | _ -> false + let pp = Syntax.Formula.pp srk +end +module Transition = struct + type t = K.t + type label = Ctx.t Syntax.formula + type state = Ctx.t Interpretation.interpretation + let check pre trs post = + K.interpolate_or_concrete_model ((K.assume pre)::trs) post + + let is_deterministic = + let is_det tr = + not (K.contains_havoc tr) || K.is_deterministic tr + in + Memo.memo is_det + + let post_model = K.get_post_model + let pp = K.pp + let mul = K.mul + let assume = K.assume + let guard = K.guard +end + - let edge_weight g u v = WG.edge_weight g u v - end (* ART module *) - module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer) + (* module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer)*) + module ReachTree = ReachTree.ART(Graph)(Label)(Transition) (** summary-guided testing *) - module SGT = SummaryGuidedTesting(Ctx)(K)(TS')(Summarizer)(ReachTree) + module PT = struct + type t = + { summary : int -> K.t + ; art : ReachTree.t ref } + type node = ReachTree.node + type state = ReachTree.state + let expand pt node = ReachTree.expand pt.art node + let log_art pt = ReachTree.log_art pt.art + let is_err_loc pt node = + (ReachTree.maps_to pt.art node) = (ReachTree.get_err_loc pt.art) + let pp_state = Interpretation.pp + let pp_node pt formatter node = + Format.fprintf formatter "%a (%d)" + ReachTree.pp_node node + (ReachTree.maps_to pt.art node) + let check pt node = + let rec path_weight v = + match ReachTree.parent_weight pt.art v with + | Some (parent, w) -> K.mul (path_weight parent) w + | None -> K.one + in + let post = K.guard (pt.summary (ReachTree.maps_to pt.art node)) in + match K.interpolate_or_concrete_model [path_weight node] post with + | `Valid _ -> `Infeasible + | `Invalid m -> `Feasible m + | `Unknown -> `Unknown + end + module SGT = Sgt.SummaryGuidedTesting(PT) (* to print the reachability tree (+ worklist), or not *) (* RF 3/2/25: If you enable this flag, and even if *) @@ -233,9 +291,11 @@ module GPS = struct (* performance penalty. *) let print_tree = false - type global_context = { - interproc: Summarizer.t; - } + type global_context = + { g_graph : cfg_t + ; g_summarizer : Summarizer.t + ; g_errloc : int } + and mc_result = | Safe of K.t | Unsafe of K.t @@ -245,11 +305,8 @@ module GPS = struct (* intraprocedural context *) type intra_context = { id : ProcName.t; - ts : cfg_t; - recurse_level : int; - precondition : K.t; + cfg : Graph.t; pre_state : Ctx.t Syntax.formula; - equalities: value ValueHT.t; mutable art : ReachTree.t ref; mutable worklist : ReachTree.node DQ.t; mutable execlist : (ReachTree.node * Ctx.t Interpretation.interpretation) DQ.t; @@ -257,20 +314,39 @@ module GPS = struct } (* global context *) (** some helper functions that operate on the context *) + let get_summarizer ctx = !(!ctx.global_ctx).g_summarizer + + let log_labelled_weights ctx uu prefix weights = + List.iteri + (fun i f -> + match f with + | Call (u, v) -> + let p = + begin match uu with + | OverApprox -> Summarizer.over_proc_summary !ctx.g_summarizer (ProcName.make (u, v)) + | UnderApprox -> Summarizer.under_proc_summary !ctx.g_summarizer (ProcName.make (u, v)) + end in + logf "[labelled weight] %s(%i, call(%d,%d)): %a\n" prefix i u v K.pp p + | Weight w -> + logf "[labelled weight] %s(%i): %a\n" prefix i K.pp w) weights - let demote_precondition (precondition: K.t) = - let pre_guard, pre_transform = K.guard precondition, K.transform precondition in - let pre_state = ref @@ pre_guard in - let equalities = ValueHT.create 991 in - BatEnum.iter (fun (var, asgn) -> - let prophecy_var = V.prophesize var in - let prophecy_sym = V.symbol_of prophecy_var in - let prophecy_term = Syntax.mk_const srk prophecy_sym in - ValueHT.add equalities var prophecy_var; - pre_state := Syntax.mk_and srk [!pre_state; (Syntax.mk_eq srk prophecy_term asgn)]) pre_transform; - !pre_state, equalities - + (* Express a relational query as a precondition/postcondition pair over + prophecy variables *) + let demote_precondition (query : K.t) = + let preconditions, postconditions = + BatEnum.fold (fun (preconditions, postconditions) (var, asgn) -> + let prophecy_var = V.prophesize var in + let prophecy_sym = V.symbol_of prophecy_var in + let prophecy_term = Syntax.mk_const srk prophecy_sym in + let var_term = Syntax.mk_const srk (V.symbol_of var) in + (Syntax.mk_eq srk prophecy_term asgn::preconditions, + Syntax.mk_eq srk prophecy_term var_term::postconditions)) + ([K.guard query], []) + (K.transform query) + in + (Syntax.mk_and srk preconditions, Syntax.mk_and srk postconditions) + (* promote an arbitrary state formula (not necessarily the pre-state) to a transition formula. *) (* To do so, we substitute in fresh skolem symbols for all prophecy variables inside [f], and *) @@ -292,42 +368,33 @@ module GPS = struct K.construct (Syntax.substitute_const srk substitute (Syntax.mk_not srk f)) (ValueHT.to_seq sym_map |> List.of_seq) - let mk_intra_context (gctx: global_context ref) (id: ProcName.t) (ts: cfg_t) (recurse_level: int) (precondition: K.t) (entry: int) (err_loc: int) = - let pre_state, equalities = demote_precondition precondition in + let mk_intra_context (gctx: global_context ref) ((src,tgt): ProcName.t) (query: K.t) = + let pre_state, equalities = demote_precondition query in + let target_summary v = + K.mul + (Summarizer.path_weight_intra !gctx.g_summarizer v tgt) + (K.assume equalities) + in + let tgt' = !gctx.g_errloc in + let graph = + Graph.{ graph = WG.add_edge (!gctx.g_graph) tgt (Weight (K.assume equalities)) tgt' + ; call_summary = Summarizer.over_proc_summary !gctx.g_summarizer + ; target_summary = target_summary } + in ref { - id = id; - ts = ts; - recurse_level = recurse_level; - precondition = precondition; + id = (src,tgt'); + cfg = graph; pre_state = pre_state; - equalities = equalities; worklist = DQ.empty; execlist = DQ.empty; - art = ReachTree.make ts entry err_loc !gctx.interproc; + art = ReachTree.make graph src tgt'; global_ctx = gctx; } - and mk_mc_context (global_cfg: cfg_t) (global_src: int) (err_loc: int) enable_summary = - ref { - interproc = Summarizer.init global_cfg global_src err_loc enable_summary; - } + (** place an element in front of the deque (worklist) *) let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i - let get_summarizer intra_ctx = - !(!intra_ctx.global_ctx).interproc - - let make_equalities (ctx: intra_context ref) = - ValueHT.fold (fun k v acc -> - let s = V.symbol_of k |> Syntax.mk_const srk in - let s' = V.symbol_of v |> Syntax.mk_const srk in - Syntax.mk_eq srk s s' :: acc) !ctx.equalities [Syntax.mk_true srk] - |> Syntax.mk_and srk - - let oracle ctx u v = - if !ctx.recurse_level = 0 then Summarizer.path_weight_inter (get_summarizer ctx) u - else Summarizer.path_weight_intra (get_summarizer ctx) u v - let rec art_cfg_path_pair (ctx: intra_context ref) (p: ReachTree.node list) = match p with | u :: v :: t -> @@ -357,23 +424,23 @@ module GPS = struct (* CFG path condition from art.src -> art.v *) let path_condition (ctx: intra_context ref) condition_type (v: ReachTree.node) = let art = !ctx.art in - let summarizer = get_summarizer ctx in - let cfg = !ctx.ts in - let art_nodes = ReachTree.tree_path art v in + let art_nodes = ReachTree.tree_path art v in + let ts = !ctx.cfg.Graph.graph in let cfg_nodes = List.map (fun x -> ReachTree.maps_to art x) art_nodes in let rec to_weights l : K.t label list = match l with | a :: b :: t -> - WG.edge_weight cfg a b :: (to_weights (b :: t)) + WG.edge_weight ts a b :: (to_weights (b :: t)) | _ -> [] - in + in + let summ = get_summarizer ctx in let pathcond = List.map (fun (weight: K.t label) -> match weight with | Call (src, dst) -> begin match condition_type with - | OverApprox -> Summarizer.over_proc_summary summarizer (ProcName.make (src, dst)) + | OverApprox -> Summarizer.over_proc_summary summ (ProcName.make (src, dst)) | UnderApprox -> - let under = Summarizer.under_proc_summary summarizer (ProcName.make (src, dst)) in + let under = Summarizer.under_proc_summary summ (ProcName.make (src, dst)) in log_weights "underapproximate summary" [under]; print_vocabulary under; under @@ -383,18 +450,10 @@ module GPS = struct let l = (K.assume !ctx.pre_state) :: pathcond in log_weights "path conditions " l; l - let mk_post (ctx: intra_context ref) (v: ReachTree.node) (sink: TS.vertex) = - let art = !ctx.art in - let post_path_summary = oracle ctx (ReachTree.maps_to art v) sink in - let equalities = make_equalities ctx |> K.assume in - log_weights "\npost_path_summary: " [post_path_summary]; - log_weights "\nequalities: " [equalities]; - logf "\n"; - K.guard (K.mul post_path_summary equalities) - (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) - let interpolate_or_get_model (ctx: intra_context ref) (src : ReachTree.node) (sink: TS.vertex) = - let suffix = mk_post ctx src sink |> Syntax.mk_not srk in + let interpolate_or_get_model (ctx: intra_context ref) (src : ReachTree.node) = + let src_v = ReachTree.maps_to !ctx.art src in + let suffix = K.guard (Graph.summary !ctx.cfg src_v) |> Syntax.mk_not srk in let prefix = path_condition ctx OverApprox src in log_weights "\nprefix " prefix; log_formulas "\nsuffix " [suffix]; @@ -414,7 +473,7 @@ module GPS = struct in `Failure (m, path_condition) in let art = !ctx.art in let path = ReachTree.tree_path art v in - match interpolate_or_get_model ctx v @@ ReachTree.get_err_loc art with + match interpolate_or_get_model ctx v with `Invalid v_model -> logf "Unable to refine but got model\n"; (* v is no longer a frontier node. *) @@ -437,17 +496,13 @@ module GPS = struct logf " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); !ctx.execlist <- w; if (ReachTree.maps_to !ctx.art u) = (ReachTree.get_err_loc !ctx.art) then begin - logf " *** found potential path-to-error, checking if prophesized pre-condition is sat...\n"; - begin match Smt.is_sat srk (make_equalities ctx) with - | `Sat -> + logf " *** found potential path-to-error, checking if prophesized pre-condition is sat...\n"; logf " *** SAT, done\n"; `ErrorReached u - | _ -> !ctx.worklist <- worklist_push u !ctx.worklist; `Continue - end end else begin logf "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); log_model "" u_model; - let new_concolic_nodes, new_frontier_nodes = ReachTree.expand !ctx.recurse_level !ctx.art u u_model in + let new_concolic_nodes, new_frontier_nodes = ReachTree.expand !ctx.art u u_model in List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; List.iter (fun frontier_node -> !ctx.worklist <- worklist_push frontier_node !ctx.worklist) new_frontier_nodes; `Continue @@ -532,7 +587,8 @@ module GPS = struct logf "\nlength of left path: %d" (List.length left); logf "\nlength of right path: %d" (List.length right); logf "\nPrinting left path... \n"; - log_labelled_weights (get_summarizer ctx) UnderApprox "left path - " left; + + log_labelled_weights !ctx.global_ctx UnderApprox "left path - " left; logf "error: handle_path_to_error: cannot project path condition" ; `Safe in let handle_left_case caller_id = @@ -549,28 +605,29 @@ module GPS = struct | _, `Right, a :: right' -> handle_path_to_error ctx (curr :: left) a right' dir err_leaf end | (u, (Call (src, dst)), _) -> - let prefix = path_condition ctx UnderApprox u |> seq in + let prefix = path_condition ctx UnderApprox u |> seq in + let summ = get_summarizer ctx in let suffix = List.map (fun (_, ew, _) -> match ew with | Weight w -> w - | Call (s, t) -> Summarizer.over_proc_summary (get_summarizer ctx) (ProcName.make (s, t))) + | Call (s, t) -> Summarizer.over_proc_summary summ (ProcName.make (s, t))) right |> seq in - let summary = Summarizer.over_proc_summary (get_summarizer ctx) (ProcName.make (src, dst)) in + let summary = Summarizer.over_proc_summary summ (ProcName.make (src, dst)) in begin match K.contextualize prefix summary suffix with | `Sat query -> let answer = - mk_intra_context (!ctx.global_ctx) (ProcName.make (src, dst)) !ctx.ts (!ctx.recurse_level + 1) query src dst + mk_intra_context (!ctx.global_ctx) (ProcName.make (src, dst)) query |> intraproc_check in begin match answer with - | Safe r -> - Summarizer.refine_over_summary (get_summarizer ctx) (ProcName.make (src, dst)) r; + | Safe r -> + Summarizer.refine_over_summary summ (ProcName.make (src, dst)) r; handle_path_to_error ctx left curr right dir err_leaf | Unsafe trs -> begin match trs |> K.project_mbp (V.is_global) with - | `Sat tr -> - Summarizer.refine_under_summary (get_summarizer ctx) (ProcName.make (src, dst)) tr; + | `Sat tr -> + Summarizer.refine_under_summary summ (ProcName.make (src, dst)) tr; begin match right with | a :: right' -> handle_path_to_error ctx (curr::left) a right' `Right err_leaf @@ -591,7 +648,6 @@ module GPS = struct and intraproc_check (ctx: intra_context ref) : mc_result = - logf " *********************************************** recurse_level: %d\n" !ctx.recurse_level; let continue = ref true in let state = ref `Continue in !ctx.worklist <- worklist_push (ReachTree.root) !ctx.worklist; @@ -605,7 +661,7 @@ module GPS = struct let has_calls, path_to_w = ReachTree.tree_path !ctx.art w |> art_cfg_path_pair ctx - |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight !ctx.ts u_vtx v_vtx, v)) + |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight !ctx.cfg.Graph.graph u_vtx v_vtx, v)) |> List.fold_left (fun (has_call, l) (u, w, v) -> match w with | Call _ -> (true, (u, w, v) :: l) @@ -648,17 +704,44 @@ module GPS = struct | `Concretized cond -> Unsafe (cond) - let execute (ts : cfg_t) (entry : int) (err_loc : int) (enable_summary:bool) : mc_result = - (** - * Set up data structures used by the algorithm: worklist, - * vtxcnt (keeps track of largest unused vertex number in tree), - * ptt is a pointer to the reachability tree. - *) - let global_context = mk_mc_context ts entry err_loc enable_summary in + let execute (ts : cfg_t) (entry : int) (err_loc : int) (enable_summary:bool) : mc_result = + let gctx = + ref { g_graph = ts + ; g_summarizer = Summarizer.init ts entry err_loc enable_summary + ; g_errloc = err_loc } + in + (* interproc_graph represents the language of interprocedural paths from + entry to err_loc (including interprocedural paths that make calls that + never return---i.e., the ``unbalanced left'' language of + interprocedurally-valid paths) *) + let interproc_graph = + WG.fold_edges (fun (u, w, _) interproc_graph -> + match w with + | Call (en, _) -> + WG.add_edge interproc_graph u (Weight K.one) en + | Weight _ -> interproc_graph) + ts + ts + in + let graph = + Graph.{ graph = interproc_graph + ; call_summary = Summarizer.over_proc_summary !gctx.g_summarizer + ; target_summary = Summarizer.path_weight_inter !gctx.g_summarizer } + in + let main_context = + ref { + id = (entry,err_loc); + cfg = graph; + pre_state = Ctx.mk_true; + worklist = DQ.empty; + execlist = DQ.empty; + art = ReachTree.make graph entry err_loc; + global_ctx = gctx; + } + in logf "executing GPS: start\n"; - let main_context = mk_intra_context global_context (entry, err_loc) ts 0 K.one entry err_loc in intraproc_check main_context - end +end module BM = BatMap.Make(Int) @@ -687,6 +770,7 @@ let analyze_mc enable_gas enable_summary file = end | _ -> assert false + let analyze_sgt enable_gas enable_summary file = let open Srk.Iteration in populate_offset_table file; @@ -702,7 +786,17 @@ let analyze_sgt enable_gas enable_summary file = logf "\nentry: %d\n" entry; Printf.printf "testing reachability of location %d\n" err_loc ; Printf.printf "------------------------------\n"; - begin match GPS.SGT.execute ts entry err_loc (mk_true ()) enable_summary with + let summ = Summarizer.init ts entry err_loc enable_summary in + let graph = + GPS.Graph.{ graph = ts + ; call_summary = (fun _ -> failwith "SGT: procedure call") + ; target_summary = Summarizer.path_weight_inter summ } + in + let pt = + GPS.PT.{ summary = Summarizer.path_weight_inter summ + ; art = GPS.ReachTree.make graph entry err_loc } + in + begin match GPS.SGT.execute pt GPS.ReachTree.root with | `Safe -> Printf.printf " proven safe\n"; | `Unsafe -> Printf.printf " proven unsafe\n" | `Error s -> Printf.printf "ERR: %s\n" s @@ -710,7 +804,7 @@ let analyze_sgt enable_gas enable_summary file = Printf.printf "------------------------------\n" end | _ -> assert false - + (** dump simplified CFG before doing model checking / CRA / concolic execution *) let dump_cfg simplify instrument file = @@ -735,14 +829,16 @@ let _ = ("-gps-nosum", analyze_mc false false, "GPS with neither gas nor CRA-generated summary"); CmdLine.register_pass ("-gps-nosum-nogas", analyze_mc true false, "GPS with gas but without CRA-generated summary (i.e., refutation-complete)"); + CmdLine.register_pass - ("-sgt", analyze_mc false true, "Summary-guided testing, without gas-instrumentation"); + ("-sgt", analyze_sgt false true, "Summary-guided testing, without gas-instrumentation"); CmdLine.register_pass ("-sgt-gas", analyze_sgt true true, "Summary-guided testing, with gas"); CmdLine.register_pass ("-sgt-nosum", analyze_sgt false false, "Summary-guided testing without CRA-generated summary"); CmdLine.register_pass ("-sgt-nosum-nogas", analyze_sgt true false, "Summary-guided testing with gas but without CRA-generated summary"); + CmdLine.register_pass ("-dump-unsimplified-cfg", dump_cfg false false, "dump unsimplified CFG"); CmdLine.register_pass diff --git a/duet/reachTree.ml b/duet/reachTree.ml index f18bd6b6..e6a820fa 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -2,7 +2,6 @@ open Srk open BatPervasives -open Syntax module RG = Interproc.RG module WG = Srk.WeightedGraph module G = RG.G @@ -21,109 +20,84 @@ end) type equery = OverApprox | UnderApprox module ART - (Ctx : Srk.Syntax.Context) - (K : sig - type t - - val guard : t -> Ctx.t formula - val assume : Ctx.t formula -> t - val mul : t -> t -> t - val contains_havoc : t -> bool - val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula - -> [`Valid of Ctx.t Syntax.formula list - | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] - - val get_post_model : - Ctx.t Interpretation.interpretation -> - t -> - Ctx.t Interpretation.interpretation option - val is_deterministic : t -> bool - end) - (TS : sig - type vertex - type transition = K.t - type t - - val iter_succ_e : - (vertex * transition TransitionSystem.label * vertex -> unit) -> - t -> - vertex -> - unit - - val edge_weight : t -> vertex -> vertex -> K.t Srk.TransitionSystem.label - - val fold_succ_e : - (vertex * K.t Srk.TransitionSystem.label * vertex -> 'b -> 'b) -> - t -> - vertex -> - 'b -> - 'b - end) - (PN : sig - type t - - val make : TS.vertex * TS.vertex -> t - - (* lexicographic comparison using Stdlib.compare *) - val compare : t -> t -> int - end) - (VN : sig - val to_vertex : int -> TS.vertex - val of_vertex : TS.vertex -> int - end) - (Summarizer : sig - type t - val over_proc_summary : t -> PN.t -> K.t - val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t - val path_weight_inter : t -> TS.vertex -> K.t - end) = + (G : sig + type t + type vertex + type weight + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val iter_succ_e : (vertex * weight * vertex -> unit) -> t -> vertex -> unit + val weight : t -> vertex -> vertex -> weight + val summary : t -> vertex -> weight + val compare_vertex : vertex -> vertex -> int + val pp_vertex : Format.formatter -> vertex -> unit + end) + (L : sig + type t + val top : t + val meet : t -> t -> t + val leq : t -> t -> bool + val pp : Format.formatter -> t -> unit + end) + (T : sig + type t + type label + type state + val check : label -> t list -> label -> [ `Valid of label list + | `Invalid of state + | `Unknown ] + val post_model : state -> t -> state option + val is_deterministic : t -> bool + val mul : t -> t -> t + val assume : label -> t + val guard : t -> label + end with type t = G.weight + and type label = L.t) = struct (* type for a tree node *) type node = int + type state = T.state + type weight = T.t - module ProcMap = BatMap.Make (PN) module IntMap = BatMap.Make (Int) + module VertexMap = BatMap.Make(struct + type t = G.vertex + let compare = G.compare_vertex + end) module StringMap = BatMap.Make (String) module ISet = BatSet.Make (Int) module DQ = BatDeque module ARR = Batteries.DynArray - type state_formula = Ctx.t Syntax.formula - exception Mexception of string - let mk_true () = Syntax.mk_true Ctx.context - let log_formulas prefix formulas = List.iteri (fun i f -> logf "[formula] %s(%i): %a\n" prefix i - (Syntax.pp_expr Ctx.context) - f) + L.pp f) formulas type t = { - graph : TS.t; - entry : TS.vertex; - err_loc : TS.vertex; + graph : G.t; + entry : G.vertex; + err_loc : G.vertex; mutable vtxcnt : int; - mutable cfg_vertex : TS.vertex IntMap.t; + mutable cfg_vertex : G.vertex IntMap.t; mutable parents : int IntMap.t; - mutable labels : Ctx.t Syntax.formula IntMap.t; + mutable labels : L.t IntMap.t; mutable covers : int IntMap.t; mutable children : int list IntMap.t; (* also maintain reverse map for each y, storing (x, y) that are in cover. *) (* i.e. reverse_covers[y] returns all x such that (x,y) is in the cover. *) mutable reverse_covers : ISet.t IntMap.t; (* precedent_nodes[v] stores all tree nodes mapping to CFG vertex v. Used in mc_close. *) - mutable precedent_nodes : ISet.t IntMap.t; - interproc : Summarizer.t; + mutable precedent_nodes : ISet.t VertexMap.t; mutable leaves : ISet.t; } let root = 0 - let make (g : TS.t) (entry : TS.vertex) (err_loc : TS.vertex) interproc = + let make (g : G.t) (entry : G.vertex) (err_loc : G.vertex) = ref { graph = g; @@ -132,16 +106,14 @@ struct vtxcnt = 1; cfg_vertex = IntMap.add 0 entry IntMap.empty; parents = IntMap.add 0 (-1) IntMap.empty; - labels = IntMap.add 0 (mk_true ()) IntMap.empty; + labels = IntMap.add 0 L.top IntMap.empty; children = IntMap.add 0 [] IntMap.empty; covers = IntMap.empty; (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) reverse_covers = IntMap.empty; (* for each v, store the v's that cover it: i.e. cover[v] *) - precedent_nodes = IntMap.empty; + precedent_nodes = VertexMap.empty; leaves = ISet.empty; - interproc; } - let get_summarizer (art : t ref) = !art.interproc let get_err_loc (art : t ref) = !art.err_loc let get_entry (art: t ref) = !art.entry @@ -149,8 +121,8 @@ struct let print_tree (art : t ref) (indent : string) (v : node) = let rec print_tree_ (art : t ref) indent v = logf "%s|" indent; - logf "%s+-%d(%d)" indent v - (IntMap.find v !art.cfg_vertex |> VN.of_vertex); + logf "%s+-%d(%a)" indent v + G.pp_vertex (IntMap.find v !art.cfg_vertex); List.iter (fun x -> print_tree_ art (indent ^ " ") x) (IntMap.find_default [] v !art.children) @@ -160,12 +132,20 @@ struct (* [parent t i] gets parent of node i in tree t. *) let parent (art : t ref) (i : node) : node = IntMap.find i !art.parents + (* [t %-> i]: get CFG vertex mapped by node i in tree t. *) - let maps_to (art : t ref) (i : node) : TS.vertex = + let maps_to (art : t ref) (i : node) : G.vertex = try IntMap.find i !art.cfg_vertex with _ -> failwith @@ Printf.sprintf "maps_to: not found tree node %d\n" i + let parent_weight (art : t ref) (i : node) = + let parent = IntMap.find i !art.parents in + if parent < 0 then + None + else + Some (parent, G.weight !art.graph (maps_to art parent) (maps_to art i)) + (* [tree_path t u] returns list of tree nodes that form the corrsp. tree path from root of t to tree node u *) let tree_path (art : t ref) ?(src=root) (u : node) : node list = let rec tree_path_rev art u = @@ -193,10 +173,10 @@ struct List.length chs == 0 (* [label t v] returns the node label of tree node v in tree t. *) - let label (art : t ref) (v : node) : state_formula = IntMap.find v !art.labels + let label (art : t ref) (v : node) : L.t = IntMap.find v !art.labels (* (replaces) sets a label at v *) - let set_label (art : t ref) (v : node) (lbl : state_formula) = + let set_label (art : t ref) (v : node) (lbl : L.t) = !art.labels <- IntMap.add v lbl !art.labels (* [get_precedent_nodes t v] retrieves a sequence of precedent nodes of tree node vin preorder in tree t. *) @@ -204,8 +184,7 @@ struct let get_precedent_nodes (art : t ref) (v : node) = let cfg_vertex = maps_to art v in let precedents_set = - IntMap.find_default ISet.empty (VN.of_vertex cfg_vertex) - !art.precedent_nodes + VertexMap.find_default ISet.empty cfg_vertex !art.precedent_nodes in ISet.elements precedents_set @@ -223,7 +202,7 @@ struct !art.leaves <- ISet.remove x !art.leaves (* Add new tree leaf mapping to CFG vertex v and with parent tree node p. *) - let add_tree_vertex (art : t ref) ?(label = mk_true ()) (v : TS.vertex) + let add_tree_vertex (art : t ref) ?(label = L.top) (v : G.vertex) (p : node) = (* sequentially add v to the lists, indexed by !vtxcnt *) let new_vertex = get_id art in @@ -238,30 +217,15 @@ struct IntMap.add p (new_vertex :: IntMap.find p !art.children) !art.children; (* Add v to precedent_nodes. *) let precedent_nodes = - IntMap.find_default ISet.empty (VN.of_vertex v) !art.precedent_nodes + VertexMap.find_default ISet.empty v !art.precedent_nodes |> ISet.add new_vertex in !art.precedent_nodes <- - IntMap.add (VN.of_vertex v) precedent_nodes !art.precedent_nodes; + VertexMap.add v precedent_nodes !art.precedent_nodes; update_leaf art p; update_leaf art new_vertex; new_vertex - (* this is a helper primitive *) - let is_deterministic = - let is_det tr = - not (K.contains_havoc tr) || K.is_deterministic tr - in - Memo.memo is_det - - - let get_weight art weight = - match weight with - | TransitionSystem.Weight w -> w - | TransitionSystem.Call (u, v) -> - let proc = (VN.to_vertex u, VN.to_vertex v) |> PN.make in - Summarizer.over_proc_summary !art.interproc proc - (** expand: for every out-neighbor y of v, first try deriving a post-state model of v-> y, if successful, put it on the concolic execution worklist. Otherwise, it is a frontier node, and put it on the @@ -274,67 +238,27 @@ struct is the identity transition. More specifically, for each out-neighbor u of G(v), we first test if m /\ tr is SAT, if so, then this out-neighbor is non-frontier. Otherwise, this out neighbor is a frontier. *) - let guarded_expand (art: t ref) (v: node) (m: Ctx.t Interpretation.interpretation) (tr: K.t) = + let expand (art: t ref) (v: node) (m: T.state) = let vg = maps_to art v in let new_concolic_nodes, new_frontier_nodes = (ref [], ref []) in (* visit out-neighbors of v *) - TS.iter_succ_e + G.iter_succ_e (fun (_, weight, y) -> - let weight = - let w' = get_weight art weight in - if is_deterministic w' then w' else - K.mul w' (K.assume @@ K.guard (tr)) - in - match K.get_post_model m weight with - | Some y_model -> - let new_vtx = add_tree_vertex art y v in - new_concolic_nodes := (new_vtx, y_model) :: !new_concolic_nodes - | None -> - let new_node = add_tree_vertex art y v in - new_frontier_nodes := new_node :: !new_frontier_nodes) - !art.graph vg; - (* make it FIFO *) - (List.rev !new_concolic_nodes, List.rev !new_frontier_nodes) - - - (* returns (new nodes on concolic worklist, new nodes on frontier worklist) *) - (* a newly expanded node (leaf) is deemed a _concolic node_ if it can inherit - a post-state model from its parent by means of symbol substitution. It is deemed - a _frontier node_ if concrete execution cannot reach it from its parent node. A - frontier node does not have a model associated with it and is in need of refinement. *) - let expand recurse_level (art : t ref) (v : node) (m: Ctx.t Interpretation.interpretation) = - let oracle s src tgt = - if recurse_level = 0 then Summarizer.path_weight_inter s src - else Summarizer.path_weight_intra s src tgt - in - let vg = maps_to art v in - let new_concolic_nodes, new_frontier_nodes = (ref [], ref []) in - (* visit out neighbors of v *) - TS.iter_succ_e - (fun (_, weight, y) -> let weight = - match weight with - | TransitionSystem.Weight w -> - if is_deterministic w then w - else - K.mul w - (K.assume - @@ K.guard (oracle !art.interproc y !art.err_loc)) - - | TransitionSystem.Call (u, v) -> - let proc = (VN.to_vertex u, VN.to_vertex v) |> PN.make in - Summarizer.over_proc_summary !art.interproc proc - in - match K.get_post_model m weight with + if T.is_deterministic weight then weight + else T.mul weight (T.assume @@ T.guard @@ G.summary !art.graph y) + in + match T.post_model m weight with | Some y_model -> - let new_vtx = add_tree_vertex art y v in - new_concolic_nodes := (new_vtx, y_model) :: !new_concolic_nodes + let new_vtx = add_tree_vertex art y v in + new_concolic_nodes := (new_vtx, y_model) :: !new_concolic_nodes | None -> - let new_node = add_tree_vertex art y v in - new_frontier_nodes := new_node :: !new_frontier_nodes) + let new_node = add_tree_vertex art y v in + new_frontier_nodes := new_node :: !new_frontier_nodes) !art.graph vg; (* make it FIFO *) (List.rev !new_concolic_nodes, List.rev !new_frontier_nodes) + (** maintenance of coverings *) @@ -346,12 +270,12 @@ struct let w_label = label art w in if maps_to art v <> maps_to art w then failwith - @@ Printf.sprintf "error: %d->%d but %d->%d\n" v - (maps_to art v |> VN.of_vertex) + @@ Format.asprintf "error: %d->%a but %d->%a\n" + v + G.pp_vertex (maps_to art v) w - (maps_to art w |> VN.of_vertex); - match Smt.entails Ctx.context v_label w_label with - | `Yes -> + G.pp_vertex (maps_to art w) + else if L.leq v_label w_label then begin logf " cover success (v=%d, w=%d). \n" v w; log_formulas " v label " [ v_label ]; log_formulas " w label " [ w_label ]; @@ -362,7 +286,7 @@ struct !art.reverse_covers <- IntMap.add w (ISet.add v reverse_covers_w) !art.reverse_covers; true - | `No | `Unknown -> false + end else false (* it returns (`true`, wl) iff covering succeeds at v and wl is a worklist of nodes to be refined. *) @@ -435,10 +359,10 @@ struct List.iter2 (fun u interpolant -> let u_label = label art u in - let u_label' = Syntax.mk_and Ctx.context [ u_label; interpolant ] in + let u_label' = L.meet u_label interpolant in log_formulas - (Printf.sprintf "[relabelling %d CFG vertex %d] to label: " u - (maps_to art u |> VN.of_vertex)) + (Format.asprintf "[relabelling %d CFG vertex %a] to label: " u + G.pp_vertex (maps_to art u)) [ u_label' ]; set_label art u u_label'; (* remove ( * -> u) in covering relation; we just refined label(u) so implications of form label(y)->label(u) @@ -453,8 +377,13 @@ struct (* test if label(x) --> new label(u)*) let x_label = label art x in let u_label = label art u in - match Smt.entails Ctx.context x_label u_label with - | `No | `Unknown -> + if L.leq x_label u_label then + (logf + " refine: cover (x %d-> u %d) still holds\n" x u; + log_formulas " x label: " [ x_label ]; + log_formulas " u label: " [ u_label ]; + ISet.add x coverers (* unchanged. *)) + else begin (* remove (x, u) from covering. *) logf " refine: removing cover (%d->%d)\n" x u; @@ -471,13 +400,9 @@ struct worklist := x_leaf :: !worklist) x_leaves; l - | `Yes -> - logf - " refine: cover (x %d-> u %d) still holds\n" x u; - log_formulas " x label: " [ x_label ]; - log_formulas " u label: " [ u_label ]; - ISet.add x coverers (* unchanged. *)) - l ISet.empty + end) + l + ISet.empty in !art.reverse_covers <- IntMap.add u u_coverers !art.reverse_covers) path @@ -498,20 +423,14 @@ struct logf "force_cover(%d, %d)\n" v w; (* let v_label = label art v in *) let w_label = label art w in - let artpath = tree_path art ~src:w v in + let artpath = tree_path art ~src:w v in let path_weights = artpath |> glue - |> List.map (fun (x, y) -> - match TS.edge_weight !art.graph (maps_to art x) (maps_to art y) with - | TransitionSystem.Call (src, dst) -> - Summarizer.over_proc_summary - !art.interproc - (PN.make (VN.to_vertex src, VN.to_vertex dst)) - | TransitionSystem.Weight wht -> wht) + |> List.map (fun (x, y) -> + G.weight !art.graph (maps_to art x) (maps_to art y)) in - let w_path_weights = (K.assume w_label) :: path_weights in - match K.interpolate_or_concrete_model w_path_weights w_label with + match T.check w_label path_weights w_label with | `Valid itps -> let new_frontiers = refine art (List.tl artpath) (List.tl itps) in if cover art v w then @@ -559,12 +478,13 @@ struct match IntMap.find_opt v !t.covers with | None -> logf "!!! found uncovered leaf: %d\n" v; - TS.fold_succ_e - (fun (x, _, y) _ -> + G.fold_succ + (fun y _ -> logf - " ERROR ERROR ERROR: mapped cfg vertex %d has \ - out-neighbor %d\n" - (VN.of_vertex x) (VN.of_vertex y); + " ERROR ERROR ERROR: mapped cfg vertex %a has \ + out-neighbor %a\n" + G.pp_vertex (maps_to t v) + G.pp_vertex y; false) !t.graph (maps_to t v) true | Some _ -> true) @@ -622,9 +542,9 @@ struct (** pretty-printing functionalities *) let tree_printer_get_name (art : t ref) i = match IntMap.find_opt i !art.covers with - | None -> Printf.sprintf "%d(%d)" i (maps_to art i |> VN.of_vertex) + | None -> Format.asprintf "%d(%a)" i G.pp_vertex (maps_to art i) | Some j -> - Printf.sprintf "[%d(%d)]->%d" i (maps_to art i |> VN.of_vertex) j + Format.asprintf "[%d(%a)]->%d" i G.pp_vertex (maps_to art i) j let log_art (art : t ref) = logf " +----------------- ART ----------------+\n"; @@ -640,4 +560,6 @@ struct logf " node: visit %d\n" u let of_node u = u + + let pp_node = Format.pp_print_int end diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 2acca507..a68e640d 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -3,139 +3,74 @@ module Syntax = Srk.Syntax module Interpretation = Srk.Interpretation type equery = OverApprox | UnderApprox -module ART : - functor - (Ctx: Srk.Syntax.Context) - (** transition formula algebra *) - (K : sig - type t - type var - val pp : Format.formatter -> t -> unit - val guard : t -> Ctx.t Srk.Syntax.formula - val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t - val mem_transform : var -> t -> bool - val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term - val assume : Ctx.t Srk.Syntax.formula -> t - val mul : t -> t -> t - val add : t -> t -> t - val conjunct : t -> t -> t - val zero : t - val one : t - val star : t -> t - val exists : (var -> bool) -> t -> t - val contains_havoc : t -> bool - val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] - val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula - -> [`Valid of Ctx.t Syntax.formula list - | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] - - val get_post_model : - Ctx.t Srk.Interpretation.interpretation -> - t -> Ctx.t Srk.Interpretation.interpretation option - val is_deterministic : t -> bool - end) - (** transition system with edge weights from K *) - (TS : sig - type vertex - type transition = K.t - type t - type query - type reverse_query - val empty : t - val path_weight : query -> vertex -> transition - val call_weight : query -> vertex * vertex -> transition - val mk_reverse_query : query -> vertex -> reverse_query - val exit_summary : reverse_query -> vertex -> vertex -> K.t - val target_summary : reverse_query -> vertex -> K.t - - val set_summary : query -> vertex * vertex -> transition -> unit - val get_summary : query -> vertex * vertex -> transition - val omega_path_weight : - query -> (transition, 'b) Srk.Pathexpr.omega_algebra -> 'b - val forward_invariants_ivl : - t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list - val forward_invariants_ivl_pa : - Ctx.t Srk.Syntax.formula list -> - t -> vertex -> (vertex * Ctx.t Srk.Syntax.formula) list - val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t - val iter_succ_e : - ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit - val edge_weight : - t -> vertex -> vertex -> K.t Srk.TransitionSystem.label - - val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b - end) - (** a module giving a procedure name type. Procedures are implicitly represented by pairs of CFG vertices in Duet. - Here we give them a type. *) - (PN : sig - type t - val make : TS.vertex * TS.vertex -> t - val string_of : t -> string - val of_string : string -> t - val compare : t -> t -> int - end) - (** a module giving a vertex name type. Vertices are integers in Duet, here we give them a type. *) - (VN : sig - val to_vertex : int -> TS.vertex - val of_vertex : TS.vertex -> int - end) - (** a module giving an interface for accessing over/under-approximate procedure summaries. *) - (Summarizer : sig - type t - (** [init g s] returns a Summarizer.t type for a given transition system, source vertex pair (g, s). *) - val init : TS.t -> TS.vertex -> TS.vertex -> bool -> t - (** [over_proc_summary s n] returns the over-approximate procedure summary for procedure `n`. *) - val over_proc_summary : t -> PN.t -> K.t - (** [under_proc_summary s n] returns the under-approximate procedure summary (initially `false`) for procedure `n`. *) - val under_proc_summary : t -> PN.t -> K.t - (** [set_over_proc_summary s n w] sets the over-approximate procedure summary to be `w` at procedure `n`. *) - val set_over_proc_summary : t -> PN.t -> K.t -> unit - (** [set_under_proc_summary s n w] sets the under-approximate procedure summary to be `w` at procedure `n`. *) - val set_under_proc_summary : t -> PN.t -> K.t -> unit - (** [refine s n pre post] refines the over-approximate procedure summary at `n` by conjuncting on (pre) /\ (post') *) - val refine_over_summary : t -> PN.t -> K.t -> unit - (** [refine_under s n tr] refines the under-approximate procedure summary at `n` by adding `tr` as a disjunct. *) - val refine_under_summary : t -> PN.t -> K.t -> unit - (** [path_weight_intra s u v] gives the weighted path summary between (u, v) on an intraprocedural CFG *) - val path_weight_intra : t -> TS.vertex -> TS.vertex -> K.t - (** [path_weight_inter s u v] gives the inter-procedural path weight between (u, v) *) - val path_weight_inter : t -> TS.vertex -> K.t - end) - -> - sig - type node - type t - type state_formula = Ctx.t Srk.Syntax.formula - exception Mexception of string - val make : TS.t -> TS.vertex -> TS.vertex -> Summarizer.t -> t ref - val get_entry : t ref -> TS.vertex - val get_err_loc : t ref -> TS.vertex - val get_summarizer : t ref -> Summarizer.t - val print_tree : t ref -> string -> node -> unit - val parent : t ref -> node -> node - val maps_to : t ref -> node -> TS.vertex - val tree_path : t ref -> ?src:node -> node -> node list - val children : t ref -> node -> node list - val descendants : t ref -> node -> node list - val leaves : t ref -> node list - val is_leaf : t ref -> node -> bool - val label : t ref -> node -> state_formula - val set_label : t ref -> node -> state_formula -> unit - val get_precedent_nodes : t ref -> node -> node list - val get_id : t ref -> node - val add_tree_vertex : - t ref -> ?label:Ctx.t Srk.Syntax.formula -> TS.vertex -> int -> node - val expand : - int -> t ref -> node -> Ctx.t Interpretation.interpretation -> (node * Ctx.t Interpretation.interpretation) list * node list - val guarded_expand : t ref -> node -> Ctx.t Interpretation.interpretation -> K.t -> (node * Ctx.t Interpretation.interpretation) list * node list - val cover : t ref -> node -> node -> bool - val close : t ref -> node -> (bool * node list) - val force_cover : t ref -> node -> node -> (bool * node list) - val lclose : t ref -> node -> (bool * node list) - val is_covered : t ref -> node -> bool - val refine: t ref -> node list -> Ctx.t Syntax.formula list -> node list - val log_art : t ref -> unit - val log_node : node -> unit - val of_node : node -> int - val root : node - end +module ART + (G : sig + type t + type vertex + type weight + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val iter_succ_e : (vertex * weight * vertex -> unit) -> t -> vertex -> unit + val weight : t -> vertex -> vertex -> weight + val summary : t -> vertex -> weight + val compare_vertex : vertex -> vertex -> int + val pp_vertex : Format.formatter -> vertex -> unit + end) + (L : sig + type t + val top : t + val bottom : t + val meet : t -> t -> t + val leq : t -> t -> bool + val pp : Format.formatter -> t -> unit + end) + (T : sig + type t + type label + type state + val check : label -> t list -> label -> [ `Valid of label list + | `Invalid of state + | `Unknown ] + val post_model : state -> t -> state option + val is_deterministic : t -> bool + val mul : t -> t -> t + val assume : label -> t + val guard : t -> label + end with type t = G.weight + and type label = L.t) : sig + type node + type t + type state = T.state + type weight = T.t + exception Mexception of string + val make : G.t -> G.vertex -> G.vertex -> t ref + val get_entry : t ref -> G.vertex + val get_err_loc : t ref -> G.vertex + val print_tree : t ref -> string -> node -> unit + val parent : t ref -> node -> node + val parent_weight : t ref -> node -> (node * weight) option + val maps_to : t ref -> node -> G.vertex + val tree_path : t ref -> ?src:node -> node -> node list + val children : t ref -> node -> node list + val descendants : t ref -> node -> node list + val leaves : t ref -> node list + val is_leaf : t ref -> node -> bool + val label : t ref -> node -> L.t + val set_label : t ref -> node -> L.t -> unit + val get_precedent_nodes : t ref -> node -> node list + val get_id : t ref -> node + val add_tree_vertex : + t ref -> ?label:L.t -> G.vertex -> int -> node + val expand : + t ref -> node -> T.state -> (node * T.state) list * node list + val cover : t ref -> node -> node -> bool + val close : t ref -> node -> (bool * node list) + val force_cover : t ref -> node -> node -> (bool * node list) + val lclose : t ref -> node -> (bool * node list) + val is_covered : t ref -> node -> bool + val refine: t ref -> node list -> L.t list -> node list + val log_art : t ref -> unit + val log_node : node -> unit + val of_node : node -> int + val root : node + val pp_node : Format.formatter -> node -> unit +end diff --git a/duet/sgt.ml b/duet/sgt.ml index c4083c11..2bd27360 100644 --- a/duet/sgt.ml +++ b/duet/sgt.ml @@ -15,83 +15,30 @@ module ARR = Batteries.DynArray module SummaryGuidedTesting -(Ctx: Srk.Syntax.Context) -(** transition formula algebra *) -(K : sig - type t - val pp : Format.formatter -> t -> unit - val guard : t -> Ctx.t Srk.Syntax.formula - val assume : Ctx.t Srk.Syntax.formula -> t - val interpolate_or_concrete_model : t list -> Ctx.t Srk.Syntax.formula - -> [`Valid of Ctx.t Srk.Syntax.formula list - | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] - end) -(TS : sig - type vertex = int - type t + (PathTree : sig + type node + type t + type state + val check : t -> node -> [ `Feasible of state | `Infeasible | `Unknown ] + val expand : t -> node -> state -> (node * state) list * node list + val log_art : t -> unit + val pp_node : t -> Format.formatter -> node -> unit + val pp_state : Format.formatter -> state -> unit + val is_err_loc : t -> node -> bool + end) = struct - val edge_weight : - t -> vertex -> vertex -> K.t Srk.TransitionSystem.label - end) -(Summarizer : sig - type t - (** [init g s] returns a Summarizer.t type for a given transition system, source vertex pair (g, s). *) - val init : TS.t -> TS.vertex -> TS.vertex -> bool -> t - (** [path_weight_inter s u v] gives the inter-procedural path weight between (u, v) *) - val path_weight_inter : t -> TS.vertex -> K.t -end) -( - PathTree : sig - type node - type t - exception Mexception of string - val make : TS.t -> TS.vertex -> TS.vertex -> Summarizer.t -> t ref - val get_err_loc : t ref -> TS.vertex - val maps_to : t ref -> node -> TS.vertex - val tree_path : t ref -> ?src:node -> node -> node list - val expand : - int -> t ref -> node -> Ctx.t Interpretation.interpretation -> (node * Ctx.t Interpretation.interpretation) list * node list - - val log_art : t ref -> unit - val of_node : node -> int - val root : node - end -) = struct - - module IntMap = BatMap.Make(Int) - module StringMap = BatMap.Make(String) - type cfg_t = TS.t - type idq_t = int BatDeque.t - type state_formula = Ctx.t Syntax.formula - exception Mexception of string - - let mk_true () = Syntax.mk_true Ctx.context - let mk_false () = Syntax.mk_false Ctx.context - let print_tree = false - let log_formulas prefix formulas = - List.iteri (fun i f -> logf "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr Ctx.context) f) formulas - - let log_weights prefix weights = - List.iteri (fun i f -> logf "[weight] %s(%i): %a\n" prefix i K.pp f) weights - - let log_model prefix model = - logf "[model] %s: %a\n" prefix Interpretation.pp model + logf "[model] %s: %a\n" prefix PathTree.pp_state model type context = { - ts : cfg_t; - entry : int; - error : int; - sum: Summarizer.t; - pre_state : Ctx.t Syntax.formula; mutable art : PathTree.t ref; (* list for frontier nodes *) mutable worklist : PathTree.node DQ.t; (* list for executor states *) - mutable execlist : (PathTree.node * Ctx.t Interpretation.interpretation) DQ.t; + mutable execlist : (PathTree.node * PathTree.state) DQ.t; } let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i @@ -102,15 +49,15 @@ end) match DQ.front (!ctx.execlist) with | Some ((u, u_model), w) -> if print_tree then - PathTree.log_art !ctx.art; - logf " visit %d (%d)\n" (PathTree.of_node u) (PathTree.maps_to !ctx.art u); + PathTree.log_art !(!ctx.art); + logf " visit %a\n" (PathTree.pp_node !(!ctx.art)) u; !ctx.execlist <- w; - if (PathTree.maps_to !ctx.art u) = (PathTree.get_err_loc !ctx.art) then + if PathTree.is_err_loc !(!ctx.art) u then `Unsafe u else begin - logf "model of %d (%d): \n" (PathTree.of_node u) (PathTree.maps_to !ctx.art u); + logf "model of %a: \n" (PathTree.pp_node !(!ctx.art)) u; log_model "" u_model; - let new_concolic_nodes, new_frontier_nodes = PathTree.expand 0 !ctx.art u u_model in + let new_concolic_nodes, new_frontier_nodes = PathTree.expand !(!ctx.art) u u_model in List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; List.iter (fun frontier_node -> !ctx.worklist <- worklist_push frontier_node !ctx.worklist) new_frontier_nodes; `Continue @@ -127,94 +74,35 @@ end) | `Unsafe u -> `Unsafe u - let mk_context (ts: cfg_t) (entry: int) (error: int) (pre_state: state_formula) (enable_summary: bool) = - let sum = Summarizer.init ts entry error enable_summary in + let mk_context art = ref { - ts = ts; - entry = entry; - error = error; - sum = sum; - pre_state = pre_state; - art = PathTree.make ts entry error sum; + art = ref art; worklist = DQ.empty; execlist = DQ.empty; } - let path_condition (ctx: context ref) (v: PathTree.node) = - let art = !ctx.art in - let cfg = !ctx.ts in - let art_nodes = PathTree.tree_path art v in - let cfg_nodes = List.map (fun x -> PathTree.maps_to art x) art_nodes in - let rec to_weights l : K.t Cra.label list = - match l with - | a :: b :: t -> - TS.edge_weight cfg a b :: (to_weights (b :: t)) - | _ -> [] - in - let pathcond = List.map (fun (weight: K.t Cra.label) -> - match weight with - | Call (_, _) -> failwith "encountered call edge" - | Weight w -> w) (to_weights cfg_nodes) in - logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); - let l = (K.assume !ctx.pre_state) :: pathcond in - log_weights "path conditions " l; l - - let mk_post (ctx: context ref) (v: PathTree.node) = - let art = !ctx.art in - let post_path_summary = Summarizer.path_weight_inter (!ctx.sum) (PathTree.maps_to art v) in - log_weights "\npost_path_summary: " [post_path_summary]; - logf "\n"; - K.guard post_path_summary - - - - (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) - let interpolate_or_get_model (ctx: context ref) (src : PathTree.node) = - let suffix = mk_post ctx src |> Syntax.mk_not Ctx.context in - let prefix = path_condition ctx src in - log_weights "\nprefix " prefix; - log_formulas "\nsuffix " [suffix]; - logf "\n"; - K.interpolate_or_concrete_model prefix suffix - - - let refine (ctx: context ref) (v: PathTree.node) = - logf "refining node %d\n" (PathTree.of_node v); - let handle_failure v m = - logf " *********************** REFINEMENT FAILED *************************\n"; - let path_condition = path_condition ctx v - in `Failure (m, path_condition) - in - match interpolate_or_get_model ctx v with - `Invalid v_model -> - logf "Unable to refine but got model\n"; - (* v is no longer a frontier node. *) - handle_failure v v_model - | `Unknown -> failwith "mc_refine: got UNKNOWN as a result for interpolate_or_get_model" - | `Valid _ -> - `Success - - - let execute (ts: cfg_t) (entry: int) (error: int) (pre_state: state_formula) (enable_summary: bool) : [`Safe | `Unsafe | `Error of string] = - let ctx = mk_context ts entry error pre_state enable_summary in + let execute art root : [`Safe | `Unsafe | `Error of string] = + let ctx = mk_context art in let state = ref `Unknown in - !ctx.worklist <- worklist_push (PathTree.root) !ctx.worklist; + !ctx.worklist <- worklist_push root !ctx.worklist; while (DQ.size !ctx.worklist > 0 || DQ.size !ctx.execlist > 0) && (!state = `Unknown) do logf " --- SGT: starting a new test execution phase\n"; match run_test ctx with | `Safe -> begin match DQ.front !ctx.worklist with | Some (u, worklist') -> - begin match refine ctx u with - | `Failure (m, _) -> + begin match PathTree.check art u with + | `Feasible m -> + Log.errorf "HERE!"; !ctx.execlist <- worklist_push (u, m) !ctx.execlist; !ctx.worklist <- worklist'; state := `Unknown - | `Success (* refinement succeeded. *) -> - logf " --- SGT: refinement success\n"; + | `Infeasible -> !ctx.worklist <- worklist'; state := `Unknown; + | `Unknown -> + logf "--- SGT: UNKNOWN!" end | None -> state := `Safe @@ -228,4 +116,3 @@ end) | `Unsafe -> `Unsafe | `Unknown | `Safe -> `Safe end - From c0df7944bc7eab07c294ea9716e4e860f9fdaa1f Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Wed, 23 Apr 2025 17:01:09 -0400 Subject: [PATCH 34/59] Spacing --- duet/gps.ml | 629 +++++++++++++++++++++--------------------- duet/sgt.ml | 76 ++--- srk/src/transition.ml | 358 ++++++++++++------------ 3 files changed, 531 insertions(+), 532 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index 7fd4132d..f1ba5b12 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -2,22 +2,22 @@ open Core open Srk open CfgIr open BatPervasives -open Cra +open Cra module TS = TransitionSystem.Make(Ctx)(V)(K) include Log.Make(struct let name = "gps" end) -module ProcName = struct - type t = int * int +module ProcName = struct + type t = int * int let make ((u, v) : TS.vertex * TS.vertex) : t = (u, v) - let string_of (p: t) = - let u, v = p in Printf.sprintf "%d:%d" u v - - let of_string (s: string) = - match String.split_on_char ':' s with + let string_of (p: t) = + let u, v = p in Printf.sprintf "%d:%d" u v + + let of_string (s: string) = + match String.split_on_char ':' s with | [ us ; vs ] -> (make ((int_of_string us), (int_of_string vs))) | _ -> failwith @@ Printf.sprintf "illegal procedure identifier %s" s @@ -32,57 +32,57 @@ module ProcMap = BatMap.Make(ProcName) module IntMap = BatMap.Make(Int) module StringMap = BatMap.Make(String) module DQ = BatDeque -module ARR = Batteries.DynArray +module ARR = Batteries.DynArray type cfg_t = TSG.t -type idq_t = int BatDeque.t -type state_formula = Ctx.t Syntax.formula -exception Mexception of string +type idq_t = int BatDeque.t +type state_formula = Ctx.t Syntax.formula +exception Mexception of string let mk_true () = Syntax.mk_true Ctx.context -let mk_false () = Syntax.mk_false Ctx.context +let mk_false () = Syntax.mk_false Ctx.context let mk_query ts entry = TS.mk_query ts entry (if !monotone then (module MonotoneDom) else (module TransitionDom)) -let log_formulas prefix formulas = - List.iteri (fun i f -> logf "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr srk) f) formulas +let log_formulas prefix formulas = + List.iteri (fun i f -> logf "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr srk) f) formulas -let log_weights prefix weights = +let log_weights prefix weights = List.iteri (fun i f -> logf "[weight] %s(%i): %a\n" prefix i K.pp f) weights -let log_model prefix model = +let log_model prefix model = logf "[model] %s: %a\n" prefix Interpretation.pp model (* let assert_i = ref 0 -let new_assert_var cond = - let i = !assert_i in - let name = "__assert" ^ (string_of_int i) in - let v = Varinfo.mk_global name (Concrete (Int 8)) |> Var.mk in - let assert_var = Syntax.mk_symbol srk ~name:name `TyInt in - let assert_term = Syntax.mk_const srk assert_var in +let new_assert_var cond = + let i = !assert_i in + let name = "__assert" ^ (string_of_int i) in + let v = Varinfo.mk_global name (Concrete (Int 8)) |> Var.mk in + let assert_var = Syntax.mk_symbol srk ~name:name `TyInt in + let assert_term = Syntax.mk_const srk assert_var in assert_i := !assert_i + 1; K.assign v cond -let process_interproc_assertion (ts: cfg_t) (phi: Ctx.formula) v = - let a_var, a_term = new_assert_var @@ Ctx.mk_not phi in +let process_interproc_assertion (ts: cfg_t) (phi: Ctx.formula) v = + let a_var, a_term = new_assert_var @@ Ctx.mk_not phi in *) (* Convert assertion checking problem to vertex reachability problem. *) -let make_ts_assertions_unreachable (ts : cfg_t) assertions = +let make_ts_assertions_unreachable (ts : cfg_t) assertions = let err_loc = 1 + (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in let ts = WG.add_vertex ts err_loc in let ts = SrkUtil.Int.Map.fold (fun v (phi, _, _) ts -> - let s = Printf.sprintf " Adding assertion node %d -> %d for label " v err_loc in - log_formulas s [ Ctx.mk_not phi ] ; + let s = Printf.sprintf " Adding assertion node %d -> %d for label " v err_loc in + log_formulas s [ Ctx.mk_not phi ] ; WG.add_edge ts v (Weight (K.assume (Ctx.mk_not phi))) err_loc) assertions ts in (ts, err_loc) -module Summarizer = - struct +module Summarizer = + struct module SMap = BatMap.Make(ProcName) type t = { query: TS.query; @@ -98,95 +98,95 @@ module Summarizer = { query = q ; rev_query = rq ; underapprox = SMap.empty - ; overapprox = SMap.empty + ; overapprox = SMap.empty ; silent = not enable_summary } - let filt_over (ctx: t) x = - if ctx.silent then begin + let filt_over (ctx: t) x = + if ctx.silent then begin (*logf "filt_over: context is silent! \n";*) - K.assume @@ mk_true () - end - else begin + K.assume @@ mk_true () + end + else begin (*logf "filt_over: context isn't silent!\n";*) x end - - let filt_under (ctx: t) x = + + let filt_under (ctx: t) x = if ctx.silent then K.assume @@ mk_false () - else x + else x (** retrieve over-approximate procedure summary *) let over_proc_summary (ctx: t) ((u, v) : ProcName.t) = - if ctx.silent then begin - match SMap.find_opt (u, v) ctx.overapprox with - | Some s -> s - | None -> - let init = K.assume @@ mk_true () in - ctx.overapprox <- SMap.add (u, v) init ctx.overapprox; init + if ctx.silent then begin + match SMap.find_opt (u, v) ctx.overapprox with + | Some s -> s + | None -> + let init = K.assume @@ mk_true () in + ctx.overapprox <- SMap.add (u, v) init ctx.overapprox; init end else - TS.get_summary ctx.query (u, v) + TS.get_summary ctx.query (u, v) |> K.exists (V.is_global) - + (** set over-approximate procedure summary *) let set_over_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) = if ctx.silent then begin match SMap.find_opt (u, v) ctx.overapprox with - | Some s -> + | Some s -> ctx.overapprox <- SMap.add (u, v) (K.conjunct s w) ctx.overapprox - | None -> + | None -> ctx.overapprox <- SMap.add (u, v) w ctx.overapprox; - end else + end else TS.set_summary ctx.query (u, v) w (** retrieve under-approximate procedure summary *) - let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = + let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = match SMap.find_default K.zero (u, v) ctx.underapprox - |> K.project_mbp (V.is_global) + |> K.project_mbp (V.is_global) with - | `Sat tr -> tr - | _ -> + | `Sat tr -> tr + | _ -> log_weights "under_proc_summary: this weight is unsat: " [SMap.find_default K.zero (u, v) ctx.underapprox]; - K.zero + K.zero (*failwith "under_proc_summary: cannot model-based project"*) - + (** set under-approximate procedure summary *) - let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = + let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = ctx.underapprox <- SMap.add (u, v) w ctx.underapprox (** refinement of procedure summaries using a two-voc transition formula *) let refine_over_summary (ctx: t) ((u, v): ProcName.t) (rfn: K.t) = - if ctx.silent then begin + if ctx.silent then begin match SMap.find_opt (u, v) ctx.overapprox with - | Some s -> + | Some s -> ctx.overapprox <- SMap.add (u, v) (K.conjunct s rfn) ctx.overapprox - | None -> + | None -> ctx.overapprox <- SMap.add (u, v) rfn ctx.overapprox - end else - over_proc_summary ctx (u, v) - |> K.conjunct rfn + end else + over_proc_summary ctx (u, v) + |> K.conjunct rfn |> set_over_proc_summary ctx (u, v) - - let refine_under_summary (ctx: t) ((u, v): ProcName.t) (w:K.t) : unit = - let summary = under_proc_summary ctx (u, v) in - let summary' = K.add summary w in + + let refine_under_summary (ctx: t) ((u, v): ProcName.t) (w:K.t) : unit = + let summary = under_proc_summary ctx (u, v) in + let summary' = K.add summary w in log_weights "under-approx summary refined to " [summary']; set_under_proc_summary ctx (u, v) summary' - + let path_weight_intra (ctx: t) (src: int) (dst: int) = TS.exit_summary ctx.rev_query src dst - |> filt_over ctx - + |> filt_over ctx + let path_weight_inter (ctx: t) (src: int) = TS.target_summary ctx.rev_query src - |> filt_over ctx - + |> filt_over ctx + end -type path_type = - | OverApprox +type path_type = + | OverApprox | UnderApprox -let srk = Ctx.context +let srk = Ctx.context module GPS = struct module Graph = struct @@ -194,67 +194,66 @@ module GPS = struct { graph : cfg_t ; call_summary : ProcName.t -> K.t ; target_summary : int -> K.t } - - type vertex = TS.vertex - type weight = K.t + type vertex = TS.vertex - let edge_label g u v = WG.edge_weight g.graph u v + type weight = K.t - let weight g u v = - match WG.edge_weight g.graph u v with - | Call (src, dst) -> - g.call_summary (src, dst) - | Weight w -> w + let edge_label g u v = WG.edge_weight g.graph u v - let fold_succ f g u acc = - WG.U.fold_succ f (WG.forget_weights g.graph) u acc + let weight g u v = + match WG.edge_weight g.graph u v with + | Call (src, dst) -> + g.call_summary (src, dst) + | Weight w -> w - let iter_succ_e f g v = - fold_succ (fun w () -> f (v, weight g v w, w)) g v () + let fold_succ f g u acc = + WG.U.fold_succ f (WG.forget_weights g.graph) u acc - let summary g src = g.target_summary src + let iter_succ_e f g v = + fold_succ (fun w () -> f (v, weight g v w, w)) g v () - let compare_vertex = Stdlib.compare - let pp_vertex = Format.pp_print_int -end + let summary g src = g.target_summary src -module Label = struct - type t = Ctx.t Syntax.formula - let top = Ctx.mk_true - let bottom = Ctx.mk_false - let meet f g = Ctx.mk_and [f; g] - let leq f g = - match Smt.entails Ctx.context f g with - | `Yes -> true - | _ -> false - let pp = Syntax.Formula.pp srk -end -module Transition = struct - type t = K.t - type label = Ctx.t Syntax.formula - type state = Ctx.t Interpretation.interpretation - let check pre trs post = - K.interpolate_or_concrete_model ((K.assume pre)::trs) post - - let is_deterministic = - let is_det tr = - not (K.contains_havoc tr) || K.is_deterministic tr - in - Memo.memo is_det + let compare_vertex = Stdlib.compare + let pp_vertex = Format.pp_print_int + end - let post_model = K.get_post_model - let pp = K.pp - let mul = K.mul - let assume = K.assume - let guard = K.guard -end + module Label = struct + type t = Ctx.t Syntax.formula + let top = Ctx.mk_true + let bottom = Ctx.mk_false + let meet f g = Ctx.mk_and [f; g] + let leq f g = + match Smt.entails Ctx.context f g with + | `Yes -> true + | _ -> false + let pp = Syntax.Formula.pp srk + end + module Transition = struct + type t = K.t + type label = Ctx.t Syntax.formula + type state = Ctx.t Interpretation.interpretation + let check pre trs post = + K.interpolate_or_concrete_model ((K.assume pre)::trs) post + + let is_deterministic = + let is_det tr = + not (K.contains_havoc tr) || K.is_deterministic tr + in + Memo.memo is_det + let post_model = K.get_post_model + let pp = K.pp + let mul = K.mul + let assume = K.assume + let guard = K.guard + end (* ART module *) (* module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer)*) module ReachTree = ReachTree.ART(Graph)(Label)(Transition) - + (** summary-guided testing *) module PT = struct type t = @@ -285,7 +284,7 @@ end end module SGT = Sgt.SummaryGuidedTesting(PT) - (* to print the reachability tree (+ worklist), or not *) + (* to print the reachability tree (+ worklist), or not *) (* RF 3/2/25: If you enable this flag, and even if *) (* the logf output stream is suppressed, it incurs a _huge_ *) (* performance penalty. *) @@ -296,8 +295,8 @@ end ; g_summarizer : Summarizer.t ; g_errloc : int } - and mc_result = - | Safe of K.t + and mc_result = + | Safe of K.t | Unsafe of K.t @@ -311,23 +310,23 @@ end mutable worklist : ReachTree.node DQ.t; mutable execlist : (ReachTree.node * Ctx.t Interpretation.interpretation) DQ.t; global_ctx : global_context ref; - } + } (* global context *) (** some helper functions that operate on the context *) let get_summarizer ctx = !(!ctx.global_ctx).g_summarizer - let log_labelled_weights ctx uu prefix weights = - List.iteri - (fun i f -> - match f with + let log_labelled_weights ctx uu prefix weights = + List.iteri + (fun i f -> + match f with | Call (u, v) -> - let p = - begin match uu with - | OverApprox -> Summarizer.over_proc_summary !ctx.g_summarizer (ProcName.make (u, v)) - | UnderApprox -> Summarizer.under_proc_summary !ctx.g_summarizer (ProcName.make (u, v)) - end in + let p = + begin match uu with + | OverApprox -> Summarizer.over_proc_summary !ctx.g_summarizer (ProcName.make (u, v)) + | UnderApprox -> Summarizer.under_proc_summary !ctx.g_summarizer (ProcName.make (u, v)) + end in logf "[labelled weight] %s(%i, call(%d,%d)): %a\n" prefix i u v K.pp p - | Weight w -> + | Weight w -> logf "[labelled weight] %s(%i): %a\n" prefix i K.pp w) weights @@ -351,20 +350,20 @@ end (* promote an arbitrary state formula (not necessarily the pre-state) to a transition formula. *) (* To do so, we substitute in fresh skolem symbols for all prophecy variables inside [f], and *) (* create a transform map, treating the substituted formula as guard. *) - let promote (f : Ctx.t Syntax.formula) = - let sym_map = ValueHT.create 991 in - let substitute = Memo.memo (fun sym -> + let promote (f : Ctx.t Syntax.formula) = + let sym_map = ValueHT.create 991 in + let substitute = Memo.memo (fun sym -> match V.of_symbol sym with | Some v -> - begin match V.var_of_prophecy_var v with + begin match V.var_of_prophecy_var v with | Some original_var -> - let fresh_skolem = Syntax.mk_symbol srk (Syntax.typ_symbol srk sym) in - let term = Syntax.mk_const srk fresh_skolem in + let fresh_skolem = Syntax.mk_symbol srk (Syntax.typ_symbol srk sym) in + let term = Syntax.mk_const srk fresh_skolem in ValueHT.add sym_map original_var term; - term - | None -> Syntax.mk_const srk sym + term + | None -> Syntax.mk_const srk sym end - | None -> Syntax.mk_const srk sym) in + | None -> Syntax.mk_const srk sym) in K.construct (Syntax.substitute_const srk substitute (Syntax.mk_not srk f)) (ValueHT.to_seq sym_map |> List.of_seq) @@ -393,29 +392,29 @@ end (** place an element in front of the deque (worklist) *) - let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i + let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i - let rec art_cfg_path_pair (ctx: intra_context ref) (p: ReachTree.node list) = - match p with + let rec art_cfg_path_pair (ctx: intra_context ref) (p: ReachTree.node list) = + match p with | u :: v :: t -> - let u_vtx = ReachTree.maps_to !ctx.art u in - let v_vtx = ReachTree.maps_to !ctx.art v in + let u_vtx = ReachTree.maps_to !ctx.art u in + let v_vtx = ReachTree.maps_to !ctx.art v in (u, (u_vtx, v_vtx), v) :: (art_cfg_path_pair ctx (v :: t)) | _ -> [] (* turn tree path into a sequence of CFG edges. *) - let cfg_path (ctx: intra_context ref) (p : ReachTree.node list) = - art_cfg_path_pair ctx p + let cfg_path (ctx: intra_context ref) (p : ReachTree.node list) = + art_cfg_path_pair ctx p |> List.map (fun (_, (u, v), _) -> (u, v)) - - let print_vocabulary tr = + + let print_vocabulary tr = let g_vocab, l_vocab = K.vocabulary tr in - let vname x = - match V.of_symbol x with - | Some var -> V.show var + let vname x = + match V.of_symbol x with + | Some var -> V.show var | None -> " [havoc] " in - log_weights " [vocabulary of transition] " [tr]; + log_weights " [vocabulary of transition] " [tr]; logf " ------ globals: ---- {\n"; List.iter (fun x -> logf " %s %s\n" (Syntax.show_symbol srk x) (vname x)) g_vocab; logf "}\n ------ locals: ---- {\n"; @@ -423,38 +422,38 @@ end (* CFG path condition from art.src -> art.v *) let path_condition (ctx: intra_context ref) condition_type (v: ReachTree.node) = - let art = !ctx.art in + let art = !ctx.art in let art_nodes = ReachTree.tree_path art v in let ts = !ctx.cfg.Graph.graph in - let cfg_nodes = List.map (fun x -> ReachTree.maps_to art x) art_nodes in - let rec to_weights l : K.t label list = - match l with - | a :: b :: t -> - WG.edge_weight ts a b :: (to_weights (b :: t)) + let cfg_nodes = List.map (fun x -> ReachTree.maps_to art x) art_nodes in + let rec to_weights l : K.t label list = + match l with + | a :: b :: t -> + WG.edge_weight ts a b :: (to_weights (b :: t)) | _ -> [] in let summ = get_summarizer ctx in - let pathcond = List.map (fun (weight: K.t label) -> - match weight with - | Call (src, dst) -> - begin match condition_type with + let pathcond = List.map (fun (weight: K.t label) -> + match weight with + | Call (src, dst) -> + begin match condition_type with | OverApprox -> Summarizer.over_proc_summary summ (ProcName.make (src, dst)) - | UnderApprox -> - let under = Summarizer.under_proc_summary summ (ProcName.make (src, dst)) in + | UnderApprox -> + let under = Summarizer.under_proc_summary summ (ProcName.make (src, dst)) in log_weights "underapproximate summary" [under]; print_vocabulary under; under end - | Weight w -> w) (to_weights cfg_nodes) in + | Weight w -> w) (to_weights cfg_nodes) in logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); - let l = (K.assume !ctx.pre_state) :: pathcond in + let l = (K.assume !ctx.pre_state) :: pathcond in log_weights "path conditions " l; l (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) let interpolate_or_get_model (ctx: intra_context ref) (src : ReachTree.node) = let src_v = ReachTree.maps_to !ctx.art src in let suffix = K.guard (Graph.summary !ctx.cfg src_v) |> Syntax.mk_not srk in - let prefix = path_condition ctx OverApprox src in + let prefix = path_condition ctx OverApprox src in log_weights "\nprefix " prefix; log_formulas "\nsuffix " [suffix]; logf "\n"; @@ -462,19 +461,19 @@ end let get_global_ctx (ctx: intra_context ref) = (!ctx.global_ctx) - (* refine path to (tree) node v. + (* refine path to (tree) node v. Returns `Failure (u, m) with (u, m) being a new item to the concolic worklist if unable to refine. Returns `Success if refine is able to refine. *) - let mc_refine (ctx: intra_context ref) (v: ReachTree.node) = + let mc_refine (ctx: intra_context ref) (v: ReachTree.node) = logf "refining node %d\n" (ReachTree.of_node v); - let handle_failure v m = - logf " *********************** REFINEMENT FAILED *************************\n"; - let path_condition = path_condition ctx OverApprox v - in `Failure (m, path_condition) - in let art = !ctx.art in - let path = ReachTree.tree_path art v in - match interpolate_or_get_model ctx v with - `Invalid v_model -> + let handle_failure v m = + logf " *********************** REFINEMENT FAILED *************************\n"; + let path_condition = path_condition ctx OverApprox v + in `Failure (m, path_condition) + in let art = !ctx.art in + let path = ReachTree.tree_path art v in + match interpolate_or_get_model ctx v with + `Invalid v_model -> logf "Unable to refine but got model\n"; (* v is no longer a frontier node. *) handle_failure v v_model @@ -483,226 +482,226 @@ end logf "--- mc_refine: interpolation succeeded. path length %d, interpolant length %d" (List.length path) (List.length interpolants); log_formulas "interpolants - " interpolants; ReachTree.refine art path interpolants - |> List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist); - `Success + |> List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist); + `Success (* concolic phase of our model checking algorithm *) let concolic_phase (ctx: intra_context ref) = - let round ctx = - match DQ.front (!ctx.execlist) with - | Some ((u, u_model), w) -> + let round ctx = + match DQ.front (!ctx.execlist) with + | Some ((u, u_model), w) -> if print_tree then (* XXX: if this is enabled, the performance penalty is huge. *) ReachTree.log_art !ctx.art; logf " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); !ctx.execlist <- w; - if (ReachTree.maps_to !ctx.art u) = (ReachTree.get_err_loc !ctx.art) then begin + if (ReachTree.maps_to !ctx.art u) = (ReachTree.get_err_loc !ctx.art) then begin logf " *** found potential path-to-error, checking if prophesized pre-condition is sat...\n"; logf " *** SAT, done\n"; `ErrorReached u end else begin logf "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); log_model "" u_model; - let new_concolic_nodes, new_frontier_nodes = ReachTree.expand !ctx.art u u_model in + let new_concolic_nodes, new_frontier_nodes = ReachTree.expand !ctx.art u u_model in List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; List.iter (fun frontier_node -> !ctx.worklist <- worklist_push frontier_node !ctx.worklist) new_frontier_nodes; `Continue end | None -> failwith "err: concolic_phase is reading from empty execution worklist" (* cannot happen *) - in - let rtn = ref `Continue in - while !rtn = `Continue && ((DQ.size !ctx.execlist) > 0) do - rtn := round ctx + in + let rtn = ref `Continue in + while !rtn = `Continue && ((DQ.size !ctx.execlist) > 0) do + rtn := round ctx done; - match !rtn with - | `Continue -> `Safe - | `ErrorReached u -> `Unsafe u + match !rtn with + | `Continue -> `Safe + | `ErrorReached u -> `Unsafe u (* refinement phase of our model checking algorithm *) - let refinement_phase (ctx: intra_context ref) = - let worklist_push_all ls = - List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist) ls in - match DQ.front (!ctx.worklist) with - | Some (u, w) -> - if print_tree then + let refinement_phase (ctx: intra_context ref) = + let worklist_push_all ls = + List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist) ls in + match DQ.front (!ctx.worklist) with + | Some (u, w) -> + if print_tree then ReachTree.log_art !ctx.art; !ctx.worklist <- w; (* Fetched tree node u from work list. First attempt to close it. *) - if not (ReachTree.is_covered !ctx.art u) then + if not (ReachTree.is_covered !ctx.art u) then begin logf " uncovered. try close %d\n" (ReachTree.of_node u); begin match ReachTree.lclose !ctx.art u with (* Close succeeded. No need to further explore it. *) - | true, leaves -> - logf "Close succeeded.\n"; + | true, leaves -> + logf "Close succeeded.\n"; worklist_push_all leaves; `Continue | false, leaves -> (* u is uncovered. *) logf " ... close failed in refining node %d, try refining it\n" (ReachTree.of_node u); worklist_push_all leaves; - begin match mc_refine ctx u with + begin match mc_refine ctx u with | `Success -> (* refinement succeeded *) logf "refinement_phase: refinement succeeded\n"; (* for every node along path of refinement try close *) - let path = ReachTree.tree_path !ctx.art u in - List.iter - (fun x -> let (_, ls) = ReachTree.close !ctx.art x in + let path = ReachTree.tree_path !ctx.art u in + List.iter + (fun x -> let (_, ls) = ReachTree.close !ctx.art x in worklist_push_all ls) path; - `Continue - | `Failure (u_m, _) -> + `Continue + | `Failure (u_m, _) -> !ctx.execlist <- worklist_push (u, u_m) !ctx.execlist; (* put u onto execlist since it now has a model. *) (* for every node along path of refinement try close *) - let path = ReachTree.tree_path !ctx.art u in - List.iter (fun x -> let (_, ls) = ReachTree.close !ctx.art x in - worklist_push_all ls) path + let path = ReachTree.tree_path !ctx.art u in + List.iter (fun x -> let (_, ls) = ReachTree.close !ctx.art x in + worklist_push_all ls) path ; `Continue end end end - else begin + else begin logf "refinement_phase: %d is covered\n" (ReachTree.of_node u); `Continue end | None -> failwith "refinement_phase: encountered an empty worklist for refinement\n" (* cannot happen *) - let extract_refinement (ctx: intra_context ref) = + let extract_refinement (ctx: intra_context ref) = let art = !ctx.art in let rfn = ReachTree.label art ReachTree.root |> promote in log_weights "refinement: " [rfn]; - K.exists (fun v -> V.is_global v) (rfn) - + K.exists (fun v -> V.is_global v) (rfn) + let seq = List.fold_left K.mul K.one (* sequentially multiply, left-right *) - let rec handle_path_to_error ctx left curr right dir err_leaf : [`Unsafe of K.t | `Safe] = - let handle_right_case caller_id = - let f = List.map (fun (_, w, _) -> w) in - let left = f left in + let rec handle_path_to_error ctx left curr right dir err_leaf : [`Unsafe of K.t | `Safe] = + let handle_right_case caller_id = + let f = List.map (fun (_, w, _) -> w) in + let left = f left in let right = f right in - match K.project_mbp (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with - | `Sat t -> `Unsafe t - | _ -> - logf " ------------------------ handle_path_to_error debug info: called by case %s ------------------\n" caller_id; + match K.project_mbp (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with + | `Sat t -> `Unsafe t + | _ -> + logf " ------------------------ handle_path_to_error debug info: called by case %s ------------------\n" caller_id; log_weights "faulty weight: " (path_condition ctx UnderApprox err_leaf); logf "\nlength of left path: %d" (List.length left); logf "\nlength of right path: %d" (List.length right); logf "\nPrinting left path... \n"; - + log_labelled_weights !ctx.global_ctx UnderApprox "left path - " left; logf "error: handle_path_to_error: cannot project path condition" ; - `Safe in + `Safe in let handle_left_case caller_id = logf "handle_path_to_error: %s\n" caller_id; - `Safe in - match curr with - | (_, Weight _, _) -> - begin match left, dir, right with - | [], `Left, _ -> - handle_left_case "reached leftmost item, `curr` variable is NOT a call-edge" - | _, `Right, [] -> - handle_right_case "reached rightmost item, `curr` variable is NOT a call-edge" - | a :: left', `Left, _ -> handle_path_to_error ctx left' a (curr :: right) dir err_leaf - | _, `Right, a :: right' -> handle_path_to_error ctx (curr :: left) a right' dir err_leaf + `Safe in + match curr with + | (_, Weight _, _) -> + begin match left, dir, right with + | [], `Left, _ -> + handle_left_case "reached leftmost item, `curr` variable is NOT a call-edge" + | _, `Right, [] -> + handle_right_case "reached rightmost item, `curr` variable is NOT a call-edge" + | a :: left', `Left, _ -> handle_path_to_error ctx left' a (curr :: right) dir err_leaf + | _, `Right, a :: right' -> handle_path_to_error ctx (curr :: left) a right' dir err_leaf end | (u, (Call (src, dst)), _) -> let prefix = path_condition ctx UnderApprox u |> seq in let summ = get_summarizer ctx in - let suffix = - List.map (fun (_, ew, _) -> - match ew with - | Weight w -> w - | Call (s, t) -> Summarizer.over_proc_summary summ (ProcName.make (s, t))) - right - |> seq in - let summary = Summarizer.over_proc_summary summ (ProcName.make (src, dst)) in - begin match K.contextualize prefix summary suffix with - | `Sat query -> + let suffix = + List.map (fun (_, ew, _) -> + match ew with + | Weight w -> w + | Call (s, t) -> Summarizer.over_proc_summary summ (ProcName.make (s, t))) + right + |> seq in + let summary = Summarizer.over_proc_summary summ (ProcName.make (src, dst)) in + begin match K.contextualize prefix summary suffix with + | `Sat query -> let answer = mk_intra_context (!ctx.global_ctx) (ProcName.make (src, dst)) query - |> intraproc_check - in begin match answer with + |> intraproc_check + in begin match answer with | Safe r -> Summarizer.refine_over_summary summ (ProcName.make (src, dst)) r; handle_path_to_error ctx left curr right dir err_leaf - | Unsafe trs -> - begin match trs |> K.project_mbp (V.is_global) with + | Unsafe trs -> + begin match trs |> K.project_mbp (V.is_global) with | `Sat tr -> Summarizer.refine_under_summary summ (ProcName.make (src, dst)) tr; - begin match right with - | a :: right' -> - handle_path_to_error ctx (curr::left) a right' `Right err_leaf - | [] -> (* we're done *) + begin match right with + | a :: right' -> + handle_path_to_error ctx (curr::left) a right' `Right err_leaf + | [] -> (* we're done *) handle_right_case "rightmost edge is call-edge, underapproximation successful" end - | _ -> failwith "error: cannot do mbp on returned error trace in handle_path_to_error" + | _ -> failwith "error: cannot do mbp on returned error trace in handle_path_to_error" end end - | `Unsat -> (* procedure summary at `curr` is UNSAT, so backtrack *) - begin match left with - | a :: left' -> + | `Unsat -> (* procedure summary at `curr` is UNSAT, so backtrack *) + begin match left with + | a :: left' -> handle_path_to_error ctx left' a (curr :: right) `Left err_leaf | [] -> (* at the very left. we're done *) handle_left_case "at the leftmost edge, is a call-edge, done" end end - - - and intraproc_check (ctx: intra_context ref) : mc_result = - let continue = ref true in + + + and intraproc_check (ctx: intra_context ref) : mc_result = + let continue = ref true in let state = ref `Continue in - !ctx.worklist <- worklist_push (ReachTree.root) !ctx.worklist; + !ctx.worklist <- worklist_push (ReachTree.root) !ctx.worklist; while !continue && (DQ.size (!ctx.worklist) > 0 || DQ.size (!ctx.execlist) > 0) do - if DQ.size (!ctx.execlist) > 0 then begin + if DQ.size (!ctx.execlist) > 0 then begin (* concolic phase *) - begin match concolic_phase ctx with - | `Unsafe w -> + begin match concolic_phase ctx with + | `Unsafe w -> logf "--- GPS: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to !ctx.art w); logf " --- forming path to error... \n"; - let has_calls, path_to_w = - ReachTree.tree_path !ctx.art w - |> art_cfg_path_pair ctx - |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight !ctx.cfg.Graph.graph u_vtx v_vtx, v)) + let has_calls, path_to_w = + ReachTree.tree_path !ctx.art w + |> art_cfg_path_pair ctx + |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight !ctx.cfg.Graph.graph u_vtx v_vtx, v)) |> List.fold_left (fun (has_call, l) (u, w, v) -> - match w with + match w with | Call _ -> (true, (u, w, v) :: l) | _ -> (has_call, (u, w, v) :: l) - ) (false, []) + ) (false, []) in logf " --- finished forming path to error, calling handle_path_to_error ... \n"; - begin match has_calls, path_to_w with - | true, curr :: right -> - begin match handle_path_to_error ctx [] curr right `Right w with + begin match has_calls, path_to_w with + | true, curr :: right -> + begin match handle_path_to_error ctx [] curr right `Right w with | `Safe -> (* path-to-error concretization failed. frontier_node is the src node of a call-edge. *) (* we can mark `w` as a frontier node to be refined, and continue. *) !ctx.worklist <- worklist_push w !ctx.worklist; continue := true - | `Unsafe pathcond -> + | `Unsafe pathcond -> logf "--- GPS: managed to concretize an intraprocedural path-to-error. returning... "; state := `Concretized (pathcond); continue := false end - | false, _::_ -> + | false, _::_ -> state := `ConcretizedList (path_to_w); continue := false | true, [] - | false, [] -> + | false, [] -> (* corner case: either no calls along the path, or if the path to error is of length 0. *) state := `Concretized (K.one); - continue := false + continue := false end - | `Safe -> + | `Safe -> state := `Continue end - end else begin + end else begin (* refinement phase *) state := refinement_phase ctx end - done; - match !state with + done; + match !state with | `Continue -> Safe (extract_refinement ctx) | `ConcretizedList _ -> Unsafe (K.one) (* TODO: fix this *) - | `Concretized cond -> Unsafe (cond) - + | `Concretized cond -> Unsafe (cond) + let execute (ts : cfg_t) (entry : int) (err_loc : int) (enable_summary:bool) : mc_result = let gctx = @@ -723,7 +722,7 @@ end ts ts in - let graph = + let graph = Graph.{ graph = interproc_graph ; call_summary = Summarizer.over_proc_summary !gctx.g_summarizer ; target_summary = Summarizer.path_weight_inter !gctx.g_summarizer } @@ -740,15 +739,15 @@ end } in logf "executing GPS: start\n"; - intraproc_check main_context + intraproc_check main_context end module BM = BatMap.Make(Int) -let analyze_mc enable_gas enable_summary file = - let open Srk.Iteration in +let analyze_mc enable_gas enable_summary file = + let open Srk.Iteration in populate_offset_table file; K.domain := split (product [ PolyhedronGuard.exp ; LossyTranslation.exp ]); @@ -757,12 +756,12 @@ let analyze_mc enable_gas enable_summary file = let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system ~simplify:true ~instr_gas:enable_gas entry rg in - let ts, err_loc = make_ts_assertions_unreachable ts assertions in + let ts, err_loc = make_ts_assertions_unreachable ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; - logf "\nentry: %d\n" entry; - Printf.printf "testing reachability of location %d\n" err_loc ; + logf "\nentry: %d\n" entry; + Printf.printf "testing reachability of location %d\n" err_loc ; Printf.printf "------------------------------\n"; - begin match GPS.execute ts entry err_loc enable_summary with + begin match GPS.execute ts entry err_loc enable_summary with | Safe _ -> Printf.printf " proven safe\n"; | Unsafe _ -> Printf.printf " proven unsafe\n" end; @@ -771,8 +770,8 @@ let analyze_mc enable_gas enable_summary file = | _ -> assert false -let analyze_sgt enable_gas enable_summary file = - let open Srk.Iteration in +let analyze_sgt enable_gas enable_summary file = + let open Srk.Iteration in populate_offset_table file; K.domain := split (product [ PolyhedronGuard.exp ; LossyTranslation.exp ]); @@ -781,13 +780,13 @@ let analyze_sgt enable_gas enable_summary file = let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system ~simplify:true ~instr_gas:enable_gas entry rg in - let ts, err_loc = make_ts_assertions_unreachable ts assertions in + let ts, err_loc = make_ts_assertions_unreachable ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; - logf "\nentry: %d\n" entry; - Printf.printf "testing reachability of location %d\n" err_loc ; + logf "\nentry: %d\n" entry; + Printf.printf "testing reachability of location %d\n" err_loc ; Printf.printf "------------------------------\n"; let summ = Summarizer.init ts entry err_loc enable_summary in - let graph = + let graph = GPS.Graph.{ graph = ts ; call_summary = (fun _ -> failwith "SGT: procedure call") ; target_summary = Summarizer.path_weight_inter summ } @@ -796,7 +795,7 @@ let analyze_sgt enable_gas enable_summary file = GPS.PT.{ summary = Summarizer.path_weight_inter summ ; art = GPS.ReachTree.make graph entry err_loc } in - begin match GPS.SGT.execute pt GPS.ReachTree.root with + begin match GPS.SGT.execute pt GPS.ReachTree.root with | `Safe -> Printf.printf " proven safe\n"; | `Unsafe -> Printf.printf " proven unsafe\n" | `Error s -> Printf.printf "ERR: %s\n" s @@ -807,36 +806,36 @@ let analyze_sgt enable_gas enable_summary file = (** dump simplified CFG before doing model checking / CRA / concolic execution *) -let dump_cfg simplify instrument file = +let dump_cfg simplify instrument file = populate_offset_table file; - match file.entry_points with + match file.entry_points with | [main] -> - begin - let rg = Interproc.make_recgraph file in - let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system ~simplify:simplify ~instr_gas:instrument entry rg in - let ts, _ = make_ts_assertions_unreachable ts assertions in + begin + let rg = Interproc.make_recgraph file in + let entry = (RG.block_entry rg main).did in + let (ts, assertions) = make_transition_system ~simplify:simplify ~instr_gas:instrument entry rg in + let ts, _ = make_ts_assertions_unreachable ts assertions in TSDisplay.display ts end | _ -> assert false -let _ = - CmdLine.register_pass +let _ = + CmdLine.register_pass ("-gps", analyze_mc false true, " GPS model checking algorithm, without gas-instrumentation"); CmdLine.register_pass ("-gps-gas", analyze_mc true true, " GPS model checking algorithm, with gas-instrumentation (i.e., refutation-complete)"); CmdLine.register_pass ("-gps-nosum", analyze_mc false false, "GPS with neither gas nor CRA-generated summary"); - CmdLine.register_pass + CmdLine.register_pass ("-gps-nosum-nogas", analyze_mc true false, "GPS with gas but without CRA-generated summary (i.e., refutation-complete)"); - CmdLine.register_pass + CmdLine.register_pass ("-sgt", analyze_sgt false true, "Summary-guided testing, without gas-instrumentation"); CmdLine.register_pass ("-sgt-gas", analyze_sgt true true, "Summary-guided testing, with gas"); CmdLine.register_pass ("-sgt-nosum", analyze_sgt false false, "Summary-guided testing without CRA-generated summary"); - CmdLine.register_pass + CmdLine.register_pass ("-sgt-nosum-nogas", analyze_sgt true false, "Summary-guided testing with gas but without CRA-generated summary"); CmdLine.register_pass diff --git a/duet/sgt.ml b/duet/sgt.ml index 2bd27360..aa7e3202 100644 --- a/duet/sgt.ml +++ b/duet/sgt.ml @@ -6,15 +6,15 @@ module Int = SrkUtil.Int module TF = TransitionFormula module TransitionSystem = Srk.TransitionSystem -module Syntax = Srk.Syntax -module Interpretation = Srk.Interpretation +module Syntax = Srk.Syntax +module Interpretation = Srk.Interpretation include Log.Make(struct let name = "sgt" end) module DQ = BatDeque -module ARR = Batteries.DynArray +module ARR = Batteries.DynArray -module SummaryGuidedTesting +module SummaryGuidedTesting (PathTree : sig type node type t @@ -27,10 +27,10 @@ module SummaryGuidedTesting val is_err_loc : t -> node -> bool end) = struct - let print_tree = false - - let log_model prefix model = - logf "[model] %s: %a\n" prefix PathTree.pp_state model + let print_tree = false + + let log_model prefix model = + logf "[model] %s: %a\n" prefix PathTree.pp_state model type context = { @@ -41,37 +41,37 @@ module SummaryGuidedTesting mutable execlist : (PathTree.node * PathTree.state) DQ.t; } - let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i + let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i let run_test (ctx: context ref) = - let round ctx = - match DQ.front (!ctx.execlist) with - | Some ((u, u_model), w) -> - if print_tree then + let round ctx = + match DQ.front (!ctx.execlist) with + | Some ((u, u_model), w) -> + if print_tree then PathTree.log_art !(!ctx.art); logf " visit %a\n" (PathTree.pp_node !(!ctx.art)) u; !ctx.execlist <- w; if PathTree.is_err_loc !(!ctx.art) u then - `Unsafe u + `Unsafe u else begin logf "model of %a: \n" (PathTree.pp_node !(!ctx.art)) u; log_model "" u_model; - let new_concolic_nodes, new_frontier_nodes = PathTree.expand !(!ctx.art) u u_model in + let new_concolic_nodes, new_frontier_nodes = PathTree.expand !(!ctx.art) u u_model in List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; List.iter (fun frontier_node -> !ctx.worklist <- worklist_push frontier_node !ctx.worklist) new_frontier_nodes; `Continue end - | None -> + | None -> failwith "err: concolic_phase is reading from empty execution worklist" (* cannot happen *) - in - let rtn = ref `Continue in - while !rtn = `Continue && ((DQ.size !ctx.execlist) > 0) do - rtn := round ctx + in + let rtn = ref `Continue in + while !rtn = `Continue && ((DQ.size !ctx.execlist) > 0) do + rtn := round ctx done; - match !rtn with - | `Continue -> `Safe - | `Unsafe u -> `Unsafe u + match !rtn with + | `Continue -> `Safe + | `Unsafe u -> `Unsafe u let mk_context art = @@ -82,37 +82,37 @@ module SummaryGuidedTesting } - let execute art root : [`Safe | `Unsafe | `Error of string] = + let execute art root : [`Safe | `Unsafe | `Error of string] = let ctx = mk_context art in - let state = ref `Unknown in + let state = ref `Unknown in !ctx.worklist <- worklist_push root !ctx.worklist; while (DQ.size !ctx.worklist > 0 || DQ.size !ctx.execlist > 0) && (!state = `Unknown) do logf " --- SGT: starting a new test execution phase\n"; - match run_test ctx with - | `Safe -> - begin match DQ.front !ctx.worklist with - | Some (u, worklist') -> - begin match PathTree.check art u with + match run_test ctx with + | `Safe -> + begin match DQ.front !ctx.worklist with + | Some (u, worklist') -> + begin match PathTree.check art u with | `Feasible m -> Log.errorf "HERE!"; !ctx.execlist <- worklist_push (u, m) !ctx.execlist; !ctx.worklist <- worklist'; state := `Unknown - | `Infeasible -> + | `Infeasible -> !ctx.worklist <- worklist'; state := `Unknown; | `Unknown -> logf "--- SGT: UNKNOWN!" end - | None -> - state := `Safe + | None -> + state := `Safe end - | `Unsafe _ -> + | `Unsafe _ -> logf " --- SGT: finished running, found a bug.\n"; - state := `Unsafe + state := `Unsafe done; logf " --- SGT: done performing execution.\n"; - match !state with - | `Unsafe -> `Unsafe - | `Unknown | `Safe -> `Safe + match !state with + | `Unsafe -> `Unsafe + | `Unknown | `Safe -> `Safe end diff --git a/srk/src/transition.ml b/srk/src/transition.ml index ad38e0a6..fba63b95 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -12,7 +12,7 @@ module type Var = sig val symbol_of : t -> symbol val of_symbol : symbol -> t option - val is_global : t -> bool + val is_global : t -> bool end module Make @@ -143,20 +143,20 @@ struct in M.merge merge left.transform right.transform in - let guard = match ty with - | `Add -> + let guard = match ty with + | `Add -> mk_or srk [mk_and srk (left.guard::(!left_eq)); mk_and srk (right.guard::(!right_eq))] - | `And -> + | `And -> mk_and srk [mk_and srk (left.guard::(!left_eq)); mk_and srk (right.guard::(!right_eq))] in { guard; transform } - - let add left right = compose left right `Add + + let add left right = compose left right `Add let conjunct left right = compose left right `And - - + + (* Canonical names for post-state symbols. Having canonical names simplifies equality testing and widening. *) let post_symbol = @@ -453,10 +453,10 @@ struct let get_post_model m f = - let f_guard = guard f in - let replacer (sym : Syntax.symbol) = - if Var.of_symbol sym == None then Syntax.mk_const C.context sym - else mk_real C.context @@ Interpretation.real m sym + let f_guard = guard f in + let replacer (sym : Syntax.symbol) = + if Var.of_symbol sym == None then Syntax.mk_const C.context sym + else mk_real C.context @@ Interpretation.real m sym in let f_guard' = Syntax.substitute_const C.context replacer f_guard in let symbols = Syntax.symbols f_guard' |> Symbol.Set.elements in @@ -498,7 +498,7 @@ struct { transform = M.map (substitute_const srk fresh_skolem) tr.transform; guard = substitute_const srk fresh_skolem tr.guard } - let interpolate_unsat_core trs post guards core = + let interpolate_unsat_core trs post guards core = let core_symbols = List.fold_left (fun core phi -> match Formula.destruct srk phi with @@ -536,25 +536,25 @@ struct trs guards ([Quantifier.mbp srk (fun x -> Var.of_symbol x <> None) post], post) - in `Valid (List.tl itp) + in `Valid (List.tl itp) - let interpolate_query trs post sat_callback unsat_callback = - let solver = Smt.StdSolver.make C.context in + let interpolate_query trs post sat_callback unsat_callback = + let solver = Smt.StdSolver.make C.context in (* Break guards into conjunctions, associate each conjunct with an indicator *) let guards = List.map (fun tr -> List.map (fun phi -> (mk_symbol srk `TyBool, phi)) (destruct_and srk tr.guard)) - trs in + trs in let indicators, indicator_symbols = List.concat_map (List.map (fun (s, _) -> mk_const srk s)) guards, List.concat_map (List.map fst) guards |> Symbol.Set.of_list in let subscript_tbl = Hashtbl.create 991 in - let ss_inv = Hashtbl.create 991 in - let sst = Hashtbl.create 991 in + let ss_inv = Hashtbl.create 991 in + let sst = Hashtbl.create 991 in let subscript sym = try Hashtbl.find subscript_tbl sym @@ -581,124 +581,124 @@ struct tr.transform ([], ss_guards) in - List.iter (fun (k, l, v) -> + List.iter (fun (k, l, v) -> Hashtbl.add subscript_tbl k v; Hashtbl.add ss_inv l k; Hashtbl.add sst k l) ss; mk_and srk phis in - (* gather all symbols into a list, while adding formulas to the solver object *) - let symbols, added_formulas = List.fold_left + (* gather all symbols into a list, while adding formulas to the solver object *) + let symbols, added_formulas = List.fold_left (fun (symbols, added_formulas) (tr, guard) -> - let f = to_ss_formula tr guard in + let f = to_ss_formula tr guard in Smt.StdSolver.add solver [f]; (Syntax.symbols f) :: symbols, f::added_formulas) - ([], []) (List.combine trs guards) in - let _ = List.iter (fun f -> + ([], []) (List.combine trs guards) in + let _ = List.iter (fun f -> let f = substitute_const srk - (fun v -> - match Hashtbl.find_opt ss_inv v with - | None -> Syntax.mk_const srk v + (fun v -> + match Hashtbl.find_opt ss_inv v with + | None -> Syntax.mk_const srk v | Some v' -> Syntax.mk_const srk v') f - in logf "added formula: %a\n" (Syntax.pp_expr srk) f) added_formulas - (* subscript the symbols in the `post` formula, as well *) in + in logf "added formula: %a\n" (Syntax.pp_expr srk) f) added_formulas + (* subscript the symbols in the `post` formula, as well *) in let target = substitute_const srk subscript (mk_not srk post) in - let symbols = (Syntax.symbols target) :: symbols + let symbols = (Syntax.symbols target) :: symbols |> List.rev - |> List.map (fun ss -> Symbol.Set.diff ss indicator_symbols) in + |> List.map (fun ss -> Symbol.Set.diff ss indicator_symbols) in Smt.StdSolver.add solver [target]; logf "-----------------------------interpolation---\n"; - List.iter (fun f -> + List.iter (fun f -> let f = substitute_const srk - (fun v -> - match Hashtbl.find_opt ss_inv v with - | None -> Syntax.mk_const srk v + (fun v -> + match Hashtbl.find_opt ss_inv v with + | None -> Syntax.mk_const srk v | Some v' -> Syntax.mk_const srk v') f in logf "indicator formula: %a\n" (Syntax.pp_expr srk) f) indicators; logf "-------------------interpolation end---\n"; logf "--- indicator length %d\n" @@ List.length indicators; logf "\ntarget formula: %a\n" (Syntax.pp_expr srk) target; - match Smt.StdSolver.get_unsat_core_or_model solver indicators with - | `Sat m -> + match Smt.StdSolver.get_unsat_core_or_model solver indicators with + | `Sat m -> (sat_callback m symbols sst ss_inv) | `Unsat core -> (unsat_callback trs post guards core) - | `Unknown -> `Unknown + | `Unknown -> `Unknown (* let interpolate trs post = - let trs = List.map rename_skolems trs in - interpolate_query trs post (fun _ _ _ _ -> `Invalid) @@ interpolate_unsat_core + let trs = List.map rename_skolems trs in + interpolate_query trs post (fun _ _ _ _ -> `Invalid) @@ interpolate_unsat_core *) - let interpolate_or_concrete_model trs post = + let interpolate_or_concrete_model trs post = (* subst_model: rename skolem constants back to their appropriate names using reverse subscript table *) - let trs = List.map rename_skolems trs in - let sat_model model (symbols: Symbol.Set.t list) ss ss_inv = - let m = - List.fold_left (fun m' symbols -> - Symbol.Set.fold (fun s m -> + let trs = List.map rename_skolems trs in + let sat_model model (symbols: Symbol.Set.t list) ss ss_inv = + let m = + List.fold_left (fun m' symbols -> + Symbol.Set.fold (fun s m -> (* the provided model is over both subscripted vocabulary and original vocabulary *) - begin match Hashtbl.find_opt ss_inv s with + begin match Hashtbl.find_opt ss_inv s with | Some s' -> (* subscripted variable *) Interpretation.add s' (Interpretation.value model s) m | None -> (* non-subscripted; query directly *) - Interpretation.add s (Interpretation.value model s) m + Interpretation.add s (Interpretation.value model s) m end) symbols m' - ) (Interpretation.wrap srk (fun s -> - match Hashtbl.find_opt ss s with - | Some sss -> Interpretation.value model sss - | None -> `Real (Q.of_int 47))) (*(Interpretation.wrap srk (fun s -> - match Hashtbl.find_opt ss s with - | Some sss -> Interpretation.value model sss - | None -> Interpretation.value model s))*) (*(Interpretation.empty srk)*) symbols in + ) (Interpretation.wrap srk (fun s -> + match Hashtbl.find_opt ss s with + | Some sss -> Interpretation.value model sss + | None -> `Real (Q.of_int 47))) (*(Interpretation.wrap srk (fun s -> + match Hashtbl.find_opt ss s with + | Some sss -> Interpretation.value model sss + | None -> Interpretation.value model s))*) (*(Interpretation.empty srk)*) symbols in logf "hashtable length: %d\n" (Hashtbl.length ss_inv); - logf "%a" Interpretation.pp m; + logf "%a" Interpretation.pp m; Format.print_flush (); - (* symbols is a list of subscripted symbols arranged in left-to-right order. + (* symbols is a list of subscripted symbols arranged in left-to-right order. folding over this in left-to-right order amounts to forward concrete execution. *) - `Invalid (m - |> Interpretation.restrict + `Invalid (m + |> Interpretation.restrict (fun s -> - match Var.of_symbol s with - | Some _ -> true + match Var.of_symbol s with + | Some _ -> true | None -> false)) - in interpolate_query trs post sat_model @@ interpolate_unsat_core + in interpolate_query trs post sat_model @@ interpolate_unsat_core - let vocabulary tr = - let tr_guard = guard tr in - let tr_trans = transform tr in - let guard_v = tr_guard |> Syntax.symbols in - let trans_v = BatEnum.fold (fun s (var, term) -> - let s = Symbol.Set.add (Var.symbol_of var) s in - let t = Syntax.symbols term in + let vocabulary tr = + let tr_guard = guard tr in + let tr_trans = transform tr in + let guard_v = tr_guard |> Syntax.symbols in + let trans_v = BatEnum.fold (fun s (var, term) -> + let s = Symbol.Set.add (Var.symbol_of var) s in + let t = Syntax.symbols term in Symbol.Set.union s t) Symbol.Set.empty tr_trans in - let v = Symbol.Set.union guard_v trans_v in - let globals = Symbol.Set.filter (fun x -> - match Var.of_symbol x with + let v = Symbol.Set.union guard_v trans_v in + let globals = Symbol.Set.filter (fun x -> + match Var.of_symbol x with | Some var -> Var.is_global var - | None -> false ) v in - let locals = Symbol.Set.diff v globals in + | None -> false ) v in + let locals = Symbol.Set.diff v globals in (Symbol.Set.to_list globals, Symbol.Set.to_list locals) let contextualize t1 t2 t3 : [`Sat of t | `Unsat ] = - let t1 = rename_skolems t1 - in let t2 = rename_skolems t2 - in let t3 = rename_skolems t3 + let t1 = rename_skolems t1 + in let t2 = rename_skolems t2 + in let t3 = rename_skolems t3 in let subscript subscript_tbl sym = try Hashtbl.find subscript_tbl sym - with Not_found -> + with Not_found -> mk_const srk sym in (* preprocess each formula to get rid of certain undesirable things *) - let preprocess_formula f = + let preprocess_formula f = let pos_rewriter = Syntax.pos_rewriter srk in - f |> Syntax.eliminate_ite srk + f |> Syntax.eliminate_ite srk |> Syntax.eliminate_floor_mod_div srk - |> Syntax.rewrite srk ~down:pos_rewriter in + |> Syntax.rewrite srk ~down:pos_rewriter in (* Convert tr into a formula, and simultaneously update the subscript - table *) + table *) let to_ss_formula tr subscript_tbl reverse_subscript_tbl = let ss_guard = substitute_const srk (subscript subscript_tbl) (guard tr) in let (ss, phis) = @@ -712,118 +712,118 @@ struct tr.transform ([], [ ss_guard ]) in - List.iter (fun (k, v, l) -> + List.iter (fun (k, v, l) -> Hashtbl.add subscript_tbl k v; Hashtbl.add reverse_subscript_tbl l k) ss; mk_and srk phis |> preprocess_formula, Hashtbl.copy reverse_subscript_tbl - in let subscript_tbl = Hashtbl.create 991 - in let reverse_subscript_tbl = Hashtbl.create 991 - in let ss_t1, reverse_subscript_tbl1 = to_ss_formula t1 subscript_tbl reverse_subscript_tbl + in let subscript_tbl = Hashtbl.create 991 + in let reverse_subscript_tbl = Hashtbl.create 991 + in let ss_t1, reverse_subscript_tbl1 = to_ss_formula t1 subscript_tbl reverse_subscript_tbl in let ss_t2, reverse_subscript_tbl2 = to_ss_formula t2 subscript_tbl reverse_subscript_tbl in let ss_t3, _ = to_ss_formula t3 subscript_tbl reverse_subscript_tbl in let conj = mk_and srk [ss_t1; ss_t2; ss_t3] - in let is_global t x = - try - begin match Var.of_symbol (Hashtbl.find t x) with - | None -> false - | Some v -> - if Var.is_global v then begin - logf "symbol %s is global\n" (Syntax.show_symbol srk (Hashtbl.find reverse_subscript_tbl x)); true + in let is_global t x = + try + begin match Var.of_symbol (Hashtbl.find t x) with + | None -> false + | Some v -> + if Var.is_global v then begin + logf "symbol %s is global\n" (Syntax.show_symbol srk (Hashtbl.find reverse_subscript_tbl x)); true end else false end - with Not_found -> false + with Not_found -> false in let symbols_t1 = Syntax.symbols ss_t1 in let symbols_t2 = Syntax.symbols ss_t2 - in let symbols_t3 = Syntax.symbols ss_t3 + in let symbols_t3 = Syntax.symbols ss_t3 in let symbols_t1_t2 = Syntax.symbols ss_t1 (* symbols in t1 that are either globals _and_ in t2 are preserved during projection *) - |> Symbol.Set.filter + |> Symbol.Set.filter (fun x -> (is_global reverse_subscript_tbl1 x)) - in let symbols_t3_t2 = + in let symbols_t3_t2 = symbols_t3 (* symbols in t3 that are globals _and_ in t2, t1 are preserved during projection *) |> Symbol.Set.filter (fun x -> (is_global reverse_subscript_tbl2 x) && (Symbol.Set.mem x symbols_t2)) in let symbols_conj = Symbol.Set.union symbols_t1 (Symbol.Set.union symbols_t2 symbols_t3) in - let project srk (f1: 'a formula) (f3: 'a formula) symbols_f1 symbols_f3 all_symbols model = - let open Polyhedron in + let project srk (f1: 'a formula) (f3: 'a formula) symbols_f1 symbols_f3 all_symbols model = + let open Polyhedron in (* first do POS conversion on f1, f3 before computing their implicants *) (* rjf Mar '24: we do this as part of preprocessing to avoid rewriting the formula after an SMT query to get `model`*) (*let pos_rewriter = Syntax.pos_rewriter srk in - let f1 = Syntax.rewrite srk ~down:(pos_rewriter) f1 in - let f3 = Syntax.rewrite srk ~down:(pos_rewriter) f3 in*) + let f1 = Syntax.rewrite srk ~down:(pos_rewriter) f1 in + let f3 = Syntax.rewrite srk ~down:(pos_rewriter) f3 in*) let implicant_o1 = Interpretation.select_implicant model f1 in - let implicant_o2 = Interpretation.select_implicant model f3 in - match implicant_o1, implicant_o2 with + let implicant_o2 = Interpretation.select_implicant model f3 in + match implicant_o1, implicant_o2 with | Some f1, Some f2 -> let cube = of_cube srk (f1@f2) in let value_of_coord = (* coord (int) -> x (symbol) -> m[x] (value in R) *) fun coord -> - Syntax.symbol_of_int coord + Syntax.symbol_of_int coord |> Interpretation.real model - in let xs = + in let xs = Symbol.Set.diff all_symbols (Symbol.Set.union symbols_f1 symbols_f3) - |> Symbol.Set.elements - |> List.map Syntax.int_of_symbol - in let projected = local_project value_of_coord xs cube + |> Symbol.Set.elements + |> List.map Syntax.int_of_symbol + in let projected = local_project value_of_coord xs cube in cube_of srk projected |> Syntax.mk_and srk - | None, Some f -> + | None, Some f -> logf "contextualize: select_implicant failed on left formula: \n"; logf "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; logf "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; List.iteri (fun _ x -> logf "\n -- impicant of right formula:%a\n" (Syntax.pp_expr srk) x) f; logf "\n * model: %a\n" (Interpretation.pp) model; failwith "error extrapolating: select_implicant failed on left formula" - | Some f, None -> + | Some f, None -> logf "contextualize: select_implicant failed on right formula: \n"; logf "\n-- left formula: %a\n" (Syntax.pp_expr srk) f1; List.iteri (fun _ x -> logf "\n -- impicant of left formula:%a\n" (Syntax.pp_expr srk) x) f; logf "\n-- right formula:%a\n" (Syntax.pp_expr srk) f3; logf "\n * model: %a\n" (Interpretation.pp) model; failwith "error extrapolating: select_implicant failed on right formula" - | None, None -> + | None, None -> logf "left: %a\n" (Syntax.pp_expr srk) f1; Format.print_flush (); logf "right: %a\n" (Syntax.pp_expr srk) f3; - Format.print_flush (); + Format.print_flush (); logf "\n * model: %a\n" (Interpretation.pp) model; Format.print_flush (); - failwith "error extrapolating: select_implicant failed on both formulae" - in - match Smt.get_model ~symbols:(symbols_conj |> Symbol.Set.elements) srk conj with - | `Sat m -> - let prepost = project srk ss_t1 ss_t3 symbols_t1_t2 symbols_t3_t2 symbols_conj m in - let reverse_rename_t1 s = - begin match Hashtbl.find_opt reverse_subscript_tbl1 s with + failwith "error extrapolating: select_implicant failed on both formulae" + in + match Smt.get_model ~symbols:(symbols_conj |> Symbol.Set.elements) srk conj with + | `Sat m -> + let prepost = project srk ss_t1 ss_t3 symbols_t1_t2 symbols_t3_t2 symbols_conj m in + let reverse_rename_t1 s = + begin match Hashtbl.find_opt reverse_subscript_tbl1 s with | Some s' -> mk_const srk s' - | None -> mk_const srk s end in - let r_guard = substitute_const srk (reverse_rename_t1) prepost in - let r_transform = - (* for each skolem symbol in r_guard, see if it can be mapped back to a variable. *) - let r_symbols = Syntax.symbols r_guard |> Symbol.Set.to_list in - List.fold_left (fun m x -> - match Hashtbl.find_opt reverse_subscript_tbl x with - | Some y -> - begin match Var.of_symbol y with + | None -> mk_const srk s end in + let r_guard = substitute_const srk (reverse_rename_t1) prepost in + let r_transform = + (* for each skolem symbol in r_guard, see if it can be mapped back to a variable. *) + let r_symbols = Syntax.symbols r_guard |> Symbol.Set.to_list in + List.fold_left (fun m x -> + match Hashtbl.find_opt reverse_subscript_tbl x with + | Some y -> + begin match Var.of_symbol y with | Some var -> M.add var (mk_const srk x) m - | None -> m - end - | None -> m) M.empty r_symbols in + | None -> m + end + | None -> m) M.empty r_symbols in let r = {transform=r_transform; guard=r_guard} in `Sat r | `Unknown -> failwith "contextualize status unknown" - | `Unsat -> `Unsat + | `Unsat -> `Unsat (** underapproximate existential quantification. Given a transition formula tr over vocabulary X, use model-based projection to project out any variable v in X such that f(v) = false. *) - let project_mbp (f : var -> bool) tr = - let ss_to_sym = Hashtbl.create 991 in + let project_mbp (f : var -> bool) tr = + let ss_to_sym = Hashtbl.create 991 in (* preprocessing of a formula *) let preprocess f = - let pos_rewriter = Syntax.pos_rewriter srk in + let pos_rewriter = Syntax.pos_rewriter srk in f |> Syntax.eliminate_ite srk |> Syntax.eliminate_floor_mod_div srk - |> Syntax.rewrite srk ~down:pos_rewriter in + |> Syntax.rewrite srk ~down:pos_rewriter in let phis = M.fold (fun var term phis -> let var_sym = Var.symbol_of var in @@ -832,59 +832,59 @@ struct Hashtbl.add ss_to_sym var_ss_sym var_sym; (mk_eq srk var_ss_term term)::phis) tr.transform - [ guard tr ] in - let tr_formula = mk_and srk phis |> preprocess in - let tr_symbols = Syntax.symbols tr_formula in - let tr_symbols_preserved = - tr_symbols - |> Symbol.Set.filter (fun s -> - match Hashtbl.find_opt ss_to_sym s with - | Some sym -> - begin match Var.of_symbol sym with + [ guard tr ] in + let tr_formula = mk_and srk phis |> preprocess in + let tr_symbols = Syntax.symbols tr_formula in + let tr_symbols_preserved = + tr_symbols + |> Symbol.Set.filter (fun s -> + match Hashtbl.find_opt ss_to_sym s with + | Some sym -> + begin match Var.of_symbol sym with | Some v -> f v - | None -> false + | None -> false end - | None -> false (* discard any skolem constants *)) in - let tr_symbols_removed = Symbol.Set.diff tr_symbols tr_symbols_preserved in - let prj formula voc model = - let open Polyhedron in + | None -> false (* discard any skolem constants *)) in + let tr_symbols_removed = Symbol.Set.diff tr_symbols tr_symbols_preserved in + let prj formula voc model = + let open Polyhedron in (* first do POS conversion on [formula] before computing their implicants *) (* rjf Mar '24: This is done using the preprocess function defined above.*) (*let pos_rewriter = Syntax.pos_rewriter srk in - let formula' = - formula - |> Syntax.eliminate_ite srk - |> Syntax.eliminate_floor_mod_div srk + let formula' = + formula + |> Syntax.eliminate_ite srk + |> Syntax.eliminate_floor_mod_div srk |> Syntax.rewrite srk ~down:(pos_rewriter) in*) let implicant = Interpretation.select_implicant model formula in - match implicant with + match implicant with | Some i -> let cube = of_cube srk i in let value_of_coord = (* coord (int) -> x (symbol) -> m[x] (value in R) *) fun coord -> - Syntax.symbol_of_int coord + Syntax.symbol_of_int coord |> Interpretation.real model in let xs = (* coordinates to be projected out *) voc - |> Symbol.Set.elements - |> List.map Syntax.int_of_symbol - in let projected = local_project value_of_coord xs cube + |> Symbol.Set.elements + |> List.map Syntax.int_of_symbol + in let projected = local_project value_of_coord xs cube in cube_of srk projected |> Syntax.mk_and srk - | _ -> + | _ -> logf "\n--select_implicant formula: %a\n" (Syntax.pp_expr srk) formula; Format.print_flush (); logf "\n--select_implicant model: %a\n" (Interpretation.pp) model; Format.print_flush(); - failwith "error projecting: select_implicant returned None" - in match Smt.get_model ~symbols:(tr_symbols |> Symbol.Set.elements) srk tr_formula with - | `Sat m -> - let projected = prj tr_formula tr_symbols_removed m in - let tr_transform = - Hashtbl.fold (fun ss sym acc -> - let ss_term = mk_const srk ss in - match Var.of_symbol sym with + failwith "error projecting: select_implicant returned None" + in match Smt.get_model ~symbols:(tr_symbols |> Symbol.Set.elements) srk tr_formula with + | `Sat m -> + let projected = prj tr_formula tr_symbols_removed m in + let tr_transform = + Hashtbl.fold (fun ss sym acc -> + let ss_term = mk_const srk ss in + match Var.of_symbol sym with | Some v -> M.add v ss_term acc - | None -> failwith "u_exists: shoul not get here: subscript invariant broken") + | None -> failwith "u_exists: shoul not get here: subscript invariant broken") ss_to_sym M.empty in `Sat {guard=projected;transform=tr_transform} @@ -944,17 +944,17 @@ struct - let contains_havoc tr = - M.fold (fun _ rhs acc -> - if acc then acc - else begin - Symbol.Set.fold - (fun s acc -> - match Var.of_symbol s with - | Some _ -> acc + let contains_havoc tr = + M.fold (fun _ rhs acc -> + if acc then acc + else begin + Symbol.Set.fold + (fun s acc -> + match Var.of_symbol s with + | Some _ -> acc | None -> true || acc) (Syntax.symbols rhs) false end - ) tr.transform false + ) tr.transform false let linearize tr = let (transform, defs) = From c20d16ab2bb9a87da4795c180f86a8c9c9f37da5 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Thu, 24 Apr 2025 14:38:29 -0400 Subject: [PATCH 35/59] Removed unncessary ref cells --- duet/gps.ml | 153 ++++++++++++++++++------------------ duet/reachTree.ml | 189 ++++++++++++++++++++++----------------------- duet/reachTree.mli | 50 ++++++------ 3 files changed, 196 insertions(+), 196 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index f1ba5b12..03de26ce 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -258,7 +258,7 @@ module GPS = struct module PT = struct type t = { summary : int -> K.t - ; art : ReachTree.t ref } + ; art : ReachTree.t } type node = ReachTree.node type state = ReachTree.state let expand pt node = ReachTree.expand pt.art node @@ -306,14 +306,14 @@ module GPS = struct id : ProcName.t; cfg : Graph.t; pre_state : Ctx.t Syntax.formula; - mutable art : ReachTree.t ref; + mutable art : ReachTree.t; mutable worklist : ReachTree.node DQ.t; mutable execlist : (ReachTree.node * Ctx.t Interpretation.interpretation) DQ.t; - global_ctx : global_context ref; + global_ctx : global_context; } (* global context *) (** some helper functions that operate on the context *) - let get_summarizer ctx = !(!ctx.global_ctx).g_summarizer + let get_summarizer ctx = ctx.global_ctx.g_summarizer let log_labelled_weights ctx uu prefix weights = List.iteri @@ -322,8 +322,8 @@ module GPS = struct | Call (u, v) -> let p = begin match uu with - | OverApprox -> Summarizer.over_proc_summary !ctx.g_summarizer (ProcName.make (u, v)) - | UnderApprox -> Summarizer.under_proc_summary !ctx.g_summarizer (ProcName.make (u, v)) + | OverApprox -> Summarizer.over_proc_summary ctx.g_summarizer (ProcName.make (u, v)) + | UnderApprox -> Summarizer.under_proc_summary ctx.g_summarizer (ProcName.make (u, v)) end in logf "[labelled weight] %s(%i, call(%d,%d)): %a\n" prefix i u v K.pp p | Weight w -> @@ -367,20 +367,20 @@ module GPS = struct K.construct (Syntax.substitute_const srk substitute (Syntax.mk_not srk f)) (ValueHT.to_seq sym_map |> List.of_seq) - let mk_intra_context (gctx: global_context ref) ((src,tgt): ProcName.t) (query: K.t) = + let mk_intra_context (gctx: global_context) ((src,tgt): ProcName.t) (query: K.t) = let pre_state, equalities = demote_precondition query in let target_summary v = K.mul - (Summarizer.path_weight_intra !gctx.g_summarizer v tgt) + (Summarizer.path_weight_intra gctx.g_summarizer v tgt) (K.assume equalities) in - let tgt' = !gctx.g_errloc in + let tgt' = gctx.g_errloc in let graph = - Graph.{ graph = WG.add_edge (!gctx.g_graph) tgt (Weight (K.assume equalities)) tgt' - ; call_summary = Summarizer.over_proc_summary !gctx.g_summarizer + Graph.{ graph = WG.add_edge (gctx.g_graph) tgt (Weight (K.assume equalities)) tgt' + ; call_summary = Summarizer.over_proc_summary gctx.g_summarizer ; target_summary = target_summary } in - ref { + { id = (src,tgt'); cfg = graph; pre_state = pre_state; @@ -394,16 +394,16 @@ module GPS = struct (** place an element in front of the deque (worklist) *) let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i - let rec art_cfg_path_pair (ctx: intra_context ref) (p: ReachTree.node list) = + let rec art_cfg_path_pair (ctx: intra_context) (p: ReachTree.node list) = match p with | u :: v :: t -> - let u_vtx = ReachTree.maps_to !ctx.art u in - let v_vtx = ReachTree.maps_to !ctx.art v in + let u_vtx = ReachTree.maps_to ctx.art u in + let v_vtx = ReachTree.maps_to ctx.art v in (u, (u_vtx, v_vtx), v) :: (art_cfg_path_pair ctx (v :: t)) | _ -> [] (* turn tree path into a sequence of CFG edges. *) - let cfg_path (ctx: intra_context ref) (p : ReachTree.node list) = + let cfg_path (ctx: intra_context) (p : ReachTree.node list) = art_cfg_path_pair ctx p |> List.map (fun (_, (u, v), _) -> (u, v)) @@ -421,10 +421,10 @@ module GPS = struct List.iter (fun x -> logf " %s %s\n" (Syntax.show_symbol srk x) (vname x)) l_vocab (* CFG path condition from art.src -> art.v *) - let path_condition (ctx: intra_context ref) condition_type (v: ReachTree.node) = - let art = !ctx.art in + let path_condition (ctx: intra_context) condition_type (v: ReachTree.node) = + let art = ctx.art in let art_nodes = ReachTree.tree_path art v in - let ts = !ctx.cfg.Graph.graph in + let ts = ctx.cfg.Graph.graph in let cfg_nodes = List.map (fun x -> ReachTree.maps_to art x) art_nodes in let rec to_weights l : K.t label list = match l with @@ -446,31 +446,32 @@ module GPS = struct end | Weight w -> w) (to_weights cfg_nodes) in logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); - let l = (K.assume !ctx.pre_state) :: pathcond in + let l = (K.assume ctx.pre_state) :: pathcond in log_weights "path conditions " l; l (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) - let interpolate_or_get_model (ctx: intra_context ref) (src : ReachTree.node) = - let src_v = ReachTree.maps_to !ctx.art src in - let suffix = K.guard (Graph.summary !ctx.cfg src_v) |> Syntax.mk_not srk in + let interpolate_or_get_model (ctx: intra_context) (src : ReachTree.node) = + let src_v = ReachTree.maps_to ctx.art src in + let suffix = K.guard (Graph.summary ctx.cfg src_v) |> Syntax.mk_not srk in let prefix = path_condition ctx OverApprox src in log_weights "\nprefix " prefix; log_formulas "\nsuffix " [suffix]; logf "\n"; K.interpolate_or_concrete_model prefix suffix - let get_global_ctx (ctx: intra_context ref) = (!ctx.global_ctx) + let get_global_ctx (ctx: intra_context) = ctx.global_ctx (* refine path to (tree) node v. Returns `Failure (u, m) with (u, m) being a new item to the concolic worklist if unable to refine. Returns `Success if refine is able to refine. *) - let mc_refine (ctx: intra_context ref) (v: ReachTree.node) = + let mc_refine (ctx: intra_context) (v: ReachTree.node) = logf "refining node %d\n" (ReachTree.of_node v); let handle_failure v m = logf " *********************** REFINEMENT FAILED *************************\n"; let path_condition = path_condition ctx OverApprox v in `Failure (m, path_condition) - in let art = !ctx.art in + in + let art = ctx.art in let path = ReachTree.tree_path art v in match interpolate_or_get_model ctx v with `Invalid v_model -> @@ -482,34 +483,34 @@ module GPS = struct logf "--- mc_refine: interpolation succeeded. path length %d, interpolant length %d" (List.length path) (List.length interpolants); log_formulas "interpolants - " interpolants; ReachTree.refine art path interpolants - |> List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist); + |> List.iter (fun x -> ctx.worklist <- worklist_push x ctx.worklist); `Success (* concolic phase of our model checking algorithm *) - let concolic_phase (ctx: intra_context ref) = + let concolic_phase (ctx: intra_context) = let round ctx = - match DQ.front (!ctx.execlist) with + match DQ.front (ctx.execlist) with | Some ((u, u_model), w) -> if print_tree then (* XXX: if this is enabled, the performance penalty is huge. *) - ReachTree.log_art !ctx.art; - logf " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); - !ctx.execlist <- w; - if (ReachTree.maps_to !ctx.art u) = (ReachTree.get_err_loc !ctx.art) then begin + ReachTree.log_art ctx.art; + logf " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to ctx.art u); + ctx.execlist <- w; + if (ReachTree.maps_to ctx.art u) = (ReachTree.get_err_loc ctx.art) then begin logf " *** found potential path-to-error, checking if prophesized pre-condition is sat...\n"; logf " *** SAT, done\n"; `ErrorReached u end else begin - logf "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to !ctx.art u); + logf "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to ctx.art u); log_model "" u_model; - let new_concolic_nodes, new_frontier_nodes = ReachTree.expand !ctx.art u u_model in - List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; - List.iter (fun frontier_node -> !ctx.worklist <- worklist_push frontier_node !ctx.worklist) new_frontier_nodes; + let new_concolic_nodes, new_frontier_nodes = ReachTree.expand ctx.art u u_model in + List.iter (fun concolic_node -> ctx.execlist <- worklist_push concolic_node ctx.execlist) new_concolic_nodes; + List.iter (fun frontier_node -> ctx.worklist <- worklist_push frontier_node ctx.worklist) new_frontier_nodes; `Continue end | None -> failwith "err: concolic_phase is reading from empty execution worklist" (* cannot happen *) in let rtn = ref `Continue in - while !rtn = `Continue && ((DQ.size !ctx.execlist) > 0) do + while !rtn = `Continue && ((DQ.size ctx.execlist) > 0) do rtn := round ctx done; match !rtn with @@ -518,19 +519,19 @@ module GPS = struct (* refinement phase of our model checking algorithm *) - let refinement_phase (ctx: intra_context ref) = + let refinement_phase (ctx: intra_context) = let worklist_push_all ls = - List.iter (fun x -> !ctx.worklist <- worklist_push x !ctx.worklist) ls in - match DQ.front (!ctx.worklist) with + List.iter (fun x -> ctx.worklist <- worklist_push x ctx.worklist) ls in + match DQ.front (ctx.worklist) with | Some (u, w) -> if print_tree then - ReachTree.log_art !ctx.art; - !ctx.worklist <- w; + ReachTree.log_art ctx.art; + ctx.worklist <- w; (* Fetched tree node u from work list. First attempt to close it. *) - if not (ReachTree.is_covered !ctx.art u) then + if not (ReachTree.is_covered ctx.art u) then begin logf " uncovered. try close %d\n" (ReachTree.of_node u); - begin match ReachTree.lclose !ctx.art u with (* Close succeeded. No need to further explore it. *) + begin match ReachTree.lclose ctx.art u with (* Close succeeded. No need to further explore it. *) | true, leaves -> logf "Close succeeded.\n"; worklist_push_all leaves; @@ -542,16 +543,16 @@ module GPS = struct | `Success -> (* refinement succeeded *) logf "refinement_phase: refinement succeeded\n"; (* for every node along path of refinement try close *) - let path = ReachTree.tree_path !ctx.art u in + let path = ReachTree.tree_path ctx.art u in List.iter - (fun x -> let (_, ls) = ReachTree.close !ctx.art x in + (fun x -> let (_, ls) = ReachTree.close ctx.art x in worklist_push_all ls) path; `Continue | `Failure (u_m, _) -> - !ctx.execlist <- worklist_push (u, u_m) !ctx.execlist; (* put u onto execlist since it now has a model. *) + ctx.execlist <- worklist_push (u, u_m) ctx.execlist; (* put u onto execlist since it now has a model. *) (* for every node along path of refinement try close *) - let path = ReachTree.tree_path !ctx.art u in - List.iter (fun x -> let (_, ls) = ReachTree.close !ctx.art x in + let path = ReachTree.tree_path ctx.art u in + List.iter (fun x -> let (_, ls) = ReachTree.close ctx.art x in worklist_push_all ls) path ; `Continue end @@ -564,8 +565,8 @@ module GPS = struct | None -> failwith "refinement_phase: encountered an empty worklist for refinement\n" (* cannot happen *) - let extract_refinement (ctx: intra_context ref) = - let art = !ctx.art in + let extract_refinement (ctx: intra_context) = + let art = ctx.art in let rfn = ReachTree.label art ReachTree.root |> promote in log_weights "refinement: " [rfn]; K.exists (fun v -> V.is_global v) (rfn) @@ -587,7 +588,7 @@ module GPS = struct logf "\nlength of right path: %d" (List.length right); logf "\nPrinting left path... \n"; - log_labelled_weights !ctx.global_ctx UnderApprox "left path - " left; + log_labelled_weights ctx.global_ctx UnderApprox "left path - " left; logf "error: handle_path_to_error: cannot project path condition" ; `Safe in let handle_left_case caller_id = @@ -617,7 +618,7 @@ module GPS = struct begin match K.contextualize prefix summary suffix with | `Sat query -> let answer = - mk_intra_context (!ctx.global_ctx) (ProcName.make (src, dst)) query + mk_intra_context (ctx.global_ctx) (ProcName.make (src, dst)) query |> intraproc_check in begin match answer with | Safe r -> @@ -646,21 +647,21 @@ module GPS = struct end - and intraproc_check (ctx: intra_context ref) : mc_result = + and intraproc_check (ctx: intra_context) : mc_result = let continue = ref true in let state = ref `Continue in - !ctx.worklist <- worklist_push (ReachTree.root) !ctx.worklist; - while !continue && (DQ.size (!ctx.worklist) > 0 || DQ.size (!ctx.execlist) > 0) do - if DQ.size (!ctx.execlist) > 0 then begin + ctx.worklist <- worklist_push (ReachTree.root) ctx.worklist; + while !continue && (DQ.size (ctx.worklist) > 0 || DQ.size (ctx.execlist) > 0) do + if DQ.size (ctx.execlist) > 0 then begin (* concolic phase *) begin match concolic_phase ctx with | `Unsafe w -> - logf "--- GPS: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to !ctx.art w); + logf "--- GPS: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to ctx.art w); logf " --- forming path to error... \n"; let has_calls, path_to_w = - ReachTree.tree_path !ctx.art w + ReachTree.tree_path ctx.art w |> art_cfg_path_pair ctx - |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight !ctx.cfg.Graph.graph u_vtx v_vtx, v)) + |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight ctx.cfg.Graph.graph u_vtx v_vtx, v)) |> List.fold_left (fun (has_call, l) (u, w, v) -> match w with | Call _ -> (true, (u, w, v) :: l) @@ -673,7 +674,7 @@ module GPS = struct begin match handle_path_to_error ctx [] curr right `Right w with | `Safe -> (* path-to-error concretization failed. frontier_node is the src node of a call-edge. *) (* we can mark `w` as a frontier node to be refined, and continue. *) - !ctx.worklist <- worklist_push w !ctx.worklist; + ctx.worklist <- worklist_push w ctx.worklist; continue := true | `Unsafe pathcond -> logf "--- GPS: managed to concretize an intraprocedural path-to-error. returning... "; @@ -705,9 +706,9 @@ module GPS = struct let execute (ts : cfg_t) (entry : int) (err_loc : int) (enable_summary:bool) : mc_result = let gctx = - ref { g_graph = ts - ; g_summarizer = Summarizer.init ts entry err_loc enable_summary - ; g_errloc = err_loc } + { g_graph = ts + ; g_summarizer = Summarizer.init ts entry err_loc enable_summary + ; g_errloc = err_loc } in (* interproc_graph represents the language of interprocedural paths from entry to err_loc (including interprocedural paths that make calls that @@ -724,19 +725,19 @@ module GPS = struct in let graph = Graph.{ graph = interproc_graph - ; call_summary = Summarizer.over_proc_summary !gctx.g_summarizer - ; target_summary = Summarizer.path_weight_inter !gctx.g_summarizer } + ; call_summary = Summarizer.over_proc_summary gctx.g_summarizer + ; target_summary = Summarizer.path_weight_inter gctx.g_summarizer } in let main_context = - ref { - id = (entry,err_loc); - cfg = graph; - pre_state = Ctx.mk_true; - worklist = DQ.empty; - execlist = DQ.empty; - art = ReachTree.make graph entry err_loc; - global_ctx = gctx; - } + { + id = (entry,err_loc); + cfg = graph; + pre_state = Ctx.mk_true; + worklist = DQ.empty; + execlist = DQ.empty; + art = ReachTree.make graph entry err_loc; + global_ctx = gctx; + } in logf "executing GPS: start\n"; intraproc_check main_context diff --git a/duet/reachTree.ml b/duet/reachTree.ml index e6a820fa..4f32dd40 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -98,56 +98,55 @@ struct let root = 0 let make (g : G.t) (entry : G.vertex) (err_loc : G.vertex) = - ref - { - graph = g; - entry; - err_loc; - vtxcnt = 1; - cfg_vertex = IntMap.add 0 entry IntMap.empty; - parents = IntMap.add 0 (-1) IntMap.empty; - labels = IntMap.add 0 L.top IntMap.empty; - children = IntMap.add 0 [] IntMap.empty; - covers = IntMap.empty; (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) - reverse_covers = IntMap.empty; (* for each v, store the v's that cover it: i.e. cover[v] *) - precedent_nodes = VertexMap.empty; - leaves = ISet.empty; - } - - let get_err_loc (art : t ref) = !art.err_loc - let get_entry (art: t ref) = !art.entry + { + graph = g; + entry; + err_loc; + vtxcnt = 1; + cfg_vertex = IntMap.add 0 entry IntMap.empty; + parents = IntMap.add 0 (-1) IntMap.empty; + labels = IntMap.add 0 L.top IntMap.empty; + children = IntMap.add 0 [] IntMap.empty; + covers = IntMap.empty; (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) + reverse_covers = IntMap.empty; (* for each v, store the v's that cover it: i.e. cover[v] *) + precedent_nodes = VertexMap.empty; + leaves = ISet.empty; + } + + let get_err_loc (art : t) = art.err_loc + let get_entry (art: t) = art.entry (** [print_tree t ident v] prints an ART t with indentation `ident` rooted at node v *) - let print_tree (art : t ref) (indent : string) (v : node) = - let rec print_tree_ (art : t ref) indent v = + let print_tree (art : t) (indent : string) (v : node) = + let rec print_tree_ (art : t) indent v = logf "%s|" indent; logf "%s+-%d(%a)" indent v - G.pp_vertex (IntMap.find v !art.cfg_vertex); + G.pp_vertex (IntMap.find v art.cfg_vertex); List.iter (fun x -> print_tree_ art (indent ^ " ") x) - (IntMap.find_default [] v !art.children) + (IntMap.find_default [] v art.children) in logf "*"; print_tree_ art indent v (* [parent t i] gets parent of node i in tree t. *) - let parent (art : t ref) (i : node) : node = IntMap.find i !art.parents + let parent (art : t) (i : node) : node = IntMap.find i art.parents (* [t %-> i]: get CFG vertex mapped by node i in tree t. *) - let maps_to (art : t ref) (i : node) : G.vertex = - try IntMap.find i !art.cfg_vertex + let maps_to (art : t) (i : node) : G.vertex = + try IntMap.find i art.cfg_vertex with _ -> failwith @@ Printf.sprintf "maps_to: not found tree node %d\n" i - let parent_weight (art : t ref) (i : node) = - let parent = IntMap.find i !art.parents in + let parent_weight (art : t) (i : node) = + let parent = IntMap.find i art.parents in if parent < 0 then None else - Some (parent, G.weight !art.graph (maps_to art parent) (maps_to art i)) + Some (parent, G.weight art.graph (maps_to art parent) (maps_to art i)) (* [tree_path t u] returns list of tree nodes that form the corrsp. tree path from root of t to tree node u *) - let tree_path (art : t ref) ?(src=root) (u : node) : node list = + let tree_path (art : t) ?(src=root) (u : node) : node list = let rec tree_path_rev art u = if u = root || u = src then [ u ] else u :: tree_path_rev art (parent art u) @@ -155,73 +154,73 @@ struct List.rev @@ tree_path_rev art u (* [children t v] returns children of tree node v in tree t. *) - let children (art : t ref) (v : node) : node list = - IntMap.find v !art.children + let children (art : t) (v : node) : node list = + IntMap.find v art.children (* [descendants t v] returns descendants of tree node v in tree t in DFS order. *) - let rec descendants (art : t ref) (v : node) : node list = + let rec descendants (art : t) (v : node) : node list = let v_children = children art v in v :: List.fold_left (fun l ch -> descendants art ch @ l) [] v_children (* return leaves of the tree. *) - let leaves (art : t ref) : node list = - !art.leaves |> ISet.to_list + let leaves (art : t) : node list = + art.leaves |> ISet.to_list (* is a node in tree a leaf? *) - let is_leaf (art : t ref) (v : node) : bool = + let is_leaf (art : t) (v : node) : bool = let chs = children art v in List.length chs == 0 (* [label t v] returns the node label of tree node v in tree t. *) - let label (art : t ref) (v : node) : L.t = IntMap.find v !art.labels + let label (art : t) (v : node) : L.t = IntMap.find v art.labels (* (replaces) sets a label at v *) - let set_label (art : t ref) (v : node) (lbl : L.t) = - !art.labels <- IntMap.add v lbl !art.labels + let set_label (art : t) (v : node) (lbl : L.t) = + art.labels <- IntMap.add v lbl art.labels (* [get_precedent_nodes t v] retrieves a sequence of precedent nodes of tree node vin preorder in tree t. *) (* the list of precedent nodes for a cfg vertex is a list of tree nodes which map to the same cfg location, ordered by < on integers. *) - let get_precedent_nodes (art : t ref) (v : node) = + let get_precedent_nodes (art : t) (v : node) = let cfg_vertex = maps_to art v in let precedents_set = - VertexMap.find_default ISet.empty cfg_vertex !art.precedent_nodes + VertexMap.find_default ISet.empty cfg_vertex art.precedent_nodes in ISet.elements precedents_set (** retrieves a new ART node ID, ensuring all ART nodes have distinct IDs in increasing order according to their creation *) - let get_id (art : t ref) : node = - let new_id = !art.vtxcnt in - !art.vtxcnt <- !art.vtxcnt + 1; + let get_id (art : t) : node = + let new_id = art.vtxcnt in + art.vtxcnt <- art.vtxcnt + 1; new_id (* [update_leaf art x] attempts to update leaf structure; if x is a leaf then x is marked as leaf, otherwise x is unmarked as leaf. *) - let update_leaf (art: t ref) (x: node) = + let update_leaf (art: t) (x: node) = if is_leaf art x then - !art.leaves <- ISet.add x !art.leaves + art.leaves <- ISet.add x art.leaves else - !art.leaves <- ISet.remove x !art.leaves + art.leaves <- ISet.remove x art.leaves (* Add new tree leaf mapping to CFG vertex v and with parent tree node p. *) - let add_tree_vertex (art : t ref) ?(label = L.top) (v : G.vertex) + let add_tree_vertex (art : t) ?(label = L.top) (v : G.vertex) (p : node) = - (* sequentially add v to the lists, indexed by !vtxcnt *) + (* sequentially add v to the lists, indexed by vtxcnt *) let new_vertex = get_id art in (* note that new_vertex refers to a new tree vertex, where as v is a corresp. cfg location. *) - !art.cfg_vertex <- IntMap.add new_vertex v !art.cfg_vertex; - !art.parents <- IntMap.add new_vertex p !art.parents; - !art.labels <- IntMap.add new_vertex label !art.labels; - !art.children <- IntMap.add new_vertex [] !art.children; - (* set children of parent to be !vtxcnt :: children. *) + art.cfg_vertex <- IntMap.add new_vertex v art.cfg_vertex; + art.parents <- IntMap.add new_vertex p art.parents; + art.labels <- IntMap.add new_vertex label art.labels; + art.children <- IntMap.add new_vertex [] art.children; + (* set children of parent to be vtxcnt :: children. *) if p >= 0 then - !art.children <- - IntMap.add p (new_vertex :: IntMap.find p !art.children) !art.children; + art.children <- + IntMap.add p (new_vertex :: IntMap.find p art.children) art.children; (* Add v to precedent_nodes. *) let precedent_nodes = - VertexMap.find_default ISet.empty v !art.precedent_nodes + VertexMap.find_default ISet.empty v art.precedent_nodes |> ISet.add new_vertex in - !art.precedent_nodes <- - VertexMap.add v precedent_nodes !art.precedent_nodes; + art.precedent_nodes <- + VertexMap.add v precedent_nodes art.precedent_nodes; update_leaf art p; update_leaf art new_vertex; new_vertex @@ -238,7 +237,7 @@ struct is the identity transition. More specifically, for each out-neighbor u of G(v), we first test if m /\ tr is SAT, if so, then this out-neighbor is non-frontier. Otherwise, this out neighbor is a frontier. *) - let expand (art: t ref) (v: node) (m: T.state) = + let expand (art: t) (v: node) (m: T.state) = let vg = maps_to art v in let new_concolic_nodes, new_frontier_nodes = (ref [], ref []) in (* visit out-neighbors of v *) @@ -246,7 +245,7 @@ struct (fun (_, weight, y) -> let weight = if T.is_deterministic weight then weight - else T.mul weight (T.assume @@ T.guard @@ G.summary !art.graph y) + else T.mul weight (T.assume @@ T.guard @@ G.summary art.graph y) in match T.post_model m weight with | Some y_model -> @@ -255,7 +254,7 @@ struct | None -> let new_node = add_tree_vertex art y v in new_frontier_nodes := new_node :: !new_frontier_nodes) - !art.graph vg; + art.graph vg; (* make it FIFO *) (List.rev !new_concolic_nodes, List.rev !new_frontier_nodes) @@ -265,7 +264,7 @@ struct (* for w that is an ancestor/precedent of v, *) (* Adds (v -> w) to covering relation if possible and returns true, false otherwise. *) (* note that (v, w) in covering if stateLabel(v) IMPLIES stateLabel(w) *) - let cover (art : t ref) v w = + let cover (art : t) v w = let v_label = label art v in let w_label = label art w in if maps_to art v <> maps_to art w then @@ -280,11 +279,11 @@ struct log_formulas " v label " [ v_label ]; log_formulas " w label " [ w_label ]; let reverse_covers_w = - IntMap.find_default ISet.empty w !art.reverse_covers + IntMap.find_default ISet.empty w art.reverse_covers in - !art.covers <- IntMap.add v w !art.covers; - !art.reverse_covers <- - IntMap.add w (ISet.add v reverse_covers_w) !art.reverse_covers; + art.covers <- IntMap.add v w art.covers; + art.reverse_covers <- + IntMap.add w (ISet.add v reverse_covers_w) art.reverse_covers; true end else false @@ -292,7 +291,7 @@ struct (* it returns (`true`, wl) iff covering succeeds at v and wl is a worklist of nodes to be refined. *) (** [close art v] visits precedents of v in tree and attempts to derive covering relations from v. *) - let close (art : t ref) (v : node) = + let close (art : t) (v : node) = (* A _precedent_ of v in tree is any vertex u v then ( (* xs = {x | x -> y} *) let xs = - IntMap.find_default ISet.empty y !art.reverse_covers + IntMap.find_default ISet.empty y art.reverse_covers in (* Iterate through and remove pairs (x, y) from covering relation. *) - (* Step 1: Remove (x |-> y) from !ptt.covers. *) + (* Step 1: Remove (x |-> y) from ptt.covers. *) ISet.iter - (fun x -> !art.covers <- IntMap.remove x !art.covers) + (fun x -> art.covers <- IntMap.remove x art.covers) xs; - (* Step 2: Remove (y |-> xs) from !pthit.reverse_covers. *) - !art.reverse_covers <- IntMap.remove y !art.reverse_covers; + (* Step 2: Remove (y |-> xs) from pthit.reverse_covers. *) + art.reverse_covers <- IntMap.remove y art.reverse_covers; (* Step 3: add xs to worklist. *) ISet.iter (fun _x -> @@ -346,15 +345,15 @@ struct result (* Checks if tree node v is covered. It is covered if its ancestors or it is in covering relation. *) - let rec is_covered (art : t ref) v = - match IntMap.find_opt v !art.covers with + let rec is_covered (art : t) v = + match IntMap.find_opt v art.covers with | None -> if v == 0 then false else is_covered art (parent art v) | Some u -> logf " | covered by %d\n" u; true (* refine the label of each tree node u along path from tree root to v. *) - let refine (art : t ref) path interpolants : node list = + let refine (art : t) path interpolants : node list = let worklist = ref [] in List.iter2 (fun u interpolant -> @@ -365,9 +364,9 @@ struct G.pp_vertex (maps_to art u)) [ u_label' ]; set_label art u u_label'; - (* remove ( * -> u) in covering relation; we just refined label(u) so implications of form label(y)->label(u) + (* remove ( * -> u) in covering relation; we justined label(u) so implications of form label(y)->label(u) might not hold anymore. *) - match IntMap.find_opt u !art.reverse_covers with + match IntMap.find_opt u art.reverse_covers with | None -> () | Some l -> (* remove covers (List.iter (fun x -> Printf.printf " (%d->%d)" x u) l *) @@ -387,7 +386,7 @@ struct (* remove (x, u) from covering. *) logf " refine: removing cover (%d->%d)\n" x u; - !art.covers <- IntMap.remove x !art.covers; + art.covers <- IntMap.remove x art.covers; (* add x's subtree leaves back to the worklist. *) (* Zak: TODO: This adds *all* leaves back to the worklist *) let x_leaves = leaves art in @@ -404,7 +403,7 @@ struct l ISet.empty in - !art.reverse_covers <- IntMap.add u u_coverers !art.reverse_covers) + art.reverse_covers <- IntMap.add u u_coverers art.reverse_covers) path interpolants; !worklist @@ -417,7 +416,7 @@ struct (* convention: w is an ancestor of v. returns true if we can add (v, w) to covers such that label(v) |= label(w) *) - let force_cover (art : t ref) v w = (* check if v_label -> w_label where v is an ancestor at w *) + let force_cover (art : t) v w = (* check if v_label -> w_label where v is an ancestor at w *) if maps_to art v <> maps_to art w then (false, []) else begin logf "force_cover(%d, %d)\n" v w; @@ -428,7 +427,7 @@ struct artpath |> glue |> List.map (fun (x, y) -> - G.weight !art.graph (maps_to art x) (maps_to art y)) + G.weight art.graph (maps_to art x) (maps_to art y)) in match T.check w_label path_weights w_label with | `Valid itps -> @@ -436,7 +435,7 @@ struct if cover art v w then (true, new_frontiers) else - failwith "error: force_cover is buggy!" + failwith "error: force_cover is buggy" | `Invalid _ -> (false, []) | `Unknown -> failwith "force_cover: interpolation failed with status UNKNOWN." @@ -444,7 +443,7 @@ struct (** a more lightweight version of close *) - let lclose (art: t ref) v = + let lclose (art: t) v = let rec go u = if u = -1 then (false, []) else begin @@ -470,12 +469,12 @@ struct (** TODO: [deprecated] procedures for lightweight verification of ART invariants *) - let _verify_well_labelled_tree (t : t ref) = + let _verify_well_labelled_tree (t : t) = let rec aux v = let children = children t v in match children with | [] (* leaf node *) -> ( - match IntMap.find_opt v !t.covers with + match IntMap.find_opt v t.covers with | None -> logf "!!! found uncovered leaf: %d\n" v; G.fold_succ @@ -486,10 +485,10 @@ struct G.pp_vertex (maps_to t v) G.pp_vertex y; false) - !t.graph (maps_to t v) true + t.graph (maps_to t v) true | Some _ -> true) | _ -> ( - match IntMap.find_opt v !t.covers with + match IntMap.find_opt v t.covers with | None -> logf "node %d uncovered\n" v; List.fold_left (fun acc u -> aux u && acc) true children @@ -502,25 +501,25 @@ struct logf "...done verifying well-labelledness of ART\n"; r - let _check_covering_welformedness (t : t ref) = + let _check_covering_welformedness (t : t) = logf "checking welformedness of covering relations\n"; IntMap.iter (fun dst covered_from -> ISet.iter (fun src -> logf "checking if (%d, %d) in covering\n" src dst; - match IntMap.find_opt src !t.covers with + match IntMap.find_opt src t.covers with | Some dst' -> if dst' <> dst then failwith @@ Printf.sprintf "ERROR: (%d, %d) in covering\n" src dst' | None -> failwith "ERROR: not in covering") covered_from) - !t.reverse_covers; + t.reverse_covers; logf "performing a reverse check\n"; IntMap.iter (fun src dst -> - match IntMap.find_opt dst !t.reverse_covers with + match IntMap.find_opt dst t.reverse_covers with | Some reverse_covers -> ( match ISet.mem src reverse_covers with | false -> @@ -536,17 +535,17 @@ struct "ERROR: (%d, %d) in t.covers but no list found in \ reverse_covers\n" src dst) - !t.covers; + t.covers; logf "...done checking welformedness of covering relations\n" (** pretty-printing functionalities *) - let tree_printer_get_name (art : t ref) i = - match IntMap.find_opt i !art.covers with + let tree_printer_get_name (art : t) i = + match IntMap.find_opt i art.covers with | None -> Format.asprintf "%d(%a)" i G.pp_vertex (maps_to art i) | Some j -> Format.asprintf "[%d(%a)]->%d" i G.pp_vertex (maps_to art i) j - let log_art (art : t ref) = + let log_art (art : t) = logf " +----------------- ART ----------------+\n"; let string_of_art = Tree_printer.to_string ~line_prefix:"* " diff --git a/duet/reachTree.mli b/duet/reachTree.mli index a68e640d..c81b9494 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -42,33 +42,33 @@ module ART type state = T.state type weight = T.t exception Mexception of string - val make : G.t -> G.vertex -> G.vertex -> t ref - val get_entry : t ref -> G.vertex - val get_err_loc : t ref -> G.vertex - val print_tree : t ref -> string -> node -> unit - val parent : t ref -> node -> node - val parent_weight : t ref -> node -> (node * weight) option - val maps_to : t ref -> node -> G.vertex - val tree_path : t ref -> ?src:node -> node -> node list - val children : t ref -> node -> node list - val descendants : t ref -> node -> node list - val leaves : t ref -> node list - val is_leaf : t ref -> node -> bool - val label : t ref -> node -> L.t - val set_label : t ref -> node -> L.t -> unit - val get_precedent_nodes : t ref -> node -> node list - val get_id : t ref -> node + val make : G.t -> G.vertex -> G.vertex -> t + val get_entry : t -> G.vertex + val get_err_loc : t -> G.vertex + val print_tree : t -> string -> node -> unit + val parent : t -> node -> node + val parent_weight : t -> node -> (node * weight) option + val maps_to : t -> node -> G.vertex + val tree_path : t -> ?src:node -> node -> node list + val children : t -> node -> node list + val descendants : t -> node -> node list + val leaves : t -> node list + val is_leaf : t -> node -> bool + val label : t -> node -> L.t + val set_label : t -> node -> L.t -> unit + val get_precedent_nodes : t -> node -> node list + val get_id : t -> node val add_tree_vertex : - t ref -> ?label:L.t -> G.vertex -> int -> node + t -> ?label:L.t -> G.vertex -> int -> node val expand : - t ref -> node -> T.state -> (node * T.state) list * node list - val cover : t ref -> node -> node -> bool - val close : t ref -> node -> (bool * node list) - val force_cover : t ref -> node -> node -> (bool * node list) - val lclose : t ref -> node -> (bool * node list) - val is_covered : t ref -> node -> bool - val refine: t ref -> node list -> L.t list -> node list - val log_art : t ref -> unit + t -> node -> T.state -> (node * T.state) list * node list + val cover : t -> node -> node -> bool + val close : t -> node -> (bool * node list) + val force_cover : t -> node -> node -> (bool * node list) + val lclose : t -> node -> (bool * node list) + val is_covered : t -> node -> bool + val refine: t -> node list -> L.t list -> node list + val log_art : t -> unit val log_node : node -> unit val of_node : node -> int val root : node From ee48b2a86dec8e9c04d8892bf09eaf876acd3257 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Thu, 24 Apr 2025 16:35:30 -0400 Subject: [PATCH 36/59] Removed explicit leaf-tracking from ART --- duet/reachTree.ml | 61 ++++++++++++++++++++-------------------------- duet/reachTree.mli | 13 +--------- 2 files changed, 28 insertions(+), 46 deletions(-) diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 4f32dd40..4db09549 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -68,8 +68,6 @@ struct module DQ = BatDeque module ARR = Batteries.DynArray - exception Mexception of string - let log_formulas prefix formulas = List.iteri (fun i f -> @@ -92,7 +90,6 @@ struct mutable reverse_covers : ISet.t IntMap.t; (* precedent_nodes[v] stores all tree nodes mapping to CFG vertex v. Used in mc_close. *) mutable precedent_nodes : ISet.t VertexMap.t; - mutable leaves : ISet.t; } let root = 0 @@ -110,7 +107,6 @@ struct covers = IntMap.empty; (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) reverse_covers = IntMap.empty; (* for each v, store the v's that cover it: i.e. cover[v] *) precedent_nodes = VertexMap.empty; - leaves = ISet.empty; } let get_err_loc (art : t) = art.err_loc @@ -162,14 +158,11 @@ struct let v_children = children art v in v :: List.fold_left (fun l ch -> descendants art ch @ l) [] v_children - (* return leaves of the tree. *) - let leaves (art : t) : node list = - art.leaves |> ISet.to_list - (* is a node in tree a leaf? *) let is_leaf (art : t) (v : node) : bool = - let chs = children art v in - List.length chs == 0 + match children art v with + | [] -> true + | _ -> false (* [label t v] returns the node label of tree node v in tree t. *) let label (art : t) (v : node) : L.t = IntMap.find v art.labels @@ -193,13 +186,6 @@ struct art.vtxcnt <- art.vtxcnt + 1; new_id - (* [update_leaf art x] attempts to update leaf structure; if x is a leaf then x is marked as leaf, otherwise x is unmarked as leaf. *) - let update_leaf (art: t) (x: node) = - if is_leaf art x then - art.leaves <- ISet.add x art.leaves - else - art.leaves <- ISet.remove x art.leaves - (* Add new tree leaf mapping to CFG vertex v and with parent tree node p. *) let add_tree_vertex (art : t) ?(label = L.top) (v : G.vertex) (p : node) = @@ -221,8 +207,6 @@ struct in art.precedent_nodes <- VertexMap.add v precedent_nodes art.precedent_nodes; - update_leaf art p; - update_leaf art new_vertex; new_vertex (** expand: @@ -288,6 +272,17 @@ struct end else false + let fold_leaves art f v acc = + let rec go worklist acc = + match worklist with + | [] -> acc + | v::worklist -> + match children art v with + | [] -> go worklist (f v acc) + | children -> go (List.rev_append children worklist) acc + in + go [v] acc + (* it returns (`true`, wl) iff covering succeeds at v and wl is a worklist of nodes to be refined. *) (** [close art v] visits precedents of v in tree and attempts to derive covering relations from v. *) @@ -325,18 +320,17 @@ struct art.reverse_covers <- IntMap.remove y art.reverse_covers; (* Step 3: add xs to worklist. *) ISet.iter - (fun _x -> + (fun x -> (* add x's subtree leaves back to the worklist. *) - (* Zak: TODO: This adds *all* leaves back to the worklist *) - let x_leaves = leaves art in - List.iter - (fun x_leaf -> - if not (is_leaf art x_leaf) then failwith "ERR: found non-leaf among leaves set of ART"; - logf + fold_leaves + art + (fun x_leaf () -> + logf " close: adding %d back to worklist \n" x_leaf; wl' := x_leaf :: !wl') - x_leaves) + x + ()) xs)) v_descendants); (cover_success, !wl')) @@ -388,17 +382,16 @@ struct x u; art.covers <- IntMap.remove x art.covers; (* add x's subtree leaves back to the worklist. *) - (* Zak: TODO: This adds *all* leaves back to the worklist *) - let x_leaves = leaves art in - List.iter - (fun x_leaf -> + fold_leaves + art + (fun x_leaf () -> logf " refine: adding %d back to worklist \n" x_leaf; - if not (is_leaf art x_leaf) then failwith "ERROR: found a non-leaf node in leaves set of ART"; worklist := x_leaf :: !worklist) - x_leaves; - l + x + (); + coverers end) l ISet.empty diff --git a/duet/reachTree.mli b/duet/reachTree.mli index c81b9494..19b3e983 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -41,7 +41,6 @@ module ART type t type state = T.state type weight = T.t - exception Mexception of string val make : G.t -> G.vertex -> G.vertex -> t val get_entry : t -> G.vertex val get_err_loc : t -> G.vertex @@ -50,19 +49,9 @@ module ART val parent_weight : t -> node -> (node * weight) option val maps_to : t -> node -> G.vertex val tree_path : t -> ?src:node -> node -> node list - val children : t -> node -> node list - val descendants : t -> node -> node list - val leaves : t -> node list val is_leaf : t -> node -> bool val label : t -> node -> L.t - val set_label : t -> node -> L.t -> unit - val get_precedent_nodes : t -> node -> node list - val get_id : t -> node - val add_tree_vertex : - t -> ?label:L.t -> G.vertex -> int -> node - val expand : - t -> node -> T.state -> (node * T.state) list * node list - val cover : t -> node -> node -> bool + val expand : t -> node -> T.state -> (node * T.state) list * node list val close : t -> node -> (bool * node list) val force_cover : t -> node -> node -> (bool * node list) val lclose : t -> node -> (bool * node list) From 56eb088ea27c53c01d033eb304d23cd3b89fd421 Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Fri, 25 Apr 2025 08:54:50 -0400 Subject: [PATCH 37/59] GPS: Use a dynamic array instead of maps to represent totally-defined functions --- duet/reachTree.ml | 98 ++++++++++++++++++++--------------------------- 1 file changed, 42 insertions(+), 56 deletions(-) diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 4db09549..af40117a 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -75,16 +75,17 @@ struct L.pp f) formulas + type node_info = + { parent : int + ; cfg_vertex : G.vertex + ; mutable label : L.t + ; mutable children : int list } + type t = { graph : G.t; - entry : G.vertex; err_loc : G.vertex; - mutable vtxcnt : int; - mutable cfg_vertex : G.vertex IntMap.t; - mutable parents : int IntMap.t; - mutable labels : L.t IntMap.t; + nodes : node_info ARR.t; mutable covers : int IntMap.t; - mutable children : int list IntMap.t; (* also maintain reverse map for each y, storing (x, y) that are in cover. *) (* i.e. reverse_covers[y] returns all x such that (x,y) is in the cover. *) mutable reverse_covers : ISet.t IntMap.t; @@ -95,47 +96,43 @@ struct let root = 0 let make (g : G.t) (entry : G.vertex) (err_loc : G.vertex) = - { - graph = g; - entry; - err_loc; - vtxcnt = 1; - cfg_vertex = IntMap.add 0 entry IntMap.empty; - parents = IntMap.add 0 (-1) IntMap.empty; - labels = IntMap.add 0 L.top IntMap.empty; - children = IntMap.add 0 [] IntMap.empty; - covers = IntMap.empty; (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) - reverse_covers = IntMap.empty; (* for each v, store the v's that cover it: i.e. cover[v] *) - precedent_nodes = VertexMap.empty; - } + let nodes = ARR.make 65536 in + ARR.add nodes { parent = -1 + ; cfg_vertex = entry + ; label = L.top + ; children = [] }; + { graph = g + ; err_loc + ; nodes = nodes + ; covers = IntMap.empty (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) + ; reverse_covers = IntMap.empty (* for each v, store the v's that cover it: i.e. cover[v] *) + ; precedent_nodes = VertexMap.empty } let get_err_loc (art : t) = art.err_loc - let get_entry (art: t) = art.entry + let get_entry (art: t) = (ARR.get art.nodes 0).cfg_vertex (** [print_tree t ident v] prints an ART t with indentation `ident` rooted at node v *) let print_tree (art : t) (indent : string) (v : node) = let rec print_tree_ (art : t) indent v = logf "%s|" indent; logf "%s+-%d(%a)" indent v - G.pp_vertex (IntMap.find v art.cfg_vertex); + G.pp_vertex (ARR.get art.nodes v).cfg_vertex; List.iter (fun x -> print_tree_ art (indent ^ " ") x) - (IntMap.find_default [] v art.children) + (ARR.get art.nodes v).children in logf "*"; print_tree_ art indent v (* [parent t i] gets parent of node i in tree t. *) - let parent (art : t) (i : node) : node = IntMap.find i art.parents + let parent (art : t) (i : node) : node = (ARR.get art.nodes i).parent (* [t %-> i]: get CFG vertex mapped by node i in tree t. *) - let maps_to (art : t) (i : node) : G.vertex = - try IntMap.find i art.cfg_vertex - with _ -> failwith @@ Printf.sprintf "maps_to: not found tree node %d\n" i + let maps_to (art : t) (i : node) : G.vertex = (ARR.get art.nodes i).cfg_vertex let parent_weight (art : t) (i : node) = - let parent = IntMap.find i art.parents in + let parent = (ARR.get art.nodes i).parent in if parent < 0 then None else @@ -150,8 +147,7 @@ struct List.rev @@ tree_path_rev art u (* [children t v] returns children of tree node v in tree t. *) - let children (art : t) (v : node) : node list = - IntMap.find v art.children + let children (art : t) (v : node) : node list = (ARR.get art.nodes v).children (* [descendants t v] returns descendants of tree node v in tree t in DFS order. *) let rec descendants (art : t) (v : node) : node list = @@ -165,11 +161,7 @@ struct | _ -> false (* [label t v] returns the node label of tree node v in tree t. *) - let label (art : t) (v : node) : L.t = IntMap.find v art.labels - - (* (replaces) sets a label at v *) - let set_label (art : t) (v : node) (lbl : L.t) = - art.labels <- IntMap.add v lbl art.labels + let label (art : t) (v : node) : L.t = (ARR.get art.nodes v).label (* [get_precedent_nodes t v] retrieves a sequence of precedent nodes of tree node vin preorder in tree t. *) (* the list of precedent nodes for a cfg vertex is a list of tree nodes which map to the same cfg location, ordered by < on integers. *) @@ -180,34 +172,28 @@ struct in ISet.elements precedents_set - (** retrieves a new ART node ID, ensuring all ART nodes have distinct IDs in increasing order according to their creation *) - let get_id (art : t) : node = - let new_id = art.vtxcnt in - art.vtxcnt <- art.vtxcnt + 1; - new_id - (* Add new tree leaf mapping to CFG vertex v and with parent tree node p. *) let add_tree_vertex (art : t) ?(label = L.top) (v : G.vertex) (p : node) = - (* sequentially add v to the lists, indexed by vtxcnt *) - let new_vertex = get_id art in (* note that new_vertex refers to a new tree vertex, where as v is a corresp. cfg location. *) - art.cfg_vertex <- IntMap.add new_vertex v art.cfg_vertex; - art.parents <- IntMap.add new_vertex p art.parents; - art.labels <- IntMap.add new_vertex label art.labels; - art.children <- IntMap.add new_vertex [] art.children; + let id = ARR.length art.nodes in + ARR.add art.nodes { cfg_vertex = v + ; parent = p + ; label = label + ; children = [] }; + (* set children of parent to be vtxcnt :: children. *) - if p >= 0 then - art.children <- - IntMap.add p (new_vertex :: IntMap.find p art.children) art.children; + begin if p >= 0 then + let parent = ARR.get art.nodes p in + parent.children <- id::parent.children + end; (* Add v to precedent_nodes. *) let precedent_nodes = VertexMap.find_default ISet.empty v art.precedent_nodes - |> ISet.add new_vertex + |> ISet.add id in - art.precedent_nodes <- - VertexMap.add v precedent_nodes art.precedent_nodes; - new_vertex + art.precedent_nodes <- VertexMap.add v precedent_nodes art.precedent_nodes; + id (** expand: for every out-neighbor y of v, first try deriving a post-state model of v-> y, if successful, put it @@ -351,13 +337,13 @@ struct let worklist = ref [] in List.iter2 (fun u interpolant -> - let u_label = label art u in - let u_label' = L.meet u_label interpolant in + let u_info = ARR.get art.nodes u in + let u_label' = L.meet u_info.label interpolant in log_formulas (Format.asprintf "[relabelling %d CFG vertex %a] to label: " u G.pp_vertex (maps_to art u)) [ u_label' ]; - set_label art u u_label'; + u_info.label <- u_label'; (* remove ( * -> u) in covering relation; we justined label(u) so implications of form label(y)->label(u) might not hold anymore. *) match IntMap.find_opt u art.reverse_covers with From b2106f336b30fb8265df2becdcd49cb5db5664ec Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Mon, 28 Apr 2025 09:10:30 -0400 Subject: [PATCH 38/59] Refactored GPS --- duet/cmdLine.ml | 8 +- duet/gps.ml | 269 ++++++++++-------------------------- duet/reachTree.ml | 212 ++++++++++++++++++---------- duet/reachTree.mli | 19 ++- duet/sgt.ml | 118 ---------------- srk/src/transitionSystem.ml | 2 +- 6 files changed, 236 insertions(+), 392 deletions(-) delete mode 100644 duet/sgt.ml diff --git a/duet/cmdLine.ml b/duet/cmdLine.ml index 6842b513..7d36022e 100644 --- a/duet/cmdLine.ml +++ b/duet/cmdLine.ml @@ -27,6 +27,11 @@ let verbose_arg = Arg.String (fun v -> Log.set_verbosity_level v `info), " Raise verbosity for a particular module") +let trace_arg = + ("-trace", + Arg.String (fun v -> Log.set_verbosity_level v `trace), + " Set verbosity for a particular module to trace") + let verbose_list_arg = ("-verbose-list", Arg.Unit (fun () -> @@ -36,7 +41,7 @@ let verbose_list_arg = ) Log.loggers; exit 0; ), - " List modules which can be used with -verbose") + " List modules which can be used with -verbose/-trace") let stats_arg = ("-stats", Arg.Set show_stats, " Display statistics") @@ -113,6 +118,7 @@ let debug_args = ref let config_args = ref [ verbose_arg; + trace_arg; verbose_list_arg; verbosity_arg; stats_arg; diff --git a/duet/gps.ml b/duet/gps.ml index 03de26ce..140f696e 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -210,9 +210,6 @@ module GPS = struct let fold_succ f g u acc = WG.U.fold_succ f (WG.forget_weights g.graph) u acc - let iter_succ_e f g v = - fold_succ (fun w () -> f (v, weight g v w, w)) g v () - let summary g src = g.target_summary src let compare_vertex = Stdlib.compare @@ -228,6 +225,7 @@ module GPS = struct match Smt.entails Ctx.context f g with | `Yes -> true | _ -> false + let negate f = Ctx.mk_not f let pp = Syntax.Formula.pp srk end module Transition = struct @@ -248,41 +246,41 @@ module GPS = struct let mul = K.mul let assume = K.assume let guard = K.guard + let pp_state = Interpretation.pp end (* ART module *) (* module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer)*) module ReachTree = ReachTree.ART(Graph)(Label)(Transition) - (** summary-guided testing *) - module PT = struct - type t = - { summary : int -> K.t - ; art : ReachTree.t } - type node = ReachTree.node - type state = ReachTree.state - let expand pt node = ReachTree.expand pt.art node - let log_art pt = ReachTree.log_art pt.art - let is_err_loc pt node = - (ReachTree.maps_to pt.art node) = (ReachTree.get_err_loc pt.art) - let pp_state = Interpretation.pp - let pp_node pt formatter node = - Format.fprintf formatter "%a (%d)" - ReachTree.pp_node node - (ReachTree.maps_to pt.art node) - let check pt node = - let rec path_weight v = - match ReachTree.parent_weight pt.art v with - | Some (parent, w) -> K.mul (path_weight parent) w - | None -> K.one - in - let post = K.guard (pt.summary (ReachTree.maps_to pt.art node)) in - match K.interpolate_or_concrete_model [path_weight node] post with - | `Valid _ -> `Infeasible - | `Invalid m -> `Feasible m - | `Unknown -> `Unknown - end - module SGT = Sgt.SummaryGuidedTesting(PT) + let generate_test_sgt art node = + logf "Generating test @ %a\n" ReachTree.pp_node node; + let post = Ctx.mk_not (K.guard (ReachTree.path_to_error art node)) in + let rec path_weight v = + match ReachTree.parent_weight art v with + | Some (parent, w) -> K.mul (path_weight parent) w + | None -> K.one + in + match K.interpolate_or_concrete_model [path_weight node] post with + | `Invalid v_model -> `Test v_model + | `Unknown -> failwith "generate_test_sgt: got UNKNOWN as a result for interpolate_or_get_model" + | `Valid _ -> `Pruned + + let sgt graph src dst = + let art = ReachTree.make graph Ctx.mk_true ~src ~dst in + let rec loop () = + match ReachTree.deque_frontier art with + | None -> `Safe + | Some node -> + match generate_test_sgt art node with + | `Pruned -> loop () + | `Test state -> + match ReachTree.execute art node state with + | `Safe -> loop () + | `Unsafe _ -> `Unsafe + in + loop () + (* to print the reachability tree (+ worklist), or not *) (* RF 3/2/25: If you enable this flag, and even if *) @@ -374,19 +372,19 @@ module GPS = struct (Summarizer.path_weight_intra gctx.g_summarizer v tgt) (K.assume equalities) in - let tgt' = gctx.g_errloc in + let dst = gctx.g_errloc in let graph = - Graph.{ graph = WG.add_edge (gctx.g_graph) tgt (Weight (K.assume equalities)) tgt' + Graph.{ graph = WG.add_edge (gctx.g_graph) tgt (Weight (K.assume equalities)) dst ; call_summary = Summarizer.over_proc_summary gctx.g_summarizer ; target_summary = target_summary } in { - id = (src,tgt'); + id = (src,dst); cfg = graph; pre_state = pre_state; worklist = DQ.empty; execlist = DQ.empty; - art = ReachTree.make graph src tgt'; + art = ReachTree.make graph pre_state ~src ~dst; global_ctx = gctx; } @@ -461,109 +459,6 @@ module GPS = struct let get_global_ctx (ctx: intra_context) = ctx.global_ctx - (* refine path to (tree) node v. - Returns `Failure (u, m) with (u, m) being a new item to the concolic worklist if unable to refine. - Returns `Success if refine is able to refine. *) - let mc_refine (ctx: intra_context) (v: ReachTree.node) = - logf "refining node %d\n" (ReachTree.of_node v); - let handle_failure v m = - logf " *********************** REFINEMENT FAILED *************************\n"; - let path_condition = path_condition ctx OverApprox v - in `Failure (m, path_condition) - in - let art = ctx.art in - let path = ReachTree.tree_path art v in - match interpolate_or_get_model ctx v with - `Invalid v_model -> - logf "Unable to refine but got model\n"; - (* v is no longer a frontier node. *) - handle_failure v v_model - | `Unknown -> failwith "mc_refine: got UNKNOWN as a result for interpolate_or_get_model" - | `Valid interpolants -> - logf "--- mc_refine: interpolation succeeded. path length %d, interpolant length %d" (List.length path) (List.length interpolants); - log_formulas "interpolants - " interpolants; - ReachTree.refine art path interpolants - |> List.iter (fun x -> ctx.worklist <- worklist_push x ctx.worklist); - `Success - - (* concolic phase of our model checking algorithm *) - let concolic_phase (ctx: intra_context) = - let round ctx = - match DQ.front (ctx.execlist) with - | Some ((u, u_model), w) -> - if print_tree then (* XXX: if this is enabled, the performance penalty is huge. *) - ReachTree.log_art ctx.art; - logf " visit %d (%d)\n" (ReachTree.of_node u) (ReachTree.maps_to ctx.art u); - ctx.execlist <- w; - if (ReachTree.maps_to ctx.art u) = (ReachTree.get_err_loc ctx.art) then begin - logf " *** found potential path-to-error, checking if prophesized pre-condition is sat...\n"; - logf " *** SAT, done\n"; - `ErrorReached u - end else begin - logf "model of %d (%d): \n" (ReachTree.of_node u) (ReachTree.maps_to ctx.art u); - log_model "" u_model; - let new_concolic_nodes, new_frontier_nodes = ReachTree.expand ctx.art u u_model in - List.iter (fun concolic_node -> ctx.execlist <- worklist_push concolic_node ctx.execlist) new_concolic_nodes; - List.iter (fun frontier_node -> ctx.worklist <- worklist_push frontier_node ctx.worklist) new_frontier_nodes; - `Continue - end - | None -> failwith "err: concolic_phase is reading from empty execution worklist" (* cannot happen *) - in - let rtn = ref `Continue in - while !rtn = `Continue && ((DQ.size ctx.execlist) > 0) do - rtn := round ctx - done; - match !rtn with - | `Continue -> `Safe - | `ErrorReached u -> `Unsafe u - - - (* refinement phase of our model checking algorithm *) - let refinement_phase (ctx: intra_context) = - let worklist_push_all ls = - List.iter (fun x -> ctx.worklist <- worklist_push x ctx.worklist) ls in - match DQ.front (ctx.worklist) with - | Some (u, w) -> - if print_tree then - ReachTree.log_art ctx.art; - ctx.worklist <- w; - (* Fetched tree node u from work list. First attempt to close it. *) - if not (ReachTree.is_covered ctx.art u) then - begin - logf " uncovered. try close %d\n" (ReachTree.of_node u); - begin match ReachTree.lclose ctx.art u with (* Close succeeded. No need to further explore it. *) - | true, leaves -> - logf "Close succeeded.\n"; - worklist_push_all leaves; - `Continue - | false, leaves -> (* u is uncovered. *) - logf " ... close failed in refining node %d, try refining it\n" (ReachTree.of_node u); - worklist_push_all leaves; - begin match mc_refine ctx u with - | `Success -> (* refinement succeeded *) - logf "refinement_phase: refinement succeeded\n"; - (* for every node along path of refinement try close *) - let path = ReachTree.tree_path ctx.art u in - List.iter - (fun x -> let (_, ls) = ReachTree.close ctx.art x in - worklist_push_all ls) path; - `Continue - | `Failure (u_m, _) -> - ctx.execlist <- worklist_push (u, u_m) ctx.execlist; (* put u onto execlist since it now has a model. *) - (* for every node along path of refinement try close *) - let path = ReachTree.tree_path ctx.art u in - List.iter (fun x -> let (_, ls) = ReachTree.close ctx.art x in - worklist_push_all ls) path - ; `Continue - end - end - end - else begin - logf "refinement_phase: %d is covered\n" (ReachTree.of_node u); - `Continue - end - | None -> failwith "refinement_phase: encountered an empty worklist for refinement\n" (* cannot happen *) - let extract_refinement (ctx: intra_context) = let art = ctx.art in @@ -648,60 +543,46 @@ module GPS = struct and intraproc_check (ctx: intra_context) : mc_result = - let continue = ref true in - let state = ref `Continue in - ctx.worklist <- worklist_push (ReachTree.root) ctx.worklist; - while !continue && (DQ.size (ctx.worklist) > 0 || DQ.size (ctx.execlist) > 0) do - if DQ.size (ctx.execlist) > 0 then begin - (* concolic phase *) - begin match concolic_phase ctx with - | `Unsafe w -> - logf "--- GPS: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to ctx.art w); - logf " --- forming path to error... \n"; - let has_calls, path_to_w = - ReachTree.tree_path ctx.art w - |> art_cfg_path_pair ctx - |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight ctx.cfg.Graph.graph u_vtx v_vtx, v)) - |> List.fold_left (fun (has_call, l) (u, w, v) -> + match ReachTree.gps ctx.art with + | `Safe -> Safe (extract_refinement ctx) + | `Unsafe w -> + logf "--- GPS: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to ctx.art w); + logf " --- forming path to error... \n"; + let has_calls, path_to_w = + ReachTree.tree_path ctx.art w + |> art_cfg_path_pair ctx + |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight ctx.cfg.Graph.graph u_vtx v_vtx, v)) + |> List.fold_left (fun (has_call, l) (u, w, v) -> match w with | Call _ -> (true, (u, w, v) :: l) | _ -> (has_call, (u, w, v) :: l) - ) (false, []) - in - logf " --- finished forming path to error, calling handle_path_to_error ... \n"; - begin match has_calls, path_to_w with - | true, curr :: right -> - begin match handle_path_to_error ctx [] curr right `Right w with - | `Safe -> (* path-to-error concretization failed. frontier_node is the src node of a call-edge. *) - (* we can mark `w` as a frontier node to be refined, and continue. *) - ctx.worklist <- worklist_push w ctx.worklist; - continue := true - | `Unsafe pathcond -> - logf "--- GPS: managed to concretize an intraprocedural path-to-error. returning... "; - state := `Concretized (pathcond); - continue := false - end - | false, _::_ -> - state := `ConcretizedList (path_to_w); - continue := false - | true, [] - | false, [] -> - (* corner case: either no calls along the path, or if the path to error is of length 0. *) - state := `Concretized (K.one); - continue := false - end - | `Safe -> - state := `Continue - end - end else begin - (* refinement phase *) - state := refinement_phase ctx - end - done; - match !state with - | `Continue -> Safe (extract_refinement ctx) - | `ConcretizedList _ -> Unsafe (K.one) (* TODO: fix this *) - | `Concretized cond -> Unsafe (cond) + ) (false, []) + in + logf " --- finished forming path to error, calling handle_path_to_error ... \n"; + begin match has_calls, path_to_w with + | true, curr :: right -> + begin match handle_path_to_error ctx [] curr right `Right w with + | `Safe -> (* path-to-error concretization failed. frontier_node is the src node of a call-edge. *) + (* we can mark `w` as a frontier node to be refined, and continue. *) + ctx.worklist <- worklist_push w ctx.worklist; + intraproc_check ctx + | `Unsafe pathcond -> + logf "--- GPS: managed to concretize an intraprocedural path-to-error. returning... "; + Unsafe pathcond end + | false, _::_ -> + (* TODO! *) +(* Unsafe (seq (List.map (fun (_, w, _) -> + match w with + | Weight w -> w + | _ -> assert false) + path_to_w)) + *) + + Unsafe K.one + | _, [] -> + (* corner case: either no calls along the path, or if the path to error is of length 0. *) + Unsafe K.one + end let execute (ts : cfg_t) (entry : int) (err_loc : int) (enable_summary:bool) : mc_result = @@ -735,7 +616,7 @@ module GPS = struct pre_state = Ctx.mk_true; worklist = DQ.empty; execlist = DQ.empty; - art = ReachTree.make graph entry err_loc; + art = ReachTree.make graph Ctx.mk_true ~src:entry ~dst:err_loc; global_ctx = gctx; } in @@ -792,11 +673,7 @@ let analyze_sgt enable_gas enable_summary file = ; call_summary = (fun _ -> failwith "SGT: procedure call") ; target_summary = Summarizer.path_weight_inter summ } in - let pt = - GPS.PT.{ summary = Summarizer.path_weight_inter summ - ; art = GPS.ReachTree.make graph entry err_loc } - in - begin match GPS.SGT.execute pt GPS.ReachTree.root with + begin match GPS.sgt graph entry err_loc with | `Safe -> Printf.printf " proven safe\n"; | `Unsafe -> Printf.printf " proven unsafe\n" | `Error s -> Printf.printf "ERR: %s\n" s diff --git a/duet/reachTree.ml b/duet/reachTree.ml index af40117a..b1d0e8b8 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -25,7 +25,6 @@ module ART type vertex type weight val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - val iter_succ_e : (vertex * weight * vertex -> unit) -> t -> vertex -> unit val weight : t -> vertex -> vertex -> weight val summary : t -> vertex -> weight val compare_vertex : vertex -> vertex -> int @@ -36,6 +35,7 @@ module ART val top : t val meet : t -> t -> t val leq : t -> t -> bool + val negate : t -> t val pp : Format.formatter -> t -> unit end) (T : sig @@ -50,6 +50,7 @@ module ART val mul : t -> t -> t val assume : label -> t val guard : t -> label + val pp_state : Format.formatter -> state -> unit end with type t = G.weight and type label = L.t) = struct @@ -85,28 +86,32 @@ struct graph : G.t; err_loc : G.vertex; nodes : node_info ARR.t; + precondition : L.t; mutable covers : int IntMap.t; (* also maintain reverse map for each y, storing (x, y) that are in cover. *) (* i.e. reverse_covers[y] returns all x such that (x,y) is in the cover. *) mutable reverse_covers : ISet.t IntMap.t; (* precedent_nodes[v] stores all tree nodes mapping to CFG vertex v. Used in mc_close. *) mutable precedent_nodes : ISet.t VertexMap.t; + mutable frontier : node DQ.t; } let root = 0 - let make (g : G.t) (entry : G.vertex) (err_loc : G.vertex) = + let make (g : G.t) (precondition : L.t) ~(src : G.vertex) ~(dst : G.vertex) = let nodes = ARR.make 65536 in ARR.add nodes { parent = -1 - ; cfg_vertex = entry + ; cfg_vertex = src ; label = L.top ; children = [] }; { graph = g - ; err_loc + ; err_loc = dst ; nodes = nodes + ; precondition = precondition ; covers = IntMap.empty (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) ; reverse_covers = IntMap.empty (* for each v, store the v's that cover it: i.e. cover[v] *) - ; precedent_nodes = VertexMap.empty } + ; precedent_nodes = VertexMap.empty + ; frontier = DQ.cons root DQ.empty } let get_err_loc (art : t) = art.err_loc let get_entry (art: t) = (ARR.get art.nodes 0).cfg_vertex @@ -195,39 +200,22 @@ struct art.precedent_nodes <- VertexMap.add v precedent_nodes art.precedent_nodes; id - (** expand: - for every out-neighbor y of v, first try deriving a post-state model of v-> y, if successful, put it - on the concolic execution worklist. Otherwise, it is a frontier node, and put it on the - refinement worklist. *) - - - (* New (more general) API for expansion that supports summary-guided testing - * and an IMPACT-style algorithm. The expansion is performed guarded by the pre-image - of [tr], where, in GPS and SGT, [tr] is a single-target path summary, in IMPACT, [tr] - is the identity transition. More specifically, for each out-neighbor u of G(v), we - first test if m /\ tr is SAT, if so, then this out-neighbor is non-frontier. Otherwise, - this out neighbor is a frontier. *) - let expand (art: t) (v: node) (m: T.state) = - let vg = maps_to art v in - let new_concolic_nodes, new_frontier_nodes = (ref [], ref []) in - (* visit out-neighbors of v *) - G.iter_succ_e - (fun (_, weight, y) -> - let weight = - if T.is_deterministic weight then weight - else T.mul weight (T.assume @@ T.guard @@ G.summary art.graph y) - in - match T.post_model m weight with - | Some y_model -> - let new_vtx = add_tree_vertex art y v in - new_concolic_nodes := (new_vtx, y_model) :: !new_concolic_nodes - | None -> - let new_node = add_tree_vertex art y v in - new_frontier_nodes := new_node :: !new_frontier_nodes) - art.graph vg; - (* make it FIFO *) - (List.rev !new_concolic_nodes, List.rev !new_frontier_nodes) - + let deque_frontier art = + match DQ.front art.frontier with + | None -> None + | Some (u, frontier') -> + art.frontier <- frontier'; + Some u + + let add_frontier art node = art.frontier <- DQ.snoc art.frontier node + + let expand (art : t) (v : node) = + G.fold_succ (fun succ () -> + let new_node = add_tree_vertex art succ v in + add_frontier art new_node) + art.graph + (maps_to art v) + () (** maintenance of coverings *) @@ -269,8 +257,6 @@ struct in go [v] acc - (* it returns (`true`, wl) iff covering succeeds at v and wl is a worklist of nodes to be refined. *) - (** [close art v] visits precedents of v in tree and attempts to derive covering relations from v. *) let close (art : t) (v : node) = (* A _precedent_ of v in tree is any vertex u let u_info = ARR.get art.nodes u in @@ -374,7 +359,7 @@ struct logf " refine: adding %d back to worklist \n" x_leaf; - worklist := x_leaf :: !worklist) + add_frontier art x_leaf) x (); coverers @@ -384,8 +369,8 @@ struct in art.reverse_covers <- IntMap.add u u_coverers art.reverse_covers) path - interpolants; - !worklist + interpolants + let rec glue l = match l with @@ -396,7 +381,7 @@ struct (* convention: w is an ancestor of v. returns true if we can add (v, w) to covers such that label(v) |= label(w) *) let force_cover (art : t) v w = (* check if v_label -> w_label where v is an ancestor at w *) - if maps_to art v <> maps_to art w then (false, []) + if maps_to art v <> maps_to art w then false else begin logf "force_cover(%d, %d)\n" v w; (* let v_label = label art v in *) @@ -410,13 +395,11 @@ struct in match T.check w_label path_weights w_label with | `Valid itps -> - let new_frontiers = refine art (List.tl artpath) (List.tl itps) in - if cover art v w then - (true, new_frontiers) - else - failwith "error: force_cover is buggy" + refine art (List.tl artpath) (List.tl itps); + assert (cover art v w); + true - | `Invalid _ -> (false, []) + | `Invalid _ -> false | `Unknown -> failwith "force_cover: interpolation failed with status UNKNOWN." end @@ -424,26 +407,23 @@ struct (** a more lightweight version of close *) let lclose (art: t) v = let rec go u = - if u = -1 then (false, []) + if u = -1 then false else begin - if maps_to art u <> maps_to art v then - try let p = parent art u in go p - with Not_found -> (false, []) - else - begin match force_cover art v u with - | (true, frontiers) -> (true, frontiers) - | (false, _) -> - try - let p = parent art u in go p - with Not_found -> (false, []) + if maps_to art u <> maps_to art v then + try go (parent art u) + with Not_found -> false + else + if force_cover art v u then true + else + try go (parent art u) + with Not_found -> false end - end in - let res = match v with - | 0 -> (false, []) - | _ -> go (parent art v) in - let bb, _ = res in - logf " --- lclose result of %d : %b ---\n" v bb ; res + let res = match v with + | 0 -> false + | _ -> go (parent art v) + in + logf " --- lclose result of %d : %b ---\n" v res ; res (** TODO: [deprecated] procedures for lightweight verification of ART invariants *) @@ -537,7 +517,99 @@ struct let log_node u = logf " node: visit %d\n" u + let pp_node = Format.pp_print_int + let of_node u = u - let pp_node = Format.pp_print_int + let execute art node state = + let rec loop worklist = + match worklist with + | [] -> `Safe + | (u, u_model)::worklist -> + logf " visit %d (%a)\n" u G.pp_vertex (maps_to art u); + if (maps_to art u) = (get_err_loc art) then begin + logf " *** found path-to-error"; + (* We're abandoning the search without exhausting worklist, so + worklist must be added to frontier. *) + List.iter (fun (v, _) -> art.frontier <- DQ.snoc art.frontier v) worklist; + `Unsafe u + end else begin + logf "model of %d (%a): @[%a@]" + u + G.pp_vertex (maps_to art u) + T.pp_state u_model; + let u_v = maps_to art u in + let worklist = + G.fold_succ (fun succ worklist -> + let succ_node = add_tree_vertex art succ u in + let weight = G.weight art.graph u_v succ in + let weight = + if T.is_deterministic weight then weight + else + T.mul weight (T.assume @@ T.guard @@ G.summary art.graph succ) + in + match T.post_model u_model weight with + | Some model -> (succ_node,model)::worklist + | None -> add_frontier art succ_node; worklist) + art.graph + u_v + worklist + in + loop worklist + end + in + loop [(node, state)] + + let path_to_error art node = G.summary art.graph (maps_to art node) + + let generate_test art node = + let post = L.negate (T.guard (path_to_error art node)) in + let rec get_path rest node = + match parent_weight art node with + | Some (p, weight) -> get_path (weight::rest) p + | None -> rest + in + let path = get_path [] node in + match T.check art.precondition path post with + | `Invalid v_model -> + logf ~level:`trace "-> found test"; + `Test v_model + | `Unknown -> failwith "generate_test: got UNKNOWN as a result for interpolate_or_get_model" + | `Valid interpolants -> + logf ~level:`trace "-> pruned"; + log_formulas "interpolants - " interpolants; + refine art (tree_path art node) interpolants; + `Pruned + + let gps art = + let rec loop () = + match deque_frontier art with + | None -> `Safe + | Some u -> + (* Fetched tree node u from work list. First attempt to close it. *) + logf ~level:`trace "At frontier node %d:" u; + if is_covered art u then + (logf ~level:`trace "-> covered"; + loop ()) + else begin + if lclose art u then (* Close succeeded. No need to further explore it. *) + (logf ~level:`trace "-> closed"; loop ()) + else begin + (* u is uncovered. *) + match generate_test art u with + | `Pruned -> (* refinement succeeded *) + (* for every node along path of refinement try close *) + List.iter (fun v -> ignore (close art v)) (tree_path art u); + + loop () + | `Test state -> + logf ~level:`trace "-> found test"; + match execute art u state with + | `Safe -> loop () + | `Unsafe n -> `Unsafe n + end + end + in + loop () + end diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 19b3e983..523e099e 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -9,7 +9,6 @@ module ART type vertex type weight val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a - val iter_succ_e : (vertex * weight * vertex -> unit) -> t -> vertex -> unit val weight : t -> vertex -> vertex -> weight val summary : t -> vertex -> weight val compare_vertex : vertex -> vertex -> int @@ -21,6 +20,7 @@ module ART val bottom : t val meet : t -> t -> t val leq : t -> t -> bool + val negate : t -> t val pp : Format.formatter -> t -> unit end) (T : sig @@ -35,31 +35,38 @@ module ART val mul : t -> t -> t val assume : label -> t val guard : t -> label + val pp_state : Format.formatter -> state -> unit end with type t = G.weight and type label = L.t) : sig type node type t type state = T.state type weight = T.t - val make : G.t -> G.vertex -> G.vertex -> t + val make : G.t -> L.t -> src:G.vertex -> dst:G.vertex -> t val get_entry : t -> G.vertex val get_err_loc : t -> G.vertex val print_tree : t -> string -> node -> unit val parent : t -> node -> node val parent_weight : t -> node -> (node * weight) option val maps_to : t -> node -> G.vertex + val add_frontier : t -> node -> unit + val deque_frontier : t -> node option val tree_path : t -> ?src:node -> node -> node list val is_leaf : t -> node -> bool val label : t -> node -> L.t - val expand : t -> node -> T.state -> (node * T.state) list * node list + val expand : t -> node -> unit val close : t -> node -> (bool * node list) - val force_cover : t -> node -> node -> (bool * node list) - val lclose : t -> node -> (bool * node list) + val force_cover : t -> node -> node -> bool + val lclose : t -> node -> bool val is_covered : t -> node -> bool - val refine: t -> node list -> L.t list -> node list + val refine: t -> node list -> L.t list -> unit val log_art : t -> unit val log_node : node -> unit val of_node : node -> int val root : node val pp_node : Format.formatter -> node -> unit + val execute : t -> node -> T.state -> [ `Safe | `Unsafe of node ] + val gps : t -> [ `Safe | `Unsafe of node ] + val path_to_error : t -> node -> weight + val generate_test : t -> node -> [ `Test of state | `Pruned ] end diff --git a/duet/sgt.ml b/duet/sgt.ml deleted file mode 100644 index aa7e3202..00000000 --- a/duet/sgt.ml +++ /dev/null @@ -1,118 +0,0 @@ -open Srk -module RG = Interproc.RG -module WG = Srk.WeightedGraph -module G = RG.G -module Int = SrkUtil.Int -module TF = TransitionFormula - -module TransitionSystem = Srk.TransitionSystem -module Syntax = Srk.Syntax -module Interpretation = Srk.Interpretation - -include Log.Make(struct let name = "sgt" end) -module DQ = BatDeque -module ARR = Batteries.DynArray - - -module SummaryGuidedTesting - (PathTree : sig - type node - type t - type state - val check : t -> node -> [ `Feasible of state | `Infeasible | `Unknown ] - val expand : t -> node -> state -> (node * state) list * node list - val log_art : t -> unit - val pp_node : t -> Format.formatter -> node -> unit - val pp_state : Format.formatter -> state -> unit - val is_err_loc : t -> node -> bool - end) = struct - - let print_tree = false - - let log_model prefix model = - logf "[model] %s: %a\n" prefix PathTree.pp_state model - - - type context = { - mutable art : PathTree.t ref; - (* list for frontier nodes *) - mutable worklist : PathTree.node DQ.t; - (* list for executor states *) - mutable execlist : (PathTree.node * PathTree.state) DQ.t; - } - - let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i - - - let run_test (ctx: context ref) = - let round ctx = - match DQ.front (!ctx.execlist) with - | Some ((u, u_model), w) -> - if print_tree then - PathTree.log_art !(!ctx.art); - logf " visit %a\n" (PathTree.pp_node !(!ctx.art)) u; - !ctx.execlist <- w; - if PathTree.is_err_loc !(!ctx.art) u then - `Unsafe u - else begin - logf "model of %a: \n" (PathTree.pp_node !(!ctx.art)) u; - log_model "" u_model; - let new_concolic_nodes, new_frontier_nodes = PathTree.expand !(!ctx.art) u u_model in - List.iter (fun concolic_node -> !ctx.execlist <- worklist_push concolic_node !ctx.execlist) new_concolic_nodes; - List.iter (fun frontier_node -> !ctx.worklist <- worklist_push frontier_node !ctx.worklist) new_frontier_nodes; - `Continue - end - | None -> - failwith "err: concolic_phase is reading from empty execution worklist" (* cannot happen *) - in - let rtn = ref `Continue in - while !rtn = `Continue && ((DQ.size !ctx.execlist) > 0) do - rtn := round ctx - done; - match !rtn with - | `Continue -> `Safe - | `Unsafe u -> `Unsafe u - - - let mk_context art = - ref { - art = ref art; - worklist = DQ.empty; - execlist = DQ.empty; - } - - - let execute art root : [`Safe | `Unsafe | `Error of string] = - let ctx = mk_context art in - let state = ref `Unknown in - !ctx.worklist <- worklist_push root !ctx.worklist; - while (DQ.size !ctx.worklist > 0 || DQ.size !ctx.execlist > 0) && (!state = `Unknown) do - logf " --- SGT: starting a new test execution phase\n"; - match run_test ctx with - | `Safe -> - begin match DQ.front !ctx.worklist with - | Some (u, worklist') -> - begin match PathTree.check art u with - | `Feasible m -> - Log.errorf "HERE!"; - !ctx.execlist <- worklist_push (u, m) !ctx.execlist; - !ctx.worklist <- worklist'; - state := `Unknown - | `Infeasible -> - !ctx.worklist <- worklist'; - state := `Unknown; - | `Unknown -> - logf "--- SGT: UNKNOWN!" - end - | None -> - state := `Safe - end - | `Unsafe _ -> - logf " --- SGT: finished running, found a bug.\n"; - state := `Unsafe - done; - logf " --- SGT: done performing execution.\n"; - match !state with - | `Unsafe -> `Unsafe - | `Unknown | `Safe -> `Safe -end diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index 09fd771d..7ca2db47 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -678,7 +678,7 @@ module Make List.map invariants (L.all_loops (L.loop_nest tg)) - let simplify ?(try_rtc=false) p tg = + let simplify ?(try_rtc=true) p tg = let rec go tg = let continue = ref false in let tg' = From b5715710eeadb8b0d67bc95b58485f7a7ba9eeab Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Mon, 28 Apr 2025 09:10:58 -0400 Subject: [PATCH 39/59] IMPACT implementation --- duet/gps.ml | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/duet/gps.ml b/duet/gps.ml index 140f696e..0716b475 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -682,6 +682,52 @@ let analyze_sgt enable_gas enable_summary file = end | _ -> assert false +let analyze_impact file = + let open Srk.Iteration in + populate_offset_table file; + K.domain := split (product [ PolyhedronGuard.exp + ; LossyTranslation.exp ]); + match file.entry_points with + | [main] -> begin + let rg = Interproc.make_recgraph file in + let entry = (RG.block_entry rg main).did in + let (ts, assertions) = make_transition_system ~simplify:true entry rg in + let ts, err_loc = make_ts_assertions_unreachable ts assertions in + if !CmdLine.display_graphs then TSDisplay.display ts; + logf "\nentry: %d\n" entry; + Printf.printf "testing reachability of location %d\n" err_loc ; + Printf.printf "------------------------------\n"; + let graph = + GPS.Graph.{ graph = ts + ; call_summary = (fun _ -> failwith "IMPACT: procedure call") + ; target_summary = (fun _ -> K.one) } + in + let module ART = GPS.ReachTree in + let art = ART.make graph Ctx.mk_true ~src:entry ~dst:err_loc in + let rec loop () = + match ART.deque_frontier art with + | None -> `Safe + | Some u -> + (* Fetched tree node u from work list. First attempt to close it. *) + if ART.is_covered art u then loop () + else if ART.lclose art u then loop () + else if ART.maps_to art u == err_loc then + match ART.generate_test art u with + | `Pruned -> + List.iter (fun v -> ignore (ART.close art v)) (ART.tree_path art u); + loop () + | `Test _ -> `Unsafe + else (ART.expand art u; loop ()) + in + begin match loop () with + | `Safe -> Printf.printf " proven safe\n"; + | `Unsafe -> Printf.printf " proven unsafe\n" + | `Error s -> Printf.printf "ERR: %s\n" s + end; + Printf.printf "------------------------------\n" + end + | _ -> assert false + (** dump simplified CFG before doing model checking / CRA / concolic execution *) let dump_cfg simplify instrument file = @@ -716,6 +762,9 @@ let _ = CmdLine.register_pass ("-sgt-nosum-nogas", analyze_sgt true false, "Summary-guided testing with gas but without CRA-generated summary"); + CmdLine.register_pass + ("-impact", analyze_impact, "Lazy abstraction with interpolants"); + CmdLine.register_pass ("-dump-unsimplified-cfg", dump_cfg false false, "dump unsimplified CFG"); CmdLine.register_pass From 9afc69f74399ae2de0c9953f989e5f9c9dad661d Mon Sep 17 00:00:00 2001 From: Zachary Kincaid Date: Mon, 28 Apr 2025 09:28:52 -0400 Subject: [PATCH 40/59] Removed redundant data from GPS intraprocedural context --- duet/gps.ml | 32 ++------------------------------ duet/reachTree.ml | 1 + duet/reachTree.mli | 1 + 3 files changed, 4 insertions(+), 30 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index 0716b475..04e26628 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -303,10 +303,7 @@ module GPS = struct type intra_context = { id : ProcName.t; cfg : Graph.t; - pre_state : Ctx.t Syntax.formula; mutable art : ReachTree.t; - mutable worklist : ReachTree.node DQ.t; - mutable execlist : (ReachTree.node * Ctx.t Interpretation.interpretation) DQ.t; global_ctx : global_context; } (* global context *) @@ -381,17 +378,10 @@ module GPS = struct { id = (src,dst); cfg = graph; - pre_state = pre_state; - worklist = DQ.empty; - execlist = DQ.empty; art = ReachTree.make graph pre_state ~src ~dst; global_ctx = gctx; } - - (** place an element in front of the deque (worklist) *) - let worklist_push (i : 'a) (q : 'a DQ.t) = DQ.snoc q i - let rec art_cfg_path_pair (ctx: intra_context) (p: ReachTree.node list) = match p with | u :: v :: t -> @@ -400,10 +390,6 @@ module GPS = struct (u, (u_vtx, v_vtx), v) :: (art_cfg_path_pair ctx (v :: t)) | _ -> [] - (* turn tree path into a sequence of CFG edges. *) - let cfg_path (ctx: intra_context) (p : ReachTree.node list) = - art_cfg_path_pair ctx p - |> List.map (fun (_, (u, v), _) -> (u, v)) let print_vocabulary tr = let g_vocab, l_vocab = K.vocabulary tr in @@ -444,22 +430,11 @@ module GPS = struct end | Weight w -> w) (to_weights cfg_nodes) in logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); - let l = (K.assume ctx.pre_state) :: pathcond in + let l = (K.assume (ReachTree.get_precondition ctx.art)) :: pathcond in log_weights "path conditions " l; l - (* Interpolate the path (entry) -> (CFG vertex corresponding to src node) -> (sink CFG vertex). If fail, then get model. *) - let interpolate_or_get_model (ctx: intra_context) (src : ReachTree.node) = - let src_v = ReachTree.maps_to ctx.art src in - let suffix = K.guard (Graph.summary ctx.cfg src_v) |> Syntax.mk_not srk in - let prefix = path_condition ctx OverApprox src in - log_weights "\nprefix " prefix; - log_formulas "\nsuffix " [suffix]; - logf "\n"; - K.interpolate_or_concrete_model prefix suffix - let get_global_ctx (ctx: intra_context) = ctx.global_ctx - let extract_refinement (ctx: intra_context) = let art = ctx.art in let rfn = ReachTree.label art ReachTree.root |> promote in @@ -564,7 +539,7 @@ module GPS = struct begin match handle_path_to_error ctx [] curr right `Right w with | `Safe -> (* path-to-error concretization failed. frontier_node is the src node of a call-edge. *) (* we can mark `w` as a frontier node to be refined, and continue. *) - ctx.worklist <- worklist_push w ctx.worklist; + ReachTree.add_frontier ctx.art w; intraproc_check ctx | `Unsafe pathcond -> logf "--- GPS: managed to concretize an intraprocedural path-to-error. returning... "; @@ -613,9 +588,6 @@ module GPS = struct { id = (entry,err_loc); cfg = graph; - pre_state = Ctx.mk_true; - worklist = DQ.empty; - execlist = DQ.empty; art = ReachTree.make graph Ctx.mk_true ~src:entry ~dst:err_loc; global_ctx = gctx; } diff --git a/duet/reachTree.ml b/duet/reachTree.ml index b1d0e8b8..0ca5c440 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -115,6 +115,7 @@ struct let get_err_loc (art : t) = art.err_loc let get_entry (art: t) = (ARR.get art.nodes 0).cfg_vertex + let get_precondition (art : t) = art.precondition (** [print_tree t ident v] prints an ART t with indentation `ident` rooted at node v *) let print_tree (art : t) (indent : string) (v : node) = diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 523e099e..674146fe 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -45,6 +45,7 @@ module ART val make : G.t -> L.t -> src:G.vertex -> dst:G.vertex -> t val get_entry : t -> G.vertex val get_err_loc : t -> G.vertex + val get_precondition : t -> L.t val print_tree : t -> string -> node -> unit val parent : t -> node -> node val parent_weight : t -> node -> (node * weight) option From 1a678b1e1286286ce4fdfc7e4ffc161d1ad33176 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 12 Jun 2025 21:01:32 -0500 Subject: [PATCH 41/59] add inlining [1/n] --- duet/cra.ml | 4 - duet/gps.ml | 10 +- srk/src/transitionSystem.ml | 81 +++++++ srk/src/transitionSystem.mli | 4 + srk/srk.install | 397 +++++++++++++++++++++++++++++++++++ 5 files changed, 487 insertions(+), 9 deletions(-) create mode 100644 srk/srk.install diff --git a/duet/cra.ml b/duet/cra.ml index 39b6ef5d..08552607 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -952,14 +952,11 @@ let make_transition_system ?(simplify=true) ?(instr_gas=false) (main_entry: int) let elim_var v = V.is_global v || VSet.mem v (!assert_vars) in - (* let _ = Printf.printf "Displaying pre-instrumented TG\n"; TSDisplay.display tg in *) let tg = if (instr_gas && entry = main_entry) then instrument_main tg entry init_gas_weight else tg in let tg = if instr_gas then instrument_with_gas tg gasweight else tg in - (* let _ = Printf.printf "Displaying post-instrumented TG\n"; TSDisplay.display tg in *) let predicates = if instr_gas then gasexpr :: predicates else predicates in let tg = if simplify then TS.simplify point_of_interest tg else tg in let tg = TS.remove_temporaries elim_var tg in - (*let _ = Printf.printf "Displaying simplified TG\n"; TSDisplay.display tg in *) let tg = if !forward_inv_gen then Log.phase "Forward invariant generation" @@ -967,7 +964,6 @@ let make_transition_system ?(simplify=true) ?(instr_gas=false) (main_entry: int) else tg in - (* let _ = Printf.printf "Displaying invariant-generated TG\n"; TSDisplay.display tg in *) WG.fold_edges (fun (src, label, tgt) ts -> match label with | Weight w -> WG.add_edge ts src (Weight w) tgt diff --git a/duet/gps.ml b/duet/gps.ml index 04e26628..391bb6c2 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -68,7 +68,7 @@ let process_interproc_assertion (ts: cfg_t) (phi: Ctx.formula) v = *) (* Convert assertion checking problem to vertex reachability problem. *) -let make_ts_assertions_unreachable (ts : cfg_t) assertions = +let safety_to_reachability (ts : cfg_t) assertions = let err_loc = 1 + (WG.fold_vertex (fun v max -> if v > max then v else max) ts 0) in let ts = WG.add_vertex ts err_loc in let ts = @@ -610,7 +610,7 @@ let analyze_mc enable_gas enable_summary file = let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system ~simplify:true ~instr_gas:enable_gas entry rg in - let ts, err_loc = make_ts_assertions_unreachable ts assertions in + let ts, err_loc = safety_to_reachability ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; logf "\nentry: %d\n" entry; Printf.printf "testing reachability of location %d\n" err_loc ; @@ -634,7 +634,7 @@ let analyze_sgt enable_gas enable_summary file = let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system ~simplify:true ~instr_gas:enable_gas entry rg in - let ts, err_loc = make_ts_assertions_unreachable ts assertions in + let ts, err_loc = safety_to_reachability ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; logf "\nentry: %d\n" entry; Printf.printf "testing reachability of location %d\n" err_loc ; @@ -664,7 +664,7 @@ let analyze_impact file = let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system ~simplify:true entry rg in - let ts, err_loc = make_ts_assertions_unreachable ts assertions in + let ts, err_loc = safety_to_reachability ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; logf "\nentry: %d\n" entry; Printf.printf "testing reachability of location %d\n" err_loc ; @@ -710,7 +710,7 @@ let dump_cfg simplify instrument file = let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in let (ts, assertions) = make_transition_system ~simplify:simplify ~instr_gas:instrument entry rg in - let ts, _ = make_ts_assertions_unreachable ts assertions in + let ts, _ = safety_to_reachability ts assertions in TSDisplay.display ts end | _ -> assert false diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index 7ca2db47..c68ac64e 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -520,7 +520,14 @@ module Make let hash = Hashtbl.hash end + module IntPairPair = struct + type t = IntPair.t * IntPair.t [@@deriving ord] + let equal (x, y) (x', y') = (x=x' && y=y') + let hash = Hashtbl.hash + end + module PS = BatSet.Make(IntPair) + module PPS = BatSet.Make(IntPairPair) (* used in inliner *) module PHT = BatHashtbl.Make(IntPair) module VHT = BatHashtbl.Make(Var) @@ -677,6 +684,80 @@ module Make in List.map invariants (L.all_loops (L.loop_nest tg)) + + let inline ?(depth=(-1)) tg = + let pmap = PHT.create 998 in (* y in pmap[x] means call from x->y *) + let qmap = PHT.create 998 in (* (x, z) in qmap[y] means call from x->y via call-edge z *) + let procedures = + WG.fold_edges (fun (_, w, _) acc -> + match w with + | Call (x, y) -> + begin match PHT.find_opt pmap (x, y) with + | None -> + PHT.add pmap (x, y) PS.empty + | Some _ -> () + end; + begin match PHT.find_opt qmap (x, y) with + | None -> + PHT.add qmap (x, y) PPS.empty + | Some _ -> () + end; + PS.add (x, y) acc + | _ -> acc + ) tg PS.empty in + let rec dfs (proc: int * int) tg src (visited : ISet.t) = + WG.iter_succ_e (fun (_, w, v) -> + match w with + | Call (x, y) -> + let caller_set = PHT.find pmap proc in + let callee_set = PHT.find qmap (x, y) in + PHT.add pmap proc (PS.add (x, y) caller_set); + PHT.add qmap (x, y) (PPS.add (proc, (src, v)) callee_set); + begin match ISet.find_opt v visited with + | None -> dfs proc tg v (ISet.add v visited) + | Some _ -> () + end + | _ -> + begin match ISet.find_opt v visited with + | None -> dfs proc tg v (ISet.add v visited) + | Some _ -> () + end + ) tg src in + PS.iter (fun (x, y) -> dfs (x, y) tg x ISet.empty) procedures; (* populate pmap, qmap *) + let compute_sinks () = + PS.fold (fun (x, y) acc -> (* compute sink locations to start inlining from *) + match (PHT.find_opt pmap (x, y), PHT.find_opt qmap (x, y)) with + | Some callees, Some callers -> + (* a procedure is considered for inlining if it is (1) a sink in the call graph (2) at least one function calls it.*) + if ((PS.cardinal callees) == 0) && ((PPS.cardinal callers) > 0) then PS.add (x, y) acc else acc + | (_, _) -> failwith "" + ) procedures PS.empty in + let inline_one tg (src, dst) (call_x, call_y) (call_src, call_dst) = + let tg = WG.add_edge tg call_x (Weight T.one) src in + let tg = WG.add_edge tg dst (Weight T.one) dst in + let tg = WG.remove_edge tg call_x call_y in + let callees = PHT.find pmap (call_src, call_dst) in + let callers = PHT.find qmap (src, dst) in + (* remove (src, dst) from callees list in caller *) + PHT.add pmap (call_src, call_dst) (PS.remove (src, dst) callees); + (* remove (call_src, call_dst) from callers list *) + PHT.add qmap (src, dst) (PPS.remove ((call_src, call_dst),(call_x, call_y)) callers); + tg + in let rec do_inline depth tg = + if depth == 0 then tg else + let sinks = compute_sinks () in + let aux currproc tg = (* inline currproc into procedures that call it, assuming currproc is inlined. *) + let inline_targets = PHT.find qmap currproc in + PPS.fold (fun (call_proc, (call_x, call_y)) tg -> + inline_one tg currproc (call_x, call_y) call_proc + ) inline_targets tg + in + PS.fold (fun call tg -> aux call tg) sinks tg + |> do_inline (if depth > 0 then depth - 1 else depth) + in do_inline depth tg + + + let simplify ?(try_rtc=true) p tg = let rec go tg = diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index f2aeeef4..6ec8a62b 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -104,6 +104,10 @@ module Make contract vertices with loops or vertices adjacent to call edges. *) val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t + (** Perform inlining of a potentially recursive iCFG. + *) + val inline : ?depth:int -> t -> t + (** Given a transition system and entry, compute a set of loop headers along with the set of variables that are read within the body of the associated loop *) diff --git a/srk/srk.install b/srk/srk.install new file mode 100644 index 00000000..2be4dffd --- /dev/null +++ b/srk/srk.install @@ -0,0 +1,397 @@ +lib: [ + "_build/install/default/lib/srk/META" + "_build/install/default/lib/srk/abstract.ml" + "_build/install/default/lib/srk/abstract.mli" + "_build/install/default/lib/srk/algebra.ml" + "_build/install/default/lib/srk/bigO.ml" + "_build/install/default/lib/srk/bigO.mli" + "_build/install/default/lib/srk/cache.ml" + "_build/install/default/lib/srk/cache.mli" + "_build/install/default/lib/srk/chc.ml" + "_build/install/default/lib/srk/chc.mli" + "_build/install/default/lib/srk/compressedWeightedForest.ml" + "_build/install/default/lib/srk/compressedWeightedForest.mli" + "_build/install/default/lib/srk/cone.ml" + "_build/install/default/lib/srk/cone.mli" + "_build/install/default/lib/srk/consequenceCone.ml" + "_build/install/default/lib/srk/consequenceCone.mli" + "_build/install/default/lib/srk/convexHull.ml" + "_build/install/default/lib/srk/convexHull.mli" + "_build/install/default/lib/srk/coordinateSystem.ml" + "_build/install/default/lib/srk/coordinateSystem.mli" + "_build/install/default/lib/srk/dD.ml" + "_build/install/default/lib/srk/dD.mli" + "_build/install/default/lib/srk/disjointSet.ml" + "_build/install/default/lib/srk/dune-package" + "_build/install/default/lib/srk/expPolynomial.ml" + "_build/install/default/lib/srk/expPolynomial.mli" + "_build/install/default/lib/srk/featureTree.ml" + "_build/install/default/lib/srk/featureTree.mli" + "_build/install/default/lib/srk/fixpoint.ml" + "_build/install/default/lib/srk/fixpoint.mli" + "_build/install/default/lib/srk/intLattice.ml" + "_build/install/default/lib/srk/intLattice.mli" + "_build/install/default/lib/srk/interpretation.ml" + "_build/install/default/lib/srk/interpretation.mli" + "_build/install/default/lib/srk/interval.ml" + "_build/install/default/lib/srk/interval.mli" + "_build/install/default/lib/srk/iteration.ml" + "_build/install/default/lib/srk/iteration.mli" + "_build/install/default/lib/srk/linear.ml" + "_build/install/default/lib/srk/linear.mli" + "_build/install/default/lib/srk/lirr.ml" + "_build/install/default/lib/srk/lirr.mli" + "_build/install/default/lib/srk/lirrInvariants.ml" + "_build/install/default/lib/srk/log.ml" + "_build/install/default/lib/srk/loop.ml" + "_build/install/default/lib/srk/loop.mli" + "_build/install/default/lib/srk/lts.ml" + "_build/install/default/lib/srk/lts.mli" + "_build/install/default/lib/srk/memo.ml" + "_build/install/default/lib/srk/memo.mli" + "_build/install/default/lib/srk/nonlinear.ml" + "_build/install/default/lib/srk/nonlinear.mli" + "_build/install/default/lib/srk/numberField.ml" + "_build/install/default/lib/srk/numberField.mli" + "_build/install/default/lib/srk/opam" + "_build/install/default/lib/srk/pathexpr.ml" + "_build/install/default/lib/srk/pathexpr.mli" + "_build/install/default/lib/srk/polyhedron.ml" + "_build/install/default/lib/srk/polyhedron.mli" + "_build/install/default/lib/srk/polynomial.ml" + "_build/install/default/lib/srk/polynomial.mli" + "_build/install/default/lib/srk/polynomialCone.ml" + "_build/install/default/lib/srk/polynomialCone.mli" + "_build/install/default/lib/srk/polynomialConeCpClosure.ml" + "_build/install/default/lib/srk/polynomialConeCpClosure.mli" + "_build/install/default/lib/srk/polynomialLattice.ml" + "_build/install/default/lib/srk/polynomialLattice.mli" + "_build/install/default/lib/srk/qQ.ml" + "_build/install/default/lib/srk/qQ.mli" + "_build/install/default/lib/srk/quantifier.ml" + "_build/install/default/lib/srk/quantifier.mli" + "_build/install/default/lib/srk/randomFormula.ml" + "_build/install/default/lib/srk/rational.ml" + "_build/install/default/lib/srk/rational.mli" + "_build/install/default/lib/srk/ring.ml" + "_build/install/default/lib/srk/ring.mli" + "_build/install/default/lib/srk/sequence.ml" + "_build/install/default/lib/srk/sequence.mli" + "_build/install/default/lib/srk/smt.ml" + "_build/install/default/lib/srk/smt.mli" + "_build/install/default/lib/srk/solvablePolynomial.ml" + "_build/install/default/lib/srk/solvablePolynomial.mli" + "_build/install/default/lib/srk/sparseMap.ml" + "_build/install/default/lib/srk/sparseMap.mli" + "_build/install/default/lib/srk/srk.a" + "_build/install/default/lib/srk/srk.cmi" + "_build/install/default/lib/srk/srk.cmt" + "_build/install/default/lib/srk/srk.cmx" + "_build/install/default/lib/srk/srk.cmxa" + "_build/install/default/lib/srk/srk.ml" + "_build/install/default/lib/srk/srkApron.ml" + "_build/install/default/lib/srk/srkApron.mli" + "_build/install/default/lib/srk/srkAst.ml" + "_build/install/default/lib/srk/srkLex.ml" + "_build/install/default/lib/srk/srkParse.ml" + "_build/install/default/lib/srk/srkParse.mli" + "_build/install/default/lib/srk/srkSimplify.ml" + "_build/install/default/lib/srk/srkSimplify.mli" + "_build/install/default/lib/srk/srkSmtlib2.ml" + "_build/install/default/lib/srk/srkSmtlib2.mli" + "_build/install/default/lib/srk/srkSmtlib2Defs.ml" + "_build/install/default/lib/srk/srkSmtlib2Lex.ml" + "_build/install/default/lib/srk/srkSmtlib2Parse.ml" + "_build/install/default/lib/srk/srkSmtlib2Parse.mli" + "_build/install/default/lib/srk/srkUtil.ml" + "_build/install/default/lib/srk/srkZ3.ml" + "_build/install/default/lib/srk/srkZ3.mli" + "_build/install/default/lib/srk/srk__Abstract.cmi" + "_build/install/default/lib/srk/srk__Abstract.cmt" + "_build/install/default/lib/srk/srk__Abstract.cmti" + "_build/install/default/lib/srk/srk__Abstract.cmx" + "_build/install/default/lib/srk/srk__Algebra.cmi" + "_build/install/default/lib/srk/srk__Algebra.cmt" + "_build/install/default/lib/srk/srk__Algebra.cmx" + "_build/install/default/lib/srk/srk__BigO.cmi" + "_build/install/default/lib/srk/srk__BigO.cmt" + "_build/install/default/lib/srk/srk__BigO.cmti" + "_build/install/default/lib/srk/srk__BigO.cmx" + "_build/install/default/lib/srk/srk__Cache.cmi" + "_build/install/default/lib/srk/srk__Cache.cmt" + "_build/install/default/lib/srk/srk__Cache.cmti" + "_build/install/default/lib/srk/srk__Cache.cmx" + "_build/install/default/lib/srk/srk__Chc.cmi" + "_build/install/default/lib/srk/srk__Chc.cmt" + "_build/install/default/lib/srk/srk__Chc.cmti" + "_build/install/default/lib/srk/srk__Chc.cmx" + "_build/install/default/lib/srk/srk__CompressedWeightedForest.cmi" + "_build/install/default/lib/srk/srk__CompressedWeightedForest.cmt" + "_build/install/default/lib/srk/srk__CompressedWeightedForest.cmti" + "_build/install/default/lib/srk/srk__CompressedWeightedForest.cmx" + "_build/install/default/lib/srk/srk__Cone.cmi" + "_build/install/default/lib/srk/srk__Cone.cmt" + "_build/install/default/lib/srk/srk__Cone.cmti" + "_build/install/default/lib/srk/srk__Cone.cmx" + "_build/install/default/lib/srk/srk__ConsequenceCone.cmi" + "_build/install/default/lib/srk/srk__ConsequenceCone.cmt" + "_build/install/default/lib/srk/srk__ConsequenceCone.cmti" + "_build/install/default/lib/srk/srk__ConsequenceCone.cmx" + "_build/install/default/lib/srk/srk__ConvexHull.cmi" + "_build/install/default/lib/srk/srk__ConvexHull.cmt" + "_build/install/default/lib/srk/srk__ConvexHull.cmti" + "_build/install/default/lib/srk/srk__ConvexHull.cmx" + "_build/install/default/lib/srk/srk__CoordinateSystem.cmi" + "_build/install/default/lib/srk/srk__CoordinateSystem.cmt" + "_build/install/default/lib/srk/srk__CoordinateSystem.cmti" + "_build/install/default/lib/srk/srk__CoordinateSystem.cmx" + "_build/install/default/lib/srk/srk__DD.cmi" + "_build/install/default/lib/srk/srk__DD.cmt" + "_build/install/default/lib/srk/srk__DD.cmti" + "_build/install/default/lib/srk/srk__DD.cmx" + "_build/install/default/lib/srk/srk__DisjointSet.cmi" + "_build/install/default/lib/srk/srk__DisjointSet.cmt" + "_build/install/default/lib/srk/srk__DisjointSet.cmx" + "_build/install/default/lib/srk/srk__ExpPolynomial.cmi" + "_build/install/default/lib/srk/srk__ExpPolynomial.cmt" + "_build/install/default/lib/srk/srk__ExpPolynomial.cmti" + "_build/install/default/lib/srk/srk__ExpPolynomial.cmx" + "_build/install/default/lib/srk/srk__FeatureTree.cmi" + "_build/install/default/lib/srk/srk__FeatureTree.cmt" + "_build/install/default/lib/srk/srk__FeatureTree.cmti" + "_build/install/default/lib/srk/srk__FeatureTree.cmx" + "_build/install/default/lib/srk/srk__Fixpoint.cmi" + "_build/install/default/lib/srk/srk__Fixpoint.cmt" + "_build/install/default/lib/srk/srk__Fixpoint.cmti" + "_build/install/default/lib/srk/srk__Fixpoint.cmx" + "_build/install/default/lib/srk/srk__IntLattice.cmi" + "_build/install/default/lib/srk/srk__IntLattice.cmt" + "_build/install/default/lib/srk/srk__IntLattice.cmti" + "_build/install/default/lib/srk/srk__IntLattice.cmx" + "_build/install/default/lib/srk/srk__Interpretation.cmi" + "_build/install/default/lib/srk/srk__Interpretation.cmt" + "_build/install/default/lib/srk/srk__Interpretation.cmti" + "_build/install/default/lib/srk/srk__Interpretation.cmx" + "_build/install/default/lib/srk/srk__Interval.cmi" + "_build/install/default/lib/srk/srk__Interval.cmt" + "_build/install/default/lib/srk/srk__Interval.cmti" + "_build/install/default/lib/srk/srk__Interval.cmx" + "_build/install/default/lib/srk/srk__Iteration.cmi" + "_build/install/default/lib/srk/srk__Iteration.cmt" + "_build/install/default/lib/srk/srk__Iteration.cmti" + "_build/install/default/lib/srk/srk__Iteration.cmx" + "_build/install/default/lib/srk/srk__Linear.cmi" + "_build/install/default/lib/srk/srk__Linear.cmt" + "_build/install/default/lib/srk/srk__Linear.cmti" + "_build/install/default/lib/srk/srk__Linear.cmx" + "_build/install/default/lib/srk/srk__Lirr.cmi" + "_build/install/default/lib/srk/srk__Lirr.cmt" + "_build/install/default/lib/srk/srk__Lirr.cmti" + "_build/install/default/lib/srk/srk__Lirr.cmx" + "_build/install/default/lib/srk/srk__LirrInvariants.cmi" + "_build/install/default/lib/srk/srk__LirrInvariants.cmt" + "_build/install/default/lib/srk/srk__LirrInvariants.cmx" + "_build/install/default/lib/srk/srk__Log.cmi" + "_build/install/default/lib/srk/srk__Log.cmt" + "_build/install/default/lib/srk/srk__Log.cmx" + "_build/install/default/lib/srk/srk__Loop.cmi" + "_build/install/default/lib/srk/srk__Loop.cmt" + "_build/install/default/lib/srk/srk__Loop.cmti" + "_build/install/default/lib/srk/srk__Loop.cmx" + "_build/install/default/lib/srk/srk__Lts.cmi" + "_build/install/default/lib/srk/srk__Lts.cmt" + "_build/install/default/lib/srk/srk__Lts.cmti" + "_build/install/default/lib/srk/srk__Lts.cmx" + "_build/install/default/lib/srk/srk__Memo.cmi" + "_build/install/default/lib/srk/srk__Memo.cmt" + "_build/install/default/lib/srk/srk__Memo.cmti" + "_build/install/default/lib/srk/srk__Memo.cmx" + "_build/install/default/lib/srk/srk__Nonlinear.cmi" + "_build/install/default/lib/srk/srk__Nonlinear.cmt" + "_build/install/default/lib/srk/srk__Nonlinear.cmti" + "_build/install/default/lib/srk/srk__Nonlinear.cmx" + "_build/install/default/lib/srk/srk__NumberField.cmi" + "_build/install/default/lib/srk/srk__NumberField.cmt" + "_build/install/default/lib/srk/srk__NumberField.cmti" + "_build/install/default/lib/srk/srk__NumberField.cmx" + "_build/install/default/lib/srk/srk__Pathexpr.cmi" + "_build/install/default/lib/srk/srk__Pathexpr.cmt" + "_build/install/default/lib/srk/srk__Pathexpr.cmti" + "_build/install/default/lib/srk/srk__Pathexpr.cmx" + "_build/install/default/lib/srk/srk__Polyhedron.cmi" + "_build/install/default/lib/srk/srk__Polyhedron.cmt" + "_build/install/default/lib/srk/srk__Polyhedron.cmti" + "_build/install/default/lib/srk/srk__Polyhedron.cmx" + "_build/install/default/lib/srk/srk__Polynomial.cmi" + "_build/install/default/lib/srk/srk__Polynomial.cmt" + "_build/install/default/lib/srk/srk__Polynomial.cmti" + "_build/install/default/lib/srk/srk__Polynomial.cmx" + "_build/install/default/lib/srk/srk__PolynomialCone.cmi" + "_build/install/default/lib/srk/srk__PolynomialCone.cmt" + "_build/install/default/lib/srk/srk__PolynomialCone.cmti" + "_build/install/default/lib/srk/srk__PolynomialCone.cmx" + "_build/install/default/lib/srk/srk__PolynomialConeCpClosure.cmi" + "_build/install/default/lib/srk/srk__PolynomialConeCpClosure.cmt" + "_build/install/default/lib/srk/srk__PolynomialConeCpClosure.cmti" + "_build/install/default/lib/srk/srk__PolynomialConeCpClosure.cmx" + "_build/install/default/lib/srk/srk__PolynomialLattice.cmi" + "_build/install/default/lib/srk/srk__PolynomialLattice.cmt" + "_build/install/default/lib/srk/srk__PolynomialLattice.cmti" + "_build/install/default/lib/srk/srk__PolynomialLattice.cmx" + "_build/install/default/lib/srk/srk__QQ.cmi" + "_build/install/default/lib/srk/srk__QQ.cmt" + "_build/install/default/lib/srk/srk__QQ.cmti" + "_build/install/default/lib/srk/srk__QQ.cmx" + "_build/install/default/lib/srk/srk__Quantifier.cmi" + "_build/install/default/lib/srk/srk__Quantifier.cmt" + "_build/install/default/lib/srk/srk__Quantifier.cmti" + "_build/install/default/lib/srk/srk__Quantifier.cmx" + "_build/install/default/lib/srk/srk__RandomFormula.cmi" + "_build/install/default/lib/srk/srk__RandomFormula.cmt" + "_build/install/default/lib/srk/srk__RandomFormula.cmx" + "_build/install/default/lib/srk/srk__Rational.cmi" + "_build/install/default/lib/srk/srk__Rational.cmt" + "_build/install/default/lib/srk/srk__Rational.cmti" + "_build/install/default/lib/srk/srk__Rational.cmx" + "_build/install/default/lib/srk/srk__Ring.cmi" + "_build/install/default/lib/srk/srk__Ring.cmt" + "_build/install/default/lib/srk/srk__Ring.cmti" + "_build/install/default/lib/srk/srk__Ring.cmx" + "_build/install/default/lib/srk/srk__Sequence.cmi" + "_build/install/default/lib/srk/srk__Sequence.cmt" + "_build/install/default/lib/srk/srk__Sequence.cmti" + "_build/install/default/lib/srk/srk__Sequence.cmx" + "_build/install/default/lib/srk/srk__Smt.cmi" + "_build/install/default/lib/srk/srk__Smt.cmt" + "_build/install/default/lib/srk/srk__Smt.cmti" + "_build/install/default/lib/srk/srk__Smt.cmx" + "_build/install/default/lib/srk/srk__SolvablePolynomial.cmi" + "_build/install/default/lib/srk/srk__SolvablePolynomial.cmt" + "_build/install/default/lib/srk/srk__SolvablePolynomial.cmti" + "_build/install/default/lib/srk/srk__SolvablePolynomial.cmx" + "_build/install/default/lib/srk/srk__SparseMap.cmi" + "_build/install/default/lib/srk/srk__SparseMap.cmt" + "_build/install/default/lib/srk/srk__SparseMap.cmti" + "_build/install/default/lib/srk/srk__SparseMap.cmx" + "_build/install/default/lib/srk/srk__SrkApron.cmi" + "_build/install/default/lib/srk/srk__SrkApron.cmt" + "_build/install/default/lib/srk/srk__SrkApron.cmti" + "_build/install/default/lib/srk/srk__SrkApron.cmx" + "_build/install/default/lib/srk/srk__SrkAst.cmi" + "_build/install/default/lib/srk/srk__SrkAst.cmt" + "_build/install/default/lib/srk/srk__SrkAst.cmx" + "_build/install/default/lib/srk/srk__SrkLex.cmi" + "_build/install/default/lib/srk/srk__SrkLex.cmt" + "_build/install/default/lib/srk/srk__SrkLex.cmx" + "_build/install/default/lib/srk/srk__SrkParse.cmi" + "_build/install/default/lib/srk/srk__SrkParse.cmt" + "_build/install/default/lib/srk/srk__SrkParse.cmti" + "_build/install/default/lib/srk/srk__SrkParse.cmx" + "_build/install/default/lib/srk/srk__SrkSimplify.cmi" + "_build/install/default/lib/srk/srk__SrkSimplify.cmt" + "_build/install/default/lib/srk/srk__SrkSimplify.cmti" + "_build/install/default/lib/srk/srk__SrkSimplify.cmx" + "_build/install/default/lib/srk/srk__SrkSmtlib2.cmi" + "_build/install/default/lib/srk/srk__SrkSmtlib2.cmt" + "_build/install/default/lib/srk/srk__SrkSmtlib2.cmti" + "_build/install/default/lib/srk/srk__SrkSmtlib2.cmx" + "_build/install/default/lib/srk/srk__SrkSmtlib2Defs.cmi" + "_build/install/default/lib/srk/srk__SrkSmtlib2Defs.cmt" + "_build/install/default/lib/srk/srk__SrkSmtlib2Defs.cmx" + "_build/install/default/lib/srk/srk__SrkSmtlib2Lex.cmi" + "_build/install/default/lib/srk/srk__SrkSmtlib2Lex.cmt" + "_build/install/default/lib/srk/srk__SrkSmtlib2Lex.cmx" + "_build/install/default/lib/srk/srk__SrkSmtlib2Parse.cmi" + "_build/install/default/lib/srk/srk__SrkSmtlib2Parse.cmt" + "_build/install/default/lib/srk/srk__SrkSmtlib2Parse.cmti" + "_build/install/default/lib/srk/srk__SrkSmtlib2Parse.cmx" + "_build/install/default/lib/srk/srk__SrkUtil.cmi" + "_build/install/default/lib/srk/srk__SrkUtil.cmt" + "_build/install/default/lib/srk/srk__SrkUtil.cmx" + "_build/install/default/lib/srk/srk__SrkZ3.cmi" + "_build/install/default/lib/srk/srk__SrkZ3.cmt" + "_build/install/default/lib/srk/srk__SrkZ3.cmti" + "_build/install/default/lib/srk/srk__SrkZ3.cmx" + "_build/install/default/lib/srk/srk__Syntax.cmi" + "_build/install/default/lib/srk/srk__Syntax.cmt" + "_build/install/default/lib/srk/srk__Syntax.cmti" + "_build/install/default/lib/srk/srk__Syntax.cmx" + "_build/install/default/lib/srk/srk__TerminationDTA.cmi" + "_build/install/default/lib/srk/srk__TerminationDTA.cmt" + "_build/install/default/lib/srk/srk__TerminationDTA.cmx" + "_build/install/default/lib/srk/srk__TerminationExp.cmi" + "_build/install/default/lib/srk/srk__TerminationExp.cmt" + "_build/install/default/lib/srk/srk__TerminationExp.cmx" + "_build/install/default/lib/srk/srk__TerminationLLRF.cmi" + "_build/install/default/lib/srk/srk__TerminationLLRF.cmt" + "_build/install/default/lib/srk/srk__TerminationLLRF.cmx" + "_build/install/default/lib/srk/srk__TerminationPRF.cmi" + "_build/install/default/lib/srk/srk__TerminationPRF.cmt" + "_build/install/default/lib/srk/srk__TerminationPRF.cmx" + "_build/install/default/lib/srk/srk__Transition.cmi" + "_build/install/default/lib/srk/srk__Transition.cmt" + "_build/install/default/lib/srk/srk__Transition.cmti" + "_build/install/default/lib/srk/srk__Transition.cmx" + "_build/install/default/lib/srk/srk__TransitionFormula.cmi" + "_build/install/default/lib/srk/srk__TransitionFormula.cmt" + "_build/install/default/lib/srk/srk__TransitionFormula.cmti" + "_build/install/default/lib/srk/srk__TransitionFormula.cmx" + "_build/install/default/lib/srk/srk__TransitionIdeal.cmi" + "_build/install/default/lib/srk/srk__TransitionIdeal.cmt" + "_build/install/default/lib/srk/srk__TransitionIdeal.cmti" + "_build/install/default/lib/srk/srk__TransitionIdeal.cmx" + "_build/install/default/lib/srk/srk__TransitionSystem.cmi" + "_build/install/default/lib/srk/srk__TransitionSystem.cmt" + "_build/install/default/lib/srk/srk__TransitionSystem.cmti" + "_build/install/default/lib/srk/srk__TransitionSystem.cmx" + "_build/install/default/lib/srk/srk__Vas.cmi" + "_build/install/default/lib/srk/srk__Vas.cmt" + "_build/install/default/lib/srk/srk__Vas.cmti" + "_build/install/default/lib/srk/srk__Vas.cmx" + "_build/install/default/lib/srk/srk__Vass.cmi" + "_build/install/default/lib/srk/srk__Vass.cmt" + "_build/install/default/lib/srk/srk__Vass.cmti" + "_build/install/default/lib/srk/srk__Vass.cmx" + "_build/install/default/lib/srk/srk__Wedge.cmi" + "_build/install/default/lib/srk/srk__Wedge.cmt" + "_build/install/default/lib/srk/srk__Wedge.cmti" + "_build/install/default/lib/srk/srk__Wedge.cmx" + "_build/install/default/lib/srk/srk__WeightedGraph.cmi" + "_build/install/default/lib/srk/srk__WeightedGraph.cmt" + "_build/install/default/lib/srk/srk__WeightedGraph.cmti" + "_build/install/default/lib/srk/srk__WeightedGraph.cmx" + "_build/install/default/lib/srk/srk__ZZ.cmi" + "_build/install/default/lib/srk/srk__ZZ.cmt" + "_build/install/default/lib/srk/srk__ZZ.cmti" + "_build/install/default/lib/srk/srk__ZZ.cmx" + "_build/install/default/lib/srk/syntax.ml" + "_build/install/default/lib/srk/syntax.mli" + "_build/install/default/lib/srk/terminationDTA.ml" + "_build/install/default/lib/srk/terminationExp.ml" + "_build/install/default/lib/srk/terminationLLRF.ml" + "_build/install/default/lib/srk/terminationPRF.ml" + "_build/install/default/lib/srk/transition.ml" + "_build/install/default/lib/srk/transition.mli" + "_build/install/default/lib/srk/transitionFormula.ml" + "_build/install/default/lib/srk/transitionFormula.mli" + "_build/install/default/lib/srk/transitionIdeal.ml" + "_build/install/default/lib/srk/transitionIdeal.mli" + "_build/install/default/lib/srk/transitionSystem.ml" + "_build/install/default/lib/srk/transitionSystem.mli" + "_build/install/default/lib/srk/vas.ml" + "_build/install/default/lib/srk/vas.mli" + "_build/install/default/lib/srk/vass.ml" + "_build/install/default/lib/srk/vass.mli" + "_build/install/default/lib/srk/wedge.ml" + "_build/install/default/lib/srk/wedge.mli" + "_build/install/default/lib/srk/weightedGraph.ml" + "_build/install/default/lib/srk/weightedGraph.mli" + "_build/install/default/lib/srk/zZ.ml" + "_build/install/default/lib/srk/zZ.mli" +] +libexec: [ + "_build/install/default/lib/srk/srk.cmxs" +] +doc: [ + "_build/install/default/doc/srk/README.md" +] From bd5ca70f601dcfb0f70c12e7fb6faf83a6da7430 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Sat, 14 Jun 2025 12:50:28 -0500 Subject: [PATCH 42/59] -w --- srk/dune-project | 1 - srk/src/dune | 1 + 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/srk/dune-project b/srk/dune-project index 8f5722aa..64bc2358 100644 --- a/srk/dune-project +++ b/srk/dune-project @@ -2,7 +2,6 @@ (name srk) (using menhir 2.0) (generate_opam_files true) - (package (name srk) (synopsis "Symbolic Reasoning Kit") diff --git a/srk/src/dune b/srk/src/dune index ecd62a9c..11e8c5ed 100644 --- a/srk/src/dune +++ b/srk/src/dune @@ -12,6 +12,7 @@ (public_name srk) (modules (:standard \ bigtop)) (modes native) + (flags (:standard -w -32)) (libraries batteries ppx_deriving ppx_deriving.show ppx_deriving.ord ppx_deriving.eq From b07f52ff1c4c961e009411cda54d5388d28b18a7 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Sat, 14 Jun 2025 12:51:46 -0500 Subject: [PATCH 43/59] remove printing --- srk/src/transitionSystem.ml | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index c68ac64e..d3f6e950 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -765,14 +765,12 @@ module Make let tg' = WG.fold_vertex (fun v tg -> let ug = WG.forget_weights tg in - Printf.printf "visiting vertex %d\n" v; if (p v || WG.mem_edge tg v v || (WG.U.in_degree ug v != 1 && WG.U.out_degree ug v != 1)) then begin if try_rtc then begin - let _ = Printf.printf "trying rtc on vertex %d\n " v in begin if WG.mem_edge tg v v then match WG.edge_weight tg v v with | Weight tr -> @@ -780,16 +778,14 @@ module Make | Some rtc -> let u = -1 in (try - Printf.printf "removing edge from %d %d\n" v v; let tg = WG.remove_edge tg v v in let tg = - Printf.printf "success: contracting vertex %d %d\n" v u; WG.contract_vertex (WG.split_vertex tg v (Weight rtc) u) u in continue := true; tg with _ -> tg) - | None -> Printf.printf "...failed.\n"; tg end + | None -> tg end with _ -> tg) | Call (_, _) -> tg else From d6273300562804630c9d355a03dc94c248096819 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 26 Jun 2025 23:20:10 -0500 Subject: [PATCH 44/59] more changes to inliner --- duet/cra.ml | 7 ++- duet/duet.ml | 6 ++ duet/gps.ml | 2 +- duet/translateCil.ml | 9 ++- srk/src/transitionSystem.ml | 103 ++++++++++++++++++++++++----------- srk/src/transitionSystem.mli | 2 +- srk/src/weightedGraph.ml | 3 + srk/src/weightedGraph.mli | 2 + 8 files changed, 96 insertions(+), 38 deletions(-) diff --git a/duet/cra.ml b/duet/cra.ml index 08552607..ea52fa46 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -976,7 +976,12 @@ let make_transition_system ?(simplify=true) ?(instr_gas=false) (main_entry: int) TS.empty (RG.bodies rg) in - (ts, !assertions) + (* perform some inlining *) + Printf.printf "calling inliner...\n"; + let inlined_ts = + TS.inline ts main_entry (fun _ -> ()) in + Printf.printf "----------inlining done-----\n"; + (inlined_ts, !assertions) let mk_query ts entry = TS.mk_query ts entry diff --git a/duet/duet.ml b/duet/duet.ml index 505f2d1f..29bf90b8 100644 --- a/duet/duet.ml +++ b/duet/duet.ml @@ -19,6 +19,12 @@ let anon_fun s = ignore (CmdLine.parse s) let _ = Sys.set_signal Sys.sigtstp (Sys.Signal_handle (fun _ -> Log.print_stats ())); + Printexc.record_backtrace true;; + Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> + Printf.eprintf "SIGINT received. Backtrace:\n%!"; + Printexc.print_backtrace stderr; + exit 1 + ));; let spec_list = CmdLine.spec_list () in Arg.parse (Arg.align spec_list) anon_fun usage_msg; match !CfgIr.gfile with diff --git a/duet/gps.ml b/duet/gps.ml index 391bb6c2..b09438b2 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -686,7 +686,7 @@ let analyze_impact file = else if ART.maps_to art u == err_loc then match ART.generate_test art u with | `Pruned -> - List.iter (fun v -> ignore (ART.close art v)) (ART.tree_path art u); + List.iter (fun v -> ignore (ART.lclose art v)) (ART.tree_path art u); loop () | `Test _ -> `Unsafe else (ART.expand art u; loop ()) diff --git a/duet/translateCil.ml b/duet/translateCil.ml index ff34ca58..f349b42b 100644 --- a/duet/translateCil.ml +++ b/duet/translateCil.ml @@ -481,11 +481,12 @@ let tr_instr ctx instr = mk_def (Assign (v, Havoc (Concrete (Int 1)))) | ("__VERIFIER_nondet_uchar", Some (Variable v), []) -> let havoc = mk_def (Assign (v, Havoc (Concrete (Int 1)))) in - let assume0 = + (*let assume0 = mk_def (Assume (Atom (Le, Aexpr.zero, AccessPath (Variable v)))) in let assume1 = mk_def (Assume (Atom (Le, AccessPath (Variable v), Constant (CInt (255, 1))))) in - mk_seq havoc @@ mk_seq assume0 assume1 + mk_seq havoc @@ mk_seq assume0 assume1 *) + havoc | ("__VERIFIER_nondet_int", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int machine_int_width)))) | ("__VERIFIER_nondet_long", Some (Variable v), []) -> @@ -494,12 +495,14 @@ let tr_instr ctx instr = | ("__VERIFIER_nondet_pointer", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int pointer_width)))) | ("__VERIFIER_nondet_bool", Some (Variable v), []) -> - let assume_lb = + (*let assume_lb = mk_def (Assume (Atom (Le, Aexpr.zero, AccessPath (Variable v)))) in (* 0 <= v *) let assume_ub = mk_def (Assume (Atom (Le, AccessPath (Variable v), Aexpr.one))) in (* v <= 1 *) let havoc = mk_def (Assign (v, Havoc (Concrete (Int 1)))) in mk_seq havoc @@ mk_seq assume_lb assume_ub + havoc*) + mk_def (Assign (v, Havoc (Concrete (Int 1)))) | ("__VERIFIER_nondet_uint", Some (Variable v), []) -> let havoc = mk_def (Assign (v, Havoc (Concrete (Int unknown_width)))) in let assume = diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index d3f6e950..0f932d69 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -684,10 +684,13 @@ module Make in List.map invariants (L.all_loops (L.loop_nest tg)) - - let inline ?(depth=(-1)) tg = + + let inline ?(depth=(-1)) tg entry (displayer: t -> unit)= let pmap = PHT.create 998 in (* y in pmap[x] means call from x->y *) let qmap = PHT.create 998 in (* (x, z) in qmap[y] means call from x->y via call-edge z *) + let greatest = ref (WG.fold_vertex max tg (-1)) in + PHT.add pmap (entry, -1) PS.empty; + PHT.add qmap (entry, -1) PPS.empty; let procedures = WG.fold_edges (fun (_, w, _) acc -> match w with @@ -704,37 +707,60 @@ module Make end; PS.add (x, y) acc | _ -> acc - ) tg PS.empty in - let rec dfs (proc: int * int) tg src (visited : ISet.t) = - WG.iter_succ_e (fun (_, w, v) -> - match w with - | Call (x, y) -> - let caller_set = PHT.find pmap proc in - let callee_set = PHT.find qmap (x, y) in - PHT.add pmap proc (PS.add (x, y) caller_set); - PHT.add qmap (x, y) (PPS.add (proc, (src, v)) callee_set); - begin match ISet.find_opt v visited with - | None -> dfs proc tg v (ISet.add v visited) - | Some _ -> () - end - | _ -> - begin match ISet.find_opt v visited with - | None -> dfs proc tg v (ISet.add v visited) - | Some _ -> () - end - ) tg src in - PS.iter (fun (x, y) -> dfs (x, y) tg x ISet.empty) procedures; (* populate pmap, qmap *) + ) tg (PS.add (entry, -1) PS.empty) in + let rec dfs (proc: int * int) tg src (f: (vertex * vertex) -> vertex -> vertex * 'a label * vertex -> unit) (visited : ISet.t) = + Printf.printf "dfs: visiting %d\n" src; + WG.fold_succ_e (fun (u, w, v) visited -> + f proc src (u, w, v); + begin match ISet.find_opt v visited with + | None -> ISet.union (dfs proc tg v f (ISet.add v visited)) visited + | Some _ -> visited + end) tg src visited in + PS.iter (fun (x, y) -> + Printf.printf "populating p/qmaps with dfs... %d %d\n" x y; + ignore @@ dfs (x, y) tg x (fun proc src (_, w, v) -> + match w with + | Call (x, y) -> + let caller_set = PHT.find pmap proc in + let callee_set = PHT.find qmap (x, y) in + PHT.add pmap proc (PS.add (x, y) caller_set); + PHT.add qmap (x, y) (PPS.add (proc, (src, v)) callee_set); + | _ -> () + ) (ISet.add x ISet.empty)) procedures; (* populate pmap, qmap *) let compute_sinks () = PS.fold (fun (x, y) acc -> (* compute sink locations to start inlining from *) match (PHT.find_opt pmap (x, y), PHT.find_opt qmap (x, y)) with | Some callees, Some callers -> (* a procedure is considered for inlining if it is (1) a sink in the call graph (2) at least one function calls it.*) - if ((PS.cardinal callees) == 0) && ((PPS.cardinal callers) > 0) then PS.add (x, y) acc else acc + if ((PS.cardinal callees) == 0) && ((PPS.cardinal callers) > 0) then PS.add (x, y) acc else + begin + Printf.printf "%d %d is not a sink; num callees = %d num callers = %d\n" x y (PS.cardinal callees) (PPS.cardinal callers); + acc + end | (_, _) -> failwith "" ) procedures PS.empty in + let copy_subgraph tg src = + let vertices = dfs (-1, -1) tg src (fun _ _ _ -> ()) (ISet.add src ISet.empty) in + let to_map = Hashtbl.create 998 in + let rtg = ref tg in + ISet.iter (fun x -> + greatest := !greatest + 1; + Hashtbl.add to_map x (!greatest); + rtg := WG.add_vertex !rtg !greatest + ) vertices; + ISet.iter (fun x -> + rtg := WG.fold_succ_e (fun (u, w, v) tg' -> + WG.add_edge tg' (Hashtbl.find to_map u) w (Hashtbl.find to_map v)) + !rtg x !rtg) vertices; + (!rtg, Hashtbl.find to_map) + in let remove_subgraph tg src = + let vertices = dfs (-1, -1) tg src (fun _ _ _ -> ()) (ISet.add src ISet.empty) in + ISet.fold (fun vtx tg' -> WG.remove_vertex tg' vtx) vertices tg in let inline_one tg (src, dst) (call_x, call_y) (call_src, call_dst) = - let tg = WG.add_edge tg call_x (Weight T.one) src in - let tg = WG.add_edge tg dst (Weight T.one) dst in + Printf.printf "inlining %d-%d into call edge %d-%d\n" src dst call_x call_y; + let (tg, to_map) = copy_subgraph tg src in + let tg = WG.add_edge tg call_x (Weight T.one) (to_map src) in + let tg = WG.add_edge tg (to_map dst) (Weight T.one) call_y in let tg = WG.remove_edge tg call_x call_y in let callees = PHT.find pmap (call_src, call_dst) in let callers = PHT.find qmap (src, dst) in @@ -748,19 +774,32 @@ module Make let sinks = compute_sinks () in let aux currproc tg = (* inline currproc into procedures that call it, assuming currproc is inlined. *) let inline_targets = PHT.find qmap currproc in - PPS.fold (fun (call_proc, (call_x, call_y)) tg -> - inline_one tg currproc (call_x, call_y) call_proc - ) inline_targets tg - in - PS.fold (fun call tg -> aux call tg) sinks tg - |> do_inline (if depth > 0 then depth - 1 else depth) - in do_inline depth tg + let tg' = + PPS.fold (fun (call_proc, (call_x, call_y)) tg -> + Printf.printf "do_inline: at edge %d %d\n\n" call_x call_y; + inline_one tg currproc (call_x, call_y) call_proc + ) inline_targets tg in + let (src, _) = currproc in + remove_subgraph tg' src + in + displayer tg; + match PS.cardinal sinks with + | n when n > 0 -> + Printf.printf "inliner: there are %d sinks to inline \n" n; + let tg' = (PS.fold aux sinks tg) in + tg' + |> do_inline ( + Printf.printf "doing more inling...\n"; + if depth > 0 then depth - 1 else depth) + | _ -> Printf.printf "no more sinks to inline. done\n"; tg + in let result = do_inline depth tg in Printf.printf "inlining done"; result let simplify ?(try_rtc=true) p tg = let rec go tg = + Printf.printf "simplify: simplifying...\n"; let continue = ref false in let tg' = WG.fold_vertex (fun v tg -> diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index 6ec8a62b..e2254647 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -106,7 +106,7 @@ module Make (** Perform inlining of a potentially recursive iCFG. *) - val inline : ?depth:int -> t -> t + val inline : ?depth:int -> t -> vertex -> (t -> unit) -> t (** Given a transition system and entry, compute a set of loop headers along with the set of variables that are read within the diff --git a/srk/src/weightedGraph.ml b/srk/src/weightedGraph.ml index f1075ae7..e9d0b947 100644 --- a/srk/src/weightedGraph.ml +++ b/srk/src/weightedGraph.ml @@ -50,6 +50,9 @@ let empty algebra = labels = M.empty; algebra = algebra } +let get_algebra wg = + wg.algebra + let add_vertex wg vertex = { wg with graph = U.add_vertex wg.graph vertex } diff --git a/srk/src/weightedGraph.mli b/srk/src/weightedGraph.mli index f9b39c78..5d172de4 100644 --- a/srk/src/weightedGraph.mli +++ b/srk/src/weightedGraph.mli @@ -29,6 +29,8 @@ type vertex = int (** Create an empty weighted graph over the given algebra of weights. *) val empty : ('a algebra) -> 'a t +val get_algebra : 'a t -> ('a algebra) + (** Add a vertex to a graph. *) val add_vertex : 'a t -> vertex -> 'a t From 148cfade266e62494b3c7656acbd759c92121130 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Fri, 27 Jun 2025 21:49:15 -0500 Subject: [PATCH 45/59] inliner bugfix --- duet/cra.ml | 6 +- srk/src/transitionSystem.ml | 19 +- srk/src/transitionSystem.mli | 2 +- srk/srk.install | 397 ----------------------------------- 4 files changed, 20 insertions(+), 404 deletions(-) delete mode 100644 srk/srk.install diff --git a/duet/cra.ml b/duet/cra.ml index ea52fa46..96a2431f 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -978,10 +978,10 @@ let make_transition_system ?(simplify=true) ?(instr_gas=false) (main_entry: int) in (* perform some inlining *) Printf.printf "calling inliner...\n"; - let inlined_ts = - TS.inline ts main_entry (fun _ -> ()) in + let inlined_ts, new_assertions = + TS.inline ts main_entry (fun _ -> ()) (!assertions) in Printf.printf "----------inlining done-----\n"; - (inlined_ts, !assertions) + (inlined_ts, new_assertions) let mk_query ts entry = TS.mk_query ts entry diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index 0f932d69..517e9699 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -685,10 +685,11 @@ module Make List.map invariants (L.all_loops (L.loop_nest tg)) - let inline ?(depth=(-1)) tg entry (displayer: t -> unit)= + let inline ?(depth=(-1)) tg entry (displayer: t -> unit) (assertion_map : 'x SrkUtil.Int.Map.t) = let pmap = PHT.create 998 in (* y in pmap[x] means call from x->y *) let qmap = PHT.create 998 in (* (x, z) in qmap[y] means call from x->y via call-edge z *) let greatest = ref (WG.fold_vertex max tg (-1)) in + let assertions = ref assertion_map in PHT.add pmap (entry, -1) PS.empty; PHT.add qmap (entry, -1) PPS.empty; let procedures = @@ -746,6 +747,10 @@ module Make ISet.iter (fun x -> greatest := !greatest + 1; Hashtbl.add to_map x (!greatest); + begin match SrkUtil.Int.Map.find_opt x !assertions with (* if x in assertions, new vertex also in assertions *) + | Some assert_value -> + assertions := SrkUtil.Int.Map.add !greatest assert_value !assertions + | None -> () end; rtg := WG.add_vertex !rtg !greatest ) vertices; ISet.iter (fun x -> @@ -755,7 +760,14 @@ module Make (!rtg, Hashtbl.find to_map) in let remove_subgraph tg src = let vertices = dfs (-1, -1) tg src (fun _ _ _ -> ()) (ISet.add src ISet.empty) in - ISet.fold (fun vtx tg' -> WG.remove_vertex tg' vtx) vertices tg in + ISet.fold (fun vtx tg' -> + begin match SrkUtil.Int.Map.find_opt vtx !assertions with + (* remove vertex from assertions map, new copied vertices already in it *) + | Some _ -> + assertions := SrkUtil.Int.Map.remove vtx !assertions + | None -> () + end; + WG.remove_vertex tg' vtx) vertices tg in let inline_one tg (src, dst) (call_x, call_y) (call_src, call_dst) = Printf.printf "inlining %d-%d into call edge %d-%d\n" src dst call_x call_y; let (tg, to_map) = copy_subgraph tg src in @@ -792,7 +804,8 @@ module Make Printf.printf "doing more inling...\n"; if depth > 0 then depth - 1 else depth) | _ -> Printf.printf "no more sinks to inline. done\n"; tg - in let result = do_inline depth tg in Printf.printf "inlining done"; result + in let result = do_inline depth tg in + (result, !assertions) diff --git a/srk/src/transitionSystem.mli b/srk/src/transitionSystem.mli index e2254647..fc10abed 100644 --- a/srk/src/transitionSystem.mli +++ b/srk/src/transitionSystem.mli @@ -106,7 +106,7 @@ module Make (** Perform inlining of a potentially recursive iCFG. *) - val inline : ?depth:int -> t -> vertex -> (t -> unit) -> t + val inline : ?depth:int -> t -> vertex -> (t -> unit) -> ('x SrkUtil.Int.Map.t) -> (t * 'x SrkUtil.Int.Map.t) (** Given a transition system and entry, compute a set of loop headers along with the set of variables that are read within the diff --git a/srk/srk.install b/srk/srk.install deleted file mode 100644 index 2be4dffd..00000000 --- a/srk/srk.install +++ /dev/null @@ -1,397 +0,0 @@ -lib: [ - "_build/install/default/lib/srk/META" - "_build/install/default/lib/srk/abstract.ml" - "_build/install/default/lib/srk/abstract.mli" - "_build/install/default/lib/srk/algebra.ml" - "_build/install/default/lib/srk/bigO.ml" - "_build/install/default/lib/srk/bigO.mli" - "_build/install/default/lib/srk/cache.ml" - "_build/install/default/lib/srk/cache.mli" - "_build/install/default/lib/srk/chc.ml" - "_build/install/default/lib/srk/chc.mli" - "_build/install/default/lib/srk/compressedWeightedForest.ml" - "_build/install/default/lib/srk/compressedWeightedForest.mli" - "_build/install/default/lib/srk/cone.ml" - "_build/install/default/lib/srk/cone.mli" - "_build/install/default/lib/srk/consequenceCone.ml" - "_build/install/default/lib/srk/consequenceCone.mli" - "_build/install/default/lib/srk/convexHull.ml" - "_build/install/default/lib/srk/convexHull.mli" - "_build/install/default/lib/srk/coordinateSystem.ml" - "_build/install/default/lib/srk/coordinateSystem.mli" - "_build/install/default/lib/srk/dD.ml" - "_build/install/default/lib/srk/dD.mli" - "_build/install/default/lib/srk/disjointSet.ml" - "_build/install/default/lib/srk/dune-package" - "_build/install/default/lib/srk/expPolynomial.ml" - "_build/install/default/lib/srk/expPolynomial.mli" - "_build/install/default/lib/srk/featureTree.ml" - "_build/install/default/lib/srk/featureTree.mli" - "_build/install/default/lib/srk/fixpoint.ml" - "_build/install/default/lib/srk/fixpoint.mli" - "_build/install/default/lib/srk/intLattice.ml" - "_build/install/default/lib/srk/intLattice.mli" - "_build/install/default/lib/srk/interpretation.ml" - "_build/install/default/lib/srk/interpretation.mli" - "_build/install/default/lib/srk/interval.ml" - "_build/install/default/lib/srk/interval.mli" - "_build/install/default/lib/srk/iteration.ml" - "_build/install/default/lib/srk/iteration.mli" - "_build/install/default/lib/srk/linear.ml" - "_build/install/default/lib/srk/linear.mli" - "_build/install/default/lib/srk/lirr.ml" - "_build/install/default/lib/srk/lirr.mli" - "_build/install/default/lib/srk/lirrInvariants.ml" - "_build/install/default/lib/srk/log.ml" - "_build/install/default/lib/srk/loop.ml" - "_build/install/default/lib/srk/loop.mli" - "_build/install/default/lib/srk/lts.ml" - "_build/install/default/lib/srk/lts.mli" - "_build/install/default/lib/srk/memo.ml" - "_build/install/default/lib/srk/memo.mli" - "_build/install/default/lib/srk/nonlinear.ml" - "_build/install/default/lib/srk/nonlinear.mli" - "_build/install/default/lib/srk/numberField.ml" - "_build/install/default/lib/srk/numberField.mli" - "_build/install/default/lib/srk/opam" - "_build/install/default/lib/srk/pathexpr.ml" - "_build/install/default/lib/srk/pathexpr.mli" - "_build/install/default/lib/srk/polyhedron.ml" - "_build/install/default/lib/srk/polyhedron.mli" - "_build/install/default/lib/srk/polynomial.ml" - "_build/install/default/lib/srk/polynomial.mli" - "_build/install/default/lib/srk/polynomialCone.ml" - "_build/install/default/lib/srk/polynomialCone.mli" - "_build/install/default/lib/srk/polynomialConeCpClosure.ml" - "_build/install/default/lib/srk/polynomialConeCpClosure.mli" - "_build/install/default/lib/srk/polynomialLattice.ml" - "_build/install/default/lib/srk/polynomialLattice.mli" - "_build/install/default/lib/srk/qQ.ml" - "_build/install/default/lib/srk/qQ.mli" - "_build/install/default/lib/srk/quantifier.ml" - "_build/install/default/lib/srk/quantifier.mli" - "_build/install/default/lib/srk/randomFormula.ml" - "_build/install/default/lib/srk/rational.ml" - "_build/install/default/lib/srk/rational.mli" - "_build/install/default/lib/srk/ring.ml" - "_build/install/default/lib/srk/ring.mli" - "_build/install/default/lib/srk/sequence.ml" - "_build/install/default/lib/srk/sequence.mli" - "_build/install/default/lib/srk/smt.ml" - "_build/install/default/lib/srk/smt.mli" - "_build/install/default/lib/srk/solvablePolynomial.ml" - "_build/install/default/lib/srk/solvablePolynomial.mli" - "_build/install/default/lib/srk/sparseMap.ml" - "_build/install/default/lib/srk/sparseMap.mli" - "_build/install/default/lib/srk/srk.a" - "_build/install/default/lib/srk/srk.cmi" - "_build/install/default/lib/srk/srk.cmt" - "_build/install/default/lib/srk/srk.cmx" - "_build/install/default/lib/srk/srk.cmxa" - "_build/install/default/lib/srk/srk.ml" - "_build/install/default/lib/srk/srkApron.ml" - "_build/install/default/lib/srk/srkApron.mli" - "_build/install/default/lib/srk/srkAst.ml" - "_build/install/default/lib/srk/srkLex.ml" - "_build/install/default/lib/srk/srkParse.ml" - "_build/install/default/lib/srk/srkParse.mli" - "_build/install/default/lib/srk/srkSimplify.ml" - "_build/install/default/lib/srk/srkSimplify.mli" - "_build/install/default/lib/srk/srkSmtlib2.ml" - "_build/install/default/lib/srk/srkSmtlib2.mli" - "_build/install/default/lib/srk/srkSmtlib2Defs.ml" - "_build/install/default/lib/srk/srkSmtlib2Lex.ml" - "_build/install/default/lib/srk/srkSmtlib2Parse.ml" - "_build/install/default/lib/srk/srkSmtlib2Parse.mli" - "_build/install/default/lib/srk/srkUtil.ml" - "_build/install/default/lib/srk/srkZ3.ml" - "_build/install/default/lib/srk/srkZ3.mli" - "_build/install/default/lib/srk/srk__Abstract.cmi" - "_build/install/default/lib/srk/srk__Abstract.cmt" - "_build/install/default/lib/srk/srk__Abstract.cmti" - "_build/install/default/lib/srk/srk__Abstract.cmx" - "_build/install/default/lib/srk/srk__Algebra.cmi" - "_build/install/default/lib/srk/srk__Algebra.cmt" - "_build/install/default/lib/srk/srk__Algebra.cmx" - "_build/install/default/lib/srk/srk__BigO.cmi" - "_build/install/default/lib/srk/srk__BigO.cmt" - "_build/install/default/lib/srk/srk__BigO.cmti" - "_build/install/default/lib/srk/srk__BigO.cmx" - "_build/install/default/lib/srk/srk__Cache.cmi" - "_build/install/default/lib/srk/srk__Cache.cmt" - "_build/install/default/lib/srk/srk__Cache.cmti" - "_build/install/default/lib/srk/srk__Cache.cmx" - "_build/install/default/lib/srk/srk__Chc.cmi" - "_build/install/default/lib/srk/srk__Chc.cmt" - "_build/install/default/lib/srk/srk__Chc.cmti" - "_build/install/default/lib/srk/srk__Chc.cmx" - "_build/install/default/lib/srk/srk__CompressedWeightedForest.cmi" - "_build/install/default/lib/srk/srk__CompressedWeightedForest.cmt" - "_build/install/default/lib/srk/srk__CompressedWeightedForest.cmti" - "_build/install/default/lib/srk/srk__CompressedWeightedForest.cmx" - "_build/install/default/lib/srk/srk__Cone.cmi" - "_build/install/default/lib/srk/srk__Cone.cmt" - "_build/install/default/lib/srk/srk__Cone.cmti" - "_build/install/default/lib/srk/srk__Cone.cmx" - "_build/install/default/lib/srk/srk__ConsequenceCone.cmi" - "_build/install/default/lib/srk/srk__ConsequenceCone.cmt" - "_build/install/default/lib/srk/srk__ConsequenceCone.cmti" - "_build/install/default/lib/srk/srk__ConsequenceCone.cmx" - "_build/install/default/lib/srk/srk__ConvexHull.cmi" - "_build/install/default/lib/srk/srk__ConvexHull.cmt" - "_build/install/default/lib/srk/srk__ConvexHull.cmti" - "_build/install/default/lib/srk/srk__ConvexHull.cmx" - "_build/install/default/lib/srk/srk__CoordinateSystem.cmi" - "_build/install/default/lib/srk/srk__CoordinateSystem.cmt" - "_build/install/default/lib/srk/srk__CoordinateSystem.cmti" - "_build/install/default/lib/srk/srk__CoordinateSystem.cmx" - "_build/install/default/lib/srk/srk__DD.cmi" - "_build/install/default/lib/srk/srk__DD.cmt" - "_build/install/default/lib/srk/srk__DD.cmti" - "_build/install/default/lib/srk/srk__DD.cmx" - "_build/install/default/lib/srk/srk__DisjointSet.cmi" - "_build/install/default/lib/srk/srk__DisjointSet.cmt" - "_build/install/default/lib/srk/srk__DisjointSet.cmx" - "_build/install/default/lib/srk/srk__ExpPolynomial.cmi" - "_build/install/default/lib/srk/srk__ExpPolynomial.cmt" - "_build/install/default/lib/srk/srk__ExpPolynomial.cmti" - "_build/install/default/lib/srk/srk__ExpPolynomial.cmx" - "_build/install/default/lib/srk/srk__FeatureTree.cmi" - "_build/install/default/lib/srk/srk__FeatureTree.cmt" - "_build/install/default/lib/srk/srk__FeatureTree.cmti" - "_build/install/default/lib/srk/srk__FeatureTree.cmx" - "_build/install/default/lib/srk/srk__Fixpoint.cmi" - "_build/install/default/lib/srk/srk__Fixpoint.cmt" - "_build/install/default/lib/srk/srk__Fixpoint.cmti" - "_build/install/default/lib/srk/srk__Fixpoint.cmx" - "_build/install/default/lib/srk/srk__IntLattice.cmi" - "_build/install/default/lib/srk/srk__IntLattice.cmt" - "_build/install/default/lib/srk/srk__IntLattice.cmti" - "_build/install/default/lib/srk/srk__IntLattice.cmx" - "_build/install/default/lib/srk/srk__Interpretation.cmi" - "_build/install/default/lib/srk/srk__Interpretation.cmt" - "_build/install/default/lib/srk/srk__Interpretation.cmti" - "_build/install/default/lib/srk/srk__Interpretation.cmx" - "_build/install/default/lib/srk/srk__Interval.cmi" - "_build/install/default/lib/srk/srk__Interval.cmt" - "_build/install/default/lib/srk/srk__Interval.cmti" - "_build/install/default/lib/srk/srk__Interval.cmx" - "_build/install/default/lib/srk/srk__Iteration.cmi" - "_build/install/default/lib/srk/srk__Iteration.cmt" - "_build/install/default/lib/srk/srk__Iteration.cmti" - "_build/install/default/lib/srk/srk__Iteration.cmx" - "_build/install/default/lib/srk/srk__Linear.cmi" - "_build/install/default/lib/srk/srk__Linear.cmt" - "_build/install/default/lib/srk/srk__Linear.cmti" - "_build/install/default/lib/srk/srk__Linear.cmx" - "_build/install/default/lib/srk/srk__Lirr.cmi" - "_build/install/default/lib/srk/srk__Lirr.cmt" - "_build/install/default/lib/srk/srk__Lirr.cmti" - "_build/install/default/lib/srk/srk__Lirr.cmx" - "_build/install/default/lib/srk/srk__LirrInvariants.cmi" - "_build/install/default/lib/srk/srk__LirrInvariants.cmt" - "_build/install/default/lib/srk/srk__LirrInvariants.cmx" - "_build/install/default/lib/srk/srk__Log.cmi" - "_build/install/default/lib/srk/srk__Log.cmt" - "_build/install/default/lib/srk/srk__Log.cmx" - "_build/install/default/lib/srk/srk__Loop.cmi" - "_build/install/default/lib/srk/srk__Loop.cmt" - "_build/install/default/lib/srk/srk__Loop.cmti" - "_build/install/default/lib/srk/srk__Loop.cmx" - "_build/install/default/lib/srk/srk__Lts.cmi" - "_build/install/default/lib/srk/srk__Lts.cmt" - "_build/install/default/lib/srk/srk__Lts.cmti" - "_build/install/default/lib/srk/srk__Lts.cmx" - "_build/install/default/lib/srk/srk__Memo.cmi" - "_build/install/default/lib/srk/srk__Memo.cmt" - "_build/install/default/lib/srk/srk__Memo.cmti" - "_build/install/default/lib/srk/srk__Memo.cmx" - "_build/install/default/lib/srk/srk__Nonlinear.cmi" - "_build/install/default/lib/srk/srk__Nonlinear.cmt" - "_build/install/default/lib/srk/srk__Nonlinear.cmti" - "_build/install/default/lib/srk/srk__Nonlinear.cmx" - "_build/install/default/lib/srk/srk__NumberField.cmi" - "_build/install/default/lib/srk/srk__NumberField.cmt" - "_build/install/default/lib/srk/srk__NumberField.cmti" - "_build/install/default/lib/srk/srk__NumberField.cmx" - "_build/install/default/lib/srk/srk__Pathexpr.cmi" - "_build/install/default/lib/srk/srk__Pathexpr.cmt" - "_build/install/default/lib/srk/srk__Pathexpr.cmti" - "_build/install/default/lib/srk/srk__Pathexpr.cmx" - "_build/install/default/lib/srk/srk__Polyhedron.cmi" - "_build/install/default/lib/srk/srk__Polyhedron.cmt" - "_build/install/default/lib/srk/srk__Polyhedron.cmti" - "_build/install/default/lib/srk/srk__Polyhedron.cmx" - "_build/install/default/lib/srk/srk__Polynomial.cmi" - "_build/install/default/lib/srk/srk__Polynomial.cmt" - "_build/install/default/lib/srk/srk__Polynomial.cmti" - "_build/install/default/lib/srk/srk__Polynomial.cmx" - "_build/install/default/lib/srk/srk__PolynomialCone.cmi" - "_build/install/default/lib/srk/srk__PolynomialCone.cmt" - "_build/install/default/lib/srk/srk__PolynomialCone.cmti" - "_build/install/default/lib/srk/srk__PolynomialCone.cmx" - "_build/install/default/lib/srk/srk__PolynomialConeCpClosure.cmi" - "_build/install/default/lib/srk/srk__PolynomialConeCpClosure.cmt" - "_build/install/default/lib/srk/srk__PolynomialConeCpClosure.cmti" - "_build/install/default/lib/srk/srk__PolynomialConeCpClosure.cmx" - "_build/install/default/lib/srk/srk__PolynomialLattice.cmi" - "_build/install/default/lib/srk/srk__PolynomialLattice.cmt" - "_build/install/default/lib/srk/srk__PolynomialLattice.cmti" - "_build/install/default/lib/srk/srk__PolynomialLattice.cmx" - "_build/install/default/lib/srk/srk__QQ.cmi" - "_build/install/default/lib/srk/srk__QQ.cmt" - "_build/install/default/lib/srk/srk__QQ.cmti" - "_build/install/default/lib/srk/srk__QQ.cmx" - "_build/install/default/lib/srk/srk__Quantifier.cmi" - "_build/install/default/lib/srk/srk__Quantifier.cmt" - "_build/install/default/lib/srk/srk__Quantifier.cmti" - "_build/install/default/lib/srk/srk__Quantifier.cmx" - "_build/install/default/lib/srk/srk__RandomFormula.cmi" - "_build/install/default/lib/srk/srk__RandomFormula.cmt" - "_build/install/default/lib/srk/srk__RandomFormula.cmx" - "_build/install/default/lib/srk/srk__Rational.cmi" - "_build/install/default/lib/srk/srk__Rational.cmt" - "_build/install/default/lib/srk/srk__Rational.cmti" - "_build/install/default/lib/srk/srk__Rational.cmx" - "_build/install/default/lib/srk/srk__Ring.cmi" - "_build/install/default/lib/srk/srk__Ring.cmt" - "_build/install/default/lib/srk/srk__Ring.cmti" - "_build/install/default/lib/srk/srk__Ring.cmx" - "_build/install/default/lib/srk/srk__Sequence.cmi" - "_build/install/default/lib/srk/srk__Sequence.cmt" - "_build/install/default/lib/srk/srk__Sequence.cmti" - "_build/install/default/lib/srk/srk__Sequence.cmx" - "_build/install/default/lib/srk/srk__Smt.cmi" - "_build/install/default/lib/srk/srk__Smt.cmt" - "_build/install/default/lib/srk/srk__Smt.cmti" - "_build/install/default/lib/srk/srk__Smt.cmx" - "_build/install/default/lib/srk/srk__SolvablePolynomial.cmi" - "_build/install/default/lib/srk/srk__SolvablePolynomial.cmt" - "_build/install/default/lib/srk/srk__SolvablePolynomial.cmti" - "_build/install/default/lib/srk/srk__SolvablePolynomial.cmx" - "_build/install/default/lib/srk/srk__SparseMap.cmi" - "_build/install/default/lib/srk/srk__SparseMap.cmt" - "_build/install/default/lib/srk/srk__SparseMap.cmti" - "_build/install/default/lib/srk/srk__SparseMap.cmx" - "_build/install/default/lib/srk/srk__SrkApron.cmi" - "_build/install/default/lib/srk/srk__SrkApron.cmt" - "_build/install/default/lib/srk/srk__SrkApron.cmti" - "_build/install/default/lib/srk/srk__SrkApron.cmx" - "_build/install/default/lib/srk/srk__SrkAst.cmi" - "_build/install/default/lib/srk/srk__SrkAst.cmt" - "_build/install/default/lib/srk/srk__SrkAst.cmx" - "_build/install/default/lib/srk/srk__SrkLex.cmi" - "_build/install/default/lib/srk/srk__SrkLex.cmt" - "_build/install/default/lib/srk/srk__SrkLex.cmx" - "_build/install/default/lib/srk/srk__SrkParse.cmi" - "_build/install/default/lib/srk/srk__SrkParse.cmt" - "_build/install/default/lib/srk/srk__SrkParse.cmti" - "_build/install/default/lib/srk/srk__SrkParse.cmx" - "_build/install/default/lib/srk/srk__SrkSimplify.cmi" - "_build/install/default/lib/srk/srk__SrkSimplify.cmt" - "_build/install/default/lib/srk/srk__SrkSimplify.cmti" - "_build/install/default/lib/srk/srk__SrkSimplify.cmx" - "_build/install/default/lib/srk/srk__SrkSmtlib2.cmi" - "_build/install/default/lib/srk/srk__SrkSmtlib2.cmt" - "_build/install/default/lib/srk/srk__SrkSmtlib2.cmti" - "_build/install/default/lib/srk/srk__SrkSmtlib2.cmx" - "_build/install/default/lib/srk/srk__SrkSmtlib2Defs.cmi" - "_build/install/default/lib/srk/srk__SrkSmtlib2Defs.cmt" - "_build/install/default/lib/srk/srk__SrkSmtlib2Defs.cmx" - "_build/install/default/lib/srk/srk__SrkSmtlib2Lex.cmi" - "_build/install/default/lib/srk/srk__SrkSmtlib2Lex.cmt" - "_build/install/default/lib/srk/srk__SrkSmtlib2Lex.cmx" - "_build/install/default/lib/srk/srk__SrkSmtlib2Parse.cmi" - "_build/install/default/lib/srk/srk__SrkSmtlib2Parse.cmt" - "_build/install/default/lib/srk/srk__SrkSmtlib2Parse.cmti" - "_build/install/default/lib/srk/srk__SrkSmtlib2Parse.cmx" - "_build/install/default/lib/srk/srk__SrkUtil.cmi" - "_build/install/default/lib/srk/srk__SrkUtil.cmt" - "_build/install/default/lib/srk/srk__SrkUtil.cmx" - "_build/install/default/lib/srk/srk__SrkZ3.cmi" - "_build/install/default/lib/srk/srk__SrkZ3.cmt" - "_build/install/default/lib/srk/srk__SrkZ3.cmti" - "_build/install/default/lib/srk/srk__SrkZ3.cmx" - "_build/install/default/lib/srk/srk__Syntax.cmi" - "_build/install/default/lib/srk/srk__Syntax.cmt" - "_build/install/default/lib/srk/srk__Syntax.cmti" - "_build/install/default/lib/srk/srk__Syntax.cmx" - "_build/install/default/lib/srk/srk__TerminationDTA.cmi" - "_build/install/default/lib/srk/srk__TerminationDTA.cmt" - "_build/install/default/lib/srk/srk__TerminationDTA.cmx" - "_build/install/default/lib/srk/srk__TerminationExp.cmi" - "_build/install/default/lib/srk/srk__TerminationExp.cmt" - "_build/install/default/lib/srk/srk__TerminationExp.cmx" - "_build/install/default/lib/srk/srk__TerminationLLRF.cmi" - "_build/install/default/lib/srk/srk__TerminationLLRF.cmt" - "_build/install/default/lib/srk/srk__TerminationLLRF.cmx" - "_build/install/default/lib/srk/srk__TerminationPRF.cmi" - "_build/install/default/lib/srk/srk__TerminationPRF.cmt" - "_build/install/default/lib/srk/srk__TerminationPRF.cmx" - "_build/install/default/lib/srk/srk__Transition.cmi" - "_build/install/default/lib/srk/srk__Transition.cmt" - "_build/install/default/lib/srk/srk__Transition.cmti" - "_build/install/default/lib/srk/srk__Transition.cmx" - "_build/install/default/lib/srk/srk__TransitionFormula.cmi" - "_build/install/default/lib/srk/srk__TransitionFormula.cmt" - "_build/install/default/lib/srk/srk__TransitionFormula.cmti" - "_build/install/default/lib/srk/srk__TransitionFormula.cmx" - "_build/install/default/lib/srk/srk__TransitionIdeal.cmi" - "_build/install/default/lib/srk/srk__TransitionIdeal.cmt" - "_build/install/default/lib/srk/srk__TransitionIdeal.cmti" - "_build/install/default/lib/srk/srk__TransitionIdeal.cmx" - "_build/install/default/lib/srk/srk__TransitionSystem.cmi" - "_build/install/default/lib/srk/srk__TransitionSystem.cmt" - "_build/install/default/lib/srk/srk__TransitionSystem.cmti" - "_build/install/default/lib/srk/srk__TransitionSystem.cmx" - "_build/install/default/lib/srk/srk__Vas.cmi" - "_build/install/default/lib/srk/srk__Vas.cmt" - "_build/install/default/lib/srk/srk__Vas.cmti" - "_build/install/default/lib/srk/srk__Vas.cmx" - "_build/install/default/lib/srk/srk__Vass.cmi" - "_build/install/default/lib/srk/srk__Vass.cmt" - "_build/install/default/lib/srk/srk__Vass.cmti" - "_build/install/default/lib/srk/srk__Vass.cmx" - "_build/install/default/lib/srk/srk__Wedge.cmi" - "_build/install/default/lib/srk/srk__Wedge.cmt" - "_build/install/default/lib/srk/srk__Wedge.cmti" - "_build/install/default/lib/srk/srk__Wedge.cmx" - "_build/install/default/lib/srk/srk__WeightedGraph.cmi" - "_build/install/default/lib/srk/srk__WeightedGraph.cmt" - "_build/install/default/lib/srk/srk__WeightedGraph.cmti" - "_build/install/default/lib/srk/srk__WeightedGraph.cmx" - "_build/install/default/lib/srk/srk__ZZ.cmi" - "_build/install/default/lib/srk/srk__ZZ.cmt" - "_build/install/default/lib/srk/srk__ZZ.cmti" - "_build/install/default/lib/srk/srk__ZZ.cmx" - "_build/install/default/lib/srk/syntax.ml" - "_build/install/default/lib/srk/syntax.mli" - "_build/install/default/lib/srk/terminationDTA.ml" - "_build/install/default/lib/srk/terminationExp.ml" - "_build/install/default/lib/srk/terminationLLRF.ml" - "_build/install/default/lib/srk/terminationPRF.ml" - "_build/install/default/lib/srk/transition.ml" - "_build/install/default/lib/srk/transition.mli" - "_build/install/default/lib/srk/transitionFormula.ml" - "_build/install/default/lib/srk/transitionFormula.mli" - "_build/install/default/lib/srk/transitionIdeal.ml" - "_build/install/default/lib/srk/transitionIdeal.mli" - "_build/install/default/lib/srk/transitionSystem.ml" - "_build/install/default/lib/srk/transitionSystem.mli" - "_build/install/default/lib/srk/vas.ml" - "_build/install/default/lib/srk/vas.mli" - "_build/install/default/lib/srk/vass.ml" - "_build/install/default/lib/srk/vass.mli" - "_build/install/default/lib/srk/wedge.ml" - "_build/install/default/lib/srk/wedge.mli" - "_build/install/default/lib/srk/weightedGraph.ml" - "_build/install/default/lib/srk/weightedGraph.mli" - "_build/install/default/lib/srk/zZ.ml" - "_build/install/default/lib/srk/zZ.mli" -] -libexec: [ - "_build/install/default/lib/srk/srk.cmxs" -] -doc: [ - "_build/install/default/doc/srk/README.md" -] From 6df9d741154224f14a6635bb6d0135a4f1af5e50 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Fri, 27 Jun 2025 22:51:54 -0500 Subject: [PATCH 46/59] restore CIL translation --- duet/translateCil.ml | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/duet/translateCil.ml b/duet/translateCil.ml index f349b42b..18906776 100644 --- a/duet/translateCil.ml +++ b/duet/translateCil.ml @@ -481,12 +481,11 @@ let tr_instr ctx instr = mk_def (Assign (v, Havoc (Concrete (Int 1)))) | ("__VERIFIER_nondet_uchar", Some (Variable v), []) -> let havoc = mk_def (Assign (v, Havoc (Concrete (Int 1)))) in - (*let assume0 = + let assume0 = mk_def (Assume (Atom (Le, Aexpr.zero, AccessPath (Variable v)))) in let assume1 = mk_def (Assume (Atom (Le, AccessPath (Variable v), Constant (CInt (255, 1))))) in - mk_seq havoc @@ mk_seq assume0 assume1 *) - havoc + mk_seq havoc @@ mk_seq assume0 assume1 | ("__VERIFIER_nondet_int", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int machine_int_width)))) | ("__VERIFIER_nondet_long", Some (Variable v), []) -> @@ -495,14 +494,12 @@ let tr_instr ctx instr = | ("__VERIFIER_nondet_pointer", Some (Variable v), []) -> mk_def (Assign (v, Havoc (Concrete (Int pointer_width)))) | ("__VERIFIER_nondet_bool", Some (Variable v), []) -> - (*let assume_lb = + let assume_lb = mk_def (Assume (Atom (Le, Aexpr.zero, AccessPath (Variable v)))) in (* 0 <= v *) let assume_ub = mk_def (Assume (Atom (Le, AccessPath (Variable v), Aexpr.one))) in (* v <= 1 *) let havoc = mk_def (Assign (v, Havoc (Concrete (Int 1)))) in mk_seq havoc @@ mk_seq assume_lb assume_ub - havoc*) - mk_def (Assign (v, Havoc (Concrete (Int 1)))) | ("__VERIFIER_nondet_uint", Some (Variable v), []) -> let havoc = mk_def (Assign (v, Havoc (Concrete (Int unknown_width)))) in let assume = @@ -809,3 +806,4 @@ let parse filename = let () = CmdLine.register_parser ("c", parse); CmdLine.register_parser ("i", parse_preprocessed); + From eef8cc176b65f36013c3dfcd8ff456580e8a8741 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 3 Jul 2025 10:41:07 -0500 Subject: [PATCH 47/59] refactorings to GPS --- duet/cra.ml | 2 -- duet/gps.ml | 44 +++++++++++++++++++++---------------- srk/src/transitionSystem.ml | 14 ++---------- 3 files changed, 27 insertions(+), 33 deletions(-) diff --git a/duet/cra.ml b/duet/cra.ml index 96a2431f..199f8bd4 100644 --- a/duet/cra.ml +++ b/duet/cra.ml @@ -977,10 +977,8 @@ let make_transition_system ?(simplify=true) ?(instr_gas=false) (main_entry: int) (RG.bodies rg) in (* perform some inlining *) - Printf.printf "calling inliner...\n"; let inlined_ts, new_assertions = TS.inline ts main_entry (fun _ -> ()) (!assertions) in - Printf.printf "----------inlining done-----\n"; (inlined_ts, new_assertions) let mk_query ts entry = diff --git a/duet/gps.ml b/duet/gps.ml index b09438b2..80c7064b 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -8,6 +8,14 @@ module TS = TransitionSystem.Make(Ctx)(V)(K) include Log.Make(struct let name = "gps" end) +(** some global flags for GPS *) +let enable_gas = ref true +let enable_summary = ref true +let enable_inlining = ref true +let enable_acceleration = ref true +let enable_ts_simplify = ref true +let print_stats = ref false + module ProcName = struct type t = int * int @@ -250,7 +258,6 @@ module GPS = struct end (* ART module *) - (* module ReachTree = ReachTree.ART(Ctx)(K)(TS')(ProcName)(VN)(Summarizer)*) module ReachTree = ReachTree.ART(Graph)(Label)(Transition) let generate_test_sgt art node = @@ -609,7 +616,7 @@ let analyze_mc enable_gas enable_summary file = | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system ~simplify:true ~instr_gas:enable_gas entry rg in + let (ts, assertions) = make_transition_system ~simplify:(!enable_ts_simplify) ~instr_gas:enable_gas entry rg in let ts, err_loc = safety_to_reachability ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; logf "\nentry: %d\n" entry; @@ -667,8 +674,8 @@ let analyze_impact file = let ts, err_loc = safety_to_reachability ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; logf "\nentry: %d\n" entry; - Printf.printf "testing reachability of location %d\n" err_loc ; - Printf.printf "------------------------------\n"; + logf "testing reachability of location %d\n" err_loc ; + logf "------------------------------\n"; let graph = GPS.Graph.{ graph = ts ; call_summary = (fun _ -> failwith "IMPACT: procedure call") @@ -716,25 +723,24 @@ let dump_cfg simplify instrument file = | _ -> assert false let _ = + CmdLine.register_config + ("-gps-disable-gas", Arg.Clear enable_gas, " Disable gas-instrumentation in GPS (enabled by default)"); + CmdLine.register_config + ("-gps-disable-summary", Arg.Clear enable_summary, " Disable CRA-generated summaries in GPS (enabled by default)"); + CmdLine.register_config + ("-gps-disable-acceleration", Arg.Clear enable_acceleration, " Disable loop acceleration during preprocessing (enabled by default)"); + CmdLine.register_config + ("-gps-disable-simplify", Arg.Clear enable_ts_simplify, " Disable CFG simplification (enabled by default)"); + CmdLine.register_config + ("-gps-stats", Arg.Unit (fun () -> print_stats := true), " Enable statistics reporting of a GPS run (disabled by default)"); + CmdLine.register_pass - ("-gps", analyze_mc false true, " GPS model checking algorithm, without gas-instrumentation"); - CmdLine.register_pass - ("-gps-gas", analyze_mc true true, " GPS model checking algorithm, with gas-instrumentation (i.e., refutation-complete)"); - CmdLine.register_pass - ("-gps-nosum", analyze_mc false false, "GPS with neither gas nor CRA-generated summary"); - CmdLine.register_pass - ("-gps-nosum-nogas", analyze_mc true false, "GPS with gas but without CRA-generated summary (i.e., refutation-complete)"); + ("-gps", analyze_mc !enable_gas !enable_summary, " GPS model checker for intraprocedural programs"); CmdLine.register_pass - ("-sgt", analyze_sgt false true, "Summary-guided testing, without gas-instrumentation"); - CmdLine.register_pass - ("-sgt-gas", analyze_sgt true true, "Summary-guided testing, with gas"); + ("-gpslite", analyze_sgt !enable_gas !enable_summary, " GPSLite summary-guided tester for intraprocedural programs"); + CmdLine.register_pass - ("-sgt-nosum", analyze_sgt false false, "Summary-guided testing without CRA-generated summary"); - CmdLine.register_pass - ("-sgt-nosum-nogas", analyze_sgt true false, "Summary-guided testing with gas but without CRA-generated summary"); - - CmdLine.register_pass ("-impact", analyze_impact, "Lazy abstraction with interpolants"); CmdLine.register_pass diff --git a/srk/src/transitionSystem.ml b/srk/src/transitionSystem.ml index 517e9699..e2968b35 100644 --- a/srk/src/transitionSystem.ml +++ b/srk/src/transitionSystem.ml @@ -710,7 +710,6 @@ module Make | _ -> acc ) tg (PS.add (entry, -1) PS.empty) in let rec dfs (proc: int * int) tg src (f: (vertex * vertex) -> vertex -> vertex * 'a label * vertex -> unit) (visited : ISet.t) = - Printf.printf "dfs: visiting %d\n" src; WG.fold_succ_e (fun (u, w, v) visited -> f proc src (u, w, v); begin match ISet.find_opt v visited with @@ -718,7 +717,6 @@ module Make | Some _ -> visited end) tg src visited in PS.iter (fun (x, y) -> - Printf.printf "populating p/qmaps with dfs... %d %d\n" x y; ignore @@ dfs (x, y) tg x (fun proc src (_, w, v) -> match w with | Call (x, y) -> @@ -733,11 +731,7 @@ module Make match (PHT.find_opt pmap (x, y), PHT.find_opt qmap (x, y)) with | Some callees, Some callers -> (* a procedure is considered for inlining if it is (1) a sink in the call graph (2) at least one function calls it.*) - if ((PS.cardinal callees) == 0) && ((PPS.cardinal callers) > 0) then PS.add (x, y) acc else - begin - Printf.printf "%d %d is not a sink; num callees = %d num callers = %d\n" x y (PS.cardinal callees) (PPS.cardinal callers); - acc - end + if ((PS.cardinal callees) == 0) && ((PPS.cardinal callers) > 0) then PS.add (x, y) acc else acc | (_, _) -> failwith "" ) procedures PS.empty in let copy_subgraph tg src = @@ -769,7 +763,6 @@ module Make end; WG.remove_vertex tg' vtx) vertices tg in let inline_one tg (src, dst) (call_x, call_y) (call_src, call_dst) = - Printf.printf "inlining %d-%d into call edge %d-%d\n" src dst call_x call_y; let (tg, to_map) = copy_subgraph tg src in let tg = WG.add_edge tg call_x (Weight T.one) (to_map src) in let tg = WG.add_edge tg (to_map dst) (Weight T.one) call_y in @@ -788,7 +781,6 @@ module Make let inline_targets = PHT.find qmap currproc in let tg' = PPS.fold (fun (call_proc, (call_x, call_y)) tg -> - Printf.printf "do_inline: at edge %d %d\n\n" call_x call_y; inline_one tg currproc (call_x, call_y) call_proc ) inline_targets tg in let (src, _) = currproc in @@ -797,13 +789,11 @@ module Make displayer tg; match PS.cardinal sinks with | n when n > 0 -> - Printf.printf "inliner: there are %d sinks to inline \n" n; let tg' = (PS.fold aux sinks tg) in tg' |> do_inline ( - Printf.printf "doing more inling...\n"; if depth > 0 then depth - 1 else depth) - | _ -> Printf.printf "no more sinks to inline. done\n"; tg + | _ -> (); tg in let result = do_inline depth tg in (result, !assertions) From e1d04ca0ad9790c37bb0d7d4096c8d5550f2d418 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 3 Jul 2025 14:33:54 -0400 Subject: [PATCH 48/59] refactor intraprocedural algorithm, take out interprocedural code for now --- Makefile | 2 +- duet/gps.ml | 471 ++++++++------------------------------------- duet/reachTree.ml | 73 ++----- duet/reachTree.mli | 9 +- 4 files changed, 103 insertions(+), 452 deletions(-) diff --git a/Makefile b/Makefile index aa3996fe..49e53106 100644 --- a/Makefile +++ b/Makefile @@ -3,7 +3,7 @@ all: build build: - dune build duet + dune build duet clean: dune clean diff --git a/duet/gps.ml b/duet/gps.ml index 80c7064b..4683de91 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -11,11 +11,14 @@ include Log.Make(struct let name = "gps" end) (** some global flags for GPS *) let enable_gas = ref true let enable_summary = ref true +let enable_refinement = ref true (* main distinction between GPS / GPSLite *) let enable_inlining = ref true let enable_acceleration = ref true let enable_ts_simplify = ref true let print_stats = ref false +let num_tests_generated = ref 0 + module ProcName = struct type t = int * int @@ -59,21 +62,6 @@ let log_weights prefix weights = let log_model prefix model = logf "[model] %s: %a\n" prefix Interpretation.pp model -(* -let assert_i = ref 0 -let new_assert_var cond = - let i = !assert_i in - let name = "__assert" ^ (string_of_int i) in - let v = Varinfo.mk_global name (Concrete (Int 8)) |> Var.mk in - let assert_var = Syntax.mk_symbol srk ~name:name `TyInt in - let assert_term = Syntax.mk_const srk assert_var in - assert_i := !assert_i + 1; - K.assign v cond - -let process_interproc_assertion (ts: cfg_t) (phi: Ctx.formula) v = - let a_var, a_term = new_assert_var @@ Ctx.mk_not phi in - -*) (* Convert assertion checking problem to vertex reachability problem. *) let safety_to_reachability (ts : cfg_t) assertions = @@ -233,7 +221,6 @@ module GPS = struct match Smt.entails Ctx.context f g with | `Yes -> true | _ -> false - let negate f = Ctx.mk_not f let pp = Syntax.Formula.pp srk end module Transition = struct @@ -260,354 +247,65 @@ module GPS = struct (* ART module *) module ReachTree = ReachTree.ART(Graph)(Label)(Transition) - let generate_test_sgt art node = + let generate_test art node = logf "Generating test @ %a\n" ReachTree.pp_node node; - let post = Ctx.mk_not (K.guard (ReachTree.path_to_error art node)) in + let post = + if !enable_summary then + Ctx.mk_not (K.guard (ReachTree.path_to_error art node)) + else + mk_true () + in let rec path_weight v = match ReachTree.parent_weight art v with | Some (parent, w) -> K.mul (path_weight parent) w | None -> K.one in + num_tests_generated := !num_tests_generated + 1; match K.interpolate_or_concrete_model [path_weight node] post with | `Invalid v_model -> `Test v_model - | `Unknown -> failwith "generate_test_sgt: got UNKNOWN as a result for interpolate_or_get_model" - | `Valid _ -> `Pruned + | `Unknown -> failwith "GPS.generate_test: got UNKNOWN as a result for interpolate_or_get_model" + | `Valid interpolants -> `Pruned (interpolants) - let sgt graph src dst = - let art = ReachTree.make graph Ctx.mk_true ~src ~dst in + let gps graph src dst = + let art = ReachTree.make graph Ctx.mk_true ~src ~dst in let rec loop () = match ReachTree.deque_frontier art with - | None -> `Safe - | Some node -> - match generate_test_sgt art node with - | `Pruned -> loop () - | `Test state -> - match ReachTree.execute art node state with - | `Safe -> loop () - | `Unsafe _ -> `Unsafe + | None -> `Safe art + | Some u -> + (* Fetched tree node u from work list. First attempt to close it. *) + logf ~level:`trace "At frontier node %d:" (ReachTree.of_node u); + if !enable_refinement && (ReachTree.is_covered art u) then + (logf ~level:`trace "-> covered"; + loop ()) + else begin + if !enable_refinement && (ReachTree.lclose art u) then (* Close succeeded. No need to further explore it. *) + (logf ~level:`trace "-> closed"; loop ()) + else begin + (* u is uncovered. *) + match generate_test art u with + | `Pruned (interpolants) -> + if !enable_refinement then begin + (* refinement *) + ReachTree.refine art (ReachTree.tree_path art u) interpolants; + (* for every node along path of refinement try close *) + List.iter (fun v -> ignore (ReachTree.close art v)) (ReachTree.tree_path art u); + loop () + end else begin (* GPSlite, no refinement *) + loop () + end + | `Test state -> + logf ~level:`trace "-> found test"; + match ReachTree.execute art u state with + | `Safe -> loop () + | `Unsafe n -> `Unsafe (n, art) + end + end in loop () - - - (* to print the reachability tree (+ worklist), or not *) - (* RF 3/2/25: If you enable this flag, and even if *) - (* the logf output stream is suppressed, it incurs a _huge_ *) - (* performance penalty. *) - let print_tree = false - - type global_context = - { g_graph : cfg_t - ; g_summarizer : Summarizer.t - ; g_errloc : int } - - and mc_result = - | Safe of K.t - | Unsafe of K.t - - - (* contextual information maintained by GPS algorithm. *) - (* intraprocedural context *) - type intra_context = { - id : ProcName.t; - cfg : Graph.t; - mutable art : ReachTree.t; - global_ctx : global_context; - } - (* global context *) - (** some helper functions that operate on the context *) - let get_summarizer ctx = ctx.global_ctx.g_summarizer - - let log_labelled_weights ctx uu prefix weights = - List.iteri - (fun i f -> - match f with - | Call (u, v) -> - let p = - begin match uu with - | OverApprox -> Summarizer.over_proc_summary ctx.g_summarizer (ProcName.make (u, v)) - | UnderApprox -> Summarizer.under_proc_summary ctx.g_summarizer (ProcName.make (u, v)) - end in - logf "[labelled weight] %s(%i, call(%d,%d)): %a\n" prefix i u v K.pp p - | Weight w -> - logf "[labelled weight] %s(%i): %a\n" prefix i K.pp w) weights - - - (* Express a relational query as a precondition/postcondition pair over - prophecy variables *) - let demote_precondition (query : K.t) = - let preconditions, postconditions = - BatEnum.fold (fun (preconditions, postconditions) (var, asgn) -> - let prophecy_var = V.prophesize var in - let prophecy_sym = V.symbol_of prophecy_var in - let prophecy_term = Syntax.mk_const srk prophecy_sym in - let var_term = Syntax.mk_const srk (V.symbol_of var) in - (Syntax.mk_eq srk prophecy_term asgn::preconditions, - Syntax.mk_eq srk prophecy_term var_term::postconditions)) - ([K.guard query], []) - (K.transform query) - in - (Syntax.mk_and srk preconditions, Syntax.mk_and srk postconditions) - - - (* promote an arbitrary state formula (not necessarily the pre-state) to a transition formula. *) - (* To do so, we substitute in fresh skolem symbols for all prophecy variables inside [f], and *) - (* create a transform map, treating the substituted formula as guard. *) - let promote (f : Ctx.t Syntax.formula) = - let sym_map = ValueHT.create 991 in - let substitute = Memo.memo (fun sym -> - match V.of_symbol sym with - | Some v -> - begin match V.var_of_prophecy_var v with - | Some original_var -> - let fresh_skolem = Syntax.mk_symbol srk (Syntax.typ_symbol srk sym) in - let term = Syntax.mk_const srk fresh_skolem in - ValueHT.add sym_map original_var term; - term - | None -> Syntax.mk_const srk sym - end - | None -> Syntax.mk_const srk sym) in - K.construct (Syntax.substitute_const srk substitute (Syntax.mk_not srk f)) (ValueHT.to_seq sym_map |> List.of_seq) - - - let mk_intra_context (gctx: global_context) ((src,tgt): ProcName.t) (query: K.t) = - let pre_state, equalities = demote_precondition query in - let target_summary v = - K.mul - (Summarizer.path_weight_intra gctx.g_summarizer v tgt) - (K.assume equalities) - in - let dst = gctx.g_errloc in - let graph = - Graph.{ graph = WG.add_edge (gctx.g_graph) tgt (Weight (K.assume equalities)) dst - ; call_summary = Summarizer.over_proc_summary gctx.g_summarizer - ; target_summary = target_summary } - in - { - id = (src,dst); - cfg = graph; - art = ReachTree.make graph pre_state ~src ~dst; - global_ctx = gctx; - } - - let rec art_cfg_path_pair (ctx: intra_context) (p: ReachTree.node list) = - match p with - | u :: v :: t -> - let u_vtx = ReachTree.maps_to ctx.art u in - let v_vtx = ReachTree.maps_to ctx.art v in - (u, (u_vtx, v_vtx), v) :: (art_cfg_path_pair ctx (v :: t)) - | _ -> [] - - - let print_vocabulary tr = - let g_vocab, l_vocab = K.vocabulary tr in - let vname x = - match V.of_symbol x with - | Some var -> V.show var - | None -> " [havoc] " - in - log_weights " [vocabulary of transition] " [tr]; - logf " ------ globals: ---- {\n"; - List.iter (fun x -> logf " %s %s\n" (Syntax.show_symbol srk x) (vname x)) g_vocab; - logf "}\n ------ locals: ---- {\n"; - List.iter (fun x -> logf " %s %s\n" (Syntax.show_symbol srk x) (vname x)) l_vocab - - (* CFG path condition from art.src -> art.v *) - let path_condition (ctx: intra_context) condition_type (v: ReachTree.node) = - let art = ctx.art in - let art_nodes = ReachTree.tree_path art v in - let ts = ctx.cfg.Graph.graph in - let cfg_nodes = List.map (fun x -> ReachTree.maps_to art x) art_nodes in - let rec to_weights l : K.t label list = - match l with - | a :: b :: t -> - WG.edge_weight ts a b :: (to_weights (b :: t)) - | _ -> [] - in - let summ = get_summarizer ctx in - let pathcond = List.map (fun (weight: K.t label) -> - match weight with - | Call (src, dst) -> - begin match condition_type with - | OverApprox -> Summarizer.over_proc_summary summ (ProcName.make (src, dst)) - | UnderApprox -> - let under = Summarizer.under_proc_summary summ (ProcName.make (src, dst)) in - log_weights "underapproximate summary" [under]; - print_vocabulary under; - under - end - | Weight w -> w) (to_weights cfg_nodes) in - logf " ---- path_condition: path length: %d, before add1: %d\n" ((List.length pathcond)+1) (List.length pathcond); - let l = (K.assume (ReachTree.get_precondition ctx.art)) :: pathcond in - log_weights "path conditions " l; l - - let get_global_ctx (ctx: intra_context) = ctx.global_ctx - - let extract_refinement (ctx: intra_context) = - let art = ctx.art in - let rfn = ReachTree.label art ReachTree.root |> promote in - log_weights "refinement: " [rfn]; - K.exists (fun v -> V.is_global v) (rfn) - - let seq = List.fold_left K.mul K.one (* sequentially multiply, left-right *) - - - let rec handle_path_to_error ctx left curr right dir err_leaf : [`Unsafe of K.t | `Safe] = - let handle_right_case caller_id = - let f = List.map (fun (_, w, _) -> w) in - let left = f left in - let right = f right in - match K.project_mbp (V.is_global) (path_condition ctx UnderApprox err_leaf |> seq) with - | `Sat t -> `Unsafe t - | _ -> - logf " ------------------------ handle_path_to_error debug info: called by case %s ------------------\n" caller_id; - log_weights "faulty weight: " (path_condition ctx UnderApprox err_leaf); - logf "\nlength of left path: %d" (List.length left); - logf "\nlength of right path: %d" (List.length right); - logf "\nPrinting left path... \n"; - - log_labelled_weights ctx.global_ctx UnderApprox "left path - " left; - logf "error: handle_path_to_error: cannot project path condition" ; - `Safe in - let handle_left_case caller_id = - logf "handle_path_to_error: %s\n" caller_id; - `Safe in - match curr with - | (_, Weight _, _) -> - begin match left, dir, right with - | [], `Left, _ -> - handle_left_case "reached leftmost item, `curr` variable is NOT a call-edge" - | _, `Right, [] -> - handle_right_case "reached rightmost item, `curr` variable is NOT a call-edge" - | a :: left', `Left, _ -> handle_path_to_error ctx left' a (curr :: right) dir err_leaf - | _, `Right, a :: right' -> handle_path_to_error ctx (curr :: left) a right' dir err_leaf - end - | (u, (Call (src, dst)), _) -> - let prefix = path_condition ctx UnderApprox u |> seq in - let summ = get_summarizer ctx in - let suffix = - List.map (fun (_, ew, _) -> - match ew with - | Weight w -> w - | Call (s, t) -> Summarizer.over_proc_summary summ (ProcName.make (s, t))) - right - |> seq in - let summary = Summarizer.over_proc_summary summ (ProcName.make (src, dst)) in - begin match K.contextualize prefix summary suffix with - | `Sat query -> - let answer = - mk_intra_context (ctx.global_ctx) (ProcName.make (src, dst)) query - |> intraproc_check - in begin match answer with - | Safe r -> - Summarizer.refine_over_summary summ (ProcName.make (src, dst)) r; - handle_path_to_error ctx left curr right dir err_leaf - | Unsafe trs -> - begin match trs |> K.project_mbp (V.is_global) with - | `Sat tr -> - Summarizer.refine_under_summary summ (ProcName.make (src, dst)) tr; - begin match right with - | a :: right' -> - handle_path_to_error ctx (curr::left) a right' `Right err_leaf - | [] -> (* we're done *) - handle_right_case "rightmost edge is call-edge, underapproximation successful" - end - | _ -> failwith "error: cannot do mbp on returned error trace in handle_path_to_error" - end - end - | `Unsat -> (* procedure summary at `curr` is UNSAT, so backtrack *) - begin match left with - | a :: left' -> - handle_path_to_error ctx left' a (curr :: right) `Left err_leaf - | [] -> (* at the very left. we're done *) - handle_left_case "at the leftmost edge, is a call-edge, done" - end - end - - - and intraproc_check (ctx: intra_context) : mc_result = - match ReachTree.gps ctx.art with - | `Safe -> Safe (extract_refinement ctx) - | `Unsafe w -> - logf "--- GPS: found path-to-error at tree node %d (cfg vertex %d) \n" (ReachTree.of_node w) (ReachTree.maps_to ctx.art w); - logf " --- forming path to error... \n"; - let has_calls, path_to_w = - ReachTree.tree_path ctx.art w - |> art_cfg_path_pair ctx - |> List.map (fun (u, (u_vtx, v_vtx), v) -> (u, WG.edge_weight ctx.cfg.Graph.graph u_vtx v_vtx, v)) - |> List.fold_left (fun (has_call, l) (u, w, v) -> - match w with - | Call _ -> (true, (u, w, v) :: l) - | _ -> (has_call, (u, w, v) :: l) - ) (false, []) - in - logf " --- finished forming path to error, calling handle_path_to_error ... \n"; - begin match has_calls, path_to_w with - | true, curr :: right -> - begin match handle_path_to_error ctx [] curr right `Right w with - | `Safe -> (* path-to-error concretization failed. frontier_node is the src node of a call-edge. *) - (* we can mark `w` as a frontier node to be refined, and continue. *) - ReachTree.add_frontier ctx.art w; - intraproc_check ctx - | `Unsafe pathcond -> - logf "--- GPS: managed to concretize an intraprocedural path-to-error. returning... "; - Unsafe pathcond end - | false, _::_ -> - (* TODO! *) -(* Unsafe (seq (List.map (fun (_, w, _) -> - match w with - | Weight w -> w - | _ -> assert false) - path_to_w)) - *) - - Unsafe K.one - | _, [] -> - (* corner case: either no calls along the path, or if the path to error is of length 0. *) - Unsafe K.one - end - - - let execute (ts : cfg_t) (entry : int) (err_loc : int) (enable_summary:bool) : mc_result = - let gctx = - { g_graph = ts - ; g_summarizer = Summarizer.init ts entry err_loc enable_summary - ; g_errloc = err_loc } - in - (* interproc_graph represents the language of interprocedural paths from - entry to err_loc (including interprocedural paths that make calls that - never return---i.e., the ``unbalanced left'' language of - interprocedurally-valid paths) *) - let interproc_graph = - WG.fold_edges (fun (u, w, _) interproc_graph -> - match w with - | Call (en, _) -> - WG.add_edge interproc_graph u (Weight K.one) en - | Weight _ -> interproc_graph) - ts - ts - in - let graph = - Graph.{ graph = interproc_graph - ; call_summary = Summarizer.over_proc_summary gctx.g_summarizer - ; target_summary = Summarizer.path_weight_inter gctx.g_summarizer } - in - let main_context = - { - id = (entry,err_loc); - cfg = graph; - art = ReachTree.make graph Ctx.mk_true ~src:entry ~dst:err_loc; - global_ctx = gctx; - } - in - logf "executing GPS: start\n"; - intraproc_check main_context end -module BM = BatMap.Make(Int) - - -let analyze_mc enable_gas enable_summary file = +let analyze_mc file = let open Srk.Iteration in populate_offset_table file; K.domain := split (product [ PolyhedronGuard.exp @@ -616,51 +314,36 @@ let analyze_mc enable_gas enable_summary file = | [main] -> begin let rg = Interproc.make_recgraph file in let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system ~simplify:(!enable_ts_simplify) ~instr_gas:enable_gas entry rg in + let (ts, assertions) = make_transition_system ~simplify:(!enable_ts_simplify) ~instr_gas:!enable_gas entry rg in let ts, err_loc = safety_to_reachability ts assertions in if !CmdLine.display_graphs then TSDisplay.display ts; logf "\nentry: %d\n" entry; Printf.printf "testing reachability of location %d\n" err_loc ; Printf.printf "------------------------------\n"; - begin match GPS.execute ts entry err_loc enable_summary with - | Safe _ -> Printf.printf " proven safe\n"; - | Unsafe _ -> Printf.printf " proven unsafe\n" + let summ = Summarizer.init ts entry err_loc !enable_summary in + let graph = + GPS.Graph.{ graph = ts + ; call_summary = (fun _ -> failwith "GPS: procedure call") + ; target_summary = (Summarizer.path_weight_inter summ) } + in + let art = + begin match GPS.gps graph entry err_loc with + | `Safe art -> Printf.printf " proven safe\n"; art + | `Unsafe (_, art) -> Printf.printf " proven unsafe\n"; art + end in + if !print_stats then begin + let statistics = GPS.ReachTree.get_statistics art in + Printf.printf " Statistics\n"; + Printf.printf " Number of tests generated: %d\n" !num_tests_generated; + Printf.printf " Number of refinements performed: %d\n" statistics.num_refinements_performed; + Printf.printf " Number of coverings added: %d\n" statistics.num_covers_added; + Printf.printf " Number of coverings removed: %d\n" statistics.num_covers_removed end; Printf.printf "------------------------------\n" end | _ -> assert false -let analyze_sgt enable_gas enable_summary file = - let open Srk.Iteration in - populate_offset_table file; - K.domain := split (product [ PolyhedronGuard.exp - ; LossyTranslation.exp ]); - match file.entry_points with - | [main] -> begin - let rg = Interproc.make_recgraph file in - let entry = (RG.block_entry rg main).did in - let (ts, assertions) = make_transition_system ~simplify:true ~instr_gas:enable_gas entry rg in - let ts, err_loc = safety_to_reachability ts assertions in - if !CmdLine.display_graphs then TSDisplay.display ts; - logf "\nentry: %d\n" entry; - Printf.printf "testing reachability of location %d\n" err_loc ; - Printf.printf "------------------------------\n"; - let summ = Summarizer.init ts entry err_loc enable_summary in - let graph = - GPS.Graph.{ graph = ts - ; call_summary = (fun _ -> failwith "SGT: procedure call") - ; target_summary = Summarizer.path_weight_inter summ } - in - begin match GPS.sgt graph entry err_loc with - | `Safe -> Printf.printf " proven safe\n"; - | `Unsafe -> Printf.printf " proven unsafe\n" - | `Error s -> Printf.printf "ERR: %s\n" s - end; - Printf.printf "------------------------------\n" - end - | _ -> assert false - let analyze_impact file = let open Srk.Iteration in populate_offset_table file; @@ -691,8 +374,9 @@ let analyze_impact file = if ART.is_covered art u then loop () else if ART.lclose art u then loop () else if ART.maps_to art u == err_loc then - match ART.generate_test art u with - | `Pruned -> + match GPS.generate_test art u with + | `Pruned interpolants -> + ART.refine art (ART.tree_path art u) interpolants; List.iter (fun v -> ignore (ART.lclose art v)) (ART.tree_path art u); loop () | `Test _ -> `Unsafe @@ -731,23 +415,20 @@ let _ = ("-gps-disable-acceleration", Arg.Clear enable_acceleration, " Disable loop acceleration during preprocessing (enabled by default)"); CmdLine.register_config ("-gps-disable-simplify", Arg.Clear enable_ts_simplify, " Disable CFG simplification (enabled by default)"); + CmdLine.register_config + ("-gps-disable-refinement", Arg.Clear enable_refinement, " Disable invariant synthesis capabilities of GPS"); CmdLine.register_config ("-gps-stats", Arg.Unit (fun () -> print_stats := true), " Enable statistics reporting of a GPS run (disabled by default)"); - - CmdLine.register_pass - ("-gps", analyze_mc !enable_gas !enable_summary, " GPS model checker for intraprocedural programs"); - CmdLine.register_pass - ("-gpslite", analyze_sgt !enable_gas !enable_summary, " GPSLite summary-guided tester for intraprocedural programs"); - + ("-gps", analyze_mc, " GPS model checker for intraprocedural programs"); CmdLine.register_pass - ("-impact", analyze_impact, "Lazy abstraction with interpolants"); + ("-impact", analyze_impact, " Lazy abstraction with interpolants"); CmdLine.register_pass - ("-dump-unsimplified-cfg", dump_cfg false false, "dump unsimplified CFG"); + ("-dump-unsimplified-cfg", dump_cfg false false, " dump unsimplified CFG"); CmdLine.register_pass - ("-dump-simplified-cfg", dump_cfg true false, "dump simplified CFG"); + ("-dump-simplified-cfg", dump_cfg true false, " dump simplified CFG"); CmdLine.register_pass - ("-dump-instrumented-unsimplified-cfg", dump_cfg false true, "dump unsimplified CFG"); + ("-dump-instrumented-unsimplified-cfg", dump_cfg false true, " dump unsimplified CFG"); CmdLine.register_pass - ("-dump-instrumented-simplified-cfg", dump_cfg true true, "dump simplified CFG"); + ("-dump-instrumented-simplified-cfg", dump_cfg true true, " dump simplified CFG"); diff --git a/duet/reachTree.ml b/duet/reachTree.ml index 0ca5c440..192fa29e 100644 --- a/duet/reachTree.ml +++ b/duet/reachTree.ml @@ -35,7 +35,6 @@ module ART val top : t val meet : t -> t -> t val leq : t -> t -> bool - val negate : t -> t val pp : Format.formatter -> t -> unit end) (T : sig @@ -82,6 +81,12 @@ struct ; mutable label : L.t ; mutable children : int list } + type stats = { + mutable num_covers_added : int; + mutable num_covers_removed : int; + mutable num_refinements_performed : int; + } + type t = { graph : G.t; err_loc : G.vertex; @@ -94,6 +99,8 @@ struct (* precedent_nodes[v] stores all tree nodes mapping to CFG vertex v. Used in mc_close. *) mutable precedent_nodes : ISet.t VertexMap.t; mutable frontier : node DQ.t; + + statistics : stats; } let root = 0 @@ -111,7 +118,11 @@ struct ; covers = IntMap.empty (* for (u, v) in cover, u is ancestor of v and label(v) |= label(u). v is covered if (u, v) in cover. Then cover[v] = u. *) ; reverse_covers = IntMap.empty (* for each v, store the v's that cover it: i.e. cover[v] *) ; precedent_nodes = VertexMap.empty - ; frontier = DQ.cons root DQ.empty } + ; frontier = DQ.cons root DQ.empty + ; statistics = { + num_covers_added = 0 + ; num_covers_removed = 0 + ; num_refinements_performed = 0 }} let get_err_loc (art : t) = art.err_loc let get_entry (art: t) = (ARR.get art.nodes 0).cfg_vertex @@ -240,6 +251,7 @@ struct let reverse_covers_w = IntMap.find_default ISet.empty w art.reverse_covers in + art.statistics.num_covers_added <- art.statistics.num_covers_added + 1; art.covers <- IntMap.add v w art.covers; art.reverse_covers <- IntMap.add w (ISet.add v reverse_covers_w) art.reverse_covers; @@ -287,7 +299,9 @@ struct (* Iterate through and remove pairs (x, y) from covering relation. *) (* Step 1: Remove (x |-> y) from ptt.covers. *) ISet.iter - (fun x -> art.covers <- IntMap.remove x art.covers) + (fun x -> + art.covers <- IntMap.remove x art.covers; + art.statistics.num_covers_removed <- art.statistics.num_covers_removed + 1) xs; (* Step 2: Remove (y |-> xs) from pthit.reverse_covers. *) art.reverse_covers <- IntMap.remove y art.reverse_covers; @@ -321,6 +335,7 @@ struct (* refine the label of each tree node u along path from tree root to v. *) let refine (art : t) path interpolants = + art.statistics.num_refinements_performed <- art.statistics.num_refinements_performed + 1; List.iter2 (fun u interpolant -> let u_info = ARR.get art.nodes u in @@ -352,6 +367,7 @@ struct (* remove (x, u) from covering. *) logf " refine: removing cover (%d->%d)\n" x u; + art.statistics.num_covers_removed <- art.statistics.num_covers_removed + 1; art.covers <- IntMap.remove x art.covers; (* add x's subtree leaves back to the worklist. *) fold_leaves @@ -563,54 +579,5 @@ struct let path_to_error art node = G.summary art.graph (maps_to art node) - let generate_test art node = - let post = L.negate (T.guard (path_to_error art node)) in - let rec get_path rest node = - match parent_weight art node with - | Some (p, weight) -> get_path (weight::rest) p - | None -> rest - in - let path = get_path [] node in - match T.check art.precondition path post with - | `Invalid v_model -> - logf ~level:`trace "-> found test"; - `Test v_model - | `Unknown -> failwith "generate_test: got UNKNOWN as a result for interpolate_or_get_model" - | `Valid interpolants -> - logf ~level:`trace "-> pruned"; - log_formulas "interpolants - " interpolants; - refine art (tree_path art node) interpolants; - `Pruned - - let gps art = - let rec loop () = - match deque_frontier art with - | None -> `Safe - | Some u -> - (* Fetched tree node u from work list. First attempt to close it. *) - logf ~level:`trace "At frontier node %d:" u; - if is_covered art u then - (logf ~level:`trace "-> covered"; - loop ()) - else begin - if lclose art u then (* Close succeeded. No need to further explore it. *) - (logf ~level:`trace "-> closed"; loop ()) - else begin - (* u is uncovered. *) - match generate_test art u with - | `Pruned -> (* refinement succeeded *) - (* for every node along path of refinement try close *) - List.iter (fun v -> ignore (close art v)) (tree_path art u); - - loop () - | `Test state -> - logf ~level:`trace "-> found test"; - match execute art u state with - | `Safe -> loop () - | `Unsafe n -> `Unsafe n - end - end - in - loop () - + let get_statistics art = art.statistics end diff --git a/duet/reachTree.mli b/duet/reachTree.mli index 674146fe..0fe5ca03 100644 --- a/duet/reachTree.mli +++ b/duet/reachTree.mli @@ -20,7 +20,6 @@ module ART val bottom : t val meet : t -> t -> t val leq : t -> t -> bool - val negate : t -> t val pp : Format.formatter -> t -> unit end) (T : sig @@ -42,6 +41,11 @@ module ART type t type state = T.state type weight = T.t + type stats = { + mutable num_covers_added : int; + mutable num_covers_removed : int; + mutable num_refinements_performed : int; + } val make : G.t -> L.t -> src:G.vertex -> dst:G.vertex -> t val get_entry : t -> G.vertex val get_err_loc : t -> G.vertex @@ -67,7 +71,6 @@ module ART val root : node val pp_node : Format.formatter -> node -> unit val execute : t -> node -> T.state -> [ `Safe | `Unsafe of node ] - val gps : t -> [ `Safe | `Unsafe of node ] val path_to_error : t -> node -> weight - val generate_test : t -> node -> [ `Test of state | `Pruned ] + val get_statistics : t -> stats end From a81eb59a7a8064fb8fd12e692facb41c0dfb1bd8 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 21 Jul 2025 17:00:24 -0400 Subject: [PATCH 49/59] remove dead code --- duet/summaryProvider.ml | 244 --------------------------------------- duet/summaryProvider.mli | 159 ------------------------- 2 files changed, 403 deletions(-) delete mode 100644 duet/summaryProvider.ml delete mode 100644 duet/summaryProvider.mli diff --git a/duet/summaryProvider.ml b/duet/summaryProvider.ml deleted file mode 100644 index 56ff7e02..00000000 --- a/duet/summaryProvider.ml +++ /dev/null @@ -1,244 +0,0 @@ -open Core -open Srk -open CfgIr -open BatPervasives -open Cra - -(* - -include Log.Make(struct let name = "sgt" end) - -module IntMap = BatMap.Make(Int) -module StringMap = BatMap.Make(String) -module DQ = BatDeque -module ARR = Batteries.DynArray -type idq_t = int BatDeque.t -type state_formula = Ctx.t Syntax.formula -exception Mexception of string - - - - -let log_formulas prefix formulas = - List.iteri (fun i f -> logf "[formula] %s(%i): %a\n" prefix i (Syntax.pp_expr srk) f) formulas - -let log_weights prefix weights = - List.iteri (fun i f -> logf "[weight] %s(%i): %a\n" prefix i K.pp f) weights - - -let log_model prefix model = - logf "[model] %s: %a\n" prefix Interpretation.pp model - -module LeftRegularSummaryProvider (Ctx: Srk.Syntax.Context) -(** transition formula algebra *) -(K : sig - type t - type var - val pp : Format.formatter -> t -> unit - val guard : t -> Ctx.t Srk.Syntax.formula - val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t - val mem_transform : var -> t -> bool - val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term - val assume : Ctx.t Srk.Syntax.formula -> t - val mul : t -> t -> t - val add : t -> t -> t - val conjunct : t -> t -> t - val zero : t - val one : t - val star : t -> t - val exists : (var -> bool) -> t -> t - val contains_havoc : t -> bool - val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] - val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula - -> [`Valid of Ctx.t Syntax.formula list - | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] - - val get_post_model : - Ctx.t Srk.Interpretation.interpretation -> - t -> Ctx.t Srk.Interpretation.interpretation option - val is_deterministic : t -> bool - end) - (TS : sig - type vertex - type transition = K.t - type t - type query - type reverse_query - val empty : t - val path_weight : query -> vertex -> transition - val call_weight : query -> vertex * vertex -> transition - val mk_reverse_query : query -> vertex -> reverse_query - val exit_summary : reverse_query -> vertex -> vertex -> K.t - val target_summary : reverse_query -> vertex -> K.t - val set_summary : query -> vertex * vertex -> transition -> unit - val get_summary : query -> vertex * vertex -> transition - val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t - val iter_succ_e : - ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit - val edge_weight : - t -> vertex -> vertex -> K.t Srk.TransitionSystem.label - val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b - end) -= -struct - type t = { - graph: TS.t; - src: int; - query: TS.query; - rev_query: TS.reverse_query; - silent: bool; - monotone: bool; - } - let mk_query ts entry = TS.mk_query ts entry (if !monotone then (module MonotoneDom) else (module TransitionDom)) - - let init (graph: TS.t) (src: int) (tgt: int) (enable_summary: bool) : t = - let q = mk_query graph src in - let rq = TS.mk_reverse_query q tgt in - { graph = graph - ; src = src - ; query = q - ; rev_query = rq - ; silent = not enable_summary } - - - let path_weight_intra (ctx: t) (src: int) (dst: int) = - TS.exit_summary ctx.rev_query src dst - - let path_weight_inter (ctx: t) (src: int) = - TS.target_summary ctx.rev_query src - -end - -module InterproceduralSummaryProvider(ProcName : sig - type t = int * int - val make : TS.vertex * TS.vertex -> t - val string_of : t -> string - val of_string : string -> t - val compare : t -> t -> int -end) -= - struct - module SMap = BatMap.Make(ProcName) - type t = { - graph: cfg_t; - src: int; - query: TS.query; - rev_query: TS.reverse_query; - mutable underapprox: K.t SMap.t; - mutable overapprox: K.t SMap.t; (* Caution: used only for silent mode where no CRA-generated summaries are used. *) - } - - let init (graph: cfg_t) (src: int) (tgt: int) : t = - let q = mk_query graph src in - let rq = TS.mk_reverse_query q tgt in - { graph = graph - ; src = src - ; query = q - ; rev_query = rq - ; underapprox = SMap.empty - ; overapprox = SMap.empty } - - (** retrieve over-approximate procedure summary *) - let over_proc_summary (ctx: t) ((u, v) : ProcName.t) = - TS.get_summary ctx.query (u, v) - |> K.exists (V.is_global) - - (** set over-approximate procedure summary *) - let set_over_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) = - TS.set_summary ctx.query (u, v) w - - (** retrieve under-approximate procedure summary *) - let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = - match SMap.find_default K.zero (u, v) ctx.underapprox - |> K.project_mbp (V.is_global) - with - | `Sat tr -> tr - | _ -> - log_weights "under_proc_summary: this weight is unsat: " [SMap.find_default K.zero (u, v) ctx.underapprox]; - K.zero - (*failwith "under_proc_summary: cannot model-based project"*) - - (** set under-approximate procedure summary *) - let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = - ctx.underapprox <- SMap.add (u, v) w ctx.underapprox - - (** refinement of procedure summaries using a two-voc transition formula *) - let refine_over_summary (ctx: t) ((u, v): ProcName.t) (rfn: K.t) = - over_proc_summary ctx (u, v) - |> K.conjunct rfn - |> set_over_proc_summary ctx (u, v) - - let refine_under_summary (ctx: t) ((u, v): ProcName.t) (w:K.t) : unit = - let summary = under_proc_summary ctx (u, v) in - let summary' = K.add summary w in - log_weights "under-approx summary refined to " [summary']; - set_under_proc_summary ctx (u, v) summary' - - end - -module SilentSummaryProvider(ProcName : sig - type t = int * int - val make : TS.vertex * TS.vertex -> t - val string_of : t -> string - val of_string : string -> t - val compare : t -> t -> int -end) = -struct - module SMap = BatMap.Make(ProcName) - type t = { - graph: cfg_t; - src: int; - mutable underapprox: K.t SMap.t; - mutable overapprox: K.t SMap.t; (* Caution: used only for silent mode where no CRA-generated summaries are used. *) - } - - let init (graph: cfg_t) (src: int) (tgt: int) : t = - { graph = graph - ; src = src - ; underapprox = SMap.empty - ; overapprox = SMap.empty } - - (** retrieve over-approximate procedure summary *) - let over_proc_summary (ctx: t) ((u, v) : ProcName.t) = - match SMap.find_opt (u, v) ctx.overapprox with - | Some s -> s - | None -> - let init = K.assume @@ mk_true () in - ctx.overapprox <- SMap.add (u, v) init ctx.overapprox; - init - - (** set over-approximate procedure summary *) - let set_over_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) = - match SMap.find_opt (u, v) ctx.overapprox with - | Some s -> - ctx.overapprox <- SMap.add (u, v) (K.conjunct s w) ctx.overapprox - | None -> - ctx.overapprox <- SMap.add (u, v) w ctx.overapprox - - (** retrieve under-approximate procedure summary *) - let under_proc_summary (ctx: t) ((u, v): ProcName.t) : K.t = - match SMap.find_default K.zero (u, v) ctx.underapprox |> K.project_mbp (V.is_global) with - | `Sat tr -> tr - | _ -> - log_weights "under_proc_summary: this weight is unsat: " [SMap.find_default K.zero (u, v) ctx.underapprox]; - K.zero - - (** set under-approximate procedure summary *) - let set_under_proc_summary (ctx: t) ((u, v): ProcName.t) (w: K.t) : unit = - ctx.underapprox <- SMap.add (u, v) w ctx.underapprox - - (** refinement of procedure summaries using a two-voc transition formula *) - let refine_over_summary (ctx: t) ((u, v): ProcName.t) (rfn: K.t) = - match SMap.find_opt (u, v) ctx.overapprox with - | Some s -> - ctx.overapprox <- SMap.add (u, v) (K.conjunct s rfn) ctx.overapprox - | None -> - ctx.overapprox <- SMap.add (u, v) rfn ctx.overapprox - - let refine_under_summary (ctx: t) ((u, v): ProcName.t) (w:K.t) : unit = - let summary = under_proc_summary ctx (u, v) in - let summary' = K.add summary w in - log_weights "under-approx summary refined to " [summary']; - set_under_proc_summary ctx (u, v) summary' -end -*) \ No newline at end of file diff --git a/duet/summaryProvider.mli b/duet/summaryProvider.mli deleted file mode 100644 index 0fe44028..00000000 --- a/duet/summaryProvider.mli +++ /dev/null @@ -1,159 +0,0 @@ -(* -module TransitionSystem = Srk.TransitionSystem -module Syntax = Srk.Syntax -module Interpretation = Srk.Interpretation -*) -(* -module LeftRegularSummaryProvider : - functor - (Ctx: Srk.Syntax.Context) - (** transition formula algebra *) - (K : sig - type t - type var - val pp : Format.formatter -> t -> unit - val guard : t -> Ctx.t Srk.Syntax.formula - val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t - val mem_transform : var -> t -> bool - val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term - val assume : Ctx.t Srk.Syntax.formula -> t - val mul : t -> t -> t - val add : t -> t -> t - val conjunct : t -> t -> t - val zero : t - val one : t - val star : t -> t - val exists : (var -> bool) -> t -> t - val contains_havoc : t -> bool - val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] - val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula - -> [`Valid of Ctx.t Syntax.formula list - | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] - - val get_post_model : - Ctx.t Srk.Interpretation.interpretation -> - t -> Ctx.t Srk.Interpretation.interpretation option - val is_deterministic : t -> bool - end) - (TS : sig - type vertex - type transition = K.t - type t - type query - type reverse_query - val empty : t - val path_weight : query -> vertex -> transition - val call_weight : query -> vertex * vertex -> transition - val mk_reverse_query : query -> vertex -> reverse_query - val exit_summary : reverse_query -> vertex -> vertex -> K.t - val target_summary : reverse_query -> vertex -> K.t - val set_summary : query -> vertex * vertex -> transition -> unit - val get_summary : query -> vertex * vertex -> transition - val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t - val iter_succ_e : - ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit - val edge_weight : - t -> vertex -> vertex -> K.t Srk.TransitionSystem.label - val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b - end) - -> sig - type t - val init : TS.t -> int -> int -> bool -> t - val path_weight_intra : t -> int -> int -> TS.transition - val path_weight_inter : t -> int -> TS.transition - end - -module InterproceduralSummaryProvider : -(Ctx: Srk.Syntax.Context) -(K : sig - type t - type var - val pp : Format.formatter -> t -> unit - val guard : t -> Ctx.t Srk.Syntax.formula - val transform : t -> (var * Ctx.t Srk.Syntax.arith_term) BatEnum.t - val mem_transform : var -> t -> bool - val get_transform : var -> t -> Ctx.t Srk.Syntax.arith_term - val assume : Ctx.t Srk.Syntax.formula -> t - val mul : t -> t -> t - val add : t -> t -> t - val conjunct : t -> t -> t - val zero : t - val one : t - val star : t -> t - val exists : (var -> bool) -> t -> t - val contains_havoc : t -> bool - val contextualize : t -> t -> t -> [ `Sat of t | `Unsat ] - val interpolate_or_concrete_model : t list -> Ctx.t Syntax.formula - -> [`Valid of Ctx.t Syntax.formula list - | `Invalid of Ctx.t Interpretation.interpretation | `Unknown ] - - val get_post_model : - Ctx.t Srk.Interpretation.interpretation -> - t -> Ctx.t Srk.Interpretation.interpretation option - val is_deterministic : t -> bool - end) -(TS : sig - type vertex - type transition = K.t - type t - type query - type reverse_query - val empty : t - val path_weight : query -> vertex -> transition - val call_weight : query -> vertex * vertex -> transition - val mk_reverse_query : query -> vertex -> reverse_query - val exit_summary : reverse_query -> vertex -> vertex -> K.t - val target_summary : reverse_query -> vertex -> K.t - val set_summary : query -> vertex * vertex -> transition -> unit - val get_summary : query -> vertex * vertex -> transition - val simplify : ?try_rtc:bool -> (vertex -> bool) -> t -> t - val iter_succ_e : - ((vertex * (transition TransitionSystem.label) * vertex) -> unit) -> t -> vertex -> unit - val edge_weight : - t -> vertex -> vertex -> K.t Srk.TransitionSystem.label - val fold_succ_e : (vertex * (K.t Srk.TransitionSystem.label) * vertex -> 'b -> 'b) -> t -> vertex -> 'b -> 'b - end) - (ProcName : sig - type t = int * int - val make : int * int -> t - val string_of : t -> string - val of_string : string -> t - val compare : t -> t -> int - end) - -> - sig - type t - val init : TS.t -> int -> int -> t - val over_proc_summary : t -> ProcName.t -> TS.transition - val set_over_proc_summary : t -> ProcName.t -> TS.transition -> unit - val under_proc_summary : t -> ProcName.t -> TS.transition - val set_under_proc_summary : t -> ProcName.t -> TS.transition -> unit - val refine_over_summary : t -> ProcName.t -> TS.transition -> unit - val refine_under_summary : t -> ProcName.t -> TS.transition -> unit - end - -module SilentSummaryProvider : -functor - (TS : sig - type t - type transition - end) - (ProcName : sig - type t = int * int - val make : int * int -> t - val string_of : t -> string - val of_string : string -> t - val compare : t -> t -> int - end) - -> - sig - type t - val init : TS.t -> int -> int -> t - val over_proc_summary : t -> ProcName.t -> TS.transition - val set_over_proc_summary : t -> ProcName.t -> TS.transition -> unit - val under_proc_summary : t -> ProcName.t -> TS.transition - val set_under_proc_summary : t -> ProcName.t -> TS.transition -> unit - val refine_over_summary : t -> ProcName.t -> TS.transition -> unit - val refine_under_summary : t -> ProcName.t -> TS.transition -> unit - end -*) \ No newline at end of file From 0edf91f0fed6e9e640fb1e749f8b6c36deeacaa3 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 28 Jul 2025 11:54:04 -0400 Subject: [PATCH 50/59] update .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index a94b7c16..9e14dc4d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +*.install *.annot *.cmo *.cma From f992c5160ab67bffbaf4342fc802a830aeb8516e Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 28 Jul 2025 13:56:33 -0400 Subject: [PATCH 51/59] start work on interpolation module --- srk/src/interpolate.ml | 462 ++++++++++++++++++++++++++++++++++++++++ srk/src/interpolate.mli | 144 +++++++++++++ srk/src/transition.ml | 6 + srk/src/transition.mli | 4 + 4 files changed, 616 insertions(+) create mode 100644 srk/src/interpolate.ml create mode 100644 srk/src/interpolate.mli diff --git a/srk/src/interpolate.ml b/srk/src/interpolate.ml new file mode 100644 index 00000000..5db4dabf --- /dev/null +++ b/srk/src/interpolate.ml @@ -0,0 +1,462 @@ +open Syntax +open BatPervasives + +include Log.Make(struct let name = "srk.interpolate" end) + +module StdInterpolate + (C: sig + type t + val context : t context + end) + (V: sig + type t + val show : t -> string + val typ : t -> [ `TyInt | `TyReal ] + val compare : t -> t -> int + val symbol_of : t -> symbol + val of_symbol : symbol -> t option + val is_global : t -> bool + end) + (T: sig + type t + type var = V.t + val equal : t -> t -> bool + val compare : t -> t -> int + val show : t -> string + + (** Guarded parallel assignment *) + val construct : C.t formula -> (var * C.t arith_term) list -> t + + (** [assume phi] is a transition that doesn't modify any variables, but can + only be executed when [phi] holds *) + val assume : C.t formula -> t + + (** [assign v t] is a transition that assigns the term [t] to the variable + [v]. *) + val assign : var -> C.t arith_term -> t + + (** Parallel assignment of a list of terms to a list of variables. + If a variable appears multiple times as a target for an + assignment, the rightmost assignment is taken. *) + val parallel_assign : (var * C.t arith_term) list -> t + + (** Assign a list of variables non-deterministic values. *) + val havoc : var list -> t + + (** Sequentially compose two transitions. *) + val mul : t -> t -> t + + (** Non-deterministically choose between two transitions *) + val add : t -> t -> t + + (** take conjunction of two transition formulas *) + val conjunct : t -> t -> t + + (** Unexecutable transition (unit of [add]). *) + val zero : t + + (** Skip (unit of [mul]). *) + val one : t + + (** [exists ex tr] removes the variables that do not satisfy the predicate + [ex] from the footprint of a transition. For example, projecting a + variable [x] out of a transition [tr] is logically equivalent to + [(exists x. tr) && x' = x]. *) + val exists : (var -> bool) -> t -> t + + val is_zero : t -> bool + val is_one : t -> bool + + (** Retrieve the value of a variable after a transition as a term over input + variables (and Skolem constants) *) + val get_transform : var -> t -> C.t arith_term + + (** Enumerate the variables and values assigned in a transition. *) + val transform : t -> (var * C.t arith_term) BatEnum.t + + (** The condition under which a transition may be executed. *) + val guard : t -> C.t formula + + (** + transtion : guard, transform + interpretation: M + find a model of the guard where we use M to replace all the pre-state value. + check interpretation.substitute + *) + val get_post_model : C.t Interpretation.interpretation -> t -> (C.t Interpretation.interpretation) option + + + (** Underapproximate existential quantification using model-based projection. + The variables to be preserved are set to `true` in the initial map. + Note the input map specifies variables to be preserved, not removed. *) + val project_mbp : (var -> bool) -> t -> [> `Sat of t | `Unsat] + + + (** Given a pre-condition [P], a path [path], and a post-condition [Q], + determine whether the Hoare triple [{P}path{Q}] is valid. *) + val valid_triple : C.t formula -> t list -> C.t formula -> [ `Valid + | `Invalid + | `Unknown ] + + val contains_havoc : t -> bool + + + val defines : t -> var list + val uses : t -> var list + + val abstract_post : (C.t,'abs) SrkApron.property -> t -> (C.t,'abs) SrkApron.property + + (** Compute a representation of a transition as a transition formula. *) + val to_transition_formula : t -> C.t TransitionFormula.t + + val domain : (C.t Iteration.exp_op) ref + val star : t -> t + val linearize : t -> t + + (** If [is_deterministic tr] holds, [tr] is deterministic (at most one + post-state for any given pre-state). If [is_deterministic tr] does not + hold, either [tr] is non-deterministic, or a proof of determinacy could + not be found. *) + val is_deterministic : t -> bool + + + (** vocabulary of a transition formula, (globals, locals)*) + val vocabulary : t -> ((Syntax.symbol list) * (Syntax.symbol list)) +end) = + struct + + let srk = C.context + module M = BatMap.Make(Var) + + + let interpolate trs post = + let trs = + trs |> List.map (fun tr -> + let fresh_skolem = + Memo.memo (fun sym -> + match V.of_symbol sym with + | Some _ -> mk_const srk sym + | None -> + let name = show_symbol srk sym in + let typ = typ_symbol srk sym in + mk_const srk (mk_symbol srk ~name typ)) + in + let transform = M.map (substitute_const srk fresh_skolem) (T.transform tr) in + let guard = substitute_const srk fresh_skolem T.guard tr in + T.construct_map guard transform + in + (* Break guards into conjunctions, associate each conjunct with an indicator *) + let guards = + List.map (fun tr -> + List.map + (fun phi -> (mk_symbol srk `TyBool, phi)) + (destruct_and srk tr.guard)) + trs + in + let indicators = + List.concat_map (List.map (fun (s, _) -> mk_const srk s)) guards + in + let subscript_tbl = Hashtbl.create 991 in + let subscript sym = + try + Hashtbl.find subscript_tbl sym + with Not_found -> mk_const srk sym + in + (* Convert tr into a formula, and simultaneously update the subscript + table *) + let to_ss_formula tr guards = + let ss_guards = + List.map (fun (indicator, guard) -> + mk_if srk + (mk_const srk indicator) + (substitute_const srk subscript guard)) + guards + in + let (ss, phis) = + M.fold (fun var term (ss, phis) -> + let var_sym = V.symbol_of var in + let var_ss_sym = mk_symbol srk (V.typ var :> typ) in + let var_ss_term = mk_const srk var_ss_sym in + let term_ss = substitute_const srk subscript term in + ((var_sym, var_ss_term)::ss, + mk_eq srk var_ss_term term_ss::phis)) + tr.transform + ([], ss_guards) + in + List.iter (fun (k, v) -> Hashtbl.add subscript_tbl k v) ss; + mk_and srk phis + in + let module Solver = Smt.StdSolver in + let solver = Solver.make srk in + List.iter2 (fun tr guard -> + Solver.add solver [to_ss_formula tr guard]) + trs + guards; + Solver.add solver [substitute_const srk subscript (mk_not srk post)]; + match Solver.get_unsat_core solver indicators with + | `Sat -> `Invalid + | `Unknown -> `Unknown + | `Unsat core -> + let core_symbols = + List.fold_left (fun core phi -> + match Formula.destruct srk phi with + | (`Proposition (`App (s, []))) -> Symbol.Set.add s core + | _ -> assert false) + Symbol.Set.empty + core + in + let (itp, _) = + List.fold_right2 (fun tr guard (itp, post) -> + let subst sym = + match V.of_symbol sym with + | Some var -> + if M.mem var tr.transform then + M.find var tr.transform + else + mk_const srk sym + | None -> mk_const srk sym + in + let post' = substitute_const srk subst post in + let reduced_guard = + List.filter_map (fun (indicator, guard) -> + if Symbol.Set.mem indicator core_symbols then + Some (mk_not srk guard) + else + None) + guard + in + let wp = + (mk_not srk (mk_or srk (post'::reduced_guard))) + |> Quantifier.mbp srk (fun s -> V.of_symbol s != None) + |> mk_not srk + in + (wp::itp, wp)) + trs + guards + ([ + mk_not srk post + |> Quantifier.mbp srk (fun x -> V.of_symbol x <> None) + |> mk_not srk + ], post) + in + `Valid (List.tl itp) + + + let get_post_model m f = + let f_guard = guard f in + let replacer (sym : Syntax.symbol) = + if V.of_symbol sym == None then Syntax.mk_const C.context sym + else mk_real C.context @@ Interpretation.real m sym + in + let f_guard' = Syntax.substitute_const C.context replacer f_guard in + let symbols = Syntax.symbols f_guard' |> Symbol.Set.elements in + let post pm = + BatEnum.fold (fun m' (lhs, rhs) -> + let sub_expr = Syntax.substitute_const C.context replacer rhs in + let lhs_symbol = V.symbol_of lhs in + let sub_val = Interpretation.evaluate_term pm sub_expr in + Interpretation.add lhs_symbol (`Real sub_val) m') + m + (M.enum f.transform) + in + match Formula.destruct srk f_guard' with + | `Fls -> None + | `Tru -> + let zero_model = Interpretation.wrap srk (fun s -> + match typ_symbol srk s with + | `TyInt | `TyReal -> `Real QQ.zero + | `TyBool -> `Bool true + | _ -> assert false) + in + Some (post zero_model) + | _ -> + match Smt.get_model ~symbols:(symbols) C.context f_guard' with + | `Sat skolem_model -> Some (post skolem_model) + | _ -> None + + (* helper method for interpolate/extrapolate procedures. creates fresh copies of skolem variables in tr *) + let rename_skolems tr = + let fresh_skolem = + Memo.memo (fun sym -> + match V.of_symbol sym with + | Some _ -> mk_const srk sym + | None -> + let name = show_symbol srk sym in + let typ = typ_symbol srk sym in + mk_const srk (mk_symbol srk ~name typ)) + in + { transform = M.map (substitute_const srk fresh_skolem) tr.transform; + guard = substitute_const srk fresh_skolem tr.guard } + + let interpolate_unsat_core trs post guards core = + let core_symbols = + List.fold_left (fun core phi -> + match Formula.destruct srk phi with + | (`Proposition (`App (s, []))) -> Symbol.Set.add s core + | _ -> assert false) + Symbol.Set.empty + core + in + let (itp, _) = + List.fold_right2 (fun tr guard (itp, post) -> + let subst sym = + match V.of_symbol sym with + | Some var -> + if M.mem var tr.transform then + M.find var tr.transform + else + mk_const srk sym + | None -> mk_const srk sym + in + let post' = substitute_const srk subst post in + let reduced_guard = + List.filter_map (fun (indicator, guard) -> + if Symbol.Set.mem indicator core_symbols then + Some (mk_not srk guard) + else + None) + guard + in + let wp = + (mk_not srk (mk_or srk (post'::reduced_guard))) + |> Quantifier.mbp srk (fun s -> V.of_symbol s != None) + |> mk_not srk + in + (wp::itp, wp)) + trs + guards + ([ + mk_not srk post + |> Quantifier.mbp srk (fun x -> V.of_symbol x <> None) + |> mk_not srk + ], post) + in `Valid (List.tl itp) + + + let interpolate_query trs post sat_callback unsat_callback = + let solver = Smt.StdSolver.make C.context in + (* Break guards into conjunctions, associate each conjunct with an indicator *) + let guards = + List.map (fun tr -> + List.map + (fun phi -> (mk_symbol srk `TyBool, phi)) + (destruct_and srk tr.guard)) + trs in + let indicators, indicator_symbols = + List.concat_map (List.map (fun (s, _) -> mk_const srk s)) guards, + List.concat_map (List.map fst) guards |> Symbol.Set.of_list + in + let subscript_tbl = Hashtbl.create 991 in + let ss_inv = Hashtbl.create 991 in + let sst = Hashtbl.create 991 in + let subscript sym = + try + Hashtbl.find subscript_tbl sym + with Not_found -> mk_const srk sym + in + (* Convert tr into a formula, and simultaneously update the subscript + table *) + let to_ss_formula tr guards = + let ss_guards = + List.map (fun (indicator, guard) -> + mk_if srk + (mk_const srk indicator) + (substitute_const srk subscript guard)) + guards + in + let (ss, phis) = + M.fold (fun var term (ss, phis) -> + let var_sym = V.symbol_of var in + let var_ss_sym = mk_symbol srk (V.typ var :> typ) in + let var_ss_term = mk_const srk var_ss_sym in + let term_ss = substitute_const srk subscript term in + ((var_sym, var_ss_sym, var_ss_term)::ss, + mk_eq srk var_ss_term term_ss::phis)) + tr.transform + ([], ss_guards) + in + List.iter (fun (k, l, v) -> + Hashtbl.add subscript_tbl k v; + Hashtbl.add ss_inv l k; + Hashtbl.add sst k l) ss; + mk_and srk phis + in + (* gather all symbols into a list, while adding formulas to the solver object *) + let symbols, added_formulas = List.fold_left + (fun (symbols, added_formulas) (tr, guard) -> + let f = to_ss_formula tr guard in + Smt.StdSolver.add solver [f]; + (Syntax.symbols f) :: symbols, f::added_formulas) + ([], []) (List.combine trs guards) in + let _ = List.iter (fun f -> + let f = substitute_const srk + (fun v -> + match Hashtbl.find_opt ss_inv v with + | None -> Syntax.mk_const srk v + | Some v' -> Syntax.mk_const srk v') f + in logf "added formula: %a\n" (Syntax.pp_expr srk) f) added_formulas + (* subscript the symbols in the `post` formula, as well *) in + let target = substitute_const srk subscript (mk_not srk post) in + let symbols = (Syntax.symbols target) :: symbols + |> List.rev + |> List.map (fun ss -> Symbol.Set.diff ss indicator_symbols) in + Smt.StdSolver.add solver [target]; + logf "-----------------------------interpolation---\n"; + List.iter (fun f -> + let f = substitute_const srk + (fun v -> + match Hashtbl.find_opt ss_inv v with + | None -> Syntax.mk_const srk v + | Some v' -> Syntax.mk_const srk v') f + in logf "indicator formula: %a\n" (Syntax.pp_expr srk) f) indicators; + logf "-------------------interpolation end---\n"; + logf "--- indicator length %d\n" @@ List.length indicators; + logf "\ntarget formula: %a\n" (Syntax.pp_expr srk) target; + match Smt.StdSolver.get_unsat_core_or_model solver indicators with + | `Sat m -> + (sat_callback m symbols sst ss_inv) + | `Unsat core -> (unsat_callback trs post guards core) + | `Unknown -> `Unknown + + + (* let interpolate trs post = + let trs = List.map rename_skolems trs in + interpolate_query trs post (fun _ _ _ _ -> `Invalid) @@ interpolate_unsat_core + *) + let interpolate_or_concrete_model trs post = + (* subst_model: rename skolem constants back to their appropriate names using reverse subscript table *) + let trs = List.map rename_skolems trs in + let sat_model model (symbols: Symbol.Set.t list) ss ss_inv = + let m = + List.fold_left (fun m' symbols -> + Symbol.Set.fold (fun s m -> + (* the provided model is over both subscripted vocabulary and original vocabulary *) + begin match Hashtbl.find_opt ss_inv s with + | Some s' -> (* subscripted variable *) + Interpretation.add s' (Interpretation.value model s) m + | None -> (* non-subscripted; query directly *) + Interpretation.add s (Interpretation.value model s) m + end) symbols m' + ) (Interpretation.wrap srk (fun s -> + match Hashtbl.find_opt ss s with + | Some sss -> Interpretation.value model sss + | None -> `Real (Q.of_int 47))) (*(Interpretation.wrap srk (fun s -> + match Hashtbl.find_opt ss s with + | Some sss -> Interpretation.value model sss + | None -> Interpretation.value model s))*) (*(Interpretation.empty srk)*) symbols in + logf "hashtable length: %d\n" (Hashtbl.length ss_inv); + logf "%a" Interpretation.pp m; + Format.print_flush (); + (* symbols is a list of subscripted symbols arranged in left-to-right order. + folding over this in left-to-right order amounts to forward concrete execution. *) + `Invalid (m + |> Interpretation.restrict + (fun s -> + match V.of_symbol s with + | Some _ -> true + | None -> false)) + in interpolate_query trs post sat_model @@ interpolate_unsat_core + + + + end diff --git a/srk/src/interpolate.mli b/srk/src/interpolate.mli new file mode 100644 index 00000000..a5a84ded --- /dev/null +++ b/srk/src/interpolate.mli @@ -0,0 +1,144 @@ +(** Interpolation of transition formulas. *) +open Syntax + +module StdInterpolate + (C: sig + type t + val context : t context + end) + (V: sig + type t + val show : t -> string + val typ : t -> [ `TyInt | `TyReal ] + val compare : t -> t -> int + val symbol_of : t -> symbol + val of_symbol : symbol -> t option + val is_global : t -> bool + end) + (T: sig + type t + type var = V.t + val equal : t -> t -> bool + val compare : t -> t -> int + val show : t -> string + + (** Guarded parallel assignment *) + val construct : C.t formula -> (var * C.t arith_term) list -> t + + (** [assume phi] is a transition that doesn't modify any variables, but can + only be executed when [phi] holds *) + val assume : C.t formula -> t + + (** [assign v t] is a transition that assigns the term [t] to the variable + [v]. *) + val assign : var -> C.t arith_term -> t + + (** Parallel assignment of a list of terms to a list of variables. + If a variable appears multiple times as a target for an + assignment, the rightmost assignment is taken. *) + val parallel_assign : (var * C.t arith_term) list -> t + + (** Assign a list of variables non-deterministic values. *) + val havoc : var list -> t + + (** Sequentially compose two transitions. *) + val mul : t -> t -> t + + (** Non-deterministically choose between two transitions *) + val add : t -> t -> t + + (** take conjunction of two transition formulas *) + val conjunct : t -> t -> t + + (** Unexecutable transition (unit of [add]). *) + val zero : t + + (** Skip (unit of [mul]). *) + val one : t + + (** [exists ex tr] removes the variables that do not satisfy the predicate + [ex] from the footprint of a transition. For example, projecting a + variable [x] out of a transition [tr] is logically equivalent to + [(exists x. tr) && x' = x]. *) + val exists : (var -> bool) -> t -> t + + val is_zero : t -> bool + val is_one : t -> bool + + (** Retrieve the value of a variable after a transition as a term over input + variables (and Skolem constants) *) + val get_transform : var -> t -> C.t arith_term + + (** Enumerate the variables and values assigned in a transition. *) + val transform : t -> (var * C.t arith_term) BatEnum.t + + (** The condition under which a transition may be executed. *) + val guard : t -> C.t formula + + (** + transtion : guard, transform + interpretation: M + find a model of the guard where we use M to replace all the pre-state value. + check interpretation.substitute + *) + val get_post_model : C.t Interpretation.interpretation -> t -> (C.t Interpretation.interpretation) option + + + (** Underapproximate existential quantification using model-based projection. + The variables to be preserved are set to `true` in the initial map. + Note the input map specifies variables to be preserved, not removed. *) + val project_mbp : (var -> bool) -> t -> [> `Sat of t | `Unsat] + + + (** Given a pre-condition [P], a path [path], and a post-condition [Q], + determine whether the Hoare triple [{P}path{Q}] is valid. *) + val valid_triple : C.t formula -> t list -> C.t formula -> [ `Valid + | `Invalid + | `Unknown ] + + val contains_havoc : t -> bool + + + val defines : t -> var list + val uses : t -> var list + + val abstract_post : (C.t,'abs) SrkApron.property -> t -> (C.t,'abs) SrkApron.property + + (** Compute a representation of a transition as a transition formula. *) + val to_transition_formula : t -> C.t TransitionFormula.t + + val domain : (C.t Iteration.exp_op) ref + val star : t -> t + val linearize : t -> t + + (** If [is_deterministic tr] holds, [tr] is deterministic (at most one + post-state for any given pre-state). If [is_deterministic tr] does not + hold, either [tr] is non-deterministic, or a proof of determinacy could + not be found. *) + val is_deterministic : t -> bool + + + (** vocabulary of a transition formula, (globals, locals)*) + val vocabulary : t -> ((Syntax.symbol list) * (Syntax.symbol list)) +end) : sig + + + (** Given a path (list of transitions [tr_1 ... tr_n]) and a post-condition + formula, determine whether the path implies the post-condition. If yes, + return a sequence of intermediate assertions [phi_1 ... phi_n] that + support the proof (for each [i], [{ phi_{i-1} } tr_i { phi_i }] holds, + where [phi_0] is [true] and [phi_n] implies the post-condition). *) + + val interpolate : T.t list -> C.t formula -> [ `Valid of C.t formula list + | `Invalid + | `Unknown ] + + + (** Same as interpolate, but returns a concrete model if interpllation fails. *) + val interpolate_or_concrete_model : T.t list -> C.t formula + -> [`Valid of C.t formula list + | `Invalid of C.t Interpretation.interpretation + | `Unknown ] + + +end diff --git a/srk/src/transition.ml b/srk/src/transition.ml index fa2cfa09..7d721f64 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -65,6 +65,12 @@ struct List.fold_left (fun m (v, term) -> M.add v term m) M.empty assignment; guard = guard } + let construct_map guard transform = + { + transform = transform; + guard = guard + } + let assign v term = { transform = M.add v term M.empty; guard = mk_true srk } diff --git a/srk/src/transition.mli b/srk/src/transition.mli index 465254f6..b82670e0 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -12,6 +12,9 @@ module type Var = sig val is_global : t -> bool end +module M = BatMap.Make(Var) + + module Make (C : sig type t @@ -48,6 +51,7 @@ module Make (** Guarded parallel assignment *) val construct : C.t formula -> (var * C.t arith_term) list -> t + val construct_map : C.t formula -> (C.t arith_term) M.t -> t (** [assume phi] is a transition that doesn't modify any variables, but can only be executed when [phi] holds *) From b2184d7e5da0135bde3c7259881081d17efcc63a Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 28 Jul 2025 15:51:52 -0400 Subject: [PATCH 52/59] finish up refactored interpolation interface --- srk/src/interpolate.ml | 151 +++++----------------------------------- srk/src/interpolate.mli | 89 ++--------------------- srk/src/transition.ml | 7 +- srk/src/transition.mli | 8 +-- 4 files changed, 32 insertions(+), 223 deletions(-) diff --git a/srk/src/interpolate.ml b/srk/src/interpolate.ml index 5db4dabf..cfd1a0fb 100644 --- a/srk/src/interpolate.ml +++ b/srk/src/interpolate.ml @@ -22,112 +22,30 @@ module StdInterpolate type var = V.t val equal : t -> t -> bool val compare : t -> t -> int - val show : t -> string (** Guarded parallel assignment *) val construct : C.t formula -> (var * C.t arith_term) list -> t - (** [assume phi] is a transition that doesn't modify any variables, but can - only be executed when [phi] holds *) - val assume : C.t formula -> t - - (** [assign v t] is a transition that assigns the term [t] to the variable - [v]. *) - val assign : var -> C.t arith_term -> t - - (** Parallel assignment of a list of terms to a list of variables. - If a variable appears multiple times as a target for an - assignment, the rightmost assignment is taken. *) - val parallel_assign : (var * C.t arith_term) list -> t - - (** Assign a list of variables non-deterministic values. *) - val havoc : var list -> t - - (** Sequentially compose two transitions. *) - val mul : t -> t -> t - - (** Non-deterministically choose between two transitions *) - val add : t -> t -> t - - (** take conjunction of two transition formulas *) - val conjunct : t -> t -> t - - (** Unexecutable transition (unit of [add]). *) - val zero : t - - (** Skip (unit of [mul]). *) - val one : t - + val create : C.t formula -> (var * C.t arith_term) BatEnum.t -> t (** [exists ex tr] removes the variables that do not satisfy the predicate [ex] from the footprint of a transition. For example, projecting a variable [x] out of a transition [tr] is logically equivalent to [(exists x. tr) && x' = x]. *) val exists : (var -> bool) -> t -> t - val is_zero : t -> bool - val is_one : t -> bool - - (** Retrieve the value of a variable after a transition as a term over input - variables (and Skolem constants) *) - val get_transform : var -> t -> C.t arith_term + (** (Needed by interpolation) *) + val destruct_and : (C.t context) -> (C.t formula) -> (C.t formula) list (** Enumerate the variables and values assigned in a transition. *) val transform : t -> (var * C.t arith_term) BatEnum.t (** The condition under which a transition may be executed. *) val guard : t -> C.t formula - - (** - transtion : guard, transform - interpretation: M - find a model of the guard where we use M to replace all the pre-state value. - check interpretation.substitute - *) - val get_post_model : C.t Interpretation.interpretation -> t -> (C.t Interpretation.interpretation) option - - - (** Underapproximate existential quantification using model-based projection. - The variables to be preserved are set to `true` in the initial map. - Note the input map specifies variables to be preserved, not removed. *) - val project_mbp : (var -> bool) -> t -> [> `Sat of t | `Unsat] - - - (** Given a pre-condition [P], a path [path], and a post-condition [Q], - determine whether the Hoare triple [{P}path{Q}] is valid. *) - val valid_triple : C.t formula -> t list -> C.t formula -> [ `Valid - | `Invalid - | `Unknown ] - - val contains_havoc : t -> bool - - - val defines : t -> var list - val uses : t -> var list - - val abstract_post : (C.t,'abs) SrkApron.property -> t -> (C.t,'abs) SrkApron.property - - (** Compute a representation of a transition as a transition formula. *) - val to_transition_formula : t -> C.t TransitionFormula.t - - val domain : (C.t Iteration.exp_op) ref - val star : t -> t - val linearize : t -> t - - (** If [is_deterministic tr] holds, [tr] is deterministic (at most one - post-state for any given pre-state). If [is_deterministic tr] does not - hold, either [tr] is non-deterministic, or a proof of determinacy could - not be found. *) - val is_deterministic : t -> bool - - - (** vocabulary of a transition formula, (globals, locals)*) - val vocabulary : t -> ((Syntax.symbol list) * (Syntax.symbol list)) -end) = + end) = struct let srk = C.context - module M = BatMap.Make(Var) - + module M = BatMap.Make(V) let interpolate trs post = let trs = @@ -141,16 +59,16 @@ end) = let typ = typ_symbol srk sym in mk_const srk (mk_symbol srk ~name typ)) in - let transform = M.map (substitute_const srk fresh_skolem) (T.transform tr) in - let guard = substitute_const srk fresh_skolem T.guard tr in - T.construct_map guard transform + let transform = M.map (substitute_const srk fresh_skolem) (M.of_enum @@ T.transform tr) in + let guard = substitute_const srk fresh_skolem (T.guard tr) in + T.create guard @@ M.enum transform) in (* Break guards into conjunctions, associate each conjunct with an indicator *) let guards = List.map (fun tr -> List.map (fun phi -> (mk_symbol srk `TyBool, phi)) - (destruct_and srk tr.guard)) + (T.destruct_and srk (T.guard tr))) trs in let indicators = @@ -180,7 +98,7 @@ end) = let term_ss = substitute_const srk subscript term in ((var_sym, var_ss_term)::ss, mk_eq srk var_ss_term term_ss::phis)) - tr.transform + (M.of_enum (T.transform tr)) ([], ss_guards) in List.iter (fun (k, v) -> Hashtbl.add subscript_tbl k v) ss; @@ -210,8 +128,8 @@ end) = let subst sym = match V.of_symbol sym with | Some var -> - if M.mem var tr.transform then - M.find var tr.transform + if M.mem var (M.of_enum (T.transform tr)) then + M.find var (M.of_enum (T.transform tr)) else mk_const srk sym | None -> mk_const srk sym @@ -242,38 +160,6 @@ end) = `Valid (List.tl itp) - let get_post_model m f = - let f_guard = guard f in - let replacer (sym : Syntax.symbol) = - if V.of_symbol sym == None then Syntax.mk_const C.context sym - else mk_real C.context @@ Interpretation.real m sym - in - let f_guard' = Syntax.substitute_const C.context replacer f_guard in - let symbols = Syntax.symbols f_guard' |> Symbol.Set.elements in - let post pm = - BatEnum.fold (fun m' (lhs, rhs) -> - let sub_expr = Syntax.substitute_const C.context replacer rhs in - let lhs_symbol = V.symbol_of lhs in - let sub_val = Interpretation.evaluate_term pm sub_expr in - Interpretation.add lhs_symbol (`Real sub_val) m') - m - (M.enum f.transform) - in - match Formula.destruct srk f_guard' with - | `Fls -> None - | `Tru -> - let zero_model = Interpretation.wrap srk (fun s -> - match typ_symbol srk s with - | `TyInt | `TyReal -> `Real QQ.zero - | `TyBool -> `Bool true - | _ -> assert false) - in - Some (post zero_model) - | _ -> - match Smt.get_model ~symbols:(symbols) C.context f_guard' with - | `Sat skolem_model -> Some (post skolem_model) - | _ -> None - (* helper method for interpolate/extrapolate procedures. creates fresh copies of skolem variables in tr *) let rename_skolems tr = let fresh_skolem = @@ -285,8 +171,9 @@ end) = let typ = typ_symbol srk sym in mk_const srk (mk_symbol srk ~name typ)) in - { transform = M.map (substitute_const srk fresh_skolem) tr.transform; - guard = substitute_const srk fresh_skolem tr.guard } + let transform = M.map (substitute_const srk fresh_skolem) (M.of_enum @@ T.transform tr) in + let guard = substitute_const srk fresh_skolem (T.guard tr) in + T.create guard (M.enum transform) let interpolate_unsat_core trs post guards core = let core_symbols = @@ -302,8 +189,8 @@ end) = let subst sym = match V.of_symbol sym with | Some var -> - if M.mem var tr.transform then - M.find var tr.transform + if M.mem var (M.of_enum @@ T.transform tr) then + M.find var (M.of_enum @@ T.transform tr) else mk_const srk sym | None -> mk_const srk sym @@ -340,7 +227,7 @@ end) = List.map (fun tr -> List.map (fun phi -> (mk_symbol srk `TyBool, phi)) - (destruct_and srk tr.guard)) + (T.destruct_and srk @@ T.guard tr)) trs in let indicators, indicator_symbols = List.concat_map (List.map (fun (s, _) -> mk_const srk s)) guards, @@ -372,7 +259,7 @@ end) = let term_ss = substitute_const srk subscript term in ((var_sym, var_ss_sym, var_ss_term)::ss, mk_eq srk var_ss_term term_ss::phis)) - tr.transform + (M.of_enum @@ T.transform tr) ([], ss_guards) in List.iter (fun (k, l, v) -> diff --git a/srk/src/interpolate.mli b/srk/src/interpolate.mli index a5a84ded..1d35a7aa 100644 --- a/srk/src/interpolate.mli +++ b/srk/src/interpolate.mli @@ -20,107 +20,26 @@ module StdInterpolate type var = V.t val equal : t -> t -> bool val compare : t -> t -> int - val show : t -> string (** Guarded parallel assignment *) val construct : C.t formula -> (var * C.t arith_term) list -> t - (** [assume phi] is a transition that doesn't modify any variables, but can - only be executed when [phi] holds *) - val assume : C.t formula -> t - - (** [assign v t] is a transition that assigns the term [t] to the variable - [v]. *) - val assign : var -> C.t arith_term -> t - - (** Parallel assignment of a list of terms to a list of variables. - If a variable appears multiple times as a target for an - assignment, the rightmost assignment is taken. *) - val parallel_assign : (var * C.t arith_term) list -> t - - (** Assign a list of variables non-deterministic values. *) - val havoc : var list -> t - - (** Sequentially compose two transitions. *) - val mul : t -> t -> t - - (** Non-deterministically choose between two transitions *) - val add : t -> t -> t - - (** take conjunction of two transition formulas *) - val conjunct : t -> t -> t - - (** Unexecutable transition (unit of [add]). *) - val zero : t - - (** Skip (unit of [mul]). *) - val one : t - + val create : C.t formula -> (var * C.t arith_term) BatEnum.t -> t (** [exists ex tr] removes the variables that do not satisfy the predicate [ex] from the footprint of a transition. For example, projecting a variable [x] out of a transition [tr] is logically equivalent to [(exists x. tr) && x' = x]. *) val exists : (var -> bool) -> t -> t - val is_zero : t -> bool - val is_one : t -> bool - - (** Retrieve the value of a variable after a transition as a term over input - variables (and Skolem constants) *) - val get_transform : var -> t -> C.t arith_term + (** (Needed by interpolation) *) + val destruct_and : (C.t context) -> (C.t formula) -> (C.t formula) list (** Enumerate the variables and values assigned in a transition. *) val transform : t -> (var * C.t arith_term) BatEnum.t (** The condition under which a transition may be executed. *) val guard : t -> C.t formula - - (** - transtion : guard, transform - interpretation: M - find a model of the guard where we use M to replace all the pre-state value. - check interpretation.substitute - *) - val get_post_model : C.t Interpretation.interpretation -> t -> (C.t Interpretation.interpretation) option - - - (** Underapproximate existential quantification using model-based projection. - The variables to be preserved are set to `true` in the initial map. - Note the input map specifies variables to be preserved, not removed. *) - val project_mbp : (var -> bool) -> t -> [> `Sat of t | `Unsat] - - - (** Given a pre-condition [P], a path [path], and a post-condition [Q], - determine whether the Hoare triple [{P}path{Q}] is valid. *) - val valid_triple : C.t formula -> t list -> C.t formula -> [ `Valid - | `Invalid - | `Unknown ] - - val contains_havoc : t -> bool - - - val defines : t -> var list - val uses : t -> var list - - val abstract_post : (C.t,'abs) SrkApron.property -> t -> (C.t,'abs) SrkApron.property - - (** Compute a representation of a transition as a transition formula. *) - val to_transition_formula : t -> C.t TransitionFormula.t - - val domain : (C.t Iteration.exp_op) ref - val star : t -> t - val linearize : t -> t - - (** If [is_deterministic tr] holds, [tr] is deterministic (at most one - post-state for any given pre-state). If [is_deterministic tr] does not - hold, either [tr] is non-deterministic, or a proof of determinacy could - not be found. *) - val is_deterministic : t -> bool - - - (** vocabulary of a transition formula, (globals, locals)*) - val vocabulary : t -> ((Syntax.symbol list) * (Syntax.symbol list)) -end) : sig + end) : sig (** Given a path (list of transitions [tr_1 ... tr_n]) and a post-condition diff --git a/srk/src/transition.ml b/srk/src/transition.ml index 7d721f64..a5fafbfa 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -65,9 +65,9 @@ struct List.fold_left (fun m (v, term) -> M.add v term m) M.empty assignment; guard = guard } - let construct_map guard transform = + let create guard transform_e = { - transform = transform; + transform = M.of_enum transform_e; guard = guard } @@ -343,6 +343,9 @@ struct let mem_transform x tr = M.mem x tr.transform let get_transform x tr = M.find x tr.transform let transform tr = M.enum tr.transform + + let transform_map tr = tr.transform + let guard tr = tr.guard let rec destruct_and srk phi = diff --git a/srk/src/transition.mli b/srk/src/transition.mli index b82670e0..77b529a6 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -12,9 +12,6 @@ module type Var = sig val is_global : t -> bool end -module M = BatMap.Make(Var) - - module Make (C : sig type t @@ -51,7 +48,7 @@ module Make (** Guarded parallel assignment *) val construct : C.t formula -> (var * C.t arith_term) list -> t - val construct_map : C.t formula -> (C.t arith_term) M.t -> t + val create : C.t formula -> (var * C.t arith_term) BatEnum.t -> t (** [assume phi] is a transition that doesn't modify any variables, but can only be executed when [phi] holds *) @@ -109,6 +106,9 @@ module Make (** Enumerate the variables and values assigned in a transition. *) val transform : t -> (var * C.t arith_term) BatEnum.t + (** Destruct conjunctions, needed by the interpolation API *) + val destruct_and : (C.t context) -> (C.t formula) -> (C.t formula) list + (** The condition under which a transition may be executed. *) val guard : t -> C.t formula From ef4fd8b06e2e640f3385584611269eb090dd2668 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 28 Jul 2025 16:06:46 -0400 Subject: [PATCH 53/59] move things around --- srk/src/dune | 1 + srk/src/{interpolate.mli => interpolant.mli} | 6 ++---- srk/src/{interpolate.ml => newtonInterpolant.ml} | 9 ++++----- 3 files changed, 7 insertions(+), 9 deletions(-) rename srk/src/{interpolate.mli => interpolant.mli} (97%) rename srk/src/{interpolate.ml => newtonInterpolant.ml} (98%) diff --git a/srk/src/dune b/srk/src/dune index 11e8c5ed..58230969 100644 --- a/srk/src/dune +++ b/srk/src/dune @@ -13,6 +13,7 @@ (modules (:standard \ bigtop)) (modes native) (flags (:standard -w -32)) + (modules_without_implementation interpolant) (libraries batteries ppx_deriving ppx_deriving.show ppx_deriving.ord ppx_deriving.eq diff --git a/srk/src/interpolate.mli b/srk/src/interpolant.mli similarity index 97% rename from srk/src/interpolate.mli rename to srk/src/interpolant.mli index 1d35a7aa..16b62f74 100644 --- a/srk/src/interpolate.mli +++ b/srk/src/interpolant.mli @@ -1,7 +1,7 @@ (** Interpolation of transition formulas. *) open Syntax -module StdInterpolate +module type Interpolant = functor (C: sig type t val context : t context @@ -39,7 +39,7 @@ module StdInterpolate (** The condition under which a transition may be executed. *) val guard : t -> C.t formula - end) : sig + end) -> sig (** Given a path (list of transitions [tr_1 ... tr_n]) and a post-condition @@ -58,6 +58,4 @@ module StdInterpolate -> [`Valid of C.t formula list | `Invalid of C.t Interpretation.interpretation | `Unknown ] - - end diff --git a/srk/src/interpolate.ml b/srk/src/newtonInterpolant.ml similarity index 98% rename from srk/src/interpolate.ml rename to srk/src/newtonInterpolant.ml index cfd1a0fb..f16678f7 100644 --- a/srk/src/interpolate.ml +++ b/srk/src/newtonInterpolant.ml @@ -1,10 +1,10 @@ open Syntax open BatPervasives +open Interpolant -include Log.Make(struct let name = "srk.interpolate" end) +include Log.Make(struct let name = "srk.newtonInterpolant" end) -module StdInterpolate - (C: sig +module Newton : Interpolant = functor (C: sig type t val context : t context end) @@ -41,8 +41,7 @@ module StdInterpolate (** The condition under which a transition may be executed. *) val guard : t -> C.t formula - end) = - struct + end) -> struct let srk = C.context module M = BatMap.Make(V) From b05273eb7d097c92b452850425c85f80283835f0 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 28 Jul 2025 21:00:37 -0400 Subject: [PATCH 54/59] first cut of future-live variables analysis --- srk/src/interpolant.mli | 11 +- srk/src/newtonInterpolant.ml | 65 +++++++++++- srk/src/transition.ml | 7 ++ srk/src/transition.mli | 7 ++ srk/test/test_newton_interpolant.ml | 150 ++++++++++++++++++++++++++++ srk/test/test_srk.ml | 1 + srk/test/test_transition.ml | 67 ------------- 7 files changed, 238 insertions(+), 70 deletions(-) create mode 100644 srk/test/test_newton_interpolant.ml diff --git a/srk/src/interpolant.mli b/srk/src/interpolant.mli index 16b62f74..81229854 100644 --- a/srk/src/interpolant.mli +++ b/srk/src/interpolant.mli @@ -37,9 +37,18 @@ module type Interpolant = functor (** Enumerate the variables and values assigned in a transition. *) val transform : t -> (var * C.t arith_term) BatEnum.t + (** Variables written to inside the transform of a transition. *) + val defines : t -> var list + + (** Variables used by a a transition, including non-Skolem symbols in both the guard and the transform. *) + val uses : t -> var list + (** The condition under which a transition may be executed. *) val guard : t -> C.t formula - end) -> sig + + val state_vocabulary : t -> (var * Syntax.symbol) list + + end) -> sig (** Given a path (list of transitions [tr_1 ... tr_n]) and a post-condition diff --git a/srk/src/newtonInterpolant.ml b/srk/src/newtonInterpolant.ml index f16678f7..66580e31 100644 --- a/srk/src/newtonInterpolant.ml +++ b/srk/src/newtonInterpolant.ml @@ -4,7 +4,7 @@ open Interpolant include Log.Make(struct let name = "srk.newtonInterpolant" end) -module Newton : Interpolant = functor (C: sig +module NewtonBackwards : Interpolant = functor (C: sig type t val context : t context end) @@ -39,17 +39,76 @@ module Newton : Interpolant = functor (C: sig (** Enumerate the variables and values assigned in a transition. *) val transform : t -> (var * C.t arith_term) BatEnum.t + val defines : t -> var list + + (** Variables used by a a transition, including non-Skolem symbols in both the guard and the transform. *) + val uses : t -> var list + (** The condition under which a transition may be executed. *) val guard : t -> C.t formula + + val state_vocabulary : t -> (var * Syntax.symbol) list end) -> struct let srk = C.context module M = BatMap.Make(V) + (* The helper functions below implement the live-variables analysis described in: + + Daniel Dietsch, Matthias Heizmann, Betim Musa, Alexander Nutz, and Andreas Podelski. + Craig vs. Newton in software model checking. ESEC/FSE 2017. + + For a sequence of transition formulas [trs]: + + Def 1 (future-live variable). We call a variable [x] future-live in [trs] at position i if there is + a transition tr_j in [trs] with j > i, such that + - tr_j reads x, and + - for all k with i < k < j the transition tr_k neither writes nor havocs [x]. + + Def 2 (past-live variable).We call a variable [x] past-live in [trs] at i if there is a transition tr_j in [trs] with + j <= i, such that + - tr_j writes x or reads x, and + - for all k with j < k <= i the transition tr_k does not havoc x. + *) + + (** test whether a variable [x] of type [var] is future-live in future transitions [trs]. *) + + let is_future_live x trs = + if trs = [] then false else begin + (* acc is a pair of booleans, acc_0 means *) + let state = List.fold_left (fun (has_been_read, has_been_written) tr -> + if has_been_read then begin + if has_been_written then begin + if List.mem x (T.uses tr) && (not (List.mem x (T.defines tr))) then (has_been_read, false) + else (has_been_read, has_been_written) + end else (has_been_read, List.mem x (T.defines tr)) + end else begin + (List.mem x (T.uses tr) && not(List.mem x (T.defines tr)), false) + end + ) (false, false) (List.rev trs) in + match state with + (* a variable is future-live if it's used in the future and not modified between current point and point-of-use. *) + | (true, false) -> true + | _ -> false + end + + (** For a list of transitions [trs], compute the set of future-live variables for each transition's vocabulary. + Returns a list of type [var Set.t] where the i-th set is the set of non-live variables at transition i. *) + let future_live_analysis trs = + let live_vars, _ = + List.fold_left (fun (acc, trs') tr -> + let vars = List.map (fun (x, _) -> x) (T.state_vocabulary tr) in + (List.filter (fun x -> is_future_live x trs') vars :: acc, tr :: trs') + ) ([], []) (List.rev trs) in + live_vars + + let interpolate trs post = + (* The following step ensures all Skolem constants in [trs] are unique. *) let trs = trs |> List.map (fun tr -> let fresh_skolem = + (* If sym is a non-skolem (i.e. stored in V), return the same symbol. Otherwise, create a fresh Skolem symbol. *) Memo.memo (fun sym -> match V.of_symbol sym with | Some _ -> mk_const srk sym @@ -62,7 +121,9 @@ module Newton : Interpolant = functor (C: sig let guard = substitute_const srk fresh_skolem (T.guard tr) in T.create guard @@ M.enum transform) in - (* Break guards into conjunctions, associate each conjunct with an indicator *) + (* Take the list of guards for each transition in the sequence. + Break guards into a list of conjunctions, and associate each conjunct with + an indicator variable that is true iff the conjunct is included in the final UNSAT core. *) let guards = List.map (fun tr -> List.map diff --git a/srk/src/transition.ml b/srk/src/transition.ml index a5fafbfa..fcfe10da 100644 --- a/srk/src/transition.ml +++ b/srk/src/transition.ml @@ -697,6 +697,13 @@ struct let locals = Symbol.Set.diff v globals in (Symbol.Set.to_list globals, Symbol.Set.to_list locals) + let state_vocabulary tr = + let global_v, local_v = vocabulary tr in + List.filter_map (fun x -> + match Var.of_symbol x with + | Some var -> Some(var, x) + | None -> None + ) (global_v @ local_v) let contextualize t1 t2 t3 : [`Sat of t | `Unsat ] = let t1 = rename_skolems t1 diff --git a/srk/src/transition.mli b/srk/src/transition.mli index 77b529a6..9e9b9e5b 100644 --- a/srk/src/transition.mli +++ b/srk/src/transition.mli @@ -154,7 +154,10 @@ module Make val contains_havoc : t -> bool + (** Variables written to inside the transform of a transition. *) val defines : t -> var list + + (** Variables used by a a transition, including non-Skolem symbols in both the guard and the transform. *) val uses : t -> var list val abstract_post : (C.t,'abs) SrkApron.property -> t -> (C.t,'abs) SrkApron.property @@ -179,4 +182,8 @@ module Make (** vocabulary of a transition formula, (globals, locals)*) val vocabulary : t -> ((Syntax.symbol list) * (Syntax.symbol list)) + + (** non-existentially quantified vocabulary of a transition formula, with all skolem symbols left out. + returns a list of pairs [var, sym] with a Var.t and a symbol corresponding to the variable. *) + val state_vocabulary: t -> (var * Syntax.symbol) list end diff --git a/srk/test/test_newton_interpolant.ml b/srk/test/test_newton_interpolant.ml new file mode 100644 index 00000000..518e83b5 --- /dev/null +++ b/srk/test/test_newton_interpolant.ml @@ -0,0 +1,150 @@ +open Srk +open OUnit +open Syntax +open Test_pervasives +open NewtonInterpolant +module V = struct + type t = string + + let typ_table = Hashtbl.create 991 + let sym_table = Hashtbl.create 991 + let rev_sym_table = Hashtbl.create 991 + + let register_var name typ = + assert (not (Hashtbl.mem typ_table name)); + let sym = Ctx.mk_symbol ~name (typ :> typ) in + Hashtbl.add typ_table name typ; + Hashtbl.add sym_table name sym; + Hashtbl.add rev_sym_table sym name + + let pp = Format.pp_print_string + let show x = x + let typ = Hashtbl.find typ_table + let compare = Stdlib.compare + let symbol_of = Hashtbl.find sym_table + let of_symbol sym = + if Hashtbl.mem rev_sym_table sym then + Some (Hashtbl.find rev_sym_table sym) + else + None + let is_global _ = true +end +module T = Transition.Make(Ctx)(V) +module NITP = NewtonBackwards(Ctx)(V)(T) + +let () = + T.domain := Iteration.split (!T.domain) + +let () = + V.register_var "i" `TyInt; + V.register_var "j" `TyInt; + V.register_var "k" `TyInt; + V.register_var "n" `TyInt; + V.register_var "x" `TyInt; + V.register_var "y" `TyInt; + V.register_var "z" `TyInt + +let x = Ctx.mk_const (V.symbol_of "x") +let y = Ctx.mk_const (V.symbol_of "y") +let z = Ctx.mk_const (V.symbol_of "z") +let i = Ctx.mk_const (V.symbol_of "i") +let j = Ctx.mk_const (V.symbol_of "j") +let k = Ctx.mk_const (V.symbol_of "k") +let n = Ctx.mk_const (V.symbol_of "n") + +let assert_post tr phi = + let not_post = + rewrite srk ~down:(pos_rewriter srk) (Ctx.mk_not phi) + in + let pathcond = + T.guard (T.mul tr (T.assume not_post)) + in + if Wedge.is_sat srk pathcond != `Unsat then + assert_failure (Printf.sprintf "%s\n is not a post-condition of\n%s" + (Formula.show srk phi) + (T.show tr)) + +let assert_equal_tr = assert_equal ~cmp:T.equal ~printer:T.show + +let mk_block = BatList.reduce T.mul + +let mk_if cond bthen belse = + T.add + (mk_block ((T.assume cond)::bthen)) + (mk_block ((T.assume (Ctx.mk_not cond))::belse)) + +let mk_while cond body = + T.mul + (T.star (mk_block ((T.assume cond)::body))) + (T.assume (Ctx.mk_not cond)) + +let assert_valid pre tr post = + if (T.valid_triple pre [tr] post) != `Valid then + assert_failure (Printf.sprintf "Invalid Hoare triple: {%s} %s {%s}" + (Formula.show srk pre) + (T.show tr) + (Formula.show srk post)) + + +let check_interpolant path itp = + let rec go path itp = + match path, itp with + | tr::path, pre::post::itp -> + assert_valid pre tr post; + go path (post::itp) + | [], [_] -> () + | _, _ -> assert false + in + go path (Ctx.mk_true::itp) + +let interpolate1 () = + let path = + let open Infix in + [T.assign "x" (int 0); + T.assign "y" (int 0); + T.assume (x < (int 10)); + T.assign "x" (x + (int 1)); + T.assign "y" (y + (int 1)); + T.assume ((int 10) <= x); + T.assume ((int 10) < x || x < (int 10))] + in + let post = Ctx.mk_false in + match NITP.interpolate path post with + | `Valid itp -> + check_interpolant path itp + | _ -> assert_failure "Invalid post-condition" + +let interpolate2 () = + let path = + let open Infix in + [T.assume (x < (int 10)); + T.assign "x" (x + (int 1)); + T.assign "y" (y + (int 1)); + T.assume ((int 10) <= x); + T.assume ((int 10) < x || x < (int 10))] + in + let post = Ctx.mk_false in + match NITP.interpolate path post with + | `Valid itp -> + check_interpolant path itp + | _ -> assert_failure "Invalid post-condition" + +let interpolate_havoc () = + let path = + let open Infix in + [T.assign "x" (int 0); + T.assign "y" v; (* havoc *) + T.assume (x <= y); + T.assume (y < (int 0))] + in + let post = Ctx.mk_false in + match NITP.interpolate path post with + | `Valid itp -> + check_interpolant path itp + | _ -> assert_failure "Invalid post-condition" + +let suite = "Newton_interpolant" >::: [ + "interpolate1" >:: interpolate1; + "interpolate2" >:: interpolate2; + "interpolate_havoc" >:: interpolate_havoc; + ] diff --git a/srk/test/test_srk.ml b/srk/test/test_srk.ml index 71daec76..219953f0 100644 --- a/srk/test/test_srk.ml +++ b/srk/test/test_srk.ml @@ -26,6 +26,7 @@ let suite = "Main" >::: [ Test_iteration.suite; Test_termination.suite; Test_transition.suite; + Test_newton_interpolant.suite; Test_WeightedGraph.suite; Test_chc.suite; Test_numberField.suite; diff --git a/srk/test/test_transition.ml b/srk/test/test_transition.ml index 8949ef75..28991b0a 100644 --- a/srk/test/test_transition.ml +++ b/srk/test/test_transition.ml @@ -255,70 +255,6 @@ let equal1 () = in assert_equal_tr tr1 tr2 -let assert_valid pre tr post = - if (T.valid_triple pre [tr] post) != `Valid then - assert_failure (Printf.sprintf "Invalid Hoare triple: {%s} %s {%s}" - (Formula.show srk pre) - (T.show tr) - (Formula.show srk post)) - -let check_interpolant path itp = - let rec go path itp = - match path, itp with - | tr::path, pre::post::itp -> - assert_valid pre tr post; - go path (post::itp) - | [], [_] -> () - | _, _ -> assert false - in - go path (Ctx.mk_true::itp) - -let interpolate1 () = - let path = - let open Infix in - [T.assign "x" (int 0); - T.assign "y" (int 0); - T.assume (x < (int 10)); - T.assign "x" (x + (int 1)); - T.assign "y" (y + (int 1)); - T.assume ((int 10) <= x); - T.assume ((int 10) < x || x < (int 10))] - in - let post = Ctx.mk_false in - match T.interpolate path post with - | `Valid itp -> - check_interpolant path itp - | _ -> assert_failure "Invalid post-condition" - -let interpolate2 () = - let path = - let open Infix in - [T.assume (x < (int 10)); - T.assign "x" (x + (int 1)); - T.assign "y" (y + (int 1)); - T.assume ((int 10) <= x); - T.assume ((int 10) < x || x < (int 10))] - in - let post = Ctx.mk_false in - match T.interpolate path post with - | `Valid itp -> - check_interpolant path itp - | _ -> assert_failure "Invalid post-condition" - -let interpolate_havoc () = - let path = - let open Infix in - [T.assign "x" (int 0); - T.assign "y" v; (* havoc *) - T.assume (x <= y); - T.assume (y < (int 0))] - in - let post = Ctx.mk_false in - match T.interpolate path post with - | `Valid itp -> - check_interpolant path itp - | _ -> assert_failure "Invalid post-condition" - let negative_eigenvalue () = let tr = let open Infix in @@ -347,8 +283,5 @@ let suite = "Transition" >::: [ "split" >:: split; "split2" >:: split2; "equal1" >:: equal1; - "interpolate1" >:: interpolate1; - "interpolate2" >:: interpolate2; - "interpolate_havoc" >:: interpolate_havoc; "negative_eigenvalue" >:: negative_eigenvalue; ] From d57a2bf1f02b5ba322c7741f8018d44dccff966d Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Mon, 28 Jul 2025 23:22:18 -0400 Subject: [PATCH 55/59] future- and past-variables analysis --- srk/src/newtonInterpolant.ml | 43 +++++++++++++++++++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/srk/src/newtonInterpolant.ml b/srk/src/newtonInterpolant.ml index 66580e31..e302bd94 100644 --- a/srk/src/newtonInterpolant.ml +++ b/srk/src/newtonInterpolant.ml @@ -75,7 +75,11 @@ module NewtonBackwards : Interpolant = functor (C: sig let is_future_live x trs = if trs = [] then false else begin - (* acc is a pair of booleans, acc_0 means *) + (* In srk, havocs are writes, so suffices to detect writes only. + Logic: Scan the transitions from right-to-left, + - if tr_j reads x, then switch to verify that all transitions left of tr_j does not write to x. + - if some tr_k writes to x, then we need to re-find some j if has_been_read then begin if has_been_written then begin @@ -102,6 +106,43 @@ module NewtonBackwards : Interpolant = functor (C: sig ) ([], []) (List.rev trs) in live_vars + (** figure out set of variables with non-deterministic right-hand-side expressions in [tr]. *) + let havoc_vars tr = + let transform = T.transform tr in + BatEnum.fold (fun curr (v, term) -> + if (Syntax.symbols term + |> Symbol.Set.filter (fun x -> V.of_symbol x = None) (* every skolem symbol is non-deterministic. *) + |> Symbol.Set.cardinal) > 0 then + curr (* variable v is deterministically assigned *) + else + v :: curr (* variable v is assigned a non-det expression *) + ) [] transform + + + (** test whether a variable [x] is past-live w.r.t. past transitions [trs]. *) + let is_past_live x trs = + let used x tr = List.mem x (T.uses tr) || List.mem x (T.defines tr) in + let havoced x tr = List.mem x (havoc_vars tr) in + if trs = [] then false else begin + (* A simpler definition of past-variable is if a variable x is + (1) used and (2) never havoc'ed beyond some point j in [trs]. + *) + let state = List.fold_left (fun (been_used, been_havoced) tr -> + if been_used then begin + if been_havoced then begin + if (used x tr) && not(havoced x tr) then (been_used, false) + else (been_used, been_havoced) + end else + (been_used, havoced x tr) + end else begin + (used x tr, false) + end + ) (false, false) trs in + match state with + | (true, false) -> true + | _ -> false + end + let interpolate trs post = (* The following step ensures all Skolem constants in [trs] are unique. *) From f20272f72ffeb6ba02fcfa86047e395907f29f1f Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Tue, 29 Jul 2025 00:45:26 -0400 Subject: [PATCH 56/59] past-live analysis code --- srk/src/newtonInterpolant.ml | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/srk/src/newtonInterpolant.ml b/srk/src/newtonInterpolant.ml index e302bd94..e4c71d14 100644 --- a/srk/src/newtonInterpolant.ml +++ b/srk/src/newtonInterpolant.ml @@ -142,7 +142,14 @@ module NewtonBackwards : Interpolant = functor (C: sig | (true, false) -> true | _ -> false end - + + let past_live_analysis trs = + let live_vars, _ = + List.fold_left (fun (acc, trs') tr -> + let vars = List.map (fun (x, _) -> x) (T.state_vocabulary tr) in + (List.filter (fun x -> is_past_live x trs') vars :: acc, tr :: trs') + ) ([], []) trs in + live_vars let interpolate trs post = (* The following step ensures all Skolem constants in [trs] are unique. *) From efd27696506f34eb7b06aa922e14c031f31ac4a7 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 7 Aug 2025 11:30:19 -0500 Subject: [PATCH 57/59] fix generate_test --- duet/gps.ml | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/duet/gps.ml b/duet/gps.ml index 4683de91..4bd7a49b 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -248,6 +248,25 @@ module GPS = struct module ReachTree = ReachTree.ART(Graph)(Label)(Transition) let generate_test art node = + let post = Ctx.mk_not (K.guard (ReachTree.path_to_error art node)) in + let rec get_path rest node = + match ReachTree.parent_weight art node with + | Some (p, weight) -> get_path (weight::rest) p + | None -> rest + in + let path = get_path [] node in + match K.interpolate_or_concrete_model ((K.assume @@ ReachTree.get_precondition art) :: path) post with + | `Invalid v_model -> + logf ~level:`trace "-> found test"; + `Test v_model + | `Unknown -> failwith "generate_test: got UNKNOWN as a result for interpolate_or_get_model" + | `Valid interpolants -> + logf ~level:`trace "-> pruned"; + log_formulas "interpolants - " interpolants; + `Pruned (interpolants) + + (* RF: this is unused for now, delete fully once I test out the function above *) + let generate_test' art node = logf "Generating test @ %a\n" ReachTree.pp_node node; let post = if !enable_summary then @@ -286,6 +305,8 @@ module GPS = struct | `Pruned (interpolants) -> if !enable_refinement then begin (* refinement *) + logf ~level:`trace " * refinement: path length %d\n" (List.length (ReachTree.tree_path art u)); + logf ~level:`trace " * interpolants length: %d\n" (List.length interpolants); ReachTree.refine art (ReachTree.tree_path art u) interpolants; (* for every node along path of refinement try close *) List.iter (fun v -> ignore (ReachTree.close art v)) (ReachTree.tree_path art u); From 064eadc558e7d22226a7f4001fa4cfc5d9989180 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 7 Aug 2025 11:37:34 -0500 Subject: [PATCH 58/59] more fixes --- duet/gps.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/duet/gps.ml b/duet/gps.ml index 4bd7a49b..91e425bc 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -255,6 +255,7 @@ module GPS = struct | None -> rest in let path = get_path [] node in + num_tests_generated := !num_tests_generated + 1; match K.interpolate_or_concrete_model ((K.assume @@ ReachTree.get_precondition art) :: path) post with | `Invalid v_model -> logf ~level:`trace "-> found test"; From ac22c76d1c20b7b573c5bb4365da0fbd7ce89387 Mon Sep 17 00:00:00 2001 From: Ruijie Fang Date: Thu, 7 Aug 2025 22:40:37 -0400 Subject: [PATCH 59/59] add new stats --- duet/gps.ml | 29 ++++++++--------------------- 1 file changed, 8 insertions(+), 21 deletions(-) diff --git a/duet/gps.ml b/duet/gps.ml index 91e425bc..355e89c7 100644 --- a/duet/gps.ml +++ b/duet/gps.ml @@ -17,8 +17,11 @@ let enable_acceleration = ref true let enable_ts_simplify = ref true let print_stats = ref false +let num_check_calls = ref 0 let num_tests_generated = ref 0 +let num_interpolants_generated = ref 0 + module ProcName = struct type t = int * int @@ -255,37 +258,19 @@ module GPS = struct | None -> rest in let path = get_path [] node in - num_tests_generated := !num_tests_generated + 1; + num_check_calls := !num_check_calls + 1; match K.interpolate_or_concrete_model ((K.assume @@ ReachTree.get_precondition art) :: path) post with | `Invalid v_model -> logf ~level:`trace "-> found test"; + num_tests_generated := !num_tests_generated + 1; `Test v_model | `Unknown -> failwith "generate_test: got UNKNOWN as a result for interpolate_or_get_model" | `Valid interpolants -> + num_interpolants_generated := !num_interpolants_generated + 1; logf ~level:`trace "-> pruned"; log_formulas "interpolants - " interpolants; `Pruned (interpolants) - (* RF: this is unused for now, delete fully once I test out the function above *) - let generate_test' art node = - logf "Generating test @ %a\n" ReachTree.pp_node node; - let post = - if !enable_summary then - Ctx.mk_not (K.guard (ReachTree.path_to_error art node)) - else - mk_true () - in - let rec path_weight v = - match ReachTree.parent_weight art v with - | Some (parent, w) -> K.mul (path_weight parent) w - | None -> K.one - in - num_tests_generated := !num_tests_generated + 1; - match K.interpolate_or_concrete_model [path_weight node] post with - | `Invalid v_model -> `Test v_model - | `Unknown -> failwith "GPS.generate_test: got UNKNOWN as a result for interpolate_or_get_model" - | `Valid interpolants -> `Pruned (interpolants) - let gps graph src dst = let art = ReachTree.make graph Ctx.mk_true ~src ~dst in let rec loop () = @@ -356,7 +341,9 @@ let analyze_mc file = if !print_stats then begin let statistics = GPS.ReachTree.get_statistics art in Printf.printf " Statistics\n"; + Printf.printf " Number of check calls: %d\n" !num_check_calls; Printf.printf " Number of tests generated: %d\n" !num_tests_generated; + Printf.printf " Number of dead-end-interpolants generated: %d\n" !num_interpolants_generated; Printf.printf " Number of refinements performed: %d\n" statistics.num_refinements_performed; Printf.printf " Number of coverings added: %d\n" statistics.num_covers_added; Printf.printf " Number of coverings removed: %d\n" statistics.num_covers_removed