From db25a27f39904603b798f31f354a096919a5e092 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Wed, 8 Jul 2026 14:54:02 +1000 Subject: [PATCH 01/67] Rebased --- nix/shell.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nix/shell.nix b/nix/shell.nix index 381d54dfe..5908d05c3 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -54,7 +54,7 @@ mkShell { ++ lib.optional stdenv.hostPlatform.isLinux perf; inputsFrom = [ - (bincaml.overrideAttrs { doCheck = true; }) + (bincaml.overrideAttrs { doCheck = false; }) ]; shellHook = '' From dd2f616931209c0fed366e0e1ae4267efb138112 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Wed, 8 Jul 2026 11:08:38 +1000 Subject: [PATCH 02/67] undoing a debugging change --- nix/shell.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nix/shell.nix b/nix/shell.nix index 5908d05c3..381d54dfe 100644 --- a/nix/shell.nix +++ b/nix/shell.nix @@ -54,7 +54,7 @@ mkShell { ++ lib.optional stdenv.hostPlatform.isLinux perf; inputsFrom = [ - (bincaml.overrideAttrs { doCheck = false; }) + (bincaml.overrideAttrs { doCheck = true; }) ]; shellHook = '' From af430d1361893a0cf76f54bcf909a1122653293c Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Wed, 8 Jul 2026 15:41:30 +1000 Subject: [PATCH 03/67] Reduction is working --- lib/transforms/cfa_reduction.ml | 22 ++++++---------------- 1 file changed, 6 insertions(+), 16 deletions(-) diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index 951907e9b..e4b5930fa 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -87,29 +87,19 @@ let construct_final_edge proc = 2. the statements for the new edge body. 3. an assignment to the termination variable. *) - CCVector.push final_edge ites; - CCVector.append_list final_edge non_guard_stmts; - CCVector.push final_edge termination; - final_edge) - (CCVector.create ()) proc - |> CCVector.freeze + final_edge + @ List.concat [ [ ites ]; block.stmts |> Vector.to_list; [ termination ] ]) + List.empty proc let reduce_procedure (proc : Program.proc) : Program.proc = (* Constructed reduced edge to replace procedure blocks. *) let final_edge = construct_final_edge proc in - let proc = - proc |> Procedure.iter_blocks |> Iter.map fst - |> Iter.fold (fun acc id -> Procedure.remove_block acc id) proc - in - let proc, id = Procedure.fresh_block proc ~stmts:[] () in - let proc = - Procedure.modify_block proc id (fun b -> { b with stmts = final_edge }) - in + let out_proc, id = Procedure.fresh_block proc ~stmts:final_edge () in (* Make this the entry and return block. *) - let proc = Procedure.set_entry_block proc id in + let out_proc = Procedure.set_entry_block out_proc id in Procedure.PG.map_graph (fun g -> Procedure.G.add_edge g (Procedure.Vert.End id) Procedure.Vert.Return) - proc + out_proc From 7e78697be85013953556f732986861382d108f2a Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Wed, 8 Jul 2026 15:56:21 +1000 Subject: [PATCH 04/67] Clean up the graph to prevent errors --- lib/transforms/cfa_reduction.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index e4b5930fa..0b1dddd0d 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -95,7 +95,11 @@ let reduce_procedure (proc : Program.proc) : Program.proc = (* Constructed reduced edge to replace procedure blocks. *) let final_edge = construct_final_edge proc in - let out_proc, id = Procedure.fresh_block proc ~stmts:final_edge () in + let out_proc = + proc |> Procedure.iter_blocks |> Iter.map fst + |> Iter.fold (fun acc id -> Procedure.remove_block acc id) proc + in + let out_proc, id = Procedure.fresh_block out_proc ~stmts:final_edge () in (* Make this the entry and return block. *) let out_proc = Procedure.set_entry_block out_proc id in From 7a921f8770f55c58cea144e4d971cc464876155f Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Wed, 8 Jul 2026 16:02:32 +1000 Subject: [PATCH 05/67] cram promotion --- test/cram/cfa_reduction.t | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/cram/cfa_reduction.t b/test/cram/cfa_reduction.t index 8e8dda7b8..a7fd24ac8 100644 --- a/test/cram/cfa_reduction.t +++ b/test/cram/cfa_reduction.t @@ -11,6 +11,8 @@ [ block %block [ var v:bool := true; + guard bvult(a:bv64, 0x0:bv64); + guard boolnot(bvult(a:bv64, 0x0:bv64)); var v_2:bool := booland(v:bool, boolnot(bvult(a:bv64, 0x0:bv64))); var x_6:bv64 := if v_2:bool then bvadd(a:bv64, 0x1:bv64) else bvsub(a:bv64, 0x1:bv64); From 94407a519391971997bf0692e98ec7422444933b Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Wed, 8 Jul 2026 16:18:53 +1000 Subject: [PATCH 06/67] simplify removed --- test/cram/cfa_reduction.sexp | 2 +- test/cram/cfa_reduction.t | 22 +++++++++++++++------- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/test/cram/cfa_reduction.sexp b/test/cram/cfa_reduction.sexp index 02b038d77..f9ef09af3 100644 --- a/test/cram/cfa_reduction.sexp +++ b/test/cram/cfa_reduction.sexp @@ -1,5 +1,5 @@ (load-il "./cfa_reduction.il") (run-transforms "ssa") (run-transforms "cfa-reduction") -(run-transforms "simplify") +; (run-transforms "simplify") (dump-il "./out.il") diff --git a/test/cram/cfa_reduction.t b/test/cram/cfa_reduction.t index a7fd24ac8..4891c20d9 100644 --- a/test/cram/cfa_reduction.t +++ b/test/cram/cfa_reduction.t @@ -2,7 +2,6 @@ (load-il ./cfa_reduction.il) (run-transforms ssa) (run-transforms cfa-reduction) - (run-transforms simplify) (dump-il ./out.il) $ cat ./out.il proc @f1(a:bv64) -> (c:bv64) { } @@ -10,13 +9,22 @@ [ block %block [ - var v:bool := true; - guard bvult(a:bv64, 0x0:bv64); - guard boolnot(bvult(a:bv64, 0x0:bv64)); - var v_2:bool := booland(v:bool, boolnot(bvult(a:bv64, 0x0:bv64))); - var x_6:bv64 := if v_2:bool then bvadd(a:bv64, 0x1:bv64) else bvsub(a:bv64, - 0x1:bv64); + nop; + var x_1:bv64 := a:bv64; + var v:bool := booland(true); + nop; + var x_2:bv64 := x_1:bv64; + guard bvult(x_2:bv64, 0x0:bv64); + var x_3:bv64 := bvsub(x_2:bv64, 0x1:bv64); + var v_1:bool := booland(boolor(v:bool), bvult(x_2:bv64, 0x0:bv64)); + nop; + var x_4:bv64 := x_1:bv64; + guard boolnot(bvult(x_4:bv64, 0x0:bv64)); + var x_5:bv64 := bvadd(x_4:bv64, 0x1:bv64); + var v_2:bool := booland(boolor(v:bool), boolnot(bvult(x_4:bv64, 0x0:bv64))); + var x_6:bv64 := if v_2:bool then x_5:bv64 else x_3:bv64; var c:bv64 := x_6:bv64; + var v_3:bool := booland(boolor(v_2:bool, v_1:bool)); return; ] ]; From 2fec26dd0e3fa91b47f705b10fd3c8367f351e96 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Wed, 8 Jul 2026 16:25:49 +1000 Subject: [PATCH 07/67] filter out guards --- lib/transforms/cfa_reduction.ml | 14 +++++++++++++- test/cram/cfa_reduction.sexp | 2 +- test/cram/cfa_reduction.t | 20 +++++--------------- 3 files changed, 19 insertions(+), 17 deletions(-) diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index 0b1dddd0d..3e691c3ac 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -88,7 +88,19 @@ let construct_final_edge proc = 3. an assignment to the termination variable. *) final_edge - @ List.concat [ [ ites ]; block.stmts |> Vector.to_list; [ termination ] ]) + @ List.concat + [ + [ ites ]; + (* Filter out the now unnecessary guards. *) + block.stmts |> Vector.to_list + |> List.filter (fun s -> + not + @@ + match s with + | Stmt.Instr_Assume { branch = true } -> true + | _ -> false); + [ termination ]; + ]) List.empty proc let reduce_procedure (proc : Program.proc) : Program.proc = diff --git a/test/cram/cfa_reduction.sexp b/test/cram/cfa_reduction.sexp index f9ef09af3..02b038d77 100644 --- a/test/cram/cfa_reduction.sexp +++ b/test/cram/cfa_reduction.sexp @@ -1,5 +1,5 @@ (load-il "./cfa_reduction.il") (run-transforms "ssa") (run-transforms "cfa-reduction") -; (run-transforms "simplify") +(run-transforms "simplify") (dump-il "./out.il") diff --git a/test/cram/cfa_reduction.t b/test/cram/cfa_reduction.t index 4891c20d9..8e8dda7b8 100644 --- a/test/cram/cfa_reduction.t +++ b/test/cram/cfa_reduction.t @@ -2,6 +2,7 @@ (load-il ./cfa_reduction.il) (run-transforms ssa) (run-transforms cfa-reduction) + (run-transforms simplify) (dump-il ./out.il) $ cat ./out.il proc @f1(a:bv64) -> (c:bv64) { } @@ -9,22 +10,11 @@ [ block %block [ - nop; - var x_1:bv64 := a:bv64; - var v:bool := booland(true); - nop; - var x_2:bv64 := x_1:bv64; - guard bvult(x_2:bv64, 0x0:bv64); - var x_3:bv64 := bvsub(x_2:bv64, 0x1:bv64); - var v_1:bool := booland(boolor(v:bool), bvult(x_2:bv64, 0x0:bv64)); - nop; - var x_4:bv64 := x_1:bv64; - guard boolnot(bvult(x_4:bv64, 0x0:bv64)); - var x_5:bv64 := bvadd(x_4:bv64, 0x1:bv64); - var v_2:bool := booland(boolor(v:bool), boolnot(bvult(x_4:bv64, 0x0:bv64))); - var x_6:bv64 := if v_2:bool then x_5:bv64 else x_3:bv64; + var v:bool := true; + var v_2:bool := booland(v:bool, boolnot(bvult(a:bv64, 0x0:bv64))); + var x_6:bv64 := if v_2:bool then bvadd(a:bv64, 0x1:bv64) else bvsub(a:bv64, + 0x1:bv64); var c:bv64 := x_6:bv64; - var v_3:bool := booland(boolor(v_2:bool, v_1:bool)); return; ] ]; From 4e58290a4b110e622f3cdfbdd78411dc6b803591 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 21 Jul 2026 15:40:40 +1000 Subject: [PATCH 08/67] cleanup --- lib/transforms/cfa_reduction.ml | 25 ++++++------------------- 1 file changed, 6 insertions(+), 19 deletions(-) diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index 3e691c3ac..4b2f5a84b 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -87,35 +87,22 @@ let construct_final_edge proc = 2. the statements for the new edge body. 3. an assignment to the termination variable. *) - final_edge - @ List.concat - [ - [ ites ]; - (* Filter out the now unnecessary guards. *) - block.stmts |> Vector.to_list - |> List.filter (fun s -> - not - @@ - match s with - | Stmt.Instr_Assume { branch = true } -> true - | _ -> false); - [ termination ]; - ]) - List.empty proc + final_edge @ List.concat [ [ ites ]; non_guard_stmts; [ termination ] ]) + [] proc let reduce_procedure (proc : Program.proc) : Program.proc = (* Constructed reduced edge to replace procedure blocks. *) let final_edge = construct_final_edge proc in - let out_proc = + let proc = proc |> Procedure.iter_blocks |> Iter.map fst |> Iter.fold (fun acc id -> Procedure.remove_block acc id) proc in - let out_proc, id = Procedure.fresh_block out_proc ~stmts:final_edge () in + let proc, id = Procedure.fresh_block proc ~stmts:final_edge () in (* Make this the entry and return block. *) - let out_proc = Procedure.set_entry_block out_proc id in + let proc = Procedure.set_entry_block proc id in Procedure.PG.map_graph (fun g -> Procedure.G.add_edge g (Procedure.Vert.End id) Procedure.Vert.Return) - out_proc + proc From e9eaafc66ad88e09056cfada34e6d3c300f09f15 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 21 Jul 2026 15:51:33 +1000 Subject: [PATCH 09/67] Some more documenting --- lib/transforms/cfa_reduction.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index 4b2f5a84b..c2fe97442 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -15,12 +15,15 @@ open Expr let construct_final_edge proc = (* Termination condition for each edge. *) - let termination_condition : (ID.t, Var.t) Hashtbl.t = Hashtbl.create 30 in + let termination_condition : (IDSet.elt, Var.t) Hashtbl.t = + Hashtbl.create 30 + in (* final_edge accumulates as one large edge containing all statements from existing edges with additional predicate variables and ite statements/assignments - filling in for phi-nodes. *) + filling in for phi-nodes. + *) Procedure.fold_blocks_topo_fwd (fun final_edge id block -> (* Compute reachability of this block. *) From 38dc7a9a0db3deed100c178886ba5ae2b57af6c1 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 21 Jul 2026 14:40:57 +1000 Subject: [PATCH 10/67] smt backend skeleton --- bin/main.ml | 10 ++++++ lib/backends/dune | 2 +- lib/backends/smt.ml | 85 ++++++++++++++++++++++++++++++++++++++++++++ lib/lang/expr_smt.ml | 38 ++++++++++++++++++-- lib/passes.ml | 14 +++++++- lib/script.ml | 11 ++++++ 6 files changed, 155 insertions(+), 5 deletions(-) create mode 100644 lib/backends/smt.ml diff --git a/bin/main.ml b/bin/main.ml index 561443a4e..6de87f140 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -167,6 +167,16 @@ let repl ~verb ~echo_cmd = |> Iter.flat_map complete_filename |> Iter.map (fun s -> l ^ " " ^ s) |> Iter.iter (LNoise.add_completion completions) + | Ok (`Atom "dump-smt" :: fnames as l) -> + let c = last fnames in + let l = + List.take (List.length l - opt_len c) l + |> List.to_string ~sep:" " CCSexp.to_string + in + (match c with Some n -> Iter.singleton n | None -> Iter.empty) + |> Iter.flat_map complete_filename + |> Iter.map (fun s -> l ^ " " ^ s) + |> Iter.iter (LNoise.add_completion completions) | Ok (`Atom "run-transforms" :: transforms as l) | Ok (`Atom "run-transform" :: transforms as l) -> let c = last transforms in diff --git a/lib/backends/dune b/lib/backends/dune index fa1e6fb21..eb60c6700 100644 --- a/lib/backends/dune +++ b/lib/backends/dune @@ -1,5 +1,5 @@ (library (public_name bincaml.backends) (name backends) - (modules boogie) + (modules boogie smt) (libraries containers containers-data containers.pp lang transforms)) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml new file mode 100644 index 000000000..38a6d8547 --- /dev/null +++ b/lib/backends/smt.ml @@ -0,0 +1,85 @@ +open Lang +open Lang.Common +open Bincaml_util.Common +open Bincaml_util +(* open Containers *) + +(* Takes a procedure that has been reduced to a single edge. + Maps each statement to an smt expression. *) +let proc_to_smt (proc : Program.proc) : Smt.sexp list = + let builder = Expr_smt.SMTLib2.empty in + + (* Generate a declaration for each local var. *) + let local_decls = Procedure.local_decls proc in + let builder = + Hashtbl.to_iter local_decls + |> Iter.fold + (fun acc (k, v) -> snd @@ Expr_smt.SMTLib2.decl_var v acc) + builder + in + + let builder = snd @@ Expr_smt.SMTLib2.push builder in + let builder = snd @@ Expr_smt.SMTLib2.pop builder in + + let builder = + Procedure.iter_stmt_topo_fwd proc + |> Iter.fold + (fun acc stmt -> + match stmt with + | Stmt.Instr_Assert { body } -> + let smt = + Expr_smt.SMTLib2.of_bexpr (Expr.BasilExpr.boolnot body) + in + Expr_smt.SMTLib2.add_assert smt acc |> snd + (* | Stmt.Instr_Assume { body } -> *) + (* let smt = Expr_smt.SMTLib2.of_bexpr body in *) + (* Expr_smt.SMTLib2.add_assert smt acc |> snd *) + | Stmt.Instr_Assign { al } -> + let asserts = + List.map + (fun (v, e) -> + Expr.BasilExpr.binexp ~op:`EQ (Expr.BasilExpr.rvar v) e + |> Expr_smt.SMTLib2.of_bexpr) + al + in + List.fold_left + (fun acc smt -> Expr_smt.SMTLib2.add_assert smt acc |> snd) + acc asserts + | _ -> acc) + builder + in + let builder = snd @@ Expr_smt.SMTLib2.check_sat builder in + Expr_smt.SMTLib2.to_sexp builder |> Iter.to_list + +let pretty_procedure (p : Program.proc) = + let open Containers_pp in + let smts = proc_to_smt p in + append_nl (smts |> List.map (CCSexp.to_string %> text)) + +let pretty_declaration (d : Program.declaration) = + let open Containers_pp in + let open Containers_pp.Infix in + match d with + | Procedure { definition } -> pretty_procedure definition + | _ -> failwith "Unsupported SMT declaration" + +let pretty_program (p : Program.t) = + let open Containers_pp in + let glob_vars_funs, rest = + Program.declarations p |> Iter.map snd |> Iter.to_list + |> List.partition_filter_map (fun d -> + let p = pretty_declaration d in + match d with + | Program.Variable _ | Program.Function _ | Program.Type _ -> `Left p + | _ -> `Right p) + in + let glob_vars = append_nl glob_vars_funs in + let rest = append_nl rest in + append_l ~sep:(newline ^ newline) [ glob_vars; rest ] + +let pretty_to_chan chan (p : Program.t) = + let p = pretty_program p in + flush chan; + let fmt = Format.formatter_of_out_channel chan in + Containers_pp.Pretty.to_format ~width:80 fmt p; + Format.flush fmt () diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index e51b03783..0d839200b 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -357,6 +357,11 @@ module SMTLib2 = struct | `MapAccess -> atom "select" | `MapUpdate -> atom "store" | `IMPLIES -> atom "=>" + | `INTADD -> atom "+" + | `INTMUL -> atom "*" + | `INTSUB -> atom "-" + | `INTDIV -> atom "/" + | `INTLT -> atom "<" | #Ops.AllOps.unary as o -> atom @@ Ops.AllOps.to_string o | #Ops.AllOps.const as o -> atom @@ Ops.AllOps.to_string o | #Ops.AllOps.binary as o -> atom @@ Ops.AllOps.to_string o @@ -378,7 +383,8 @@ module SMTLib2 = struct let* body = in_body in return @@ list [ quant; list binds; body ] - let smt_alg (e : sexp t BasilExpr.abstract_expr) = + let smt_alg' (e : sexp t BasilExpr.abstract_expr) + (inner : sexp t BasilExpr.abstract_expr BasilExpr.abstract_expr) = match e with | Constant { const = o } -> let* o = add_logic_const o in @@ -437,6 +443,24 @@ module SMTLib2 = struct let* l = l in let* r = r in return @@ list [ of_op o; l; r ] + | ApplyIntrin { op = `Cases; args } -> ( + match (inner, args) with + (* ITE Expressions are special. + They cannot be represented using an smt match which + expects a datatype not a bool. So we have to + identify an ITE and handle it specially. *) + | ( ApplyIntrin + { + op = `Cases; + args = [ BinaryExpr { op = `IfThen; arg1; arg2 }; _ ]; + }, + [ _; arg3 ] ) -> + let* arg1 = arg1 in + let* arg2 = arg2 in + let* arg3 = arg3 in + return @@ list [ atom "ite"; arg1; arg2; arg3 ] + (* TODO actual matches. *) + | _ -> failwith "Match expressions unsupported.") | ApplyIntrin { op = o; args } -> let* args = sequence args in return (list (of_op o :: args)) @@ -446,9 +470,17 @@ module SMTLib2 = struct let* func = func in return @@ list (func :: args) - let bind_of_bexpr e b = + let smt_alg + (e : (sexp t * sexp t BasilExpr.abstract_expr) BasilExpr.abstract_expr) : + sexp t * sexp t BasilExpr.abstract_expr = + let l = AbstractExpr.map fst e in + let r = AbstractExpr.map snd e in + let o = smt_alg' l r in + (o, l) + + let bind_of_bexpr e = let e = (BasilExpr.rewrite_typed_two Algsimp.drop_assoc) e in - BasilExpr.cata smt_alg e b + BasilExpr.cata smt_alg e |> fst let of_bexpr e = fst @@ (bind_of_bexpr e) empty diff --git a/lib/passes.ml b/lib/passes.ml index f8d787cd0..11ee9e9e1 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -56,6 +56,18 @@ module PassManager = struct prog); } + let dump_smt out_channel = + { + name = "dump-smt"; + doc = "write smt to channel"; + invariants = Invariants.make ~presupposes:[ SSA; NoPhis ] (); + apply = + Prog + (fun prog -> + Backends.Smt.pretty_to_chan out_channel prog; + prog); + } + let lift_intrinsics_aarch64 = { name = "lift-intrinsics-aarch64"; @@ -220,7 +232,7 @@ module PassManager = struct name = "cfa-reduction"; apply = Proc Transforms.Cfa_reduction.reduce_procedure; doc = "Performs reduction of acyclic CFA"; - invariants = Invariants.presupposes [ SSA ]; + invariants = Invariants.presupposes [ SSA ] ~establishes:[ NoPhis; SSA ]; } let remove_unreachable_blocks = diff --git a/lib/script.ml b/lib/script.ml index 0307115ac..e5fc118d4 100644 --- a/lib/script.ml +++ b/lib/script.ml @@ -153,6 +153,16 @@ let dump_boogie st ofile = in set_prog st prog) +let dump_smt st ofile = + let ofile = P.(opt string ofile) in + file_opt ofile (fun c -> + let prog = + Some + (Passes.PassManager.run_transform (get_prog st) + (Passes.PassManager.dump_smt c)) + in + set_prog st prog) + let interp_out st ofile = let ofile = P.(opt string ofile) in let prog = get_prog st in @@ -345,6 +355,7 @@ let cmds_list = ("list-procs", list_procs, "", "List procedures in program"); ("dump-il", dump_il, "?file", "Write IL to file or stdout"); ("dump-boogie", dump_boogie, "?file", "Write Boogie to file or stdout"); + ("dump-smt", dump_smt, "?file", "Write SMT to file or stdout"); ( "chc-dump-clauses", chc_dump_clauses, "", From aeacc5160192084ea9acf08abc9c9ce12e54bd4f Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Wed, 22 Jul 2026 12:37:28 +1000 Subject: [PATCH 11/67] Replaced all the old boogie backend stuff with builders --- lib/backends/smt.ml | 68 ++++++++++++++++++--------------------------- 1 file changed, 27 insertions(+), 41 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 38a6d8547..31675d6ac 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -2,80 +2,66 @@ open Lang open Lang.Common open Bincaml_util.Common open Bincaml_util +open Expr_smt (* open Containers *) (* Takes a procedure that has been reduced to a single edge. Maps each statement to an smt expression. *) -let proc_to_smt (proc : Program.proc) : Smt.sexp list = - let builder = Expr_smt.SMTLib2.empty in +let build_proc (proc : Program.proc) (builder : SMTLib2.builder) : + SMTLib2.builder = + let builder = snd @@ SMTLib2.push builder in (* Generate a declaration for each local var. *) let local_decls = Procedure.local_decls proc in let builder = Hashtbl.to_iter local_decls - |> Iter.fold - (fun acc (k, v) -> snd @@ Expr_smt.SMTLib2.decl_var v acc) - builder + |> Iter.fold (fun acc (k, v) -> snd @@ SMTLib2.decl_var v acc) builder in - let builder = snd @@ Expr_smt.SMTLib2.push builder in - let builder = snd @@ Expr_smt.SMTLib2.pop builder in - let builder = Procedure.iter_stmt_topo_fwd proc |> Iter.fold (fun acc stmt -> match stmt with | Stmt.Instr_Assert { body } -> - let smt = - Expr_smt.SMTLib2.of_bexpr (Expr.BasilExpr.boolnot body) - in - Expr_smt.SMTLib2.add_assert smt acc |> snd - (* | Stmt.Instr_Assume { body } -> *) - (* let smt = Expr_smt.SMTLib2.of_bexpr body in *) - (* Expr_smt.SMTLib2.add_assert smt acc |> snd *) + let smt = SMTLib2.of_bexpr (Expr.BasilExpr.boolnot body) in + SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assign { al } -> let asserts = List.map (fun (v, e) -> Expr.BasilExpr.binexp ~op:`EQ (Expr.BasilExpr.rvar v) e - |> Expr_smt.SMTLib2.of_bexpr) + |> SMTLib2.of_bexpr) al in List.fold_left - (fun acc smt -> Expr_smt.SMTLib2.add_assert smt acc |> snd) + (fun acc smt -> SMTLib2.add_assert smt acc |> snd) acc asserts | _ -> acc) builder in - let builder = snd @@ Expr_smt.SMTLib2.check_sat builder in - Expr_smt.SMTLib2.to_sexp builder |> Iter.to_list + let builder = snd @@ SMTLib2.check_sat builder in + let builder = snd @@ SMTLib2.pop builder in + builder -let pretty_procedure (p : Program.proc) = - let open Containers_pp in - let smts = proc_to_smt p in - append_nl (smts |> List.map (CCSexp.to_string %> text)) - -let pretty_declaration (d : Program.declaration) = - let open Containers_pp in - let open Containers_pp.Infix in - match d with - | Procedure { definition } -> pretty_procedure definition +let build_declaration (declaration : Program.declaration) + (builder : SMTLib2.builder) : SMTLib2.builder = + match declaration with + | Procedure { definition } -> build_proc definition builder | _ -> failwith "Unsupported SMT declaration" -let pretty_program (p : Program.t) = +let build_program (program : Program.t) (builder : SMTLib2.builder) : + SMTLib2.builder = + Program.declarations program + |> Iter.map snd + |> Iter.fold (fun a b -> build_declaration b a) builder + +let pretty_program (program : Program.t) : Containers_pp.t = let open Containers_pp in - let glob_vars_funs, rest = - Program.declarations p |> Iter.map snd |> Iter.to_list - |> List.partition_filter_map (fun d -> - let p = pretty_declaration d in - match d with - | Program.Variable _ | Program.Function _ | Program.Type _ -> `Left p - | _ -> `Right p) - in - let glob_vars = append_nl glob_vars_funs in - let rest = append_nl rest in - append_l ~sep:(newline ^ newline) [ glob_vars; rest ] + let builder = build_program program SMTLib2.empty in + Expr_smt.SMTLib2.to_sexp ~set_logic:true builder + |> Iter.map (Sexp.to_string %> text) + |> Iter.to_list |> append_nl let pretty_to_chan chan (p : Program.t) = let p = pretty_program p in From ea8dbba73e031220839c18954421726993581403 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 24 Jul 2026 13:54:36 +1000 Subject: [PATCH 12/67] Summary inlining --- lib/backends/smt.ml | 5 ++++ lib/invariants.ml | 2 ++ lib/lang/expr_smt.ml | 4 ++- lib/passes.ml | 11 ++++++- lib/transforms/summary_inlining.ml | 48 ++++++++++++++++++++++++++++++ 5 files changed, 68 insertions(+), 2 deletions(-) create mode 100644 lib/transforms/summary_inlining.ml diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 31675d6ac..5936b6308 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -26,6 +26,9 @@ let build_proc (proc : Program.proc) (builder : SMTLib2.builder) : | Stmt.Instr_Assert { body } -> let smt = SMTLib2.of_bexpr (Expr.BasilExpr.boolnot body) in SMTLib2.add_assert smt acc |> snd + | Stmt.Instr_Assume { body } -> + let smt = SMTLib2.of_bexpr (Expr.BasilExpr.boolnot body) in + SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assign { al } -> let asserts = List.map @@ -37,6 +40,8 @@ let build_proc (proc : Program.proc) (builder : SMTLib2.builder) : List.fold_left (fun acc smt -> SMTLib2.add_assert smt acc |> snd) acc asserts + (* | Stmt.Instr_Call { lhs; procid; args } -> *) + (* let assumes = *) | _ -> acc) builder in diff --git a/lib/invariants.ml b/lib/invariants.ml index ca1241406..5b56d3bf0 100644 --- a/lib/invariants.ml +++ b/lib/invariants.ml @@ -13,6 +13,7 @@ type t = | SSA | DSA | NoPhis + | NoCalls | Params | LambdaLift | MemoryEncoding @@ -28,6 +29,7 @@ let read s = | "SSA" -> SSA | "DSA" -> DSA | "NoPhis" -> NoPhis + | "NoCalls" -> NoCalls | "Params" -> Params | "LambdaLift" -> LambdaLift | "ReducibleLoops" -> ReducibleLoops diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 0d839200b..b38d4f56e 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -389,7 +389,9 @@ module SMTLib2 = struct | Constant { const = o } -> let* o = add_logic_const o in return (of_op o) - | RVar { id } -> get_var id + | RVar { id } -> + let* var = get_var id in + return @@ list [atom "as"; var; fst @@ of_typ @@ Var.typ id ] | UnaryExpr { op = `BOOLTOBV1; arg = e } -> let* e = e in return diff --git a/lib/passes.ml b/lib/passes.ml index 11ee9e9e1..78add5d57 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -232,7 +232,15 @@ module PassManager = struct name = "cfa-reduction"; apply = Proc Transforms.Cfa_reduction.reduce_procedure; doc = "Performs reduction of acyclic CFA"; - invariants = Invariants.presupposes [ SSA ] ~establishes:[ NoPhis; SSA ]; + invariants = Invariants.presupposes [ SSA; NoCalls ] ~establishes:[ NoPhis; SSA ]; + } + + let inline_summaries = + { + name = "inline_summaries"; + apply = Prog Transforms.Summary_inlining.transform; + doc = "Replaces procedure calls with asserts/assumes for summaries"; + invariants = Invariants.presupposes [ SSA ] ~establishes:[ NoCalls ]; } let remove_unreachable_blocks = @@ -492,6 +500,7 @@ module PassManager = struct read_uninit true; sssa; cfa_reduction; + inline_summaries; sva; full_ssa; chc_infer_invariants; diff --git a/lib/transforms/summary_inlining.ml b/lib/transforms/summary_inlining.ml new file mode 100644 index 000000000..72c5266d7 --- /dev/null +++ b/lib/transforms/summary_inlining.ml @@ -0,0 +1,48 @@ +open Lang +open Lang.Common +open Expr + +let transform_block (prog : Program.t) (proc : Program.proc) + ((bid, block) : IDSet.elt * Program.bloc) : Program.bloc = + Block.flat_map ~phi:Common.id + ( List.to_iter % function + | Stmt.Instr_Call { attrib; lhs; procid; args } as stmt -> + let subst_var varmap expression = + BasilExpr.substitute + (fun v -> + StringMap.get (Var.name v) varmap |> Option.map BasilExpr.rvar) + expression + in + let subst_expr varmap expression = + BasilExpr.substitute + (fun v -> StringMap.get (Var.name v) varmap) + expression + in + let call_proc = Program.proc prog procid in + let spec = Procedure.specification call_proc in + let requires = + spec.requires + |> List.map (fun e -> + Stmt.Instr_Assert + { attrib = StringMap.empty; body = subst_expr args e }) + in + let ensures = + spec.ensures + |> List.map (fun e -> + Stmt.Instr_Assume + { + attrib = StringMap.empty; + body = subst_var lhs @@ subst_expr args e; + branch = false; + }) + in + requires @ [stmt] @ ensures + | other -> [ other ] ) + block + +let transform_proc (prog : Program.t) (pid : IDSet.elt) (proc : Program.proc) : + Program.proc = + Procedure.map_blocks_nondet (transform_block prog proc) proc + +let transform (prog : Program.t) : Program.t = + Program.map_procedures (transform_proc prog) prog From 5a8875f7581362a017051bd22e08124c0459dfb2 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 24 Jul 2026 14:53:39 +1000 Subject: [PATCH 13/67] Procedure Summaries --- lib/backends/smt.ml | 26 +++++++++++++++++++++----- lib/transforms/cfa_reduction.ml | 2 +- lib/transforms/summary_inlining.ml | 2 +- 3 files changed, 23 insertions(+), 7 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 5936b6308..0755c8567 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -3,6 +3,8 @@ open Lang.Common open Bincaml_util.Common open Bincaml_util open Expr_smt +open Expr + (* open Containers *) (* Takes a procedure that has been reduced to a single edge. @@ -18,33 +20,47 @@ let build_proc (proc : Program.proc) (builder : SMTLib2.builder) : |> Iter.fold (fun acc (k, v) -> snd @@ SMTLib2.decl_var v acc) builder in + (* Need the specification for requires/ensures. *) + let spec = Procedure.specification proc in + let assert_exprs exprs builder = + exprs |> List.fold_left + (fun acc expr -> snd @@ SMTLib2.add_assert (SMTLib2.of_bexpr expr) acc) + builder in + + (* Produce assertions for the requires requirements of a procedure. *) + let builder = assert_exprs spec.requires builder in + + (* Translate each statement to smt. *) let builder = Procedure.iter_stmt_topo_fwd proc |> Iter.fold (fun acc stmt -> match stmt with | Stmt.Instr_Assert { body } -> - let smt = SMTLib2.of_bexpr (Expr.BasilExpr.boolnot body) in + let smt = SMTLib2.of_bexpr (BasilExpr.boolnot body) in SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assume { body } -> - let smt = SMTLib2.of_bexpr (Expr.BasilExpr.boolnot body) in + let smt = SMTLib2.of_bexpr (BasilExpr.boolnot body) in SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assign { al } -> let asserts = List.map (fun (v, e) -> - Expr.BasilExpr.binexp ~op:`EQ (Expr.BasilExpr.rvar v) e + BasilExpr.binexp ~op:`EQ (BasilExpr.rvar v) e |> SMTLib2.of_bexpr) al in List.fold_left (fun acc smt -> SMTLib2.add_assert smt acc |> snd) acc asserts - (* | Stmt.Instr_Call { lhs; procid; args } -> *) - (* let assumes = *) + | Stmt.Instr_Call { lhs; procid; args } -> acc | _ -> acc) builder in + + (* Produce assertions for the ensures of a procedure. *) + let builder = assert_exprs spec.ensures builder in + let builder = snd @@ SMTLib2.check_sat builder in let builder = snd @@ SMTLib2.pop builder in builder diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index c2fe97442..26ce60bbe 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -67,7 +67,7 @@ let construct_final_edge proc = let guard_expressions, non_guard_stmts = Block.stmts_iter block |> Iter.to_list |> List.partition_map_either (function - | Stmt.Instr_Assume { body; branch = true } -> Left body + | Stmt.Instr_Assume { body; branch = _ } -> Left body | stmt -> Right stmt) in diff --git a/lib/transforms/summary_inlining.ml b/lib/transforms/summary_inlining.ml index 72c5266d7..8d71cebab 100644 --- a/lib/transforms/summary_inlining.ml +++ b/lib/transforms/summary_inlining.ml @@ -36,7 +36,7 @@ let transform_block (prog : Program.t) (proc : Program.proc) branch = false; }) in - requires @ [stmt] @ ensures + requires @ [ stmt ] @ ensures | other -> [ other ] ) block From de346dcca2d21219201d714c060766b91725f413 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 24 Jul 2026 14:54:53 +1000 Subject: [PATCH 14/67] gitignoring .helix alongside vscode --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index 39d7dc16b..d276e4a5d 100644 --- a/.gitignore +++ b/.gitignore @@ -8,5 +8,6 @@ trace.json **/*.dot .vscode/ +.helix/ .direnv .envrc From 446de02dff0db1068af3550f98a0eeabdb13afce Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 24 Jul 2026 16:57:48 +1000 Subject: [PATCH 15/67] Messy, inlining summaries was not wise --- lib/backends/smt.ml | 98 +++++++++++++++++++++++++++------ lib/lang/expr_smt.ml | 2 + lib/transforms/cfa_reduction.ml | 2 +- 3 files changed, 84 insertions(+), 18 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 0755c8567..1df5cb4d5 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -9,38 +9,49 @@ open Expr (* Takes a procedure that has been reduced to a single edge. Maps each statement to an smt expression. *) -let build_proc (proc : Program.proc) (builder : SMTLib2.builder) : - SMTLib2.builder = +let build_proc (program : Program.t) (procedure : Program.proc) + (builder : SMTLib2.builder) : SMTLib2.builder = let builder = snd @@ SMTLib2.push builder in + (* Echo the name of the proc being verified. *) + let builder = + snd + @@ SMTLib2.echo + ("Verifying Procedure: " ^ ID.name (Procedure.id procedure)) + builder + in + (* Generate a declaration for each local var. *) - let local_decls = Procedure.local_decls proc in + let local_decls = Procedure.local_decls procedure in let builder = Hashtbl.to_iter local_decls |> Iter.fold (fun acc (k, v) -> snd @@ SMTLib2.decl_var v acc) builder in (* Need the specification for requires/ensures. *) - let spec = Procedure.specification proc in - let assert_exprs exprs builder = - exprs |> List.fold_left - (fun acc expr -> snd @@ SMTLib2.add_assert (SMTLib2.of_bexpr expr) acc) - builder in + let spec = Procedure.specification procedure in + let assert_exprs f exprs builder = + exprs + |> List.fold_left + (fun acc expr -> + snd @@ SMTLib2.add_assert (SMTLib2.of_bexpr @@ f expr) acc) + builder + in (* Produce assertions for the requires requirements of a procedure. *) - let builder = assert_exprs spec.requires builder in + let builder = assert_exprs id spec.requires builder in (* Translate each statement to smt. *) let builder = - Procedure.iter_stmt_topo_fwd proc + Procedure.iter_stmt_topo_fwd procedure |> Iter.fold (fun acc stmt -> match stmt with | Stmt.Instr_Assert { body } -> - let smt = SMTLib2.of_bexpr (BasilExpr.boolnot body) in + let smt = SMTLib2.of_bexpr body in SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assume { body } -> - let smt = SMTLib2.of_bexpr (BasilExpr.boolnot body) in + let smt = SMTLib2.of_bexpr body in SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assign { al } -> let asserts = @@ -53,29 +64,82 @@ let build_proc (proc : Program.proc) (builder : SMTLib2.builder) : List.fold_left (fun acc smt -> SMTLib2.add_assert smt acc |> snd) acc asserts - | Stmt.Instr_Call { lhs; procid; args } -> acc + | Stmt.Instr_Call { lhs; procid; args } -> + (* Calls are interesting. + First we verify their requires in a local scope. + Done by checking their negation is unsatisfiable. + Then after exiting their scope, assert the requires + to be true as usual. + Lastly assert the ensures expressions for future. + *) + let subst_var varmap expression = + BasilExpr.substitute + (fun v -> + StringMap.get (Var.name v) varmap + |> Option.map BasilExpr.rvar) + expression + in + let subst_expr varmap expression = + BasilExpr.substitute + (fun v -> StringMap.get (Var.name v) varmap) + expression + in + let call_proc = Program.proc program procid in + let spec = Procedure.specification call_proc in + let requires = + spec.requires |> List.map (fun e -> subst_expr args e) + in + let ensures = + spec.ensures + |> List.map (fun e -> subst_var lhs @@ subst_expr args e) + in + + (* Verify *) + let acc = snd @@ SMTLib2.push acc in + let acc = + requires + |> List.fold_left + (fun acc e -> + snd + @@ SMTLib2.add_assert + (SMTLib2.of_bexpr (BasilExpr.boolnot e)) + acc) + acc + in + let acc = snd @@ SMTLib2.check_sat acc in + let acc = snd @@ SMTLib2.pop acc in + + (* Assert *) + let acc = + requires + |> List.fold_left + (fun acc e -> + snd @@ SMTLib2.add_assert (SMTLib2.of_bexpr e) acc) + acc + in + acc | _ -> acc) builder in (* Produce assertions for the ensures of a procedure. *) - let builder = assert_exprs spec.ensures builder in + let builder = assert_exprs BasilExpr.boolnot spec.ensures builder in let builder = snd @@ SMTLib2.check_sat builder in let builder = snd @@ SMTLib2.pop builder in builder -let build_declaration (declaration : Program.declaration) +let build_declaration (program : Program.t) (declaration : Program.declaration) (builder : SMTLib2.builder) : SMTLib2.builder = match declaration with - | Procedure { definition } -> build_proc definition builder + | Procedure { definition } -> build_proc program definition builder | _ -> failwith "Unsupported SMT declaration" let build_program (program : Program.t) (builder : SMTLib2.builder) : SMTLib2.builder = Program.declarations program |> Iter.map snd - |> Iter.fold (fun a b -> build_declaration b a) builder + |> Iter.fold (fun a b -> build_declaration program b a) builder let pretty_program (program : Program.t) : Containers_pp.t = let open Containers_pp in diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index b38d4f56e..e14a8a197 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -547,6 +547,8 @@ module SMTLib2 = struct let* s = bind_of_bexpr e in add_assert s + let echo s = add_command (list [atom "echo"; atom s]) + let push = add_command (list [ atom "push" ]) let pop = add_command (list [ atom "pop" ]) let check_sat = add_command (list [ atom "check-sat" ]) diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index 26ce60bbe..c2fe97442 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -67,7 +67,7 @@ let construct_final_edge proc = let guard_expressions, non_guard_stmts = Block.stmts_iter block |> Iter.to_list |> List.partition_map_either (function - | Stmt.Instr_Assume { body; branch = _ } -> Left body + | Stmt.Instr_Assume { body; branch = true } -> Left body | stmt -> Right stmt) in From d35bde9930c36f30e162d56a78a0ee155e4c337d Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 10:19:29 +1000 Subject: [PATCH 16/67] Checking VCs properly --- lib/backends/smt.ml | 61 ++++++++++++++++++++++----------------------- 1 file changed, 30 insertions(+), 31 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 1df5cb4d5..f67fd2e68 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -5,9 +5,7 @@ open Bincaml_util open Expr_smt open Expr -(* open Containers *) - -(* Takes a procedure that has been reduced to a single edge. +(* Takes a single edge procedure (see cfa_reduction.ml transform). Maps each statement to an smt expression. *) let build_proc (program : Program.t) (procedure : Program.proc) (builder : SMTLib2.builder) : SMTLib2.builder = @@ -48,9 +46,22 @@ let build_proc (program : Program.t) (procedure : Program.proc) (fun acc stmt -> match stmt with | Stmt.Instr_Assert { body } -> + (* Verify negation of assertion is unsat. *) + let acc = snd @@ SMTLib2.push acc in + let acc = + snd + @@ SMTLib2.add_assert + (SMTLib2.of_bexpr (BasilExpr.boolnot body)) + acc + in + let acc = snd @@ SMTLib2.check_sat acc in + let acc = snd @@ SMTLib2.pop acc in + + (* Assert the assertion. *) let smt = SMTLib2.of_bexpr body in SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assume { body } -> + (* Assert the assumption as is. *) let smt = SMTLib2.of_bexpr body in SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assign { al } -> @@ -65,13 +76,10 @@ let build_proc (program : Program.t) (procedure : Program.proc) (fun acc smt -> SMTLib2.add_assert smt acc |> snd) acc asserts | Stmt.Instr_Call { lhs; procid; args } -> - (* Calls are interesting. - First we verify their requires in a local scope. - Done by checking their negation is unsatisfiable. - Then after exiting their scope, assert the requires - to be true as usual. - Lastly assert the ensures expressions for future. - *) + (* For calls, assert the negation of requires is unsat. + Then we simply assert the requires/ensures. + Asserting the requires is fine as this is on fresh SSA + variables.*) let subst_var varmap expression = BasilExpr.substitute (fun v -> @@ -94,38 +102,29 @@ let build_proc (program : Program.t) (procedure : Program.proc) |> List.map (fun e -> subst_var lhs @@ subst_expr args e) in - (* Verify *) + (* Verify negation of requires is unsat. *) let acc = snd @@ SMTLib2.push acc in - let acc = - requires - |> List.fold_left - (fun acc e -> - snd - @@ SMTLib2.add_assert - (SMTLib2.of_bexpr (BasilExpr.boolnot e)) - acc) - acc - in + let acc = assert_exprs BasilExpr.boolnot requires acc in let acc = snd @@ SMTLib2.check_sat acc in let acc = snd @@ SMTLib2.pop acc in - (* Assert *) - let acc = - requires - |> List.fold_left - (fun acc e -> - snd @@ SMTLib2.add_assert (SMTLib2.of_bexpr e) acc) - acc - in + (* Assert Requires. *) + let acc = assert_exprs id requires acc in + + (* Assert Ensures. *) + let acc = assert_exprs id ensures acc in + acc | _ -> acc) builder in - (* Produce assertions for the ensures of a procedure. *) + (* Verify negation of ensures is unsat. *) + let builder = snd @@ SMTLib2.push builder in let builder = assert_exprs BasilExpr.boolnot spec.ensures builder in - let builder = snd @@ SMTLib2.check_sat builder in + let builder = snd @@ SMTLib2.pop builder in + let builder = snd @@ SMTLib2.pop builder in builder From 45ac348477ff5b534e7085c01c4cf95510345206 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 10:32:11 +1000 Subject: [PATCH 17/67] Small cleanup --- lib/backends/smt.ml | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index f67fd2e68..9b7ac70dd 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -7,7 +7,7 @@ open Expr (* Takes a single edge procedure (see cfa_reduction.ml transform). Maps each statement to an smt expression. *) -let build_proc (program : Program.t) (procedure : Program.proc) +let build_procedure (program : Program.t) (procedure : Program.proc) (builder : SMTLib2.builder) : SMTLib2.builder = let builder = snd @@ SMTLib2.push builder in @@ -94,12 +94,14 @@ let build_proc (program : Program.t) (procedure : Program.proc) in let call_proc = Program.proc program procid in let spec = Procedure.specification call_proc in + let requires = - spec.requires |> List.map (fun e -> subst_expr args e) + List.map (fun e -> subst_expr args e) spec.requires in let ensures = - spec.ensures - |> List.map (fun e -> subst_var lhs @@ subst_expr args e) + List.map + (fun e -> subst_var lhs @@ subst_expr args e) + spec.ensures in (* Verify negation of requires is unsat. *) @@ -131,7 +133,7 @@ let build_proc (program : Program.t) (procedure : Program.proc) let build_declaration (program : Program.t) (declaration : Program.declaration) (builder : SMTLib2.builder) : SMTLib2.builder = match declaration with - | Procedure { definition } -> build_proc program definition builder + | Procedure { definition } -> build_procedure program definition builder | _ -> failwith "Unsupported SMT declaration" let build_program (program : Program.t) (builder : SMTLib2.builder) : From f0da82df46de2b93a30bac86c9e49bff89d73e5b Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 10:38:56 +1000 Subject: [PATCH 18/67] smt backend test --- test/cram/smt_backend.il | 40 ++++++++++++++++++++++++++++++++++++++ test/cram/smt_backend.sexp | 6 ++++++ test/cram/smt_backend.t | 2 ++ 3 files changed, 48 insertions(+) create mode 100644 test/cram/smt_backend.il create mode 100644 test/cram/smt_backend.sexp create mode 100644 test/cram/smt_backend.t diff --git a/test/cram/smt_backend.il b/test/cram/smt_backend.il new file mode 100644 index 000000000..5f7af5125 --- /dev/null +++ b/test/cram/smt_backend.il @@ -0,0 +1,40 @@ +prog entry @f3; + +// A poorly implemented square function which +// just multiplies by 2, but is specified correctly. +// Should fail to verify (sat). +proc @bad_square(x:bv64) -> (y:bv64) + requires bvsge(x, 0:bv64) + ensures eq(y, bvmul(x, x)) +[ + block %b1 [ + var y:bv64 := bvmul(x, 2:bv64); + return; + ]; +]; + +// Uses bad_square correctly according to it's spec. +proc @f2(x:bv64) -> (z:bv64) + requires bvsge(x, 0:bv64) + ensures eq(z, bvadd(bvmul(x, x), 1:bv64)) +[ + block %b1 [ + var (y:bv64) := call @bad_square(x); + var z:bv64 := bvadd(y, 1:bv64); + return; + ]; +]; + +// Uses bad_square incorrectly according to it's spec. +proc @f3(x:bv64) -> (z:bv64) + requires bvsge(x, 0:bv64) + ensures eq(z, bvadd(bvmul(bvadd(x, 1:bv64), bvadd(x, 1:bv64)), 1:bv64)) +[ + block %b1 [ + var x:bv64 := bvadd(x, 1:bv64); + var (y:bv64) := call @bad_square(x); + var z:bv64 := bvadd(y, 1:bv64); + return; + ]; +]; + diff --git a/test/cram/smt_backend.sexp b/test/cram/smt_backend.sexp new file mode 100644 index 000000000..29d5743ae --- /dev/null +++ b/test/cram/smt_backend.sexp @@ -0,0 +1,6 @@ +(load-il "./test.il") +(run-transforms "ssa") +(run-transforms "cfa-reduction") +(dump-smt "./out.smt") +(dump-il "./out.il") + diff --git a/test/cram/smt_backend.t b/test/cram/smt_backend.t new file mode 100644 index 000000000..9cd433d46 --- /dev/null +++ b/test/cram/smt_backend.t @@ -0,0 +1,2 @@ + $ bincaml script ./smt_backend.sexp + $ cvc5 ./out.smt --incremental From 9dbb12db190296d8deab3c5ab939117282568996 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 10:53:01 +1000 Subject: [PATCH 19/67] smt backend test --- lib/invariants.ml | 2 -- lib/passes.ml | 4 ++-- test/cram/dune | 2 ++ test/cram/smt_backend.sexp | 3 +-- test/cram/smt_backend.t | 13 +++++++++++++ 5 files changed, 18 insertions(+), 6 deletions(-) diff --git a/lib/invariants.ml b/lib/invariants.ml index 5b56d3bf0..ca1241406 100644 --- a/lib/invariants.ml +++ b/lib/invariants.ml @@ -13,7 +13,6 @@ type t = | SSA | DSA | NoPhis - | NoCalls | Params | LambdaLift | MemoryEncoding @@ -29,7 +28,6 @@ let read s = | "SSA" -> SSA | "DSA" -> DSA | "NoPhis" -> NoPhis - | "NoCalls" -> NoCalls | "Params" -> Params | "LambdaLift" -> LambdaLift | "ReducibleLoops" -> ReducibleLoops diff --git a/lib/passes.ml b/lib/passes.ml index 78add5d57..e5bae335d 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -232,7 +232,7 @@ module PassManager = struct name = "cfa-reduction"; apply = Proc Transforms.Cfa_reduction.reduce_procedure; doc = "Performs reduction of acyclic CFA"; - invariants = Invariants.presupposes [ SSA; NoCalls ] ~establishes:[ NoPhis; SSA ]; + invariants = Invariants.presupposes [ SSA ] ~establishes:[ NoPhis; SSA ]; } let inline_summaries = @@ -240,7 +240,7 @@ module PassManager = struct name = "inline_summaries"; apply = Prog Transforms.Summary_inlining.transform; doc = "Replaces procedure calls with asserts/assumes for summaries"; - invariants = Invariants.presupposes [ SSA ] ~establishes:[ NoCalls ]; + invariants = Invariants.presupposes [ SSA ]; } let remove_unreachable_blocks = diff --git a/test/cram/dune b/test/cram/dune index 769da30e0..2a8fe8941 100644 --- a/test/cram/dune +++ b/test/cram/dune @@ -64,6 +64,8 @@ repeated_ssa.sexp cfa_reduction.il cfa_reduction.sexp + smt_backend.il + smt_backend.sexp ../../bin/main.exe)) (cram diff --git a/test/cram/smt_backend.sexp b/test/cram/smt_backend.sexp index 29d5743ae..9242cf51e 100644 --- a/test/cram/smt_backend.sexp +++ b/test/cram/smt_backend.sexp @@ -1,6 +1,5 @@ -(load-il "./test.il") +(load-il "./smt_backend.il") (run-transforms "ssa") (run-transforms "cfa-reduction") (dump-smt "./out.smt") (dump-il "./out.il") - diff --git a/test/cram/smt_backend.t b/test/cram/smt_backend.t index 9cd433d46..86937e844 100644 --- a/test/cram/smt_backend.t +++ b/test/cram/smt_backend.t @@ -1,2 +1,15 @@ $ bincaml script ./smt_backend.sexp + (load-il ./smt_backend.il) + (run-transforms ssa) + (run-transforms cfa-reduction) + (dump-smt ./out.smt) + (dump-il ./out.il) $ cvc5 ./out.smt --incremental + "Verifying Procedure: @bad_square" + sat + "Verifying Procedure: @f2" + unsat + unsat + "Verifying Procedure: @f3" + sat + unsat From fdfbf338dcd51fdc8a1bf309cdbb3cc305bd280d Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 11:08:21 +1000 Subject: [PATCH 20/67] rebased --- lib/transforms/cfa_reduction.ml | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index c2fe97442..951907e9b 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -15,15 +15,12 @@ open Expr let construct_final_edge proc = (* Termination condition for each edge. *) - let termination_condition : (IDSet.elt, Var.t) Hashtbl.t = - Hashtbl.create 30 - in + let termination_condition : (ID.t, Var.t) Hashtbl.t = Hashtbl.create 30 in (* final_edge accumulates as one large edge containing all statements from existing edges with additional predicate variables and ite statements/assignments - filling in for phi-nodes. - *) + filling in for phi-nodes. *) Procedure.fold_blocks_topo_fwd (fun final_edge id block -> (* Compute reachability of this block. *) @@ -90,8 +87,12 @@ let construct_final_edge proc = 2. the statements for the new edge body. 3. an assignment to the termination variable. *) - final_edge @ List.concat [ [ ites ]; non_guard_stmts; [ termination ] ]) - [] proc + CCVector.push final_edge ites; + CCVector.append_list final_edge non_guard_stmts; + CCVector.push final_edge termination; + final_edge) + (CCVector.create ()) proc + |> CCVector.freeze let reduce_procedure (proc : Program.proc) : Program.proc = (* Constructed reduced edge to replace procedure blocks. *) @@ -101,7 +102,10 @@ let reduce_procedure (proc : Program.proc) : Program.proc = proc |> Procedure.iter_blocks |> Iter.map fst |> Iter.fold (fun acc id -> Procedure.remove_block acc id) proc in - let proc, id = Procedure.fresh_block proc ~stmts:final_edge () in + let proc, id = Procedure.fresh_block proc ~stmts:[] () in + let proc = + Procedure.modify_block proc id (fun b -> { b with stmts = final_edge }) + in (* Make this the entry and return block. *) let proc = Procedure.set_entry_block proc id in From 6723b426143fd15de2254aadda3da442b26dc887 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 11:38:39 +1000 Subject: [PATCH 21/67] Summary inlining is useful now --- lib/backends/smt.ml | 61 ------------------ lib/invariants.ml | 2 + lib/lang/procedure.ml | 4 ++ lib/passes.ml | 4 +- lib/transforms/summary_inlining.ml | 100 +++++++++++++++++++---------- test/cram/smt_backend.sexp | 1 + 6 files changed, 74 insertions(+), 98 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 9b7ac70dd..e6b920075 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -26,19 +26,6 @@ let build_procedure (program : Program.t) (procedure : Program.proc) |> Iter.fold (fun acc (k, v) -> snd @@ SMTLib2.decl_var v acc) builder in - (* Need the specification for requires/ensures. *) - let spec = Procedure.specification procedure in - let assert_exprs f exprs builder = - exprs - |> List.fold_left - (fun acc expr -> - snd @@ SMTLib2.add_assert (SMTLib2.of_bexpr @@ f expr) acc) - builder - in - - (* Produce assertions for the requires requirements of a procedure. *) - let builder = assert_exprs id spec.requires builder in - (* Translate each statement to smt. *) let builder = Procedure.iter_stmt_topo_fwd procedure @@ -75,58 +62,10 @@ let build_procedure (program : Program.t) (procedure : Program.proc) List.fold_left (fun acc smt -> SMTLib2.add_assert smt acc |> snd) acc asserts - | Stmt.Instr_Call { lhs; procid; args } -> - (* For calls, assert the negation of requires is unsat. - Then we simply assert the requires/ensures. - Asserting the requires is fine as this is on fresh SSA - variables.*) - let subst_var varmap expression = - BasilExpr.substitute - (fun v -> - StringMap.get (Var.name v) varmap - |> Option.map BasilExpr.rvar) - expression - in - let subst_expr varmap expression = - BasilExpr.substitute - (fun v -> StringMap.get (Var.name v) varmap) - expression - in - let call_proc = Program.proc program procid in - let spec = Procedure.specification call_proc in - - let requires = - List.map (fun e -> subst_expr args e) spec.requires - in - let ensures = - List.map - (fun e -> subst_var lhs @@ subst_expr args e) - spec.ensures - in - - (* Verify negation of requires is unsat. *) - let acc = snd @@ SMTLib2.push acc in - let acc = assert_exprs BasilExpr.boolnot requires acc in - let acc = snd @@ SMTLib2.check_sat acc in - let acc = snd @@ SMTLib2.pop acc in - - (* Assert Requires. *) - let acc = assert_exprs id requires acc in - - (* Assert Ensures. *) - let acc = assert_exprs id ensures acc in - - acc | _ -> acc) builder in - (* Verify negation of ensures is unsat. *) - let builder = snd @@ SMTLib2.push builder in - let builder = assert_exprs BasilExpr.boolnot spec.ensures builder in - let builder = snd @@ SMTLib2.check_sat builder in - let builder = snd @@ SMTLib2.pop builder in - let builder = snd @@ SMTLib2.pop builder in builder diff --git a/lib/invariants.ml b/lib/invariants.ml index ca1241406..1105235b3 100644 --- a/lib/invariants.ml +++ b/lib/invariants.ml @@ -13,6 +13,7 @@ type t = | SSA | DSA | NoPhis + | NoSummaries | Params | LambdaLift | MemoryEncoding @@ -28,6 +29,7 @@ let read s = | "SSA" -> SSA | "DSA" -> DSA | "NoPhis" -> NoPhis + | "NoSummaries" -> NoSummaries | "Params" -> Params | "LambdaLift" -> LambdaLift | "ReducibleLoops" -> ReducibleLoops diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index 5774a00fe..d03476c04 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -365,6 +365,10 @@ let get_entry_block p = let id = get_blocks_succ p Entry in List.head_opt id +let get_return_block p = + let id = get_blocks_succ p Return in + List.head_opt id + let is_entry_block p id = graph p |> Option.map (fun g -> diff --git a/lib/passes.ml b/lib/passes.ml index e5bae335d..4a456516d 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -60,7 +60,7 @@ module PassManager = struct { name = "dump-smt"; doc = "write smt to channel"; - invariants = Invariants.make ~presupposes:[ SSA; NoPhis ] (); + invariants = Invariants.make ~presupposes:[ SSA; NoPhis; NoSummaries ] (); apply = Prog (fun prog -> @@ -240,7 +240,7 @@ module PassManager = struct name = "inline_summaries"; apply = Prog Transforms.Summary_inlining.transform; doc = "Replaces procedure calls with asserts/assumes for summaries"; - invariants = Invariants.presupposes [ SSA ]; + invariants = Invariants.presupposes [ SSA ] ~establishes:[ NoSummaries ]; } let remove_unreachable_blocks = diff --git a/lib/transforms/summary_inlining.ml b/lib/transforms/summary_inlining.ml index 8d71cebab..48ed7cd59 100644 --- a/lib/transforms/summary_inlining.ml +++ b/lib/transforms/summary_inlining.ml @@ -4,41 +4,68 @@ open Expr let transform_block (prog : Program.t) (proc : Program.proc) ((bid, block) : IDSet.elt * Program.bloc) : Program.bloc = - Block.flat_map ~phi:Common.id - ( List.to_iter % function - | Stmt.Instr_Call { attrib; lhs; procid; args } as stmt -> - let subst_var varmap expression = - BasilExpr.substitute - (fun v -> - StringMap.get (Var.name v) varmap |> Option.map BasilExpr.rvar) - expression - in - let subst_expr varmap expression = - BasilExpr.substitute - (fun v -> StringMap.get (Var.name v) varmap) - expression - in - let call_proc = Program.proc prog procid in - let spec = Procedure.specification call_proc in - let requires = - spec.requires - |> List.map (fun e -> - Stmt.Instr_Assert - { attrib = StringMap.empty; body = subst_expr args e }) - in - let ensures = - spec.ensures - |> List.map (fun e -> - Stmt.Instr_Assume - { - attrib = StringMap.empty; - body = subst_var lhs @@ subst_expr args e; - branch = false; - }) - in - requires @ [ stmt ] @ ensures - | other -> [ other ] ) - block + (* Inline summaries around any procedure call. *) + let block = + Block.flat_map ~phi:Common.id + ( List.to_iter % function + | Stmt.Instr_Call { attrib; lhs; procid; args } as stmt -> + let subst_var varmap expression = + BasilExpr.substitute + (fun v -> + StringMap.get (Var.name v) varmap |> Option.map BasilExpr.rvar) + expression + in + let subst_expr varmap expression = + BasilExpr.substitute + (fun v -> StringMap.get (Var.name v) varmap) + expression + in + let call_proc = Program.proc prog procid in + let spec = Procedure.specification call_proc in + let requires = + spec.requires + |> List.map (fun e -> + Stmt.Instr_Assert + { attrib = StringMap.empty; body = subst_expr args e }) + in + let ensures = + spec.ensures + |> List.map (fun e -> + Stmt.Instr_Assume + { + attrib = StringMap.empty; + body = subst_var lhs @@ subst_expr args e; + branch = false; + }) + in + requires @ [ stmt ] @ ensures + | other -> [ other ] ) + block + in + + let entry_id = Procedure.get_blocks_succ proc Entry in + let return_id = Procedure.get_blocks_pred proc Return in + + (* Add requires to entry block. *) + let spec = Procedure.specification proc in + let block = + if match List.head_opt entry_id with Some bid -> true | _ -> false then + Block.prepend_stmts block + (List.map + (fun e -> + Stmt.Instr_Assume + { attrib = StringMap.empty; body = e; branch = false }) + spec.requires) + else block + in + + (* Add ensures to return block. *) + if match List.head_opt return_id with Some bid -> true | _ -> false then + Block.append_stmts block + (List.map + (fun e -> Stmt.Instr_Assert { attrib = StringMap.empty; body = e }) + spec.ensures) + else block let transform_proc (prog : Program.t) (pid : IDSet.elt) (proc : Program.proc) : Program.proc = @@ -46,3 +73,6 @@ let transform_proc (prog : Program.t) (pid : IDSet.elt) (proc : Program.proc) : let transform (prog : Program.t) : Program.t = Program.map_procedures (transform_proc prog) prog + |> Program.map_procedures (fun id proc -> + let spec = Procedure.specification proc in + Procedure.set_specification proc { spec with ensures = []; requires = [] }) diff --git a/test/cram/smt_backend.sexp b/test/cram/smt_backend.sexp index 9242cf51e..c863b39fc 100644 --- a/test/cram/smt_backend.sexp +++ b/test/cram/smt_backend.sexp @@ -1,5 +1,6 @@ (load-il "./smt_backend.il") (run-transforms "ssa") (run-transforms "cfa-reduction") +(run-transforms "inline_summaries") (dump-smt "./out.smt") (dump-il "./out.il") From 909b4236fcf5b75e7eaa2f5590ab967e68227562 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 11:48:55 +1000 Subject: [PATCH 22/67] Documentation --- lib/transforms/summary_inlining.ml | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/lib/transforms/summary_inlining.ml b/lib/transforms/summary_inlining.ml index 48ed7cd59..92101bf01 100644 --- a/lib/transforms/summary_inlining.ml +++ b/lib/transforms/summary_inlining.ml @@ -2,6 +2,17 @@ open Lang open Lang.Common open Expr +(* This transformation inlines procedure summaries. + This means three things: + 1. All procedure requires will be replaced with assumes at the top + of the procedures entry block. + 2. All procedure ensures will be replaced with asserts at the end of + the procedures return block. + 3. Any procedure call will have assert statements added before + for the requires, and assumes added after for the ensures. + It will also clear all procedure specification ensures/requires. +*) + let transform_block (prog : Program.t) (proc : Program.proc) ((bid, block) : IDSet.elt * Program.bloc) : Program.bloc = (* Inline summaries around any procedure call. *) From a116da072bdb0ee052a6fcbdad6d04cdf5b89c78 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 11:50:57 +1000 Subject: [PATCH 23/67] More documentation --- lib/backends/smt.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index e6b920075..cc29d3f56 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -5,6 +5,12 @@ open Bincaml_util open Expr_smt open Expr +(* SMT Backend. + This backend expects the CFA Reduction and Summary Inlining transforms. + Will output a .smt file containing all declarations and asserts necessary + for verification. +*) + (* Takes a single edge procedure (see cfa_reduction.ml transform). Maps each statement to an smt expression. *) let build_procedure (program : Program.t) (procedure : Program.proc) From 3f819cd04c018e1f4a0e3b54c30ecfc1b0d93794 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 11:51:56 +1000 Subject: [PATCH 24/67] cram promote --- test/cram/smt_backend.t | 1 + 1 file changed, 1 insertion(+) diff --git a/test/cram/smt_backend.t b/test/cram/smt_backend.t index 86937e844..3eeea55c2 100644 --- a/test/cram/smt_backend.t +++ b/test/cram/smt_backend.t @@ -2,6 +2,7 @@ (load-il ./smt_backend.il) (run-transforms ssa) (run-transforms cfa-reduction) + (run-transforms inline_summaries) (dump-smt ./out.smt) (dump-il ./out.il) $ cvc5 ./out.smt --incremental From b7797fc9b347a50dd25f3419eb98846cad8d2c3b Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 11:59:34 +1000 Subject: [PATCH 25/67] formatter --- lib/lang/expr_smt.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index e14a8a197..4fd53f71d 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -390,8 +390,8 @@ module SMTLib2 = struct let* o = add_logic_const o in return (of_op o) | RVar { id } -> - let* var = get_var id in - return @@ list [atom "as"; var; fst @@ of_typ @@ Var.typ id ] + let* var = get_var id in + return @@ list [ atom "as"; var; fst @@ of_typ @@ Var.typ id ] | UnaryExpr { op = `BOOLTOBV1; arg = e } -> let* e = e in return @@ -547,8 +547,7 @@ module SMTLib2 = struct let* s = bind_of_bexpr e in add_assert s - let echo s = add_command (list [atom "echo"; atom s]) - + let echo s = add_command (list [ atom "echo"; atom s ]) let push = add_command (list [ atom "push" ]) let pop = add_command (list [ atom "pop" ]) let check_sat = add_command (list [ atom "check-sat" ]) From c04449bb0f30fa4dc0174980d3c7dd201cc2c250 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 12:00:15 +1000 Subject: [PATCH 26/67] bug --- lib/lang/procedure.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index d03476c04..e2d12e52f 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -366,7 +366,7 @@ let get_entry_block p = List.head_opt id let get_return_block p = - let id = get_blocks_succ p Return in + let id = get_blocks_pred p Return in List.head_opt id let is_entry_block p id = From 42f24a908dc1214bf5ca02d9f6a5497da35732a9 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 12:04:09 +1000 Subject: [PATCH 27/67] Removed useless comment --- lib/backends/smt.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index cc29d3f56..3c428f9fa 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -11,8 +11,6 @@ open Expr for verification. *) -(* Takes a single edge procedure (see cfa_reduction.ml transform). - Maps each statement to an smt expression. *) let build_procedure (program : Program.t) (procedure : Program.proc) (builder : SMTLib2.builder) : SMTLib2.builder = let builder = snd @@ SMTLib2.push builder in From 68d58c62ca57bbbdbee2973e91632cba7e80ef7c Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 13:27:20 +1000 Subject: [PATCH 28/67] test depends on cvc5 --- test/cram/dune | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/cram/dune b/test/cram/dune index 2a8fe8941..fdd6ada95 100644 --- a/test/cram/dune +++ b/test/cram/dune @@ -1,11 +1,13 @@ (cram - (applies_to expr_smt) + (applies_to expr_smt smt_backend) (package bincaml) (enabled_if %{bin-available:cvc5}) (deps %{bin:bincaml} ../../examples/cntlm-output.il expr_smt_check.sexp + smt_backend.il + smt_backend.sexp concat.il)) (cram @@ -21,7 +23,8 @@ chc_spec chc_per_query chc_mem - chc_mem_call) + chc_mem_call + smt_backend) (package bincaml) (deps loop_dfg.sexp @@ -64,8 +67,6 @@ repeated_ssa.sexp cfa_reduction.il cfa_reduction.sexp - smt_backend.il - smt_backend.sexp ../../bin/main.exe)) (cram From ba49f761f5a438368d5f02a587f95059ade8a8d6 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 16:06:54 +1000 Subject: [PATCH 29/67] rename, primes bad --- lib/lang/expr_smt.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 4fd53f71d..992453bf2 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -383,7 +383,7 @@ module SMTLib2 = struct let* body = in_body in return @@ list [ quant; list binds; body ] - let smt_alg' (e : sexp t BasilExpr.abstract_expr) + let smt_alg_helper (e : sexp t BasilExpr.abstract_expr) (inner : sexp t BasilExpr.abstract_expr BasilExpr.abstract_expr) = match e with | Constant { const = o } -> @@ -477,7 +477,7 @@ module SMTLib2 = struct sexp t * sexp t BasilExpr.abstract_expr = let l = AbstractExpr.map fst e in let r = AbstractExpr.map snd e in - let o = smt_alg' l r in + let o = smt_alg_helper l r in (o, l) let bind_of_bexpr e = From 38bb495a410ea4a02d90e160612a7f2fb3b8464f Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 27 Jul 2026 16:14:33 +1000 Subject: [PATCH 30/67] quantifier-free removed by default --- lib/lang/expr_smt.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 992453bf2..cce0f9995 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -36,7 +36,7 @@ module SMTLib2 = struct let lia = get_part (function Int -> Some "LIA" | _ -> None) in let arr = get_part (function Array -> Some "A" | _ -> None) in let dt = get_part (function DT -> Some "DT" | _ -> None) in - "QF_" ^ arr ^ bv ^ lia ^ dt + arr ^ bv ^ lia ^ dt let return e = fun s -> (e, s) From d3ec54a9709c3677512603753c81d60658e2d62d Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Thu, 30 Jul 2026 16:51:20 +1000 Subject: [PATCH 31/67] confusing work in progress acyclification --- lib/invariants.ml | 2 + lib/passes.ml | 12 +++ lib/transforms/remove_loops.ml | 166 +++++++++++++++++++++++++++++++++ 3 files changed, 180 insertions(+) create mode 100644 lib/transforms/remove_loops.ml diff --git a/lib/invariants.ml b/lib/invariants.ml index 1105235b3..40aed9bc3 100644 --- a/lib/invariants.ml +++ b/lib/invariants.ml @@ -19,6 +19,7 @@ type t = | MemoryEncoding | GtirbArm | ReducibleLoops + | CycleFree (** All loops are reducible. That is, there are no {i irreducible} loops. *) [@@deriving show { with_path = false }, eq, ord] @@ -34,6 +35,7 @@ let read s = | "LambdaLift" -> LambdaLift | "ReducibleLoops" -> ReducibleLoops | "MemoryEncoding" -> MemoryEncoding + | "CycleFree" -> CycleFree | _ -> failwith (Printf.sprintf "cannot parse string into Invariants.t: %s" s) let show_list xs = "[" ^ CCString.concat ", " (List.map show xs) ^ "]" diff --git a/lib/passes.ml b/lib/passes.ml index 4a456516d..f64b22658 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -275,6 +275,17 @@ module PassManager = struct invariants = Invariants.presupposes [] ~establishes:[ ReducibleLoops ]; } + let remove_loops = + { + name = "remove-loops"; + apply = Prog Transforms.Remove_loops.transform; + doc = + "Makes reducible loops acyclic by cutting back edges and inserting \ + assumes/asserts."; + invariants = + Invariants.presupposes [ ReducibleLoops ] ~establishes:[ CycleFree ]; + } + let full_ssa = let batch = [ remove_unreachable_blocks; sparams; sssa; remove_unused ] in { @@ -486,6 +497,7 @@ module PassManager = struct flatten_phis; dynamic_single_assignment; irreducible_loop; + remove_loops; remove_unreachable_blocks; collapse_empty_blocks; cleanup_cfg; diff --git a/lib/transforms/remove_loops.ml b/lib/transforms/remove_loops.ml new file mode 100644 index 000000000..9e7ba9a6e --- /dev/null +++ b/lib/transforms/remove_loops.ml @@ -0,0 +1,166 @@ +open Lang +open Common +open Analysis.Irreducible_loops + +(* Makes reducible loops acyclic according to the algorithm described in + https://dx.doi.org/10.1145/1108768.1108813 *) + +let transform_loop (prog : Program.t) (proc : Program.proc) + (loop : ProcIntra.block_info) = + let header, next_h, headers, nodes, entries, backedges = + match loop with + | { block; loop = PrimaryHeader { primary_header; headers; nodes } } -> + let entries = ProcIntra.compute_entries proc loop in + let backedges = ProcIntra.compute_backedges proc loop in + (block, primary_header, headers, nodes, entries, backedges) + | _ -> + raise + (Invalid_argument + "called on non-primary header / non-irreducible loop ") + in + let header_block = Procedure.get_block proc header |> Option.get in + + let dest = ProcIntra.BlockGraph.E.dst in + let src = ProcIntra.BlockGraph.E.src in + + (* Treat any assertions in the header as invariants. *) + let invariants = + Block.fold_forwards ~phi:const + ~f:(fun acc stmt -> + match stmt with Stmt.Instr_Assert { body } -> body :: acc | _ -> acc) + [] header_block + in + + (* Add havoc statements. *) + let havocs = + Block.free_vars header_block + |> flip + (VarSet.fold (fun var acc -> acc)) + (Stmt.Instr_IntrinCall + { + attrib = Attrib.empty; + lhs = []; + name = Stmt.Intrinsic.Havoc; + args = []; + }) + in + let proc = Procedure. + + (* Add invariants to a backedge, subbing phi node vars. *) + let add_invariants block = + let phis = + header_block.phis + |> List.map (fun (phi : 'v Block.phi) -> + let rhs = + List.find_map + (fun (id, v) -> + if ID.equal id header then Some (Expr.BasilExpr.rvar v) + else None) + phi.rhs + in + (phi.lhs, rhs)) + |> VarMap.of_list + in + let invariants = + invariants + |> List.map + @@ Expr.BasilExpr.substitute (Option.flatten % flip VarMap.get phis) + |> List.map (fun inv -> + Stmt.Instr_Assert { body = inv; attrib = Attrib.empty }) + in + let block = Block.append_stmts block invariants in + block + in + + let proc = + backedges + |> List.fold_left + (fun acc edge -> + let src_id : IDSet.elt = src edge in + let dest_id : IDSet.elt = dest edge in + let block = Procedure.get_block acc src_id |> Option.get in + (* Update all entry nodes on back edges to assert invariants. *) + let acc = Procedure.update_block acc src_id (add_invariants block) in + (* Remove the back edge. *) + Procedure.map_graph + (fun g -> + Procedure.G.remove_edge g (Procedure.Vert.End src_id) + (Procedure.Vert.Begin dest_id)) + acc) + proc + in + + (* Remove back edges *) + proc + +let transform_proc (prog : Program.t) (proc_id : IDSet.elt) + (proc : Program.proc) = + let block_infos = + Procedure.get_entry_block proc + |> Option.flat_map_l (fun entry -> ProcIntra.solve proc entry) + in + let loops = + block_infos + |> List.filter (fun block -> + match ProcIntra.classify_block block with + | `ReducibleHeader -> true + | _ -> false) + in + Printf.printf "length: %d\n" @@ List.length loops; + List.fold_left (transform_loop prog) proc loops + +(* let transform_proc (prog : Program.t) (proc_id : IDSet.elt) *) +(* (proc : Program.proc) = *) +(* Block info for each block. *) +(* let block_infos = *) +(* Procedure.get_entry_block proc *) +(* |> Option.flat_map_l (fun entry -> ProcIntra.solve proc entry) *) +(* |> List.map (fun (block_info : ProcIntra.block_info) -> *) +(* (block_info.block, block_info)) *) +(* |> IDMap.of_list *) +(* in *) + +(* Map each block to all back edge head nodes. *) +(* let back_edges = ProcIntra.compute_backedges proc in *) +(* let back_edges = *) +(* IDMap.map *) +(* (fun block_info -> back_edges block_info |> List.map fst |> IDSet.of_list) *) +(* block_infos *) +(* in *) + +(* let _ = *) +(* block_infos |> IDMap.to_list |> List.map snd *) +(* |> List.map (fun block_info -> *) +(* print_endline @@ ProcIntra.show_block_info block_info) *) +(* in *) +(* proc *) +(* |> Procedure.map_blocks_nondet (fun (id, block) -> *) +(* match IDMap.get id block_infos with *) +(* | Some { loop = ProcIntra.PrimaryHeader { primary_header; headers } } -> *) +(* (* Get all variables touched in the loop and havoc them. *) + (* Then assume the invariant. *) *) +(* block *) +(* | Some { loop } -> *) +(* Non headers assert invariants if they *) +(* | Some { loop = ProcIntra.LoopParticipant { primary_header } } *) +(* when IDMap.get_or ~default:IDSet.empty primary_header back_edges *) +(* |> IDSet.mem id -> *) +(* If this is the head of a backedge, assert the invariant. *) +(* block *) +(* | None -> block) *) + +let transform (prog : Program.t) = + Program.map_procedures (transform_proc prog) prog + +(* Logs.info (fun m -> *) +(* m "found %d loops, %d irreducible" (List.length block_infos) *) +(* (List.count *) +(* (( function `IrreducibleHeader -> true | _ -> false ) *) +(* % classify_block) *) +(* block_infos)); *) + +(* let loops = *) +(* solve_proc proc *) +(* |> List.filter (fun b -> *) +(* match classify_block b with `IrreducibleHeader -> true | _ -> false) *) +(* in *) From 589ffd4e75600fc3b98f14f94f559bc869048aa5 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 10:10:21 +1000 Subject: [PATCH 32/67] Cleanup + assumes --- lib/transforms/remove_loops.ml | 137 +++++++++++---------------------- 1 file changed, 43 insertions(+), 94 deletions(-) diff --git a/lib/transforms/remove_loops.ml b/lib/transforms/remove_loops.ml index 9e7ba9a6e..e64ddb3dc 100644 --- a/lib/transforms/remove_loops.ml +++ b/lib/transforms/remove_loops.ml @@ -1,6 +1,7 @@ open Lang open Common open Analysis.Irreducible_loops +open Expr (* Makes reducible loops acyclic according to the algorithm described in https://dx.doi.org/10.1145/1108768.1108813 *) @@ -13,10 +14,7 @@ let transform_loop (prog : Program.t) (proc : Program.proc) let entries = ProcIntra.compute_entries proc loop in let backedges = ProcIntra.compute_backedges proc loop in (block, primary_header, headers, nodes, entries, backedges) - | _ -> - raise - (Invalid_argument - "called on non-primary header / non-irreducible loop ") + | _ -> raise (Invalid_argument "called on non-primary header") in let header_block = Procedure.get_block proc header |> Option.get in @@ -34,28 +32,37 @@ let transform_loop (prog : Program.t) (proc : Program.proc) (* Add havoc statements. *) let havocs = Block.free_vars header_block - |> flip - (VarSet.fold (fun var acc -> acc)) - (Stmt.Instr_IntrinCall - { - attrib = Attrib.empty; - lhs = []; - name = Stmt.Intrinsic.Havoc; - args = []; - }) + |> VarSet.to_list + |> List.map (fun var -> + Stmt.Instr_IntrinCall + { + attrib = Attrib.empty; + lhs = [ var ]; + name = Stmt.Intrinsic.Havoc; + args = []; + }) in - let proc = Procedure. + + (* Assume the invariant after havocing. *) + let assumes = + invariants + |> List.map (fun inv -> + Stmt.Instr_Assume { body = inv; attrib = Attrib.empty; branch = false }) + in + + (* Update header with new statements. *) + let header_block = Block.append_stmts header_block (havocs @ assumes) in + let proc = Procedure.update_block proc header header_block in (* Add invariants to a backedge, subbing phi node vars. *) - let add_invariants block = + let add_invariants = let phis = header_block.phis |> List.map (fun (phi : 'v Block.phi) -> let rhs = List.find_map (fun (id, v) -> - if ID.equal id header then Some (Expr.BasilExpr.rvar v) - else None) + if ID.equal id header then Some (BasilExpr.rvar v) else None) phi.rhs in (phi.lhs, rhs)) @@ -63,35 +70,30 @@ let transform_loop (prog : Program.t) (proc : Program.proc) in let invariants = invariants - |> List.map - @@ Expr.BasilExpr.substitute (Option.flatten % flip VarMap.get phis) + |> List.map @@ BasilExpr.substitute (Option.flatten % flip VarMap.get phis) |> List.map (fun inv -> Stmt.Instr_Assert { body = inv; attrib = Attrib.empty }) in - let block = Block.append_stmts block invariants in - block - in - - let proc = - backedges - |> List.fold_left - (fun acc edge -> - let src_id : IDSet.elt = src edge in - let dest_id : IDSet.elt = dest edge in - let block = Procedure.get_block acc src_id |> Option.get in - (* Update all entry nodes on back edges to assert invariants. *) - let acc = Procedure.update_block acc src_id (add_invariants block) in - (* Remove the back edge. *) - Procedure.map_graph - (fun g -> - Procedure.G.remove_edge g (Procedure.Vert.End src_id) - (Procedure.Vert.Begin dest_id)) - acc) - proc + fun block -> + let block = Block.append_stmts block invariants in + block in - (* Remove back edges *) - proc + backedges + |> List.fold_left + (fun acc edge -> + let src_id : IDSet.elt = src edge in + let dest_id : IDSet.elt = dest edge in + let block = Procedure.get_block acc src_id |> Option.get in + (* Update all entry nodes on back edges to assert invariants. *) + let acc = Procedure.update_block acc src_id (add_invariants block) in + (* Remove the back edge. *) + Procedure.map_graph + (fun g -> + Procedure.G.remove_edge g (Procedure.Vert.End src_id) + (Procedure.Vert.Begin dest_id)) + acc) + proc let transform_proc (prog : Program.t) (proc_id : IDSet.elt) (proc : Program.proc) = @@ -109,58 +111,5 @@ let transform_proc (prog : Program.t) (proc_id : IDSet.elt) Printf.printf "length: %d\n" @@ List.length loops; List.fold_left (transform_loop prog) proc loops -(* let transform_proc (prog : Program.t) (proc_id : IDSet.elt) *) -(* (proc : Program.proc) = *) -(* Block info for each block. *) -(* let block_infos = *) -(* Procedure.get_entry_block proc *) -(* |> Option.flat_map_l (fun entry -> ProcIntra.solve proc entry) *) -(* |> List.map (fun (block_info : ProcIntra.block_info) -> *) -(* (block_info.block, block_info)) *) -(* |> IDMap.of_list *) -(* in *) - -(* Map each block to all back edge head nodes. *) -(* let back_edges = ProcIntra.compute_backedges proc in *) -(* let back_edges = *) -(* IDMap.map *) -(* (fun block_info -> back_edges block_info |> List.map fst |> IDSet.of_list) *) -(* block_infos *) -(* in *) - -(* let _ = *) -(* block_infos |> IDMap.to_list |> List.map snd *) -(* |> List.map (fun block_info -> *) -(* print_endline @@ ProcIntra.show_block_info block_info) *) -(* in *) -(* proc *) -(* |> Procedure.map_blocks_nondet (fun (id, block) -> *) -(* match IDMap.get id block_infos with *) -(* | Some { loop = ProcIntra.PrimaryHeader { primary_header; headers } } -> *) -(* (* Get all variables touched in the loop and havoc them. *) - (* Then assume the invariant. *) *) -(* block *) -(* | Some { loop } -> *) -(* Non headers assert invariants if they *) -(* | Some { loop = ProcIntra.LoopParticipant { primary_header } } *) -(* when IDMap.get_or ~default:IDSet.empty primary_header back_edges *) -(* |> IDSet.mem id -> *) -(* If this is the head of a backedge, assert the invariant. *) -(* block *) -(* | None -> block) *) - let transform (prog : Program.t) = Program.map_procedures (transform_proc prog) prog - -(* Logs.info (fun m -> *) -(* m "found %d loops, %d irreducible" (List.length block_infos) *) -(* (List.count *) -(* (( function `IrreducibleHeader -> true | _ -> false ) *) -(* % classify_block) *) -(* block_infos)); *) - -(* let loops = *) -(* solve_proc proc *) -(* |> List.filter (fun b -> *) -(* match classify_block b with `IrreducibleHeader -> true | _ -> false) *) -(* in *) From a3c2101ffface5582794b69fbe17fe3ab5735237 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 12:00:44 +1000 Subject: [PATCH 33/67] transform assertions in acyclic --- lib/lang/expr_smt.ml | 1 + lib/passes.ml | 2 +- lib/transforms/cfa_reduction.ml | 14 +++++++++++++- 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index cce0f9995..210d54b0d 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -362,6 +362,7 @@ module SMTLib2 = struct | `INTSUB -> atom "-" | `INTDIV -> atom "/" | `INTLT -> atom "<" + | `INTLE -> atom "<=" | #Ops.AllOps.unary as o -> atom @@ Ops.AllOps.to_string o | #Ops.AllOps.const as o -> atom @@ Ops.AllOps.to_string o | #Ops.AllOps.binary as o -> atom @@ Ops.AllOps.to_string o diff --git a/lib/passes.ml b/lib/passes.ml index f64b22658..4b16063cd 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -237,7 +237,7 @@ module PassManager = struct let inline_summaries = { - name = "inline_summaries"; + name = "inline-summaries"; apply = Prog Transforms.Summary_inlining.transform; doc = "Replaces procedure calls with asserts/assumes for summaries"; invariants = Invariants.presupposes [ SSA ] ~establishes:[ NoSummaries ]; diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index 951907e9b..fb5629f66 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -82,14 +82,26 @@ let construct_final_edge proc = } in + (* Assert(P) becomes Assert(Reachability => P) + to allow assertions in branches prior to joining + to reason about assumes/guards. *) + let non_guard_stmts = + non_guard_stmts + |> List.map (function + | Stmt.Instr_Assert { body; attrib } -> + Stmt.Instr_Assert + { body = BasilExpr.binexp ~op:`IMPLIES (BasilExpr.rvar termination_var) body; attrib } + | other -> other) + in + (* Final edge is existing statements plus: 1. the ites for the new edge being merged in. 2. the statements for the new edge body. 3. an assignment to the termination variable. *) CCVector.push final_edge ites; - CCVector.append_list final_edge non_guard_stmts; CCVector.push final_edge termination; + CCVector.append_list final_edge non_guard_stmts; final_edge) (CCVector.create ()) proc |> CCVector.freeze From a9887c36c34a8219ed10fe2ba6efb948fc855646 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 12:07:25 +1000 Subject: [PATCH 34/67] promotions --- test/cram/smt_backend.sexp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/cram/smt_backend.sexp b/test/cram/smt_backend.sexp index c863b39fc..6872d4baa 100644 --- a/test/cram/smt_backend.sexp +++ b/test/cram/smt_backend.sexp @@ -1,6 +1,6 @@ (load-il "./smt_backend.il") (run-transforms "ssa") (run-transforms "cfa-reduction") -(run-transforms "inline_summaries") +(run-transforms "inline-summaries") (dump-smt "./out.smt") (dump-il "./out.il") From 5c715f6309728920ed9c53919290626d83774d58 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 12:08:28 +1000 Subject: [PATCH 35/67] renamed invariant to acyclic --- lib/invariants.ml | 4 ++-- lib/passes.ml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/invariants.ml b/lib/invariants.ml index 40aed9bc3..9483f9f81 100644 --- a/lib/invariants.ml +++ b/lib/invariants.ml @@ -19,7 +19,7 @@ type t = | MemoryEncoding | GtirbArm | ReducibleLoops - | CycleFree + | Acyclic (** All loops are reducible. That is, there are no {i irreducible} loops. *) [@@deriving show { with_path = false }, eq, ord] @@ -35,7 +35,7 @@ let read s = | "LambdaLift" -> LambdaLift | "ReducibleLoops" -> ReducibleLoops | "MemoryEncoding" -> MemoryEncoding - | "CycleFree" -> CycleFree + | "Acyclic" -> Acyclic | _ -> failwith (Printf.sprintf "cannot parse string into Invariants.t: %s" s) let show_list xs = "[" ^ CCString.concat ", " (List.map show xs) ^ "]" diff --git a/lib/passes.ml b/lib/passes.ml index 4b16063cd..ee23b637a 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -283,7 +283,7 @@ module PassManager = struct "Makes reducible loops acyclic by cutting back edges and inserting \ assumes/asserts."; invariants = - Invariants.presupposes [ ReducibleLoops ] ~establishes:[ CycleFree ]; + Invariants.presupposes [ ReducibleLoops ] ~establishes:[ Acyclic ]; } let full_ssa = From f2b6afe918622f7253ddc93d9229fca9d007ab22 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 13:59:44 +1000 Subject: [PATCH 36/67] Proper ordering of statements --- lib/transforms/cfa_reduction.ml | 34 ++++++++++++++++++++++++--------- 1 file changed, 25 insertions(+), 9 deletions(-) diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index fb5629f66..b2dd9b330 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -57,14 +57,16 @@ let construct_final_edge proc = in (* Add a fresh termination variable to assign the condition. *) - let termination_var = Procedure.fresh_var proc ~pure:true Types.Boolean in + let termination_var = + Procedure.fresh_var ~name:"trm" proc ~pure:true Types.Boolean + in Hashtbl.add termination_condition id termination_var; (* Isolate the guard statements. *) let guard_expressions, non_guard_stmts = Block.stmts_iter block |> Iter.to_list |> List.partition_map_either (function - | Stmt.Instr_Assume { body; branch = true } -> Left body + | Stmt.Instr_Assume { body; branch = _ } -> Left body | stmt -> Right stmt) in @@ -85,23 +87,37 @@ let construct_final_edge proc = (* Assert(P) becomes Assert(Reachability => P) to allow assertions in branches prior to joining to reason about assumes/guards. *) - let non_guard_stmts = + let assert_stmts, non_guard_stmts = non_guard_stmts - |> List.map (function + |> List.partition_filter_map (function | Stmt.Instr_Assert { body; attrib } -> - Stmt.Instr_Assert - { body = BasilExpr.binexp ~op:`IMPLIES (BasilExpr.rvar termination_var) body; attrib } - | other -> other) + `Left + (Stmt.Instr_Assert + { + body = + BasilExpr.binexp ~op:`IMPLIES + (BasilExpr.rvar termination_var) + body; + attrib; + }) + | other -> `Right other) in (* Final edge is existing statements plus: 1. the ites for the new edge being merged in. 2. the statements for the new edge body. 3. an assignment to the termination variable. - *) + 4. any assertions from the block *) CCVector.push final_edge ites; - CCVector.push final_edge termination; CCVector.append_list final_edge non_guard_stmts; + CCVector.push final_edge termination; + + (* Asserts are moved to the end. + They should be order invariant thanks to SSA, + however the added dependence on the termination + condition requires them after it's declared. *) + CCVector.append_list final_edge assert_stmts; + final_edge) (CCVector.create ()) proc |> CCVector.freeze From 612b1c4b70a338243f88bb59237b1babd87ed63c Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 14:34:39 +1000 Subject: [PATCH 37/67] promotions, loop removal test --- test/cram/cfa_reduction.t | 6 ++--- test/cram/dune | 9 ++++--- test/cram/loop_removal.il | 50 +++++++++++++++++++++++++++++++++++++ test/cram/loop_removal.sexp | 11 ++++++++ test/cram/loop_removal.t | 30 ++++++++++++++++++++++ test/cram/smt_backend.t | 2 +- 6 files changed, 101 insertions(+), 7 deletions(-) create mode 100644 test/cram/loop_removal.il create mode 100644 test/cram/loop_removal.sexp create mode 100644 test/cram/loop_removal.t diff --git a/test/cram/cfa_reduction.t b/test/cram/cfa_reduction.t index 8e8dda7b8..c25ef6f51 100644 --- a/test/cram/cfa_reduction.t +++ b/test/cram/cfa_reduction.t @@ -10,9 +10,9 @@ [ block %block [ - var v:bool := true; - var v_2:bool := booland(v:bool, boolnot(bvult(a:bv64, 0x0:bv64))); - var x_6:bv64 := if v_2:bool then bvadd(a:bv64, 0x1:bv64) else bvsub(a:bv64, + var trm:bool := true; + var trm_2:bool := booland(trm:bool, boolnot(bvult(a:bv64, 0x0:bv64))); + var x_6:bv64 := if trm_2:bool then bvadd(a:bv64, 0x1:bv64) else bvsub(a:bv64, 0x1:bv64); var c:bv64 := x_6:bv64; return; diff --git a/test/cram/dune b/test/cram/dune index fdd6ada95..7d4098264 100644 --- a/test/cram/dune +++ b/test/cram/dune @@ -24,7 +24,8 @@ chc_per_query chc_mem chc_mem_call - smt_backend) + smt_backend + loop_removal) (package bincaml) (deps loop_dfg.sexp @@ -70,7 +71,7 @@ ../../bin/main.exe)) (cram - (applies_to malloc_free memory_safety memory_interproc) + (applies_to malloc_free memory_safety memory_interproc loop_removal) (package bincaml) (enabled_if (and %{bin-available:boogie} %{bin-available:cvc5})) @@ -81,7 +82,9 @@ ./malloc_free.sexp ../../examples/memory/memory_interproc.il ./memory_interproc.sexp - ../../examples/memory/memory_safety.il)) + ../../examples/memory/memory_safety.il + loop_removal.il + loop_removal.sexp)) (cram (applies_to chc_loop chc_call chc_spec chc_per_query chc_mem chc_mem_call) diff --git a/test/cram/loop_removal.il b/test/cram/loop_removal.il new file mode 100644 index 000000000..018da419d --- /dev/null +++ b/test/cram/loop_removal.il @@ -0,0 +1,50 @@ +prog entry @f1_good; + +// f1 +// A simple loop example. +// Decrements x by 1 (initially > 200) +// until it hits 0. +proc @f1_good(x:int) -> (r:int) +[ + block %start [ + assume (intle(100,x)); + goto (%head); + ]; + block %head [ + assert (intle(0,x)); + goto (%after, %body); + ]; + block %body [ + guard (intlt(0,x)); + var x := intsub(x,1); + goto (%head); + ]; + block %after [ + guard (boolnot(intlt(0,x))); + return (x); + ]; +]; + +// Decrements by 2, breaking invariant. +// Should fail. +proc @f1_bad(x:int) -> (r:int) +[ + block %start [ + assume (intle(100,x)); + goto (%head); + ]; + block %head [ + assert (intle(0,x)); + goto (%after, %body); + ]; + block %body [ + guard (intlt(0,x)); + var x := intsub(x,2); + goto (%head); + ]; + block %after [ + guard (boolnot(intlt(0,x))); + return (x); + ]; +]; + diff --git a/test/cram/loop_removal.sexp b/test/cram/loop_removal.sexp new file mode 100644 index 000000000..cbc92b6f8 --- /dev/null +++ b/test/cram/loop_removal.sexp @@ -0,0 +1,11 @@ +(load-il "./loop_removal.il") +(run-transform "irreducible-loops") +(run-transform "remove-loops") +(run-transform "ssa") +(run-transform "inline-summaries") +(run-transform "cfa-reduction") +(run-transform "simplify") +(dump-il "./out.il") +(dump-smt "./out.smt") +(dump-boogie "./out.bpl") + diff --git a/test/cram/loop_removal.t b/test/cram/loop_removal.t new file mode 100644 index 000000000..37b5f654c --- /dev/null +++ b/test/cram/loop_removal.t @@ -0,0 +1,30 @@ + $ bincaml script loop_removal.sexp + (load-il ./loop_removal.il) + (run-transform irreducible-loops) + bincaml: [INFO] found 4 loops, 0 irreducible + bincaml: [INFO] found 4 loops, 0 irreducible + (run-transform remove-loops) + length: 1 + length: 1 + (run-transform ssa) + (run-transform inline-summaries) + (run-transform cfa-reduction) + (run-transform simplify) + (dump-il ./out.il) + (dump-smt ./out.smt) + (dump-boogie ./out.bpl) + + $ cvc5 ./out.smt --incremental + "Verifying Procedure: @f1_good" + unsat + unsat + "Verifying Procedure: @f1_bad" + unsat + sat + + $ boogie ./out.bpl + ./out.bpl(50,5): Error: this assertion could not be proved + Execution trace: + ./out.bpl(42,3): b#block + + Boogie program verifier finished with 1 verified, 1 error diff --git a/test/cram/smt_backend.t b/test/cram/smt_backend.t index 3eeea55c2..f6075e467 100644 --- a/test/cram/smt_backend.t +++ b/test/cram/smt_backend.t @@ -2,7 +2,7 @@ (load-il ./smt_backend.il) (run-transforms ssa) (run-transforms cfa-reduction) - (run-transforms inline_summaries) + (run-transforms inline-summaries) (dump-smt ./out.smt) (dump-il ./out.il) $ cvc5 ./out.smt --incremental From 1626c8d3ddc9bc9f22566559f0c73f43508bffd5 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 15:08:07 +1000 Subject: [PATCH 38/67] fixed smt type hints with bandaid, needs rework to functorize over config later --- lib/backends/smt.ml | 8 ++++---- lib/lang/expr_smt.ml | 24 ++++++++++++++---------- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 3c428f9fa..2d3c05964 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -42,25 +42,25 @@ let build_procedure (program : Program.t) (procedure : Program.proc) let acc = snd @@ SMTLib2.add_assert - (SMTLib2.of_bexpr (BasilExpr.boolnot body)) + (SMTLib2.of_bexpr ~type_hints:true (BasilExpr.boolnot body)) acc in let acc = snd @@ SMTLib2.check_sat acc in let acc = snd @@ SMTLib2.pop acc in (* Assert the assertion. *) - let smt = SMTLib2.of_bexpr body in + let smt = SMTLib2.of_bexpr ~type_hints:true body in SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assume { body } -> (* Assert the assumption as is. *) - let smt = SMTLib2.of_bexpr body in + let smt = SMTLib2.of_bexpr ~type_hints:true body in SMTLib2.add_assert smt acc |> snd | Stmt.Instr_Assign { al } -> let asserts = List.map (fun (v, e) -> BasilExpr.binexp ~op:`EQ (BasilExpr.rvar v) e - |> SMTLib2.of_bexpr) + |> SMTLib2.of_bexpr ~type_hints:true) al in List.fold_left diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 210d54b0d..11245c29e 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -384,15 +384,17 @@ module SMTLib2 = struct let* body = in_body in return @@ list [ quant; list binds; body ] - let smt_alg_helper (e : sexp t BasilExpr.abstract_expr) + let smt_alg_helper ~type_hints (e : sexp t BasilExpr.abstract_expr) (inner : sexp t BasilExpr.abstract_expr BasilExpr.abstract_expr) = match e with | Constant { const = o } -> let* o = add_logic_const o in return (of_op o) - | RVar { id } -> + | RVar { id } -> ( let* var = get_var id in - return @@ list [ atom "as"; var; fst @@ of_typ @@ Var.typ id ] + match type_hints with + | true -> return @@ list [ atom "as"; var; fst @@ of_typ @@ Var.typ id ] + | false -> return @@ var) | UnaryExpr { op = `BOOLTOBV1; arg = e } -> let* e = e in return @@ -473,19 +475,20 @@ module SMTLib2 = struct let* func = func in return @@ list (func :: args) - let smt_alg + let smt_alg ~type_hints (e : (sexp t * sexp t BasilExpr.abstract_expr) BasilExpr.abstract_expr) : sexp t * sexp t BasilExpr.abstract_expr = let l = AbstractExpr.map fst e in let r = AbstractExpr.map snd e in - let o = smt_alg_helper l r in + let o = smt_alg_helper ~type_hints l r in (o, l) - let bind_of_bexpr e = + let bind_of_bexpr ?(type_hints = false) e = let e = (BasilExpr.rewrite_typed_two Algsimp.drop_assoc) e in - BasilExpr.cata smt_alg e |> fst + BasilExpr.cata (smt_alg ~type_hints) e |> fst - let of_bexpr e = fst @@ (bind_of_bexpr e) empty + let of_bexpr ?(type_hints = false) e = + fst @@ (bind_of_bexpr ~type_hints e) empty let trans_decl (decl : Program.declaration) = let* x = return () in @@ -575,8 +578,9 @@ module SMTLib2 = struct [%expect {| eq(sign_extend(10, 0x7:bv3), 0x64:bv13) - (set-logic QF_BV) - (assert (= ((_ sign_extend 10) (_ bv7 3)) (_ bv100 13))) |}] + (set-logic BV) + (assert (= ((_ sign_extend 10) (_ bv7 3)) (_ bv100 13))) + |}] end let%expect_test "datatypes" = From 8593e1dddb3dd463e349c3becdc735999fa0cd1e Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 15:25:46 +1000 Subject: [PATCH 39/67] IfThen intrinsic --- lib/analysis/sva.ml | 2 +- lib/lang/hm/inference.ml | 1 + lib/lang/ops.ml | 4 +++- lib/transforms/remove_loops.ml | 5 ++++- lib/transforms/type_check.ml | 10 ++++++++++ 5 files changed, 19 insertions(+), 3 deletions(-) diff --git a/lib/analysis/sva.ml b/lib/analysis/sva.ml index 74fb35a51..33a126380 100644 --- a/lib/analysis/sva.ml +++ b/lib/analysis/sva.ml @@ -117,7 +117,7 @@ module SVAAbstraction = struct match op with | (`BVADD | `BVOR | `BVXOR | `BVAND | `BVMUL) as op -> (eval_binary op a b rt, rt) - | `OR | `AND | `Cases | `MapUpdate -> (SymAddrSetLattice.top, rt) + | `OR | `AND | `Cases | `MapUpdate | `IfThen -> (SymAddrSetLattice.top, rt) | `BVConcat -> ( SymAddrSetLattice.fold (fun sb1 vs1 acc -> diff --git a/lib/lang/hm/inference.ml b/lib/lang/hm/inference.ml index d5ca79b77..fa37aa853 100644 --- a/lib/lang/hm/inference.ml +++ b/lib/lang/hm/inference.ml @@ -111,6 +111,7 @@ let scheme_of_intrin st ?(visit_constraint = fun a -> ()) (gen : ID.generator) let m = curry_f st [ a ] b in curry_f st [ m; a; b ] m | `Cases -> fv () + | `IfThen -> fv () let do_infer st ~visit_constraint (infer : diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index 2ce67ea70..e4e5baae1 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -298,7 +298,8 @@ module Spec = struct and catch fire *) ] [@@deriving show { with_path = false }, eq, ord] - type intrin = [ `Cases (** choose first argument that is defined *) ] + type intrin = + [ `Cases | `IfThen (** choose first argument that is defined *) ] [@@deriving show { with_path = false }, eq, ord] type unary = [ `Old | `Classification | `Gamma ] @@ -453,6 +454,7 @@ module AllOps = struct in return (Bitvector w) | `MapUpdate -> return @@ List.hd args + | `IfThen -> return @@ List.hd args (** ops returning booleans *) diff --git a/lib/transforms/remove_loops.ml b/lib/transforms/remove_loops.ml index e64ddb3dc..0d946cec2 100644 --- a/lib/transforms/remove_loops.ml +++ b/lib/transforms/remove_loops.ml @@ -4,7 +4,10 @@ open Analysis.Irreducible_loops open Expr (* Makes reducible loops acyclic according to the algorithm described in - https://dx.doi.org/10.1145/1108768.1108813 *) + https://dx.doi.org/10.1145/1108768.1108813. + + The only difference is that we put asserts at top of loop header block + instead of at the ends of non-entry blocks. *) let transform_loop (prog : Program.t) (proc : Program.proc) (loop : ProcIntra.block_info) = diff --git a/lib/transforms/type_check.ml b/lib/transforms/type_check.ml index 61416da5f..db863e2b3 100644 --- a/lib/transforms/type_check.ml +++ b/lib/transforms/type_check.ml @@ -196,6 +196,16 @@ let type_check stmt_id block_id expr = :: errs, ty )) ([], h) tl) + | `IfThen -> ( + match args with + | [ Types.Boolean; arg1; arg2 ] -> + if Types.equal arg1 arg2 then [] + else + [ + type_err "non-equal branch : %s %s" (Types.to_string arg1) + (Types.to_string arg2); + ] + | _ -> [ type_err "if then expects 3 arguments" ]) | `MapUpdate -> ( match args with | [ Types.Map (k, v); arg1; arg2 ] -> From 968dba14f80af7210dad0730b1bafebf5f1e8597 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 16:12:30 +1000 Subject: [PATCH 40/67] ITE Expression cleanup --- lib/lang/algsimp.ml | 28 ++++++++++++++++++++++++++ lib/lang/expr.ml | 21 ++++++++++++------- lib/lang/expr_smt.ml | 39 +++++++++--------------------------- lib/lang/ops.ml | 2 +- lib/transforms/type_check.ml | 5 +++-- test/cram/smt_backend.il | 1 - 6 files changed, 56 insertions(+), 40 deletions(-) diff --git a/lib/lang/algsimp.ml b/lib/lang/algsimp.ml index 1f3af5d7a..3713994c4 100644 --- a/lib/lang/algsimp.ml +++ b/lib/lang/algsimp.ml @@ -312,6 +312,34 @@ let algebraic_simplifications replace [%here] arg | _ -> Keep +let if_then_else + (e : + (BasilExpr.t BasilExpr.abstract_expr * Types.t) BasilExpr.abstract_expr) = + let open AbstractExpr in + let open BasilExpr in + match e with + | ApplyIntrin + { + op = `Cases; + args = + [ + ( ApplyIntrin { op = `IfThen; args=[cond;br_true] }, + Types.Boolean ) | (BinaryExpr {op = `IfThen; arg1=cond; arg2=br_true;}, Types.Boolean); + (br_false, _); + ]; + attrib; + } -> + ApplyIntrin + { + op = `IfThen; + args = [ cond; br_true; fix br_false ]; + attrib; + typ = BasilExpr.type_of br_true; + } + |> fix + |> replace [%here] + | _ -> Keep + let algebraic_simplifications = sequence drop_assoc algebraic_simplifications let alg_simp_rewriter ?visit e = diff --git a/lib/lang/expr.ml b/lib/lang/expr.ml index ca673a08a..b243b489f 100644 --- a/lib/lang/expr.ml +++ b/lib/lang/expr.ml @@ -295,13 +295,20 @@ module BasilExpr = struct [ { inner = - Some - (BinaryExpr - { - op = `IfThen; - arg1 = { this = Some cond }; - arg2 = { this = Some thn }; - }); + ( Some + (BinaryExpr + { + op = `IfThen; + arg1 = { this = Some cond }; + arg2 = { this = Some thn }; + }) + | Some + (ApplyIntrin + { + op = `IfThen; + args = + [ { this = Some cond }; { this = Some thn } ]; + }) ); }; { this = Some els }; ]; diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 11245c29e..459dff355 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -384,8 +384,7 @@ module SMTLib2 = struct let* body = in_body in return @@ list [ quant; list binds; body ] - let smt_alg_helper ~type_hints (e : sexp t BasilExpr.abstract_expr) - (inner : sexp t BasilExpr.abstract_expr BasilExpr.abstract_expr) = + let smt_alg ~type_hints (e : sexp t BasilExpr.abstract_expr) : sexp t = match e with | Constant { const = o } -> let* o = add_logic_const o in @@ -448,24 +447,13 @@ module SMTLib2 = struct let* l = l in let* r = r in return @@ list [ of_op o; l; r ] - | ApplyIntrin { op = `Cases; args } -> ( - match (inner, args) with - (* ITE Expressions are special. - They cannot be represented using an smt match which - expects a datatype not a bool. So we have to - identify an ITE and handle it specially. *) - | ( ApplyIntrin - { - op = `Cases; - args = [ BinaryExpr { op = `IfThen; arg1; arg2 }; _ ]; - }, - [ _; arg3 ] ) -> - let* arg1 = arg1 in - let* arg2 = arg2 in - let* arg3 = arg3 in - return @@ list [ atom "ite"; arg1; arg2; arg3 ] - (* TODO actual matches. *) - | _ -> failwith "Match expressions unsupported.") + | ApplyIntrin { op = `IfThen; args = [ cond; br_true; br_false ] } -> + let* cond = cond in + let* br_true = br_true in + let* br_false = br_false in + return @@ list [ atom "ite"; cond; br_true; br_false ] + | ApplyIntrin { op = `Cases; args } -> + failwith "Match expressions unsupported." | ApplyIntrin { op = o; args } -> let* args = sequence args in return (list (of_op o :: args)) @@ -475,17 +463,10 @@ module SMTLib2 = struct let* func = func in return @@ list (func :: args) - let smt_alg ~type_hints - (e : (sexp t * sexp t BasilExpr.abstract_expr) BasilExpr.abstract_expr) : - sexp t * sexp t BasilExpr.abstract_expr = - let l = AbstractExpr.map fst e in - let r = AbstractExpr.map snd e in - let o = smt_alg_helper ~type_hints l r in - (o, l) - let bind_of_bexpr ?(type_hints = false) e = let e = (BasilExpr.rewrite_typed_two Algsimp.drop_assoc) e in - BasilExpr.cata (smt_alg ~type_hints) e |> fst + let e = (BasilExpr.rewrite_typed_two Algsimp.if_then_else) e in + BasilExpr.cata (smt_alg ~type_hints) e let of_bexpr ?(type_hints = false) e = fst @@ (bind_of_bexpr ~type_hints e) empty diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index e4e5baae1..004f93cec 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -454,7 +454,7 @@ module AllOps = struct in return (Bitvector w) | `MapUpdate -> return @@ List.hd args - | `IfThen -> return @@ List.hd args + | `IfThen -> return @@ List.hd @@ List.tl args (** ops returning booleans *) diff --git a/lib/transforms/type_check.ml b/lib/transforms/type_check.ml index db863e2b3..839873627 100644 --- a/lib/transforms/type_check.ml +++ b/lib/transforms/type_check.ml @@ -202,10 +202,11 @@ let type_check stmt_id block_id expr = if Types.equal arg1 arg2 then [] else [ - type_err "non-equal branch : %s %s" (Types.to_string arg1) + type_err "non-equal ite branches : %s %s" (Types.to_string arg1) (Types.to_string arg2); ] - | _ -> [ type_err "if then expects 3 arguments" ]) + | [ Types.Boolean; arg1 ] -> [] + | _ -> [ type_err "if then expects 2 or 3 arguments" ]) | `MapUpdate -> ( match args with | [ Types.Map (k, v); arg1; arg2 ] -> diff --git a/test/cram/smt_backend.il b/test/cram/smt_backend.il index 5f7af5125..7f1b2c341 100644 --- a/test/cram/smt_backend.il +++ b/test/cram/smt_backend.il @@ -37,4 +37,3 @@ proc @f3(x:bv64) -> (z:bv64) return; ]; ]; - From ef59d49fcc1925ca7121b6443237fa1c99334c8e Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 31 Jul 2026 16:30:13 +1000 Subject: [PATCH 41/67] Formatter --- lib/backends/smt.ml | 3 ++- lib/lang/algsimp.ml | 6 ++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 2d3c05964..98c491048 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -42,7 +42,8 @@ let build_procedure (program : Program.t) (procedure : Program.proc) let acc = snd @@ SMTLib2.add_assert - (SMTLib2.of_bexpr ~type_hints:true (BasilExpr.boolnot body)) + (SMTLib2.of_bexpr ~type_hints:true + (BasilExpr.boolnot body)) acc in let acc = snd @@ SMTLib2.check_sat acc in diff --git a/lib/lang/algsimp.ml b/lib/lang/algsimp.ml index 3713994c4..00183e8b4 100644 --- a/lib/lang/algsimp.ml +++ b/lib/lang/algsimp.ml @@ -323,8 +323,10 @@ let if_then_else op = `Cases; args = [ - ( ApplyIntrin { op = `IfThen; args=[cond;br_true] }, - Types.Boolean ) | (BinaryExpr {op = `IfThen; arg1=cond; arg2=br_true;}, Types.Boolean); + ( ( ApplyIntrin { op = `IfThen; args = [ cond; br_true ] }, + Types.Boolean ) + | ( BinaryExpr { op = `IfThen; arg1 = cond; arg2 = br_true }, + Types.Boolean ) ); (br_false, _); ]; attrib; From e9140aa8652a64a48c97c8c781212d5630851b95 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 3 Aug 2026 15:44:16 +1000 Subject: [PATCH 42/67] Live running backend --- bin/main.ml | 10 +++ lib/backends/smt.ml | 167 +++++++++++++++++++++++++++++-------------- lib/lang/expr_smt.ml | 34 +++++++-- lib/passes.ml | 12 ++++ lib/script.ml | 11 +++ lib/util/smt.ml | 6 ++ 6 files changed, 180 insertions(+), 60 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 6de87f140..15c1ebc04 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -177,6 +177,16 @@ let repl ~verb ~echo_cmd = |> Iter.flat_map complete_filename |> Iter.map (fun s -> l ^ " " ^ s) |> Iter.iter (LNoise.add_completion completions) + | Ok (`Atom "live-smt" :: fnames as l) -> + let c = last fnames in + let l = + List.take (List.length l - opt_len c) l + |> List.to_string ~sep:" " CCSexp.to_string + in + (match c with Some n -> Iter.singleton n | None -> Iter.empty) + |> Iter.flat_map complete_filename + |> Iter.map (fun s -> l ^ " " ^ s) + |> Iter.iter (LNoise.add_completion completions) | Ok (`Atom "run-transforms" :: transforms as l) | Ok (`Atom "run-transform" :: transforms as l) -> let c = last transforms in diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 98c491048..44831a915 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -11,16 +11,25 @@ open Expr for verification. *) -let build_procedure (program : Program.t) (procedure : Program.proc) - (builder : SMTLib2.builder) : SMTLib2.builder = - let builder = snd @@ SMTLib2.push builder in +type context = { stmt : Program.stmt option; proc : ID.t option; vc : bool } + +let empty : context = { stmt = None; proc = None; vc = false } + +(* type context = Stmt of Program.stmt | Verify of Program.stmt | None *) + +(* Produce a list of builders for a procedure, with context. + Builder for local declarations + one for each statement. + Assertions produce a second builder for verification. *) +let build_procedure (program : Program.t) (procedure : Program.proc) : + (SMTLib2.builder * context) list = + let ctx = { empty with proc = Some (Procedure.id procedure) } in + + let builders = CCVector.create () in - (* Echo the name of the proc being verified. *) let builder = - snd - @@ SMTLib2.echo - ("Verifying Procedure: " ^ ID.name (Procedure.id procedure)) - builder + SMTLib2.empty |> SMTLib2.push |> snd + |> SMTLib2.echo ("Verifying Procedure: " ^ ID.name (Procedure.id procedure)) + |> snd in (* Generate a declaration for each local var. *) @@ -30,65 +39,113 @@ let build_procedure (program : Program.t) (procedure : Program.proc) |> Iter.fold (fun acc (k, v) -> snd @@ SMTLib2.decl_var v acc) builder in + CCVector.push builders (builder, ctx); + (* Translate each statement to smt. *) - let builder = - Procedure.iter_stmt_topo_fwd procedure - |> Iter.fold - (fun acc stmt -> - match stmt with - | Stmt.Instr_Assert { body } -> - (* Verify negation of assertion is unsat. *) - let acc = snd @@ SMTLib2.push acc in - let acc = - snd - @@ SMTLib2.add_assert - (SMTLib2.of_bexpr ~type_hints:true - (BasilExpr.boolnot body)) - acc - in - let acc = snd @@ SMTLib2.check_sat acc in - let acc = snd @@ SMTLib2.pop acc in - - (* Assert the assertion. *) - let smt = SMTLib2.of_bexpr ~type_hints:true body in - SMTLib2.add_assert smt acc |> snd - | Stmt.Instr_Assume { body } -> - (* Assert the assumption as is. *) - let smt = SMTLib2.of_bexpr ~type_hints:true body in - SMTLib2.add_assert smt acc |> snd - | Stmt.Instr_Assign { al } -> - let asserts = - List.map - (fun (v, e) -> - BasilExpr.binexp ~op:`EQ (BasilExpr.rvar v) e - |> SMTLib2.of_bexpr ~type_hints:true) - al - in - List.fold_left - (fun acc smt -> SMTLib2.add_assert smt acc |> snd) - acc asserts - | _ -> acc) - builder - in + Procedure.iter_stmt_topo_fwd procedure + |> flip Iter.for_each (fun stmt -> + let builder = SMTLib2.empty in + let ctx = { ctx with stmt = Some stmt; vc = false } in + match stmt with + | Stmt.Instr_Assert { body } -> + (* Verify negation of assertion is unsat. *) + let builder = snd @@ SMTLib2.push builder in + let builder = + snd + @@ SMTLib2.add_assert + (SMTLib2.of_bexpr ~type_hints:true (BasilExpr.boolnot body)) + builder + in + let builder = snd @@ SMTLib2.check_sat builder in + let builder = snd @@ SMTLib2.pop builder in + CCVector.push builders (builder, { ctx with vc = true }); + + (* Assert the actual assertion. *) + let smt = SMTLib2.of_bexpr ~type_hints:true body in + let builder = SMTLib2.add_assert smt SMTLib2.empty |> snd in + CCVector.push builders (builder, ctx) + | Stmt.Instr_Assume { body } -> + (* Assert the assumption as is. SSA makes this equiv to assume. *) + let smt = SMTLib2.of_bexpr ~type_hints:true body in + let builder = SMTLib2.add_assert smt builder |> snd in + CCVector.push builders (builder, ctx) + | Stmt.Instr_Assign { al } -> + (* Assign is just an assertion of equivalent lhs and rhs. + This is bidirectional, but SSA + Reachability conds avoid this + causing issues. *) + let asserts = + List.map + (fun (v, e) -> + BasilExpr.binexp ~op:`EQ (BasilExpr.rvar v) e + |> SMTLib2.of_bexpr ~type_hints:true) + al + in + let builder = + List.fold_left + (fun builder smt -> SMTLib2.add_assert smt builder |> snd) + builder asserts + in + CCVector.push builders (builder, ctx) + | _ -> ()); - let builder = snd @@ SMTLib2.pop builder in - builder + CCVector.push builders (SMTLib2.pop SMTLib2.empty |> snd, ctx); + CCVector.to_list builders let build_declaration (program : Program.t) (declaration : Program.declaration) - (builder : SMTLib2.builder) : SMTLib2.builder = + : (SMTLib2.builder * context) list = match declaration with - | Procedure { definition } -> build_procedure program definition builder + | Procedure { definition } -> build_procedure program definition | _ -> failwith "Unsupported SMT declaration" -let build_program (program : Program.t) (builder : SMTLib2.builder) : - SMTLib2.builder = +let build_program (program : Program.t) : (SMTLib2.builder * context) list = Program.declarations program |> Iter.map snd - |> Iter.fold (fun a b -> build_declaration program b a) builder + |> Iter.flat_map_l (fun d -> build_declaration program d) + |> Iter.to_list + +let eval_single chan (solver : Smt.Solver.t) + ((builder, context) : SMTLib2.builder * context) = + let sexps = SMTLib2.commands_to_sexp builder in + sexps + |> flip Iter.for_each (fun sexp -> + let response = Smt.Solver.add_sexp solver sexp in + match (context, response) with + | { stmt = Some stmt; vc = true }, `Atom "sat" -> + Printf.fprintf chan "Failing Assertion: %s\n" + (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt) + | _ -> ()) + +let eval_program chan (program : Program.t) = + flush chan; + let solver = + Bincaml_util.Smt.Solver.create + { + Bincaml_util.Smt.Config.cvc5 with + log = Bincaml_util.Smt.Config.quiet_log; + } + in + let builders = build_program program in + (* Join the builders together for computing unified declarations/preamble. *) + let builder = + List.fold_left + (fun acc b -> SMTLib2.append acc (fst b)) + SMTLib2.empty builders + in + let preamble = SMTLib2.preamble_to_sexp builder in + let decls = SMTLib2.decls_to_sexp builder in + Iter.append preamble decls + |> flip Iter.for_each (fun sexp -> Smt.Solver.add_command solver sexp); + builders |> List.to_iter |> flip Iter.for_each @@ eval_single chan solver; + flush chan let pretty_program (program : Program.t) : Containers_pp.t = let open Containers_pp in - let builder = build_program program SMTLib2.empty in + let builders = build_program program in + let builder = + List.fold_left + (fun acc b -> SMTLib2.append acc (fst b)) + SMTLib2.empty builders + in Expr_smt.SMTLib2.to_sexp ~set_logic:true builder |> Iter.map (Sexp.to_string %> text) |> Iter.to_list |> append_nl diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 459dff355..a3f057492 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -74,18 +74,42 @@ module SMTLib2 = struct let add_preamble (v : Sexp.t) (s : builder) = (v, { s with preamble = v :: s.preamble }) - let to_sexp ?(set_logic = true) b = - let open Iter.Infix in + let preamble_to_sexp ?(set_logic = true) b = let logic = if set_logic then [ list [ atom "set-logic"; atom (get_logic_string b.logics) ] ] else [] in - let preamble = List.to_iter (logic @ b.preamble) in - let decls = VarMap.to_iter b.var_decls >|= fun (v, d) -> d.decl_cmd in - let commands = List.rev b.commands |> List.to_iter in + List.to_iter (logic @ b.preamble) + + let decls_to_sexp b = + let open Iter.Infix in + VarMap.to_iter b.var_decls >|= fun (v, d) -> d.decl_cmd + + let commands_to_sexp b = List.rev b.commands |> List.to_iter + + let to_sexp ?(set_logic = true) b = + let open Iter.Infix in + let preamble = preamble_to_sexp ~set_logic b in + let decls = decls_to_sexp b in + let commands = commands_to_sexp b in preamble <+> decls <+> commands + let append (a : builder) (b : builder) = + { + preamble = b.preamble @ a.preamble; + var_decls = + VarMap.merge_safe + ~f: + ( const @@ function + | `Both (d1, d2) -> Some d2 + | `Left d -> Some d + | `Right d -> Some d ) + a.var_decls b.var_decls; + commands = b.commands @ a.commands; + logics = LSet.union a.logics b.logics; + } + let run (e : 'e t) = e empty let extract s = diff --git a/lib/passes.ml b/lib/passes.ml index ee23b637a..a219ea49a 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -68,6 +68,18 @@ module PassManager = struct prog); } + let live_smt out_channel = + { + name = "live-smt"; + doc = "Perform live smt analysis, outputting logs to channel."; + invariants = Invariants.make ~presupposes:[ SSA; NoPhis; NoSummaries ] (); + apply = + Prog + (fun prog -> + Backends.Smt.eval_program out_channel prog; + prog); + } + let lift_intrinsics_aarch64 = { name = "lift-intrinsics-aarch64"; diff --git a/lib/script.ml b/lib/script.ml index e5fc118d4..a6f94be2b 100644 --- a/lib/script.ml +++ b/lib/script.ml @@ -163,6 +163,16 @@ let dump_smt st ofile = in set_prog st prog) +let live_smt st ofile = + let ofile = P.(opt string ofile) in + file_opt ofile (fun c -> + let prog = + Some + (Passes.PassManager.run_transform (get_prog st) + (Passes.PassManager.live_smt c)) + in + set_prog st prog) + let interp_out st ofile = let ofile = P.(opt string ofile) in let prog = get_prog st in @@ -356,6 +366,7 @@ let cmds_list = ("dump-il", dump_il, "?file", "Write IL to file or stdout"); ("dump-boogie", dump_boogie, "?file", "Write Boogie to file or stdout"); ("dump-smt", dump_smt, "?file", "Write SMT to file or stdout"); + ("live-smt", live_smt, "?file", "Run SMT solver writing output to file or stdout"); ( "chc-dump-clauses", chc_dump_clauses, "", diff --git a/lib/util/smt.ml b/lib/util/smt.ml index 230c1c769..5d435275a 100644 --- a/lib/util/smt.ml +++ b/lib/util/smt.ml @@ -621,6 +621,9 @@ module Solver : sig val create : solver_config -> t (** Create a new solver with [config] *) + val add_sexp: t -> sexp -> sexp + (* Send a sexp to the solver, returning the result *) + val add_command : t -> sexp -> unit (** Send a command to the solver *) @@ -915,6 +918,9 @@ the model does not contain those. We need to explicitly add them. (** create a new solver with config *) let create conf = new_solver conf + let add_sexp solver cmd = + solver.command cmd + (** add a command to solver *) let add_command solver cmd = match solver.command cmd with From d870eebaa1cf8a45c0ab32d5bb832dabc245b1f9 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 3 Aug 2026 16:09:59 +1000 Subject: [PATCH 43/67] Better reporting and variable cleanup --- lib/backends/smt.ml | 35 ++++++++++++++++++++++++++++------- lib/passes.ml | 1 + 2 files changed, 29 insertions(+), 7 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 44831a915..951bbad04 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -11,7 +11,11 @@ open Expr for verification. *) -type context = { stmt : Program.stmt option; proc : ID.t option; vc : bool } +type context = { + stmt : Program.stmt option; + proc : Program.proc option; + vc : bool; +} let empty : context = { stmt = None; proc = None; vc = false } @@ -22,7 +26,7 @@ let empty : context = { stmt = None; proc = None; vc = false } Assertions produce a second builder for verification. *) let build_procedure (program : Program.t) (procedure : Program.proc) : (SMTLib2.builder * context) list = - let ctx = { empty with proc = Some (Procedure.id procedure) } in + let ctx = { empty with proc = Some procedure } in let builders = CCVector.create () in @@ -103,16 +107,32 @@ let build_program (program : Program.t) : (SMTLib2.builder * context) list = |> Iter.flat_map_l (fun d -> build_declaration program d) |> Iter.to_list -let eval_single chan (solver : Smt.Solver.t) +let eval_single chan (solver : Smt.Solver.t) (prog : Program.t) ((builder, context) : SMTLib2.builder * context) = let sexps = SMTLib2.commands_to_sexp builder in sexps |> flip Iter.for_each (fun sexp -> let response = Smt.Solver.add_sexp solver sexp in match (context, response) with - | { stmt = Some stmt; vc = true }, `Atom "sat" -> - Printf.fprintf chan "Failing Assertion: %s\n" - (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt) + | { stmt = Some stmt; proc = Some proc; vc = true }, `Atom "sat" -> ( + Printf.fprintf chan "\nFailing Assertion: %s\n" + (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt); + Printf.fprintf chan "Belonging to procedure: %s\n" + (ID.name @@ Procedure.id proc); + Printf.fprintf chan "Counterexample:\n"; + let model = Smt.Solver.get_model solver in + match model with + | `Atom a -> Printf.fprintf chan "%s\n" (Sexp.to_string model) + | `List l -> + l |> List.to_iter + |> Iter.filter (function + | `List (`Atom "define-fun" :: `Atom var :: _ :: `Atom typ :: _) + -> + Procedure.lookup_local_decl proc var |> Option.is_some + || Program.get_decl_by_name var prog |> Option.is_some + | _ -> false) + |> flip Iter.for_each (fun s -> + Printf.fprintf chan "%s\n" (Sexp.to_string s))) | _ -> ()) let eval_program chan (program : Program.t) = @@ -135,7 +155,8 @@ let eval_program chan (program : Program.t) = let decls = SMTLib2.decls_to_sexp builder in Iter.append preamble decls |> flip Iter.for_each (fun sexp -> Smt.Solver.add_command solver sexp); - builders |> List.to_iter |> flip Iter.for_each @@ eval_single chan solver; + builders |> List.to_iter + |> flip Iter.for_each @@ eval_single chan solver program; flush chan let pretty_program (program : Program.t) : Containers_pp.t = diff --git a/lib/passes.ml b/lib/passes.ml index a219ea49a..7d4ccd417 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -453,6 +453,7 @@ module PassManager = struct cf_exprs; inter_dead; cleanup_cfg; + remove_unused; ] in { From 1f7293ac7b7d3820de3b35968cefdb4a753e1daf Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 3 Aug 2026 16:12:51 +1000 Subject: [PATCH 44/67] cleanup debug print --- lib/transforms/remove_loops.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/transforms/remove_loops.ml b/lib/transforms/remove_loops.ml index 0d946cec2..8387b597a 100644 --- a/lib/transforms/remove_loops.ml +++ b/lib/transforms/remove_loops.ml @@ -111,7 +111,6 @@ let transform_proc (prog : Program.t) (proc_id : IDSet.elt) | `ReducibleHeader -> true | _ -> false) in - Printf.printf "length: %d\n" @@ List.length loops; List.fold_left (transform_loop prog) proc loops let transform (prog : Program.t) = From 475db6de2b82e5b8e0a0366af5c13d06e5f011b3 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 3 Aug 2026 16:13:14 +1000 Subject: [PATCH 45/67] formatter --- lib/script.ml | 5 ++++- lib/util/smt.ml | 5 ++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/lib/script.ml b/lib/script.ml index a6f94be2b..9bab65b24 100644 --- a/lib/script.ml +++ b/lib/script.ml @@ -366,7 +366,10 @@ let cmds_list = ("dump-il", dump_il, "?file", "Write IL to file or stdout"); ("dump-boogie", dump_boogie, "?file", "Write Boogie to file or stdout"); ("dump-smt", dump_smt, "?file", "Write SMT to file or stdout"); - ("live-smt", live_smt, "?file", "Run SMT solver writing output to file or stdout"); + ( "live-smt", + live_smt, + "?file", + "Run SMT solver writing output to file or stdout" ); ( "chc-dump-clauses", chc_dump_clauses, "", diff --git a/lib/util/smt.ml b/lib/util/smt.ml index 5d435275a..936cce517 100644 --- a/lib/util/smt.ml +++ b/lib/util/smt.ml @@ -621,7 +621,7 @@ module Solver : sig val create : solver_config -> t (** Create a new solver with [config] *) - val add_sexp: t -> sexp -> sexp + val add_sexp : t -> sexp -> sexp (* Send a sexp to the solver, returning the result *) val add_command : t -> sexp -> unit @@ -918,8 +918,7 @@ the model does not contain those. We need to explicitly add them. (** create a new solver with config *) let create conf = new_solver conf - let add_sexp solver cmd = - solver.command cmd + let add_sexp solver cmd = solver.command cmd (** add a command to solver *) let add_command solver cmd = From 4c619768fe64eaa784d1bfc2fac44a223fddd5be Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 4 Aug 2026 15:10:37 +1000 Subject: [PATCH 46/67] idk --- lib/backends/smt.ml | 11 ++++++++-- lib/lang/expr_smt.ml | 25 ++++++++++++++-------- lib/passes.ml | 2 +- lib/transforms/cfa_reduction.ml | 38 +++++++++++++++++---------------- 4 files changed, 46 insertions(+), 30 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 951bbad04..f8700b294 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -19,7 +19,11 @@ type context = { let empty : context = { stmt = None; proc = None; vc = false } -(* type context = Stmt of Program.stmt | Verify of Program.stmt | None *) +(* let build_procedure (program : Program.t) binding typ : *) + (* (SMTLib2.builder * context) list = *) + (* let ctx = empty in *) + (* Expr_smt.SMTLib2.decls_to_sexp *) + (* [] *) (* Produce a list of builders for a procedure, with context. Builder for local declarations + one for each statement. @@ -99,11 +103,14 @@ let build_declaration (program : Program.t) (declaration : Program.declaration) : (SMTLib2.builder * context) list = match declaration with | Procedure { definition } -> build_procedure program definition - | _ -> failwith "Unsupported SMT declaration" + | other -> [(SMTLib2.trans_decl declaration SMTLib2.empty |> snd, empty)] + (* | Type { binding; typ; } -> build_type program binding typ *) + (* | _ -> failwith "Unsupported SMT declaration" *) let build_program (program : Program.t) : (SMTLib2.builder * context) list = Program.declarations program |> Iter.map snd + |> Iter.rev |> Iter.flat_map_l (fun d -> build_declaration program d) |> Iter.to_list diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index a3f057492..cf4bd2563 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -65,7 +65,7 @@ module SMTLib2 = struct let add_command (v : Sexp.t) (s : builder) = let asrt = v in - (asrt, { s with commands = asrt :: s.commands }) + (asrt, { s with commands = asrt :: s.commands; logics = s.logics }) let add_assert (v : Sexp.t) (s : builder) = let asrt = list [ atom "assert"; v ] in @@ -498,9 +498,13 @@ module SMTLib2 = struct let trans_decl (decl : Program.declaration) = let* x = return () in match decl with - | Type { binding; typ = Sort (name, [ { variant; fields = [] } ]) } -> - return (Bincaml_util.Smt.Expr.declare_sort variant 0) - | Type { binding; typ = Sort (name, vs) } -> + | Type { binding; typ = Sort (name, [ { variant; fields = [] } ]) as typ } + -> + let sexp = Bincaml_util.Smt.Expr.declare_sort variant 0 in + let* _ = add_preamble sexp in + let* _ = add_logic DT in + return sexp + | Type { binding; typ = Sort (name, vs) as typ } -> let fields = List.map Types.( @@ -512,9 +516,12 @@ module SMTLib2 = struct fields )) vs in - return (Bincaml_util.Smt.Expr.declare_datatype name [] fields) + let sexp = Bincaml_util.Smt.Expr.declare_datatype name [] fields in + let* _ = add_preamble sexp in + let* _ = add_logic DT in + return sexp | Type { binding; typ } -> - return (list [ atom "decl-sort"; fst @@ of_typ typ ]) + add_preamble (list [ atom "decl-sort"; fst @@ of_typ typ ]) | Function { binding; attrib; definition = Function body } -> let op, bound_vars, in_body = match BasilExpr.unfix body with @@ -530,7 +537,7 @@ module SMTLib2 = struct let r = Expr.BasilExpr.type_of in_body in let* body = bind_of_bexpr in_body in let r = fst (of_typ r) in - return + add_preamble @@ list [ atom "define-fun"; @@ -541,12 +548,12 @@ module SMTLib2 = struct ] | Function { binding; definition = Axiom body } -> let* body = bind_of_bexpr body in - return @@ list [ atom "assert"; body ] + add_preamble @@ list [ atom "assert"; body ] | Function { binding; attrib; definition = Uninterpreted } -> let args, r = Var.typ binding |> Types.uncurry in let args = List.map (of_typ %> fst) args in let r = fst (of_typ r) in - return + add_preamble @@ list [ atom "declare-fun"; smt_symbol (Var.name binding); list args; r ] | Variable v -> failwith "mutable" diff --git a/lib/passes.ml b/lib/passes.ml index 7d4ccd417..d7b11afc9 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -93,7 +93,7 @@ module PassManager = struct let sparams = { name = "simple-params"; - apply = Prog Transforms.Ssa.set_params; + apply = Prog (Transforms.Ssa.set_params ~skip_observable:false ~skip_maps:false); doc = "Pull all global variables into the parameter list, discarding initial \ parameter list (i.e. assuming its empty)"; diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index b2dd9b330..c8bbba708 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -123,21 +123,23 @@ let construct_final_edge proc = |> CCVector.freeze let reduce_procedure (proc : Program.proc) : Program.proc = - (* Constructed reduced edge to replace procedure blocks. *) - let final_edge = construct_final_edge proc in - - let proc = - proc |> Procedure.iter_blocks |> Iter.map fst - |> Iter.fold (fun acc id -> Procedure.remove_block acc id) proc - in - let proc, id = Procedure.fresh_block proc ~stmts:[] () in - let proc = - Procedure.modify_block proc id (fun b -> { b with stmts = final_edge }) - in - - (* Make this the entry and return block. *) - let proc = Procedure.set_entry_block proc id in - Procedure.PG.map_graph - (fun g -> - Procedure.G.add_edge g (Procedure.Vert.End id) Procedure.Vert.Return) - proc + if Procedure.graph proc |> Option.is_none then proc + else + (* Constructed reduced edge to replace procedure blocks. *) + let final_edge = construct_final_edge proc in + + let proc = + proc |> Procedure.iter_blocks |> Iter.map fst + |> Iter.fold (fun acc id -> Procedure.remove_block acc id) proc + in + let proc, id = Procedure.fresh_block proc ~stmts:[] () in + let proc = + Procedure.modify_block proc id (fun b -> { b with stmts = final_edge }) + in + + (* Make this the entry and return block. *) + let proc = Procedure.set_entry_block proc id in + Procedure.PG.map_graph + (fun g -> + Procedure.G.add_edge g (Procedure.Vert.End id) Procedure.Vert.Return) + proc From 5bc171d922da4e7b5e6099edce6547e14c9c2818 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 4 Aug 2026 17:30:16 +1000 Subject: [PATCH 47/67] boogie type fix --- lib/backends/smt.ml | 2 - lib/lang/expr_smt.ml | 3 +- lib/transforms/memory_encoding.ml | 67 +++++++++---------------------- 3 files changed, 21 insertions(+), 51 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index f8700b294..00b407349 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -104,8 +104,6 @@ let build_declaration (program : Program.t) (declaration : Program.declaration) match declaration with | Procedure { definition } -> build_procedure program definition | other -> [(SMTLib2.trans_decl declaration SMTLib2.empty |> snd, empty)] - (* | Type { binding; typ; } -> build_type program binding typ *) - (* | _ -> failwith "Unsupported SMT declaration" *) let build_program (program : Program.t) : (SMTLib2.builder * context) list = Program.declarations program diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index cf4bd2563..ec8cacccb 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -417,7 +417,7 @@ module SMTLib2 = struct let* var = get_var id in match type_hints with | true -> return @@ list [ atom "as"; var; fst @@ of_typ @@ Var.typ id ] - | false -> return @@ var) + | false -> fun s -> ((if s.var_decls |> VarMap.get id |> Option.is_some then var else var), s)) | UnaryExpr { op = `BOOLTOBV1; arg = e } -> let* e = e in return @@ -485,6 +485,7 @@ module SMTLib2 = struct | ApplyFun { func; args } -> let* args = sequence args in let* func = func in + print_endline (Sexp.to_string func); return @@ list (func :: args) let bind_of_bexpr ?(type_hints = false) e = diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index f3604956e..a09cb8c15 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -17,23 +17,21 @@ end module Calls = struct open BasilExpr + let func name args ret = + rvar + (Var.create name ~scope:GlobalConst + (Types.curry (List.map Expr.BasilExpr.type_of args) @@ ret)) + (** [addr_is_heap args] checks if an address belongs to the heap. args(0) is the memory encoding object. args(1) is the address to check. *) let addr_is_heap ?attrib args = - apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_addr_is_heap" ~scope:Var.GlobalConst Types.Boolean)) - args + apply_fun ?attrib ~func:(func "$me_addr_is_heap" args Types.Boolean) args (** [alloc_base args] returns the base address of a supplied allocation id. args(0) is the memory encoding object. args(1) is the allocation id. *) let alloc_base ?attrib args = apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_alloc_base" ~scope:Var.GlobalConst - (Types.Bitvector 64))) + ~func:(func "$me_alloc_base" args (Types.Bitvector 64)) args (** [alloc_live args] returns the liveness of an allocation. Returns value is @@ -41,40 +39,28 @@ module Calls = struct encoding object. args(1) is the allocation id. *) let alloc_live ?attrib args = apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_alloc_live" ~scope:Var.GlobalConst - (Types.Bitvector 2))) + ~func:(func "$me_alloc_live" args (Types.Bitvector 2)) args (** [alloc_size args] returns the size of an allocation. args(0) is the memory encoding object. args(1) is the allocation id. *) let alloc_size ?attrib args = apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_alloc_size" ~scope:Var.GlobalConst - (Types.Bitvector 64))) + ~func:(func "$me_alloc_size" args (Types.Bitvector 64)) args (** [addr_alloc args] returns the allocation id of an address. args(0) is the memory encoding object. args(1) is the address. *) let addr_alloc ?attrib args = apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_addr_alloc" ~scope:Var.GlobalConst - (Types.Bitvector 64))) + ~func:(func "$me_addr_alloc" args (Types.Bitvector 64)) args (** [addr_offset args] returns the offset an address is into its allocation. args(0) is the memory encoding object. args(1) is the address. *) let addr_offset ?attrib args = apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_addr_offset" ~scope:Var.GlobalConst - (Types.Bitvector 64))) + ~func:(func "$me_addr_offset" args (Types.Bitvector 64)) args (** [alloc_size_update args] returns a new memory encoding with the size of an @@ -82,10 +68,7 @@ module Calls = struct allocation id. args(2) is the new size. *) let alloc_size_update ?attrib args = apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_alloc_size_update" ~scope:Var.GlobalConst - Globals.mem_encoding_typ)) + ~func:(func "$me_alloc_size_update" args Globals.mem_encoding_typ) args (** [alloc_live_update args] returns a new memory encoding with the liveness @@ -93,39 +76,25 @@ module Calls = struct is the allocation id. args(2) is the new liveness value as a bv3. *) let alloc_live_update ?attrib args = apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_alloc_live_update" ~scope:Var.GlobalConst - Globals.mem_encoding_typ)) + ~func:(func "$me_alloc_live_update" args Globals.mem_encoding_typ) args (** [allocate args] allocates space at a size. args(0) is the memory encoding object, args(1) is the updated encoding. args(2) is the address being allocated at. args(3) is the size of the allocation. *) let allocate ?attrib args = - apply_fun ?attrib - ~func: - (rvar (Var.create "$me_allocate" ~scope:Var.GlobalConst Types.Boolean)) - args + apply_fun ?attrib ~func:(func "$me_allocate" args Types.Boolean) args (** [can_alloc args] Returns whether an alloc, performed by [allocate], is valid/allowed. args(0) is the memory encoding object. args(1) is the target address. args(2) is the size of the allocation. *) let can_alloc ?attrib args = - apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_can_allocate" ~scope:Var.GlobalConst Types.Boolean)) - args + apply_fun ?attrib ~func:(func "$me_can_allocate" args Types.Boolean) args (** [init_encoding args] Returns if a memory encoding is initialized. args(0) is the memory encoding. *) let init_encoding ?attrib args = - apply_fun ?attrib - ~func: - (rvar - (Var.create "$me_init_encoding" ~scope:Var.GlobalConst Types.Boolean)) - args + apply_fun ?attrib ~func:(func "$me_init_encoding" args Types.Boolean) args (** [valid_access args] Checks if an access is valid. args(0) is the memory encoding object. args(1) is the address being accessed. args(2) is the @@ -134,7 +103,9 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_valid_access" ~scope:Var.GlobalConst Types.Boolean)) + (Var.create "$me_valid_access" ~scope:GlobalConst + (Types.curry (List.map Expr.BasilExpr.type_of args) + @@ Types.Boolean))) args end From a46830742698c1168f9fd92614a5634ca19b5f42 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 7 Aug 2026 15:43:25 +1000 Subject: [PATCH 48/67] disambiguating variables, removing duplicate types --- lib/backends/smt.ml | 81 +++++++++++++++++++++++++++++++------------- lib/lang/expr_smt.ml | 19 +++++------ lib/util/var.ml | 14 ++++++-- 3 files changed, 78 insertions(+), 36 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 00b407349..368e6b526 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -19,12 +19,6 @@ type context = { let empty : context = { stmt = None; proc = None; vc = false } -(* let build_procedure (program : Program.t) binding typ : *) - (* (SMTLib2.builder * context) list = *) - (* let ctx = empty in *) - (* Expr_smt.SMTLib2.decls_to_sexp *) - (* [] *) - (* Produce a list of builders for a procedure, with context. Builder for local declarations + one for each statement. Assertions produce a second builder for verification. *) @@ -61,7 +55,7 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : let builder = snd @@ SMTLib2.add_assert - (SMTLib2.of_bexpr ~type_hints:true (BasilExpr.boolnot body)) + (SMTLib2.of_bexpr ~rvars:VarMap.empty (BasilExpr.boolnot body)) builder in let builder = snd @@ SMTLib2.check_sat builder in @@ -69,12 +63,12 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : CCVector.push builders (builder, { ctx with vc = true }); (* Assert the actual assertion. *) - let smt = SMTLib2.of_bexpr ~type_hints:true body in + let smt = SMTLib2.of_bexpr ~rvars:VarMap.empty body in let builder = SMTLib2.add_assert smt SMTLib2.empty |> snd in CCVector.push builders (builder, ctx) | Stmt.Instr_Assume { body } -> (* Assert the assumption as is. SSA makes this equiv to assume. *) - let smt = SMTLib2.of_bexpr ~type_hints:true body in + let smt = SMTLib2.of_bexpr ~rvars:VarMap.empty body in let builder = SMTLib2.add_assert smt builder |> snd in CCVector.push builders (builder, ctx) | Stmt.Instr_Assign { al } -> @@ -85,7 +79,7 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : List.map (fun (v, e) -> BasilExpr.binexp ~op:`EQ (BasilExpr.rvar v) e - |> SMTLib2.of_bexpr ~type_hints:true) + |> SMTLib2.of_bexpr ~rvars:VarMap.empty) al in let builder = @@ -103,15 +97,63 @@ let build_declaration (program : Program.t) (declaration : Program.declaration) : (SMTLib2.builder * context) list = match declaration with | Procedure { definition } -> build_procedure program definition - | other -> [(SMTLib2.trans_decl declaration SMTLib2.empty |> snd, empty)] + | other -> [ (SMTLib2.trans_decl declaration SMTLib2.empty |> snd, empty) ] let build_program (program : Program.t) : (SMTLib2.builder * context) list = Program.declarations program - |> Iter.map snd - |> Iter.rev + |> Iter.map snd |> Iter.rev |> Iter.flat_map_l (fun d -> build_declaration program d) |> Iter.to_list +(* Joins a list of builders (disregarding context), removing any duplicate declarations + caused by sort/variable types. *) +let join_builders (builders : (SMTLib2.builder * context) list) : + SMTLib2.builder = + let builder = + List.fold_left + (fun acc b -> SMTLib2.append acc (fst b)) + SMTLib2.empty builders + in + + let removals = + VarMap.to_iter builder.var_decls + |> Iter.filter_map (fun (var, _) -> + match Var.typ var with + | Sort (name, _) -> Some (Var.copy ~typ:(Types.Variable name) var) + | _ -> None) + |> VarSet.of_iter + in + + { + builder with + var_decls = + builder.var_decls + |> VarMap.filter (fun var _ -> not @@ VarSet.mem var removals); + } + +(* Get any ambiguous variables (shared name, different type). *) +let ambiguities (program : Program.t) = + Program.procs program + (* Get all variables in program: *) + |> Iter.flat_map + (snd %> Procedure.iter_blocks + %> Iter.flat_map (fun (_, b) -> + Iter.append (Block.read_vars_iter b) (Block.assigned_vars_iter b))) + (* Group variables by name: *) + |> Iter.group_by + ~hash:(fun v -> Hash.string @@ Var.name v) + ~eq:(fun v1 v2 -> String.equal (Var.name v1) (Var.name v2)) + (* Only keep lists of length > 1: *) + |> Iter.filter (List.length %> ( > ) 1) + +(* Map rvars to sexps, necessary to handle ambiguities and + function calls which are sensitive to context in program. *) +let rvar_map (program : Program.t) = + ambiguities program |> Iter.flat_map_l (List.map (fun v -> + (* TODO *) + fun s -> CCSexp.(list [ atom "as"; fst @@ SMTLib2.get_var v s; ]) + )) + let eval_single chan (solver : Smt.Solver.t) (prog : Program.t) ((builder, context) : SMTLib2.builder * context) = let sexps = SMTLib2.commands_to_sexp builder in @@ -149,13 +191,10 @@ let eval_program chan (program : Program.t) = log = Bincaml_util.Smt.Config.quiet_log; } in + ambiguities program |> StringSet.to_string id |> print_endline; let builders = build_program program in (* Join the builders together for computing unified declarations/preamble. *) - let builder = - List.fold_left - (fun acc b -> SMTLib2.append acc (fst b)) - SMTLib2.empty builders - in + let builder = join_builders builders in let preamble = SMTLib2.preamble_to_sexp builder in let decls = SMTLib2.decls_to_sexp builder in Iter.append preamble decls @@ -167,11 +206,7 @@ let eval_program chan (program : Program.t) = let pretty_program (program : Program.t) : Containers_pp.t = let open Containers_pp in let builders = build_program program in - let builder = - List.fold_left - (fun acc b -> SMTLib2.append acc (fst b)) - SMTLib2.empty builders - in + let builder = join_builders builders in Expr_smt.SMTLib2.to_sexp ~set_logic:true builder |> Iter.map (Sexp.to_string %> text) |> Iter.to_list |> append_nl diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index ec8cacccb..551f0cd2f 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -349,7 +349,8 @@ module SMTLib2 = struct logics = LSet.union logics s.logics; } ) - let get_var v = fun s -> decl_var v s + let get_var v = fun s -> + decl_var v s let of_op (op : @@ -408,16 +409,14 @@ module SMTLib2 = struct let* body = in_body in return @@ list [ quant; list binds; body ] - let smt_alg ~type_hints (e : sexp t BasilExpr.abstract_expr) : sexp t = + let smt_alg ?(rvars : sexp t VarMap.t = VarMap.empty) + (e : sexp t BasilExpr.abstract_expr) : sexp t = match e with | Constant { const = o } -> let* o = add_logic_const o in return (of_op o) | RVar { id } -> ( - let* var = get_var id in - match type_hints with - | true -> return @@ list [ atom "as"; var; fst @@ of_typ @@ Var.typ id ] - | false -> fun s -> ((if s.var_decls |> VarMap.get id |> Option.is_some then var else var), s)) + match VarMap.get id rvars with Some s -> s | None -> get_var id) | UnaryExpr { op = `BOOLTOBV1; arg = e } -> let* e = e in return @@ -485,16 +484,14 @@ module SMTLib2 = struct | ApplyFun { func; args } -> let* args = sequence args in let* func = func in - print_endline (Sexp.to_string func); return @@ list (func :: args) - let bind_of_bexpr ?(type_hints = false) e = + let bind_of_bexpr ?rvars e = let e = (BasilExpr.rewrite_typed_two Algsimp.drop_assoc) e in let e = (BasilExpr.rewrite_typed_two Algsimp.if_then_else) e in - BasilExpr.cata (smt_alg ~type_hints) e + BasilExpr.cata (smt_alg ?rvars) e - let of_bexpr ?(type_hints = false) e = - fst @@ (bind_of_bexpr ~type_hints e) empty + let of_bexpr ?rvars e = fst @@ (bind_of_bexpr ?rvars e) empty let trans_decl (decl : Program.declaration) = let* x = return () in diff --git a/lib/util/var.ml b/lib/util/var.ml index 1ba6d0570..d3ab55aa4 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -24,9 +24,19 @@ include ( let create name ?(scope = LocalVar) typ = (* disallow creating local const as its too hard to have declaration order *) - match scope with + let out = match scope with | LocalConst -> H.make { name; typ; scope = LocalVar } - | _ -> H.make { name; typ; scope } + | _ -> H.make { name; typ; scope } in + let _ = + match name with "mem_encoding_out" -> print_endline "got one"; + print_endline (V.show (Fix.HashCons.data out)); + print_endline (Int.to_string @@ V.hash (Fix.HashCons.data out)); + print_endline (Int.to_string @@ Fix.HashCons.id out); + print_endline (Int.to_string @@ Hash.poly typ); + + | _ -> () + in + out let copy ?name ?scope ?typ (v : t) = let v = Fix.HashCons.data v in From a2b78a1fcc3cfc259e075228fee9fa71f2c4c55a Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 10 Aug 2026 10:17:46 +1000 Subject: [PATCH 49/67] Minimal variable disambiguation --- lib/backends/smt.ml | 67 ++++++++++++++++++++++++++------------------- 1 file changed, 39 insertions(+), 28 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 368e6b526..9375cbadb 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -19,6 +19,39 @@ type context = { let empty : context = { stmt = None; proc = None; vc = false } +(* Get any ambiguous variables (shared name, different type). *) +let ambiguities (program : Program.t) : VarSet.t Iter.t = + Program.procs program + (* Get all variables in program: *) + |> Iter.flat_map + (snd %> Procedure.iter_blocks + %> Iter.flat_map (fun (_, b) -> + Iter.append (Block.read_vars_iter b) (Block.assigned_vars_iter b))) + (* Group variables by name: *) + |> Iter.group_by + ~hash:(fun v -> Hash.string @@ Var.name v) + ~eq:(fun v1 v2 -> String.equal (Var.name v1) (Var.name v2)) + |> Iter.map VarSet.of_list + (* Only keep lists of length > 1: *) + |> Iter.filter (VarSet.cardinal %> ( <= ) 2) + +(* Map rvars to sexps, necessary to handle ambiguities and + function calls which are sensitive to context in program. *) +let rvar_map (program : Program.t) = + ambiguities program + (* Map all ambiguous variables to as expressions. *) + |> Iter.flat_map + @@ VarSet.to_iter + %> Iter.map (fun v -> + let sexp = + fun s -> + let var, s = SMTLib2.get_var v s in + let typ = fst @@ SMTLib2.of_typ (Var.typ v) in + (CCSexp.(list [ atom "as"; var; typ ]), s) + in + (v, sexp)) + |> VarMap.of_iter + (* Produce a list of builders for a procedure, with context. Builder for local declarations + one for each statement. Assertions produce a second builder for verification. *) @@ -43,6 +76,8 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : CCVector.push builders (builder, ctx); + let rvars = rvar_map program in + (* Translate each statement to smt. *) Procedure.iter_stmt_topo_fwd procedure |> flip Iter.for_each (fun stmt -> @@ -55,7 +90,7 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : let builder = snd @@ SMTLib2.add_assert - (SMTLib2.of_bexpr ~rvars:VarMap.empty (BasilExpr.boolnot body)) + (SMTLib2.of_bexpr ~rvars (BasilExpr.boolnot body)) builder in let builder = snd @@ SMTLib2.check_sat builder in @@ -63,12 +98,12 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : CCVector.push builders (builder, { ctx with vc = true }); (* Assert the actual assertion. *) - let smt = SMTLib2.of_bexpr ~rvars:VarMap.empty body in + let smt = SMTLib2.of_bexpr ~rvars body in let builder = SMTLib2.add_assert smt SMTLib2.empty |> snd in CCVector.push builders (builder, ctx) | Stmt.Instr_Assume { body } -> (* Assert the assumption as is. SSA makes this equiv to assume. *) - let smt = SMTLib2.of_bexpr ~rvars:VarMap.empty body in + let smt = SMTLib2.of_bexpr ~rvars body in let builder = SMTLib2.add_assert smt builder |> snd in CCVector.push builders (builder, ctx) | Stmt.Instr_Assign { al } -> @@ -79,7 +114,7 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : List.map (fun (v, e) -> BasilExpr.binexp ~op:`EQ (BasilExpr.rvar v) e - |> SMTLib2.of_bexpr ~rvars:VarMap.empty) + |> SMTLib2.of_bexpr ~rvars) al in let builder = @@ -131,29 +166,6 @@ let join_builders (builders : (SMTLib2.builder * context) list) : |> VarMap.filter (fun var _ -> not @@ VarSet.mem var removals); } -(* Get any ambiguous variables (shared name, different type). *) -let ambiguities (program : Program.t) = - Program.procs program - (* Get all variables in program: *) - |> Iter.flat_map - (snd %> Procedure.iter_blocks - %> Iter.flat_map (fun (_, b) -> - Iter.append (Block.read_vars_iter b) (Block.assigned_vars_iter b))) - (* Group variables by name: *) - |> Iter.group_by - ~hash:(fun v -> Hash.string @@ Var.name v) - ~eq:(fun v1 v2 -> String.equal (Var.name v1) (Var.name v2)) - (* Only keep lists of length > 1: *) - |> Iter.filter (List.length %> ( > ) 1) - -(* Map rvars to sexps, necessary to handle ambiguities and - function calls which are sensitive to context in program. *) -let rvar_map (program : Program.t) = - ambiguities program |> Iter.flat_map_l (List.map (fun v -> - (* TODO *) - fun s -> CCSexp.(list [ atom "as"; fst @@ SMTLib2.get_var v s; ]) - )) - let eval_single chan (solver : Smt.Solver.t) (prog : Program.t) ((builder, context) : SMTLib2.builder * context) = let sexps = SMTLib2.commands_to_sexp builder in @@ -191,7 +203,6 @@ let eval_program chan (program : Program.t) = log = Bincaml_util.Smt.Config.quiet_log; } in - ambiguities program |> StringSet.to_string id |> print_endline; let builders = build_program program in (* Join the builders together for computing unified declarations/preamble. *) let builder = join_builders builders in From 8b22614c04952114f89d90592ece661010fd8e09 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 10 Aug 2026 15:48:24 +1000 Subject: [PATCH 50/67] Triggers support --- lib/backends/smt.ml | 53 +++++++++++++++++++++++++++++++------------- lib/lang/expr_smt.ml | 27 +++++++++++++++++----- 2 files changed, 60 insertions(+), 20 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 9375cbadb..3cd4b21d1 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -55,7 +55,7 @@ let rvar_map (program : Program.t) = (* Produce a list of builders for a procedure, with context. Builder for local declarations + one for each statement. Assertions produce a second builder for verification. *) -let build_procedure (program : Program.t) (procedure : Program.proc) : +let build_procedure ~rvars (program : Program.t) (procedure : Program.proc) : (SMTLib2.builder * context) list = let ctx = { empty with proc = Some procedure } in @@ -76,8 +76,6 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : CCVector.push builders (builder, ctx); - let rvars = rvar_map program in - (* Translate each statement to smt. *) Procedure.iter_stmt_topo_fwd procedure |> flip Iter.for_each (fun stmt -> @@ -128,16 +126,17 @@ let build_procedure (program : Program.t) (procedure : Program.proc) : CCVector.push builders (SMTLib2.pop SMTLib2.empty |> snd, ctx); CCVector.to_list builders -let build_declaration (program : Program.t) (declaration : Program.declaration) - : (SMTLib2.builder * context) list = +let build_declaration ~rvars (program : Program.t) + (declaration : Program.declaration) : (SMTLib2.builder * context) list = match declaration with - | Procedure { definition } -> build_procedure program definition + | Procedure { definition } -> build_procedure ~rvars program definition | other -> [ (SMTLib2.trans_decl declaration SMTLib2.empty |> snd, empty) ] let build_program (program : Program.t) : (SMTLib2.builder * context) list = + let rvars = rvar_map program in Program.declarations program |> Iter.map snd |> Iter.rev - |> Iter.flat_map_l (fun d -> build_declaration program d) + |> Iter.flat_map_l (fun d -> build_declaration ~rvars program d) |> Iter.to_list (* Joins a list of builders (disregarding context), removing any duplicate declarations @@ -170,17 +169,17 @@ let eval_single chan (solver : Smt.Solver.t) (prog : Program.t) ((builder, context) : SMTLib2.builder * context) = let sexps = SMTLib2.commands_to_sexp builder in sexps - |> flip Iter.for_each (fun sexp -> + |> Iter.map (fun sexp -> let response = Smt.Solver.add_sexp solver sexp in match (context, response) with - | { stmt = Some stmt; proc = Some proc; vc = true }, `Atom "sat" -> ( + | { stmt = Some stmt; proc = Some proc; vc = true }, `Atom "sat" -> Printf.fprintf chan "\nFailing Assertion: %s\n" (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt); Printf.fprintf chan "Belonging to procedure: %s\n" (ID.name @@ Procedure.id proc); Printf.fprintf chan "Counterexample:\n"; let model = Smt.Solver.get_model solver in - match model with + (match model with | `Atom a -> Printf.fprintf chan "%s\n" (Sexp.to_string model) | `List l -> l |> List.to_iter @@ -191,8 +190,15 @@ let eval_single chan (solver : Smt.Solver.t) (prog : Program.t) || Program.get_decl_by_name var prog |> Option.is_some | _ -> false) |> flip Iter.for_each (fun s -> - Printf.fprintf chan "%s\n" (Sexp.to_string s))) - | _ -> ()) + Printf.fprintf chan "%s\n" (Sexp.to_string s))); + (`Fail, Some (Procedure.id proc)) + | { stmt = Some stmt; proc = Some proc; vc = true }, `Atom "unknown" -> + Printf.fprintf chan "\nUnknown Assertion:\n%s\n" + (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt); + (`Unknown, Some (Procedure.id proc)) + | { proc = Some proc; vc = true }, _ -> + (`Success, Some (Procedure.id proc)) + | _ -> (`Skip, None)) let eval_program chan (program : Program.t) = flush chan; @@ -200,7 +206,7 @@ let eval_program chan (program : Program.t) = Bincaml_util.Smt.Solver.create { Bincaml_util.Smt.Config.cvc5 with - log = Bincaml_util.Smt.Config.quiet_log; + log = Bincaml_util.Smt.Config.printf_log; } in let builders = build_program program in @@ -210,8 +216,25 @@ let eval_program chan (program : Program.t) = let decls = SMTLib2.decls_to_sexp builder in Iter.append preamble decls |> flip Iter.for_each (fun sexp -> Smt.Solver.add_command solver sexp); - builders |> List.to_iter - |> flip Iter.for_each @@ eval_single chan solver program; + let results = + builders |> List.to_iter + |> Iter.flat_map @@ eval_single chan solver program + |> Iter.filter_map (fun (a, b) -> Option.map (fun i -> (a, i)) b) + |> Iter.map (fun (a, b) -> (b, a)) + |> Hashtbl.of_iter_count + in + Program.procs program |> Iter.map fst + |> flip Iter.for_each (fun id -> + Printf.fprintf chan "\nProcedure %s verified with:\n" (ID.name id); + [ `Success; `Fail; `Unknown ] + |> List.to_iter + |> flip Iter.for_each (fun res -> + let count = Hashtbl.get_or ~default:0 results (id, res) in + Printf.fprintf chan "%d %s assertions.\n" count + (match res with + | `Success -> "succeeding" + | `Fail -> "failing" + | _ -> "unknown"))); flush chan let pretty_program (program : Program.t) : Containers_pp.t = diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 551f0cd2f..ca7133c1e 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -349,8 +349,7 @@ module SMTLib2 = struct logics = LSet.union logics s.logics; } ) - let get_var v = fun s -> - decl_var v s + let get_var v = fun s -> decl_var v s let of_op (op : @@ -427,8 +426,7 @@ module SMTLib2 = struct of_op (`Bitvector (Bitvec.one ~size:1)); of_op (`Bitvector (Bitvec.zero ~size:1)); ] - | Lambda { op; bound_vars; in_body } -> - (* TODO: trigger *) + | Lambda { op; bound_vars; in_body; triggers } -> let names = List.map (Var.name %> smt_symbol) bound_vars in let types = List.map (Var.typ %> of_typ %> fst) bound_vars in let binds = @@ -441,9 +439,28 @@ module SMTLib2 = struct | `Exists -> "exists" | `Lambda -> "lambda" in + (* for body B, introducing triggers replaced it with the sexp: + (! B :pattern (t1_1 ... t1_n) ... :pattern (tm_1 .. tm_n)) + where ti_j are triggers for each pattern. *) + let* triggers = + fun s -> + triggers + |> List.fold_flat_map + (fun acc inner -> + let inner, acc = sequence inner acc in + let inner = List.map (fun i -> list [i]) inner in + (acc, atom ":pattern" :: inner)) + s + |> function + | a, b -> (b, a) + in + let in_body = + if List.length triggers > 0 then + list ([ atom "!"; in_body ] @ triggers) + else in_body + in return @@ list [ atom o; list binds; in_body ] | Let { bound_vars; in_body } -> - (* TODO: trigger *) let* in_body = in_body in let* binds = sequence From 5945b6bb96aaaebc01e45230a33b1266f17783e3 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 10 Aug 2026 16:19:11 +1000 Subject: [PATCH 51/67] fixed missing id check --- lib/backends/smt.ml | 2 +- lib/lang/expr_smt.ml | 4 ++-- lib/transforms/summary_inlining.ml | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 3cd4b21d1..3b173f463 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -206,7 +206,7 @@ let eval_program chan (program : Program.t) = Bincaml_util.Smt.Solver.create { Bincaml_util.Smt.Config.cvc5 with - log = Bincaml_util.Smt.Config.printf_log; + log = Bincaml_util.Smt.Config.quiet_log; } in let builders = build_program program in diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index ca7133c1e..456005395 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -440,8 +440,8 @@ module SMTLib2 = struct | `Lambda -> "lambda" in (* for body B, introducing triggers replaced it with the sexp: - (! B :pattern (t1_1 ... t1_n) ... :pattern (tm_1 .. tm_n)) - where ti_j are triggers for each pattern. *) + (! B :pattern (t1_1 ... t1_a) ... :pattern (tn_1 .. tn_b)) + where ti_j are j expressions from trigger i. *) let* triggers = fun s -> triggers diff --git a/lib/transforms/summary_inlining.ml b/lib/transforms/summary_inlining.ml index 92101bf01..197efddf1 100644 --- a/lib/transforms/summary_inlining.ml +++ b/lib/transforms/summary_inlining.ml @@ -60,7 +60,7 @@ let transform_block (prog : Program.t) (proc : Program.proc) (* Add requires to entry block. *) let spec = Procedure.specification proc in let block = - if match List.head_opt entry_id with Some bid -> true | _ -> false then + if match List.head_opt entry_id with Some id -> ID.equal bid id | _ -> false then Block.prepend_stmts block (List.map (fun e -> @@ -71,7 +71,7 @@ let transform_block (prog : Program.t) (proc : Program.proc) in (* Add ensures to return block. *) - if match List.head_opt return_id with Some bid -> true | _ -> false then + if match List.head_opt return_id with Some id -> ID.equal bid id| _ -> false then Block.append_stmts block (List.map (fun e -> Stmt.Instr_Assert { attrib = StringMap.empty; body = e }) From 5a53292d0e6fca656f9aa7e87a860a2025435ba8 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 09:26:51 +1000 Subject: [PATCH 52/67] test promotion --- lib/passes.ml | 2 +- lib/util/var.ml | 16 +++------------- test/cram/loop_removal.t | 12 +++++------- test/cram/smt_backend.t | 6 +++--- test/cram/sva.t | 2 +- 5 files changed, 13 insertions(+), 25 deletions(-) diff --git a/lib/passes.ml b/lib/passes.ml index d7b11afc9..b315fd470 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -93,7 +93,7 @@ module PassManager = struct let sparams = { name = "simple-params"; - apply = Prog (Transforms.Ssa.set_params ~skip_observable:false ~skip_maps:false); + apply = Prog (Transforms.Ssa.set_params ~skip_observable:true ~skip_maps:true); doc = "Pull all global variables into the parameter list, discarding initial \ parameter list (i.e. assuming its empty)"; diff --git a/lib/util/var.ml b/lib/util/var.ml index d3ab55aa4..7f3173e64 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -24,19 +24,9 @@ include ( let create name ?(scope = LocalVar) typ = (* disallow creating local const as its too hard to have declaration order *) - let out = match scope with - | LocalConst -> H.make { name; typ; scope = LocalVar } - | _ -> H.make { name; typ; scope } in - let _ = - match name with "mem_encoding_out" -> print_endline "got one"; - print_endline (V.show (Fix.HashCons.data out)); - print_endline (Int.to_string @@ V.hash (Fix.HashCons.data out)); - print_endline (Int.to_string @@ Fix.HashCons.id out); - print_endline (Int.to_string @@ Hash.poly typ); - - | _ -> () - in - out + match scope with + | LocalConst -> H.make { name; typ; scope = LocalVar } + | _ -> H.make { name; typ; scope } let copy ?name ?scope ?typ (v : t) = let v = Fix.HashCons.data v in diff --git a/test/cram/loop_removal.t b/test/cram/loop_removal.t index 37b5f654c..16302c732 100644 --- a/test/cram/loop_removal.t +++ b/test/cram/loop_removal.t @@ -4,8 +4,6 @@ bincaml: [INFO] found 4 loops, 0 irreducible bincaml: [INFO] found 4 loops, 0 irreducible (run-transform remove-loops) - length: 1 - length: 1 (run-transform ssa) (run-transform inline-summaries) (run-transform cfa-reduction) @@ -15,16 +13,16 @@ (dump-boogie ./out.bpl) $ cvc5 ./out.smt --incremental - "Verifying Procedure: @f1_good" - unsat - unsat "Verifying Procedure: @f1_bad" unsat sat + "Verifying Procedure: @f1_good" + unsat + unsat $ boogie ./out.bpl - ./out.bpl(50,5): Error: this assertion could not be proved + ./out.bpl(36,5): Error: this assertion could not be proved Execution trace: - ./out.bpl(42,3): b#block + ./out.bpl(28,3): b#block Boogie program verifier finished with 1 verified, 1 error diff --git a/test/cram/smt_backend.t b/test/cram/smt_backend.t index f6075e467..c35796778 100644 --- a/test/cram/smt_backend.t +++ b/test/cram/smt_backend.t @@ -6,11 +6,11 @@ (dump-smt ./out.smt) (dump-il ./out.il) $ cvc5 ./out.smt --incremental - "Verifying Procedure: @bad_square" + "Verifying Procedure: @f3" sat + unsat "Verifying Procedure: @f2" unsat unsat - "Verifying Procedure: @f3" + "Verifying Procedure: @bad_square" sat - unsat diff --git a/test/cram/sva.t b/test/cram/sva.t index b4be47cb9..a3023d697 100644 --- a/test/cram/sva.t +++ b/test/cram/sva.t @@ -2,4 +2,4 @@ (load-il ../../examples/irreducible_loop_1.il) (run-transforms ssa sva) (CF_in->(Par(@puts_1584_{ Var.V.name = "CF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_in->(Par(@puts_1584_{ Var.V.name = "NF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_in->(Par(@puts_1584_{ Var.V.name = "R0_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_in->(Par(@puts_1584_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_in->(Par(@puts_1584_{ Var.V.name = "R29_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@puts_1584_{ Var.V.name = "R30_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_in->(Stack(@puts_1584)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_in->(Par(@puts_1584_{ Var.V.name = "VF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_in->(Par(@puts_1584_{ Var.V.name = "ZF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), _->⊥) - (CF_in->(Par(@main_1876_{ Var.V.name = "CF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_in->(Par(@main_1876_{ Var.V.name = "NF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_in->(Par(@main_1876_{ Var.V.name = "R0_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_in->(Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_in->(Par(@main_1876_{ Var.V.name = "R29_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@main_1876_{ Var.V.name = "R30_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_in->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_in->(Par(@main_1876_{ Var.V.name = "VF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_in->(Par(@main_1876_{ Var.V.name = "ZF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), CF_out->(Ret(@puts_1584_{ Var.V.name = "CF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_out->(Ret(@puts_1584_{ Var.V.name = "NF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_out->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_out->(Ret(@puts_1584_{ Var.V.name = "R1_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_out->(Loaded(load21_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_out->(Loaded(load22_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_out->(Ret(@puts_1584_{ Var.V.name = "R31_7"; typ = bv64; scope = Var.LocalVar })->⟦0x20:bv64, 0x20:bv64⟧, _->⊥), VF_out->(Ret(@puts_1584_{ Var.V.name = "VF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_out->(Ret(@puts_1584_{ Var.V.name = "ZF_12"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), CF_1->(Par(@main_1876_{ Var.V.name = "CF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_1->(Par(@main_1876_{ Var.V.name = "NF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_1->(Par(@main_1876_{ Var.V.name = "R0_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_1->(Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_1->(Par(@main_1876_{ Var.V.name = "R29_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_1->(Par(@main_1876_{ Var.V.name = "R30_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_1->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_1->(Par(@main_1876_{ Var.V.name = "VF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_1->(Par(@main_1876_{ Var.V.name = "ZF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), #4_1->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R31_2->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R29_2->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R0_2->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_3->(Constant->⟦0x2003c:bv64, 0x2003c:bv64⟧, _->⊥), R0_4->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_5->(Constant->⟦0x20040:bv64, 0x20040:bv64⟧, _->⊥), load18_1->(Loaded(load18_1)->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), R0_6->(Loaded(load18_1)->⊤, _->⊥), R0_7->(Loaded(load18_1)->⊤, _->⊥), #5_1->(Loaded(load18_1)->⊤, _->⊥), VF_2->(Loaded(load18_1)->⊤, _->⊥), CF_2->(Loaded(load18_1)->⊤, _->⊥), ZF_2->(Loaded(load18_1)->⊤, _->⊥), NF_2->(Loaded(load18_1)->⊤, _->⊥), ZF_3->(Loaded(load18_1)->⊤, _->⊥), ZF_4->(Loaded(load18_1)->⊤, _->⊥), ZF_5->(Ret(@puts_1584_{ Var.V.name = "ZF_10"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), VF_3->(Ret(@puts_1584_{ Var.V.name = "VF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), R31_3->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, Ret(@puts_1584_{ Var.V.name = "R31_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_3->(Ret(@puts_1584_{ Var.V.name = "R29_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R1_2->(Loaded(load19_1)->⊤, Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), NF_3->(Ret(@puts_1584_{ Var.V.name = "NF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), CF_3->(Ret(@puts_1584_{ Var.V.name = "CF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), R0_8->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R0_9->(Constant->⟦0x820:bv64, 0x820:bv64⟧, _->⊥), R30_2->(Constant->⟦0x7d0:bv64, 0x7d0:bv64⟧, _->⊥), CF_4->(Ret(@puts_1584_{ Var.V.name = "CF_4"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_4->(Ret(@puts_1584_{ Var.V.name = "NF_4"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_10->(Ret(@puts_1584_{ Var.V.name = "R0_10"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_3->(Ret(@puts_1584_{ Var.V.name = "R1_3"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_4->(Ret(@puts_1584_{ Var.V.name = "R29_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_3->(Ret(@puts_1584_{ Var.V.name = "R30_3"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_4->(Ret(@puts_1584_{ Var.V.name = "R31_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_4->(Ret(@puts_1584_{ Var.V.name = "VF_4"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_6->(Ret(@puts_1584_{ Var.V.name = "ZF_6"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_11->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_12->(Constant->⟦0x2003c:bv64, 0x2003c:bv64⟧, _->⊥), load20_1->(Loaded(load20_1)->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), R0_13->(Loaded(load20_1)->⊤, _->⊥), #6_1->(Loaded(load20_1)->⊤, _->⊥), VF_5->(Loaded(load20_1)->⊤, _->⊥), CF_5->(Loaded(load20_1)->⊤, _->⊥), ZF_7->(Loaded(load20_1)->⊤, _->⊥), NF_5->(Loaded(load20_1)->⊤, _->⊥), ZF_8->(Loaded(load20_1)->⊤, _->⊥), ZF_9->(Loaded(load18_1)->⊤, Loaded(load20_1)->⊤, _->⊥), VF_6->(Loaded(load18_1)->⊤, Loaded(load20_1)->⊤, _->⊥), R31_5->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, Ret(@puts_1584_{ Var.V.name = "R31_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_5->(Ret(@puts_1584_{ Var.V.name = "R29_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R1_4->(Ret(@puts_1584_{ Var.V.name = "R1_3"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), NF_6->(Loaded(load18_1)->⊤, Loaded(load20_1)->⊤, _->⊥), CF_6->(Loaded(load18_1)->⊤, Loaded(load20_1)->⊤, _->⊥), R0_14->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R0_15->(Constant->⟦0x820:bv64, 0x820:bv64⟧, _->⊥), R30_4->(Constant->⟦0x7a0:bv64, 0x7a0:bv64⟧, _->⊥), CF_7->(Ret(@puts_1584_{ Var.V.name = "CF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_7->(Ret(@puts_1584_{ Var.V.name = "NF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_16->(Ret(@puts_1584_{ Var.V.name = "R0_16"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_5->(Ret(@puts_1584_{ Var.V.name = "R1_5"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_6->(Ret(@puts_1584_{ Var.V.name = "R29_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_5->(Ret(@puts_1584_{ Var.V.name = "R30_5"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_6->(Ret(@puts_1584_{ Var.V.name = "R31_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_7->(Ret(@puts_1584_{ Var.V.name = "VF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_10->(Ret(@puts_1584_{ Var.V.name = "ZF_10"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_17->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_18->(Constant->⟦0x2003c:bv64, 0x2003c:bv64⟧, _->⊥), load19_1->(Loaded(load19_1)->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), R0_19->(Loaded(load19_1)->⊤, _->⊥), R1_6->(Loaded(load19_1)->⊤, _->⊥), R0_20->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_21->(Constant->⟦0x2003c:bv64, 0x2003c:bv64⟧, _->⊥), ZF_11->(Loaded(load20_1)->⊤, _->⊥), R0_22->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R0_23->(Constant->⟦0x828:bv64, 0x828:bv64⟧, _->⊥), R30_6->(Constant->⟦0x7f4:bv64, 0x7f4:bv64⟧, _->⊥), CF_8->(Ret(@puts_1584_{ Var.V.name = "CF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_8->(Ret(@puts_1584_{ Var.V.name = "NF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_24->(Ret(@puts_1584_{ Var.V.name = "R0_24"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_7->(Ret(@puts_1584_{ Var.V.name = "R1_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_7->(Ret(@puts_1584_{ Var.V.name = "R29_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_7->(Ret(@puts_1584_{ Var.V.name = "R30_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_7->(Ret(@puts_1584_{ Var.V.name = "R31_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_8->(Ret(@puts_1584_{ Var.V.name = "VF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_12->(Ret(@puts_1584_{ Var.V.name = "ZF_12"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_25->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), load21_1->(Loaded(load21_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_8->(Loaded(load21_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), load22_1->(Loaded(load22_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_8->(Loaded(load22_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_8->(Ret(@puts_1584_{ Var.V.name = "R31_7"; typ = bv64; scope = Var.LocalVar })->⟦0x20:bv64, 0x20:bv64⟧, _->⊥), _->⊥) + (CF_in->(Par(@main_1876_{ Var.V.name = "CF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_in->(Par(@main_1876_{ Var.V.name = "NF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_in->(Par(@main_1876_{ Var.V.name = "R0_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_in->(Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_in->(Par(@main_1876_{ Var.V.name = "R29_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@main_1876_{ Var.V.name = "R30_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_in->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_in->(Par(@main_1876_{ Var.V.name = "VF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_in->(Par(@main_1876_{ Var.V.name = "ZF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), CF_out->(Ret(@puts_1584_{ Var.V.name = "CF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_out->(Ret(@puts_1584_{ Var.V.name = "NF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_out->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_out->(Ret(@puts_1584_{ Var.V.name = "R1_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_out->(Loaded(load21_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_out->(Loaded(load22_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_out->(Ret(@puts_1584_{ Var.V.name = "R31_7"; typ = bv64; scope = Var.LocalVar })->⟦0x20:bv64, 0x20:bv64⟧, _->⊥), VF_out->(Ret(@puts_1584_{ Var.V.name = "VF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_out->(Ret(@puts_1584_{ Var.V.name = "ZF_12"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), CF_1->(Par(@main_1876_{ Var.V.name = "CF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_1->(Par(@main_1876_{ Var.V.name = "NF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_1->(Par(@main_1876_{ Var.V.name = "R0_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_1->(Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_1->(Par(@main_1876_{ Var.V.name = "R29_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_1->(Par(@main_1876_{ Var.V.name = "R30_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_1->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_1->(Par(@main_1876_{ Var.V.name = "VF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_1->(Par(@main_1876_{ Var.V.name = "ZF_in"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), #4_1->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R31_2->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R29_2->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R0_2->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_3->(Constant->⟦0x2003c:bv64, 0x2003c:bv64⟧, _->⊥), R0_4->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_5->(Constant->⟦0x20040:bv64, 0x20040:bv64⟧, _->⊥), load18_1->(Loaded(load18_1)->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), R0_6->(Loaded(load18_1)->⊤, _->⊥), R0_7->(Loaded(load18_1)->⊤, _->⊥), #5_1->(Loaded(load18_1)->⊤, _->⊥), VF_2->(Loaded(load18_1)->⊤, _->⊥), CF_2->(Loaded(load18_1)->⊤, _->⊥), ZF_2->(Loaded(load18_1)->⊤, _->⊥), NF_2->(Loaded(load18_1)->⊤, _->⊥), ZF_3->(Loaded(load18_1)->⊤, _->⊥), ZF_4->(Loaded(load18_1)->⊤, _->⊥), ZF_5->(Ret(@puts_1584_{ Var.V.name = "ZF_10"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), VF_3->(Ret(@puts_1584_{ Var.V.name = "VF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), R31_3->(Ret(@puts_1584_{ Var.V.name = "R31_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R29_3->(Ret(@puts_1584_{ Var.V.name = "R29_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R1_2->(Loaded(load19_1)->⊤, Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), NF_3->(Ret(@puts_1584_{ Var.V.name = "NF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), CF_3->(Ret(@puts_1584_{ Var.V.name = "CF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), R0_8->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R0_9->(Constant->⟦0x820:bv64, 0x820:bv64⟧, _->⊥), R30_2->(Constant->⟦0x7d0:bv64, 0x7d0:bv64⟧, _->⊥), CF_4->(Ret(@puts_1584_{ Var.V.name = "CF_4"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_4->(Ret(@puts_1584_{ Var.V.name = "NF_4"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_10->(Ret(@puts_1584_{ Var.V.name = "R0_10"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_3->(Ret(@puts_1584_{ Var.V.name = "R1_3"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_4->(Ret(@puts_1584_{ Var.V.name = "R29_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_3->(Ret(@puts_1584_{ Var.V.name = "R30_3"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_4->(Ret(@puts_1584_{ Var.V.name = "R31_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_4->(Ret(@puts_1584_{ Var.V.name = "VF_4"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_6->(Ret(@puts_1584_{ Var.V.name = "ZF_6"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_11->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_12->(Constant->⟦0x2003c:bv64, 0x2003c:bv64⟧, _->⊥), load20_1->(Loaded(load20_1)->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), R0_13->(Loaded(load20_1)->⊤, _->⊥), #6_1->(Loaded(load20_1)->⊤, _->⊥), VF_5->(Loaded(load20_1)->⊤, _->⊥), CF_5->(Loaded(load20_1)->⊤, _->⊥), ZF_7->(Loaded(load20_1)->⊤, _->⊥), NF_5->(Loaded(load20_1)->⊤, _->⊥), ZF_8->(Loaded(load20_1)->⊤, _->⊥), ZF_9->(Loaded(load20_1)->⊤, Loaded(load18_1)->⊤, _->⊥), VF_6->(Loaded(load20_1)->⊤, Loaded(load18_1)->⊤, _->⊥), R31_5->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, Ret(@puts_1584_{ Var.V.name = "R31_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_5->(Ret(@puts_1584_{ Var.V.name = "R29_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R1_4->(Ret(@puts_1584_{ Var.V.name = "R1_3"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), NF_6->(Loaded(load20_1)->⊤, Loaded(load18_1)->⊤, _->⊥), CF_6->(Loaded(load20_1)->⊤, Loaded(load18_1)->⊤, _->⊥), R0_14->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R0_15->(Constant->⟦0x820:bv64, 0x820:bv64⟧, _->⊥), R30_4->(Constant->⟦0x7a0:bv64, 0x7a0:bv64⟧, _->⊥), CF_7->(Ret(@puts_1584_{ Var.V.name = "CF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_7->(Ret(@puts_1584_{ Var.V.name = "NF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_16->(Ret(@puts_1584_{ Var.V.name = "R0_16"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_5->(Ret(@puts_1584_{ Var.V.name = "R1_5"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_6->(Ret(@puts_1584_{ Var.V.name = "R29_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_5->(Ret(@puts_1584_{ Var.V.name = "R30_5"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_6->(Ret(@puts_1584_{ Var.V.name = "R31_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_7->(Ret(@puts_1584_{ Var.V.name = "VF_7"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_10->(Ret(@puts_1584_{ Var.V.name = "ZF_10"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_17->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_18->(Constant->⟦0x2003c:bv64, 0x2003c:bv64⟧, _->⊥), load19_1->(Loaded(load19_1)->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), R0_19->(Loaded(load19_1)->⊤, _->⊥), R1_6->(Loaded(load19_1)->⊤, _->⊥), R0_20->(Constant->⟦0x20000:bv64, 0x20000:bv64⟧, _->⊥), R0_21->(Constant->⟦0x2003c:bv64, 0x2003c:bv64⟧, _->⊥), ZF_11->(Loaded(load20_1)->⊤, _->⊥), R0_22->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R0_23->(Constant->⟦0x828:bv64, 0x828:bv64⟧, _->⊥), R30_6->(Constant->⟦0x7f4:bv64, 0x7f4:bv64⟧, _->⊥), CF_8->(Ret(@puts_1584_{ Var.V.name = "CF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_8->(Ret(@puts_1584_{ Var.V.name = "NF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_24->(Ret(@puts_1584_{ Var.V.name = "R0_24"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_7->(Ret(@puts_1584_{ Var.V.name = "R1_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_7->(Ret(@puts_1584_{ Var.V.name = "R29_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_7->(Ret(@puts_1584_{ Var.V.name = "R30_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_7->(Ret(@puts_1584_{ Var.V.name = "R31_7"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_8->(Ret(@puts_1584_{ Var.V.name = "VF_8"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_12->(Ret(@puts_1584_{ Var.V.name = "ZF_12"; typ = bv1; scope = Var.LocalVar })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_25->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), load21_1->(Loaded(load21_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_8->(Loaded(load21_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), load22_1->(Loaded(load22_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_8->(Loaded(load22_1)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_8->(Ret(@puts_1584_{ Var.V.name = "R31_7"; typ = bv64; scope = Var.LocalVar })->⟦0x20:bv64, 0x20:bv64⟧, _->⊥), _->⊥) From 1a5613e8f1232dd70bcd0080530275113a4097f5 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 09:37:34 +1000 Subject: [PATCH 53/67] restored ssa to skip maps/observable --- lib/backends/smt.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 3b173f463..31c6bf761 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -133,6 +133,9 @@ let build_declaration ~rvars (program : Program.t) | other -> [ (SMTLib2.trans_decl declaration SMTLib2.empty |> snd, empty) ] let build_program (program : Program.t) : (SMTLib2.builder * context) list = + let program = + (Transforms.Ssa.set_params ~skip_observable:false ~skip_maps:false) program + in let rvars = rvar_map program in Program.declarations program |> Iter.map snd |> Iter.rev @@ -223,7 +226,9 @@ let eval_program chan (program : Program.t) = |> Iter.map (fun (a, b) -> (b, a)) |> Hashtbl.of_iter_count in - Program.procs program |> Iter.map fst + Program.procs program + |> Iter.filter (snd %> Procedure.graph %> Option.is_some) + |> Iter.map fst |> flip Iter.for_each (fun id -> Printf.fprintf chan "\nProcedure %s verified with:\n" (ID.name id); [ `Success; `Fail; `Unknown ] From 895852ffdec9d0e9c2dab6da302fd03c6770ccee Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 09:40:46 +1000 Subject: [PATCH 54/67] test for live smt backend --- test/cram/memory_safety.t | 77 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) diff --git a/test/cram/memory_safety.t b/test/cram/memory_safety.t index 4462128e9..f03888a7b 100644 --- a/test/cram/memory_safety.t +++ b/test/cram/memory_safety.t @@ -9,6 +9,14 @@ > (run-transforms dynamic-single-assignment) > (dump-il after.il) > (dump-boogie out.bpl) + > + > (run-transform irreducible-loops) + > (run-transform remove-loops) + > (run-transform ssa) + > (run-transform inline-summaries) + > (run-transform cfa-reduction) + > (run-transforms simplify) + > (live-smt) > EOF (load-il ../../examples/memory/memory_safety.il) (run-transforms ssa) @@ -20,6 +28,75 @@ (run-transforms dynamic-single-assignment) (dump-il after.il) (dump-boogie out.bpl) + (run-transform irreducible-loops) + bincaml: [INFO] found 0 loops, 0 irreducible + bincaml: [INFO] found 0 loops, 0 irreducible + bincaml: [INFO] found 4 loops, 0 irreducible + bincaml: [INFO] found 4 loops, 0 irreducible + bincaml: [INFO] found 4 loops, 0 irreducible + bincaml: [INFO] found 4 loops, 0 irreducible + bincaml: [INFO] found 4 loops, 0 irreducible + bincaml: [INFO] found 4 loops, 0 irreducible + (run-transform remove-loops) + (run-transform ssa) + (run-transform inline-summaries) + (run-transform cfa-reduction) + (run-transforms simplify) + (live-smt) + + Unknown Assertion: + assert boolor(forall { .boogie = { .msg = "Memory Error: Memory Leak" } } (i:bv64) :: (boolor(neq(($me_alloc_live)(mem_encoding_6:memory_encoding, + ($me_addr_alloc)(mem_encoding_6:memory_encoding, i:bv64)), 0x1:bv2), + boolnot(($me_addr_is_heap)(mem_encoding_6:memory_encoding, i:bv64)))), + boolnot(trm_1:bool)) + + Unknown Assertion: + assert boolor(($me_valid_access)(mem_encoding_7:memory_encoding, + bvadd(addr_5:bv64, 0x4:bv64), 0x1:bv64), boolnot(trm_1:bool)) { .boogie = { .msg = "Memory Error: Invalid Access" } } + + Unknown Assertion: + assert boolor(($me_valid_access)(mem_encoding_10:memory_encoding, addr_5:bv64, + 0x1:bv64), boolnot(trm_1:bool)) { .boogie = { .msg = "Memory Error: Invalid Access" } } + + Unknown Assertion: + assert boolor(eq { .boogie = { .msg = "Memory Error: Invalid Free (not base address)" } }(0x0:bv64, + ($me_addr_offset)(mem_encoding_5:memory_encoding, bvadd(addr_3:bv64, 0x1:bv64))), + boolnot(trm_1:bool)) + + Unknown Assertion: + assert boolor(eq { .boogie = { .msg = "Memory Error: Invalid Free (object not live)" } }(($me_alloc_live)(mem_encoding_13:memory_encoding, + ($me_addr_alloc)(mem_encoding_13:memory_encoding, addr_5:bv64)), 0x1:bv2), + boolnot(trm_1:bool)) + + Procedure @main verified with: + 24 succeeding assertions. + 0 failing assertions. + 0 unknown assertions. + + Procedure @double_free verified with: + 35 succeeding assertions. + 0 failing assertions. + 1 unknown assertions. + + Procedure @invalid_free verified with: + 15 succeeding assertions. + 0 failing assertions. + 1 unknown assertions. + + Procedure @use_after_free verified with: + 23 succeeding assertions. + 0 failing assertions. + 1 unknown assertions. + + Procedure @out_of_bounds verified with: + 23 succeeding assertions. + 0 failing assertions. + 1 unknown assertions. + + Procedure @memory_leak verified with: + 11 succeeding assertions. + 0 failing assertions. + 1 unknown assertions. $ boogie out.bpl Memory Error: Invalid Free (object not live) Execution trace: From 4b4d65cfc55287806cb321db60fa8946052afd10 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 09:42:15 +1000 Subject: [PATCH 55/67] Simpler live smt test --- test/cram/smt_backend.sexp | 1 + test/cram/smt_backend.t | 1 + 2 files changed, 2 insertions(+) diff --git a/test/cram/smt_backend.sexp b/test/cram/smt_backend.sexp index 6872d4baa..f93dea52d 100644 --- a/test/cram/smt_backend.sexp +++ b/test/cram/smt_backend.sexp @@ -4,3 +4,4 @@ (run-transforms "inline-summaries") (dump-smt "./out.smt") (dump-il "./out.il") +(live-smt) diff --git a/test/cram/smt_backend.t b/test/cram/smt_backend.t index c35796778..123ac13d2 100644 --- a/test/cram/smt_backend.t +++ b/test/cram/smt_backend.t @@ -5,6 +5,7 @@ (run-transforms inline-summaries) (dump-smt ./out.smt) (dump-il ./out.il) + (live-smt) $ cvc5 ./out.smt --incremental "Verifying Procedure: @f3" sat From 31768afce2af752f8943907392f22f9ab2ce8573 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 09:42:28 +1000 Subject: [PATCH 56/67] promote test --- test/cram/smt_backend.t | 25 +++++++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/test/cram/smt_backend.t b/test/cram/smt_backend.t index 123ac13d2..530331f3a 100644 --- a/test/cram/smt_backend.t +++ b/test/cram/smt_backend.t @@ -6,6 +6,31 @@ (dump-smt ./out.smt) (dump-il ./out.il) (live-smt) + + Failing Assertion: assert boolnot(bvslt(x_1:bv64, 0x0:bv64)) + Belonging to procedure: @f3 + Counterexample: + (define-fun trm () Bool false) + + Failing Assertion: assert eq(y:bv64, bvmul(x:bv64, x:bv64)) + Belonging to procedure: @bad_square + Counterexample: + (define-fun trm () Bool true) + + Procedure @bad_square verified with: + 3 succeeding assertions. + 1 failing assertions. + 0 unknown assertions. + + Procedure @f2 verified with: + 8 succeeding assertions. + 0 failing assertions. + 0 unknown assertions. + + Procedure @f3 verified with: + 7 succeeding assertions. + 1 failing assertions. + 0 unknown assertions. $ cvc5 ./out.smt --incremental "Verifying Procedure: @f3" sat From 2c1cbdeaddb945eeb7fdcfa1526b68d2581e4640 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 09:50:26 +1000 Subject: [PATCH 57/67] Improements from PR review --- bin/main.ml | 11 +---------- lib/backends/smt.ml | 8 +++----- lib/invariants.ml | 2 +- lib/lang/algsimp.ml | 1 + lib/transforms/cfa_reduction.ml | 13 ++++--------- lib/transforms/summary_inlining.ml | 30 ++++++++++++++++-------------- 6 files changed, 26 insertions(+), 39 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index 15c1ebc04..b44f2438f 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -167,16 +167,7 @@ let repl ~verb ~echo_cmd = |> Iter.flat_map complete_filename |> Iter.map (fun s -> l ^ " " ^ s) |> Iter.iter (LNoise.add_completion completions) - | Ok (`Atom "dump-smt" :: fnames as l) -> - let c = last fnames in - let l = - List.take (List.length l - opt_len c) l - |> List.to_string ~sep:" " CCSexp.to_string - in - (match c with Some n -> Iter.singleton n | None -> Iter.empty) - |> Iter.flat_map complete_filename - |> Iter.map (fun s -> l ^ " " ^ s) - |> Iter.iter (LNoise.add_completion completions) + | Ok (`Atom "dump-smt" :: fnames as l) | Ok (`Atom "live-smt" :: fnames as l) -> let c = last fnames in let l = diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 31c6bf761..39182483e 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -5,11 +5,9 @@ open Bincaml_util open Expr_smt open Expr -(* SMT Backend. - This backend expects the CFA Reduction and Summary Inlining transforms. - Will output a .smt file containing all declarations and asserts necessary - for verification. -*) +(** SMT Backend. This backend expects the CFA Reduction and Summary Inlining + transforms. Will output a .smt file containing all declarations and asserts + necessary for verification. *) type context = { stmt : Program.stmt option; diff --git a/lib/invariants.ml b/lib/invariants.ml index 9483f9f81..9ac79ab83 100644 --- a/lib/invariants.ml +++ b/lib/invariants.ml @@ -19,9 +19,9 @@ type t = | MemoryEncoding | GtirbArm | ReducibleLoops - | Acyclic (** All loops are reducible. That is, there are no {i irreducible} loops. *) + | Acyclic [@@deriving show { with_path = false }, eq, ord] let read s = diff --git a/lib/lang/algsimp.ml b/lib/lang/algsimp.ml index 00183e8b4..6bde5f7b3 100644 --- a/lib/lang/algsimp.ml +++ b/lib/lang/algsimp.ml @@ -312,6 +312,7 @@ let algebraic_simplifications replace [%here] arg | _ -> Keep +(** Simplify case expressions over booleans into if-then-else chains. *) let if_then_else (e : (BasilExpr.t BasilExpr.abstract_expr * Types.t) BasilExpr.abstract_expr) = diff --git a/lib/transforms/cfa_reduction.ml b/lib/transforms/cfa_reduction.ml index c8bbba708..c406c2f51 100644 --- a/lib/transforms/cfa_reduction.ml +++ b/lib/transforms/cfa_reduction.ml @@ -91,15 +91,10 @@ let construct_final_edge proc = non_guard_stmts |> List.partition_filter_map (function | Stmt.Instr_Assert { body; attrib } -> - `Left - (Stmt.Instr_Assert - { - body = - BasilExpr.binexp ~op:`IMPLIES - (BasilExpr.rvar termination_var) - body; - attrib; - }) + let body = + BasilExpr.(binexp ~op:`IMPLIES (rvar termination_var) body) + in + `Left (Stmt.Instr_Assert { body; attrib }) | other -> `Right other) in diff --git a/lib/transforms/summary_inlining.ml b/lib/transforms/summary_inlining.ml index 197efddf1..2e6c1cbf9 100644 --- a/lib/transforms/summary_inlining.ml +++ b/lib/transforms/summary_inlining.ml @@ -60,23 +60,25 @@ let transform_block (prog : Program.t) (proc : Program.proc) (* Add requires to entry block. *) let spec = Procedure.specification proc in let block = - if match List.head_opt entry_id with Some id -> ID.equal bid id | _ -> false then - Block.prepend_stmts block - (List.map - (fun e -> - Stmt.Instr_Assume - { attrib = StringMap.empty; body = e; branch = false }) - spec.requires) - else block + match List.head_opt entry_id with + | Some id when ID.equal bid id -> + Block.prepend_stmts block + (List.map + (fun e -> + Stmt.Instr_Assume + { attrib = StringMap.empty; body = e; branch = false }) + spec.requires) + | _ -> block in (* Add ensures to return block. *) - if match List.head_opt return_id with Some id -> ID.equal bid id| _ -> false then - Block.append_stmts block - (List.map - (fun e -> Stmt.Instr_Assert { attrib = StringMap.empty; body = e }) - spec.ensures) - else block + match List.head_opt return_id with + | Some id when ID.equal bid id -> + Block.append_stmts block + (List.map + (fun e -> Stmt.Instr_Assert { attrib = StringMap.empty; body = e }) + spec.ensures) + | _ -> block let transform_proc (prog : Program.t) (pid : IDSet.elt) (proc : Program.proc) : Program.proc = From 91e22ea3010e9bd769d6a5bab7a006ef600e6550 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 10:50:15 +1000 Subject: [PATCH 58/67] Formatter --- lib/lang/expr_smt.ml | 2 +- lib/passes.ml | 3 ++- lib/util/var.ml | 6 +++--- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 456005395..45bce015d 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -448,7 +448,7 @@ module SMTLib2 = struct |> List.fold_flat_map (fun acc inner -> let inner, acc = sequence inner acc in - let inner = List.map (fun i -> list [i]) inner in + let inner = List.map (fun i -> list [ i ]) inner in (acc, atom ":pattern" :: inner)) s |> function diff --git a/lib/passes.ml b/lib/passes.ml index b315fd470..c1b737779 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -93,7 +93,8 @@ module PassManager = struct let sparams = { name = "simple-params"; - apply = Prog (Transforms.Ssa.set_params ~skip_observable:true ~skip_maps:true); + apply = + Prog (Transforms.Ssa.set_params ~skip_observable:true ~skip_maps:true); doc = "Pull all global variables into the parameter list, discarding initial \ parameter list (i.e. assuming its empty)"; diff --git a/lib/util/var.ml b/lib/util/var.ml index 7f3173e64..1ba6d0570 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -24,9 +24,9 @@ include ( let create name ?(scope = LocalVar) typ = (* disallow creating local const as its too hard to have declaration order *) - match scope with - | LocalConst -> H.make { name; typ; scope = LocalVar } - | _ -> H.make { name; typ; scope } + match scope with + | LocalConst -> H.make { name; typ; scope = LocalVar } + | _ -> H.make { name; typ; scope } let copy ?name ?scope ?typ (v : t) = let v = Fix.HashCons.data v in From 3986f25f4c07e2d4c403725017475c4cd6ef0ec0 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 10:51:28 +1000 Subject: [PATCH 59/67] Unused variables removed --- lib/lang/expr_smt.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 45bce015d..5fa273945 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -513,13 +513,12 @@ module SMTLib2 = struct let trans_decl (decl : Program.declaration) = let* x = return () in match decl with - | Type { binding; typ = Sort (name, [ { variant; fields = [] } ]) as typ } - -> + | Type { binding; typ = Sort (name, [ { variant; fields = [] } ]) } -> let sexp = Bincaml_util.Smt.Expr.declare_sort variant 0 in let* _ = add_preamble sexp in let* _ = add_logic DT in return sexp - | Type { binding; typ = Sort (name, vs) as typ } -> + | Type { binding; typ = Sort (name, vs) } -> let fields = List.map Types.( From 326fc94a2009033d4f325ba438d945f46eb89a84 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 11:06:52 +1000 Subject: [PATCH 60/67] Moved ITE to its own intrin --- lib/analysis/sva.ml | 2 +- lib/fe/AbsBasilIR.ml | 1 + lib/fe/BasilIR.cf | 2 +- lib/fe/LexBasilIR.mll | 4 ++-- lib/fe/ParBasilIR.mly | 3 ++- lib/fe/PrintBasilIR.ml | 1 + lib/fe/ShowBasilIR.ml | 1 + lib/fe/SkelBasilIR.ml | 1 + lib/lang/algsimp.ml | 8 +++----- lib/lang/expr.ml | 21 +++++++-------------- lib/lang/expr_smt.ml | 2 +- lib/lang/hm/inference.ml | 2 +- lib/lang/ops.ml | 5 +++-- lib/loadir.ml | 1 + lib/transforms/type_check.ml | 2 +- 15 files changed, 27 insertions(+), 29 deletions(-) diff --git a/lib/analysis/sva.ml b/lib/analysis/sva.ml index 33a126380..82218837d 100644 --- a/lib/analysis/sva.ml +++ b/lib/analysis/sva.ml @@ -117,7 +117,7 @@ module SVAAbstraction = struct match op with | (`BVADD | `BVOR | `BVXOR | `BVAND | `BVMUL) as op -> (eval_binary op a b rt, rt) - | `OR | `AND | `Cases | `MapUpdate | `IfThen -> (SymAddrSetLattice.top, rt) + | `OR | `AND | `Cases | `MapUpdate | `IfThenElse -> (SymAddrSetLattice.top, rt) | `BVConcat -> ( SymAddrSetLattice.fold (fun sb1 vs1 acc -> diff --git a/lib/fe/AbsBasilIR.ml b/lib/fe/AbsBasilIR.ml index 7826cbd1a..b9e0e325b 100644 --- a/lib/fe/AbsBasilIR.ml +++ b/lib/fe/AbsBasilIR.ml @@ -317,6 +317,7 @@ and intrinOp = | IntrinOp_bvconcat | IntrinOp_bvmul | IntrinOp_update + | IntrinOp_ite and pointerBinOp = PointerBinOp_ptradd diff --git a/lib/fe/BasilIR.cf b/lib/fe/BasilIR.cf index 25eeb6420..b85126d0e 100644 --- a/lib/fe/BasilIR.cf +++ b/lib/fe/BasilIR.cf @@ -305,7 +305,7 @@ rules BVLogicalBinOp ::= "bvule" | "bvugt" | "bvuge" | "bvult" | "bvslt" | "b rules IntBinOp ::= "intadd" | "intmul" | "intsub" | "intdiv" | "intmod" ; rules IntLogicalBinOp ::= "intlt" | "intle" | "intgt" | "intge" ; -rules IntrinOp ::= "booland" | "boolor" | "bvand" | "bvor" | "bvadd" | "bvxor" | "bvconcat" | "bvmul" | "update"; +rules IntrinOp ::= "booland" | "boolor" | "bvand" | "bvor" | "bvadd" | "bvxor" | "bvconcat" | "bvmul" | "update" | "ite"; rules PointerBinOp ::= "ptradd" ; {- SPECIFICATION -} diff --git a/lib/fe/LexBasilIR.mll b/lib/fe/LexBasilIR.mll index c75cdd1a1..fe3f6e199 100644 --- a/lib/fe/LexBasilIR.mll +++ b/lib/fe/LexBasilIR.mll @@ -11,9 +11,9 @@ let symbol_table = Hashtbl.create 10 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add symbol_table kwd tok) [(";", SYMB1);(",", SYMB2);("->", SYMB3);("::", SYMB4);(":", SYMB5);("=", SYMB6);("|", SYMB7);(":=", SYMB8);("mem:=", SYMB9);("_", SYMB10)] -let resword_table = Hashtbl.create 109 +let resword_table = Hashtbl.create 110 let _ = List.iter (fun (kwd, tok) -> Hashtbl.add resword_table kwd tok) - [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("ptr", KW_ptr);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("in", KW_in);("old", KW_old);("implies", KW_implies);("get", KW_get);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("if", KW_if);("then", KW_then);("else", KW_else);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvxor", KW_bvxor);("bvconcat", KW_bvconcat);("bvmul", KW_bvmul);("update", KW_update);("ptradd", KW_ptradd);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] + [("shared", KW_shared);("observable", KW_observable);("axiom", KW_axiom);("memory", KW_memory);("var", KW_var);("val", KW_val);("let", KW_let);("prog", KW_prog);("entry", KW_entry);("proc", KW_proc);("and", KW_and);("type", KW_type);("ptr", KW_ptr);("of", KW_of);("le", KW_le);("be", KW_be);("nop", KW_nop);("store", KW_store);("load", KW_load);("call", KW_call);("indirect", KW_indirect);("assume", KW_assume);("guard", KW_guard);("assert", KW_assert);("goto", KW_goto);("unreachable", KW_unreachable);("return", KW_return);("phi", KW_phi);("block", KW_block);("true", KW_true);("false", KW_false);("forall", KW_forall);("exists", KW_exists);("fun", KW_fun);("in", KW_in);("old", KW_old);("implies", KW_implies);("get", KW_get);("boolnot", KW_boolnot);("intneg", KW_intneg);("booltobv1", KW_booltobv1);("gamma", KW_gamma);("classification", KW_classification);("load_be", KW_load_be);("load_le", KW_load_le);("zero_extend", KW_zero_extend);("sign_extend", KW_sign_extend);("extract", KW_extract);("if", KW_if);("then", KW_then);("else", KW_else);("match", KW_match);("with", KW_with);("cases", KW_cases);("eq", KW_eq);("neq", KW_neq);("bvnot", KW_bvnot);("bvneg", KW_bvneg);("bvudiv", KW_bvudiv);("bvurem", KW_bvurem);("bvshl", KW_bvshl);("bvlshr", KW_bvlshr);("bvnand", KW_bvnand);("bvnor", KW_bvnor);("bvxnor", KW_bvxnor);("bvcomp", KW_bvcomp);("bvsub", KW_bvsub);("bvsdiv", KW_bvsdiv);("bvsrem", KW_bvsrem);("bvsmod", KW_bvsmod);("bvashr", KW_bvashr);("bvule", KW_bvule);("bvugt", KW_bvugt);("bvuge", KW_bvuge);("bvult", KW_bvult);("bvslt", KW_bvslt);("bvsle", KW_bvsle);("bvsgt", KW_bvsgt);("bvsge", KW_bvsge);("intadd", KW_intadd);("intmul", KW_intmul);("intsub", KW_intsub);("intdiv", KW_intdiv);("intmod", KW_intmod);("intlt", KW_intlt);("intle", KW_intle);("intgt", KW_intgt);("intge", KW_intge);("booland", KW_booland);("boolor", KW_boolor);("bvand", KW_bvand);("bvor", KW_bvor);("bvadd", KW_bvadd);("bvxor", KW_bvxor);("bvconcat", KW_bvconcat);("bvmul", KW_bvmul);("update", KW_update);("ite", KW_ite);("ptradd", KW_ptradd);("require", KW_require);("requires", KW_requires);("ensure", KW_ensure);("ensures", KW_ensures);("rely", KW_rely);("relies", KW_relies);("guarantee", KW_guarantee);("guarantees", KW_guarantees);("captures", KW_captures);("modifies", KW_modifies);("invariant", KW_invariant)] let unescapeInitTail (s:string) : string = let rec unesc s = match s with diff --git a/lib/fe/ParBasilIR.mly b/lib/fe/ParBasilIR.mly index d47dbb223..d52b3466f 100644 --- a/lib/fe/ParBasilIR.mly +++ b/lib/fe/ParBasilIR.mly @@ -7,7 +7,7 @@ open AbsBasilIR open Lexing %} -%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_ptr KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_in KW_old KW_implies KW_get KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_if KW_then KW_else KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_bvand KW_bvor KW_bvadd KW_bvxor KW_bvconcat KW_bvmul KW_update KW_ptradd KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant +%token KW_shared KW_observable KW_axiom KW_memory KW_var KW_val KW_let KW_prog KW_entry KW_proc KW_and KW_type KW_ptr KW_of KW_le KW_be KW_nop KW_store KW_load KW_call KW_indirect KW_assume KW_guard KW_assert KW_goto KW_unreachable KW_return KW_phi KW_block KW_true KW_false KW_forall KW_exists KW_fun KW_in KW_old KW_implies KW_get KW_boolnot KW_intneg KW_booltobv1 KW_gamma KW_classification KW_load_be KW_load_le KW_zero_extend KW_sign_extend KW_extract KW_if KW_then KW_else KW_match KW_with KW_cases KW_eq KW_neq KW_bvnot KW_bvneg KW_bvudiv KW_bvurem KW_bvshl KW_bvlshr KW_bvnand KW_bvnor KW_bvxnor KW_bvcomp KW_bvsub KW_bvsdiv KW_bvsrem KW_bvsmod KW_bvashr KW_bvule KW_bvugt KW_bvuge KW_bvult KW_bvslt KW_bvsle KW_bvsgt KW_bvsge KW_intadd KW_intmul KW_intsub KW_intdiv KW_intmod KW_intlt KW_intle KW_intgt KW_intge KW_booland KW_boolor KW_bvand KW_bvor KW_bvadd KW_bvxor KW_bvconcat KW_bvmul KW_update KW_ite KW_ptradd KW_require KW_requires KW_ensure KW_ensures KW_rely KW_relies KW_guarantee KW_guarantees KW_captures KW_modifies KW_invariant %token SYMB1 /* ; */ %token SYMB2 /* , */ @@ -876,6 +876,7 @@ intrinOp : KW_booland { IntrinOp_booland } | KW_bvconcat { IntrinOp_bvconcat } | KW_bvmul { IntrinOp_bvmul } | KW_update { IntrinOp_update } + | KW_ite { IntrinOp_ite } ; pointerBinOp : KW_ptradd { PointerBinOp_ptradd } diff --git a/lib/fe/PrintBasilIR.ml b/lib/fe/PrintBasilIR.ml index 6aaf0f3c8..c069fdf21 100644 --- a/lib/fe/PrintBasilIR.ml +++ b/lib/fe/PrintBasilIR.ml @@ -565,6 +565,7 @@ and prtIntrinOp (i:int) (e : AbsBasilIR.intrinOp) : doc = match e with | AbsBasilIR.IntrinOp_bvconcat -> prPrec i 0 (concatD [render "bvconcat"]) | AbsBasilIR.IntrinOp_bvmul -> prPrec i 0 (concatD [render "bvmul"]) | AbsBasilIR.IntrinOp_update -> prPrec i 0 (concatD [render "update"]) + | AbsBasilIR.IntrinOp_ite -> prPrec i 0 (concatD [render "ite"]) and prtPointerBinOp (i:int) (e : AbsBasilIR.pointerBinOp) : doc = match e with diff --git a/lib/fe/ShowBasilIR.ml b/lib/fe/ShowBasilIR.ml index bb1dc1c62..f91af8211 100644 --- a/lib/fe/ShowBasilIR.ml +++ b/lib/fe/ShowBasilIR.ml @@ -411,6 +411,7 @@ and showIntrinOp (e : AbsBasilIR.intrinOp) : showable = match e with | AbsBasilIR.IntrinOp_bvconcat -> s2s "IntrinOp_bvconcat" | AbsBasilIR.IntrinOp_bvmul -> s2s "IntrinOp_bvmul" | AbsBasilIR.IntrinOp_update -> s2s "IntrinOp_update" + | AbsBasilIR.IntrinOp_ite -> s2s "IntrinOp_ite" and showPointerBinOp (e : AbsBasilIR.pointerBinOp) : showable = match e with diff --git a/lib/fe/SkelBasilIR.ml b/lib/fe/SkelBasilIR.ml index d1012b4d2..adac1a1fd 100644 --- a/lib/fe/SkelBasilIR.ml +++ b/lib/fe/SkelBasilIR.ml @@ -434,6 +434,7 @@ and transIntrinOp (x : intrinOp) : result = match x with | IntrinOp_bvconcat -> failure x | IntrinOp_bvmul -> failure x | IntrinOp_update -> failure x + | IntrinOp_ite -> failure x and transPointerBinOp (x : pointerBinOp) : result = match x with diff --git a/lib/lang/algsimp.ml b/lib/lang/algsimp.ml index 6bde5f7b3..d3bc99813 100644 --- a/lib/lang/algsimp.ml +++ b/lib/lang/algsimp.ml @@ -324,17 +324,15 @@ let if_then_else op = `Cases; args = [ - ( ( ApplyIntrin { op = `IfThen; args = [ cond; br_true ] }, - Types.Boolean ) - | ( BinaryExpr { op = `IfThen; arg1 = cond; arg2 = br_true }, - Types.Boolean ) ); + ( BinaryExpr { op = `IfThen; arg1 = cond; arg2 = br_true }, + Types.Boolean ); (br_false, _); ]; attrib; } -> ApplyIntrin { - op = `IfThen; + op = `IfThenElse; args = [ cond; br_true; fix br_false ]; attrib; typ = BasilExpr.type_of br_true; diff --git a/lib/lang/expr.ml b/lib/lang/expr.ml index b243b489f..ca673a08a 100644 --- a/lib/lang/expr.ml +++ b/lib/lang/expr.ml @@ -295,20 +295,13 @@ module BasilExpr = struct [ { inner = - ( Some - (BinaryExpr - { - op = `IfThen; - arg1 = { this = Some cond }; - arg2 = { this = Some thn }; - }) - | Some - (ApplyIntrin - { - op = `IfThen; - args = - [ { this = Some cond }; { this = Some thn } ]; - }) ); + Some + (BinaryExpr + { + op = `IfThen; + arg1 = { this = Some cond }; + arg2 = { this = Some thn }; + }); }; { this = Some els }; ]; diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 5fa273945..a7f712595 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -487,7 +487,7 @@ module SMTLib2 = struct let* l = l in let* r = r in return @@ list [ of_op o; l; r ] - | ApplyIntrin { op = `IfThen; args = [ cond; br_true; br_false ] } -> + | ApplyIntrin { op = `IfThenElse; args = [ cond; br_true; br_false ] } -> let* cond = cond in let* br_true = br_true in let* br_false = br_false in diff --git a/lib/lang/hm/inference.ml b/lib/lang/hm/inference.ml index fa37aa853..069ca41af 100644 --- a/lib/lang/hm/inference.ml +++ b/lib/lang/hm/inference.ml @@ -111,7 +111,7 @@ let scheme_of_intrin st ?(visit_constraint = fun a -> ()) (gen : ID.generator) let m = curry_f st [ a ] b in curry_f st [ m; a; b ] m | `Cases -> fv () - | `IfThen -> fv () + | `IfThenElse -> fv () let do_infer st ~visit_constraint (infer : diff --git a/lib/lang/ops.ml b/lib/lang/ops.ml index 004f93cec..a150c29ea 100644 --- a/lib/lang/ops.ml +++ b/lib/lang/ops.ml @@ -299,7 +299,7 @@ module Spec = struct [@@deriving show { with_path = false }, eq, ord] type intrin = - [ `Cases | `IfThen (** choose first argument that is defined *) ] + [ `Cases | `IfThenElse (** choose first argument that is defined *) ] [@@deriving show { with_path = false }, eq, ord] type unary = [ `Old | `Classification | `Gamma ] @@ -454,7 +454,7 @@ module AllOps = struct in return (Bitvector w) | `MapUpdate -> return @@ List.hd args - | `IfThen -> return @@ List.hd @@ List.tl args + | `IfThenElse -> return @@ List.hd @@ List.tl args (** ops returning booleans *) @@ -523,6 +523,7 @@ module AllOps = struct | `MapAccess -> "get" | `MapUpdate -> "update" | `IfThen -> "case" + | `IfThenElse -> "ite" | `Cases -> "match" let eval_equal (a : const) (b : const) = diff --git a/lib/loadir.ml b/lib/loadir.ml index a831315d7..816f52616 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -1461,6 +1461,7 @@ module BasilASTLoader = struct | IntrinOp_bvxor -> `BVXOR | IntrinOp_bvconcat -> `BVConcat | IntrinOp_bvmul -> `BVMUL + | IntrinOp_ite -> `IfThenElse end exception ILBParseError of { input : Pp_loc.Input.t; lexbuf : Lexing.lexbuf } diff --git a/lib/transforms/type_check.ml b/lib/transforms/type_check.ml index 839873627..111a656e5 100644 --- a/lib/transforms/type_check.ml +++ b/lib/transforms/type_check.ml @@ -196,7 +196,7 @@ let type_check stmt_id block_id expr = :: errs, ty )) ([], h) tl) - | `IfThen -> ( + | `IfThenElse -> ( match args with | [ Types.Boolean; arg1; arg2 ] -> if Types.equal arg1 arg2 then [] From 0e8d9c7598b4e713ed1eb48f4f0dd21b930d21a9 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 11:07:09 +1000 Subject: [PATCH 61/67] Moved ITE to its own intrin --- lsp/raw_tokens.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/lsp/raw_tokens.ml b/lsp/raw_tokens.ml index 73c79d75e..3825927dd 100644 --- a/lsp/raw_tokens.ml +++ b/lsp/raw_tokens.ml @@ -73,6 +73,7 @@ type raw_token = BasilIR.ParBasilIR.token = | KW_load | KW_let | KW_le + | KW_ite | KW_invariant | KW_intsub | KW_intneg From 613e04c24ce3780d00f4b1e581d7d7d88975a3e1 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 11:08:03 +1000 Subject: [PATCH 62/67] formatter --- lib/analysis/sva.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/analysis/sva.ml b/lib/analysis/sva.ml index 82218837d..ecfa543aa 100644 --- a/lib/analysis/sva.ml +++ b/lib/analysis/sva.ml @@ -117,7 +117,8 @@ module SVAAbstraction = struct match op with | (`BVADD | `BVOR | `BVXOR | `BVAND | `BVMUL) as op -> (eval_binary op a b rt, rt) - | `OR | `AND | `Cases | `MapUpdate | `IfThenElse -> (SymAddrSetLattice.top, rt) + | `OR | `AND | `Cases | `MapUpdate | `IfThenElse -> + (SymAddrSetLattice.top, rt) | `BVConcat -> ( SymAddrSetLattice.fold (fun sb1 vs1 acc -> From c5c06b401da4c6fac96aaa53a8204210ac941eca Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 11:09:54 +1000 Subject: [PATCH 63/67] updated docstring --- lib/backends/smt.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 39182483e..d772ff09a 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -7,7 +7,8 @@ open Expr (** SMT Backend. This backend expects the CFA Reduction and Summary Inlining transforms. Will output a .smt file containing all declarations and asserts - necessary for verification. *) + necessary for verification. Live variant runs smt solver in bincaml, + printing more useful and readable output from analysis. *) type context = { stmt : Program.stmt option; From 903c258f33f9c8e4cc941c1a90f1fb333088fdbd Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Tue, 11 Aug 2026 11:11:42 +1000 Subject: [PATCH 64/67] tree sitter ite promotion --- tree-sitter/grammar.bnfc.js | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/tree-sitter/grammar.bnfc.js b/tree-sitter/grammar.bnfc.js index ea073da40..afa28d263 100644 --- a/tree-sitter/grammar.bnfc.js +++ b/tree-sitter/grammar.bnfc.js @@ -737,7 +737,9 @@ module.exports = ({ // IntrinOp_bvmul. IntrinOp ::= "bvmul" ; "bvmul", // IntrinOp_update. IntrinOp ::= "update" ; - "update" + "update", + // IntrinOp_ite. IntrinOp ::= "ite" ; + "ite" ), PointerBinOp: $ => // PointerBinOp_ptradd. PointerBinOp ::= "ptradd" ; From 95c9042f318a2ab78705a511ecea018df2116a28 Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 31 Aug 2026 12:02:55 +1000 Subject: [PATCH 65/67] Cleaned up SMT backend using effects, slightly broken --- lib/backends/dune | 13 +- lib/backends/smt.ml | 327 ++++++++++++++++++++----------------------- lib/lang/expr_smt.ml | 2 +- lib/passes.ml | 4 +- lib/util/smt.ml | 4 +- 5 files changed, 171 insertions(+), 179 deletions(-) diff --git a/lib/backends/dune b/lib/backends/dune index eb60c6700..6eae8dcc4 100644 --- a/lib/backends/dune +++ b/lib/backends/dune @@ -2,4 +2,15 @@ (public_name bincaml.backends) (name backends) (modules boogie smt) - (libraries containers containers-data containers.pp lang transforms)) + (libraries containers containers-data containers.pp lang transforms) + (preprocess + (pps + ppx_here + ppx_deriving.show + ppx_deriving.eq + ppx_deriving.ord + ppx_deriving.map + ppx_deriving.iter + ppx_deriving.fold + ppx_deriving.enum + ppx_expect))) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index d772ff09a..5a5c72782 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -10,13 +10,11 @@ open Expr necessary for verification. Live variant runs smt solver in bincaml, printing more useful and readable output from analysis. *) -type context = { - stmt : Program.stmt option; - proc : Program.proc option; - vc : bool; -} +open Effect -let empty : context = { stmt = None; proc = None; vc = false } +type _ Effect.t += + | Push : SMTLib2.builder -> unit Effect.t + | Verify : SMTLib2.builder * (Program.proc * Program.stmt) -> unit Effect.t (* Get any ambiguous variables (shared name, different type). *) let ambiguities (program : Program.t) : VarSet.t Iter.t = @@ -51,137 +49,166 @@ let rvar_map (program : Program.t) = (v, sexp)) |> VarMap.of_iter -(* Produce a list of builders for a procedure, with context. - Builder for local declarations + one for each statement. - Assertions produce a second builder for verification. *) -let build_procedure ~rvars (program : Program.t) (procedure : Program.proc) : - (SMTLib2.builder * context) list = - let ctx = { empty with proc = Some procedure } in +(** Remove all variable declarations from a builder which conflict with a sort + declaration. *) +let dedup_decls (builder : SMTLib2.builder) : SMTLib2.builder = + let removals = + VarMap.to_iter builder.var_decls + |> Iter.filter_map (fun (var, _) -> + match Var.typ var with + | Sort (name, _) -> Some (Var.copy ~typ:(Types.Variable name) var) + | _ -> None) + |> VarSet.of_iter + in - let builders = CCVector.create () in + { + builder with + var_decls = + builder.var_decls + |> VarMap.filter (fun var _ -> not @@ VarSet.mem var removals); + } +let visit_stmt procedure rvars = function + | Stmt.Instr_Assert { body } as stmt -> + (* Verify negation of assertion is unsat. *) + let builder = + SMTLib2.add_assert + (SMTLib2.of_bexpr ~rvars (BasilExpr.boolnot body)) + SMTLib2.empty + |> snd + in + perform (Verify (builder, (procedure, stmt))); + + (* Assert the actual assertion. *) + let smt = SMTLib2.of_bexpr ~rvars body in + let builder = SMTLib2.add_assert smt SMTLib2.empty |> snd in + perform (Push builder) + | Stmt.Instr_Assume { body } -> + (* Assert the assumption as is. SSA makes this equiv to assume. *) + let smt = SMTLib2.of_bexpr ~rvars body in + let builder = SMTLib2.add_assert smt SMTLib2.empty |> snd in + perform (Push builder) + | Stmt.Instr_Assign { al } -> + (* Assign is just an assertion of equivalent lhs and rhs. + This is bidirectional, but SSA + Reachability conds avoid this + causing issues. *) + let asserts = + List.map + (fun (v, e) -> + BasilExpr.binexp ~op:`EQ (BasilExpr.rvar v) e + |> SMTLib2.of_bexpr ~rvars) + al + in + let builder = + List.fold_left + (fun builder smt -> SMTLib2.add_assert smt builder |> snd) + SMTLib2.empty asserts + in + perform (Push builder) + | _ -> () + +let visit_procedure ~rvars (program : Program.t) (procedure : Program.proc) = + print_endline @@ "visitng proc" ^ (Procedure.id procedure |> ID.name); let builder = SMTLib2.empty |> SMTLib2.push |> snd |> SMTLib2.echo ("Verifying Procedure: " ^ ID.name (Procedure.id procedure)) |> snd in + perform (Push builder); - (* Generate a declaration for each local var. *) let local_decls = Procedure.local_decls procedure in - let builder = - Hashtbl.to_iter local_decls - |> Iter.fold (fun acc (k, v) -> snd @@ SMTLib2.decl_var v acc) builder - in - - CCVector.push builders (builder, ctx); + local_decls + |> Hashtbl.iter (fun k v -> + perform (Push (snd @@ SMTLib2.decl_var v SMTLib2.empty))); (* Translate each statement to smt. *) Procedure.iter_stmt_topo_fwd procedure - |> flip Iter.for_each (fun stmt -> - let builder = SMTLib2.empty in - let ctx = { ctx with stmt = Some stmt; vc = false } in - match stmt with - | Stmt.Instr_Assert { body } -> - (* Verify negation of assertion is unsat. *) - let builder = snd @@ SMTLib2.push builder in - let builder = - snd - @@ SMTLib2.add_assert - (SMTLib2.of_bexpr ~rvars (BasilExpr.boolnot body)) - builder - in - let builder = snd @@ SMTLib2.check_sat builder in - let builder = snd @@ SMTLib2.pop builder in - CCVector.push builders (builder, { ctx with vc = true }); - - (* Assert the actual assertion. *) - let smt = SMTLib2.of_bexpr ~rvars body in - let builder = SMTLib2.add_assert smt SMTLib2.empty |> snd in - CCVector.push builders (builder, ctx) - | Stmt.Instr_Assume { body } -> - (* Assert the assumption as is. SSA makes this equiv to assume. *) - let smt = SMTLib2.of_bexpr ~rvars body in - let builder = SMTLib2.add_assert smt builder |> snd in - CCVector.push builders (builder, ctx) - | Stmt.Instr_Assign { al } -> - (* Assign is just an assertion of equivalent lhs and rhs. - This is bidirectional, but SSA + Reachability conds avoid this - causing issues. *) - let asserts = - List.map - (fun (v, e) -> - BasilExpr.binexp ~op:`EQ (BasilExpr.rvar v) e - |> SMTLib2.of_bexpr ~rvars) - al - in - let builder = - List.fold_left - (fun builder smt -> SMTLib2.add_assert smt builder |> snd) - builder asserts - in - CCVector.push builders (builder, ctx) - | _ -> ()); - - CCVector.push builders (SMTLib2.pop SMTLib2.empty |> snd, ctx); - CCVector.to_list builders + |> flip Iter.for_each (visit_stmt procedure rvars); -let build_declaration ~rvars (program : Program.t) - (declaration : Program.declaration) : (SMTLib2.builder * context) list = - match declaration with - | Procedure { definition } -> build_procedure ~rvars program definition - | other -> [ (SMTLib2.trans_decl declaration SMTLib2.empty |> snd, empty) ] + perform (Push (SMTLib2.pop SMTLib2.empty |> snd)) -let build_program (program : Program.t) : (SMTLib2.builder * context) list = +let visit_program (program : Program.t) = let program = (Transforms.Ssa.set_params ~skip_observable:false ~skip_maps:false) program in let rvars = rvar_map program in Program.declarations program - |> Iter.map snd |> Iter.rev - |> Iter.flat_map_l (fun d -> build_declaration ~rvars program d) - |> Iter.to_list - -(* Joins a list of builders (disregarding context), removing any duplicate declarations - caused by sort/variable types. *) -let join_builders (builders : (SMTLib2.builder * context) list) : - SMTLib2.builder = - let builder = - List.fold_left - (fun acc b -> SMTLib2.append acc (fst b)) - SMTLib2.empty builders + |> Iter.map snd + |> flip Iter.for_each (function + | Program.Procedure { definition } -> + visit_procedure ~rvars program definition + | other -> perform (Push (SMTLib2.trans_decl other SMTLib2.empty |> snd))) + +(** Offline SMT backend. Converts entire program to smt and dumps to chan. + Inserts verification condition checks with echos for easier tracing. *) +let smt_offline chan (program : Program.t) : unit = + let open Containers_pp in + let builder = ref SMTLib2.empty in + (try visit_program program with + | effect Push b, k -> + builder := SMTLib2.append !builder b; + Effect.Deep.continue k () + | effect Verify (b, c), k -> + builder := snd @@ SMTLib2.push !builder; + builder := SMTLib2.append !builder b; + builder := snd @@ SMTLib2.check_sat !builder; + builder := snd @@ SMTLib2.pop !builder; + Effect.Deep.continue k ()); + let p = + Expr_smt.SMTLib2.to_sexp ~set_logic:true !builder + |> Iter.map (Sexp.to_string %> text) + |> Iter.to_list |> append_nl in + flush chan; + let fmt = Format.formatter_of_out_channel chan in + Containers_pp.Pretty.to_format ~width:80 fmt p; + Format.flush fmt () - let removals = - VarMap.to_iter builder.var_decls - |> Iter.filter_map (fun (var, _) -> - match Var.typ var with - | Sort (name, _) -> Some (Var.copy ~typ:(Types.Variable name) var) - | _ -> None) - |> VarSet.of_iter +(** Online SMT backend. Starts up a solver and feeds program one statement at a + time to it. Prints more useful messages for failing VCs and tracks stats for + entire procedures. *) +let smt_online chan (program : Program.t) : unit = + let module M = Map.Make (struct + type t = Smt.Solver.result [@@deriving eq, ord] + end) in + flush chan; + let solver = + Bincaml_util.Smt.Solver.create + { + Bincaml_util.Smt.Config.cvc5 with + log = Bincaml_util.Smt.Config.printf_log; + } in - - { - builder with - var_decls = - builder.var_decls - |> VarMap.filter (fun var _ -> not @@ VarSet.mem var removals); - } - -let eval_single chan (solver : Smt.Solver.t) (prog : Program.t) - ((builder, context) : SMTLib2.builder * context) = - let sexps = SMTLib2.commands_to_sexp builder in - sexps - |> Iter.map (fun sexp -> - let response = Smt.Solver.add_sexp solver sexp in - match (context, response) with - | { stmt = Some stmt; proc = Some proc; vc = true }, `Atom "sat" -> + let results : int M.t IDMap.t ref = ref IDMap.empty in + (try visit_program program with + | effect Push b, k -> + if + SMTLib2.to_sexp ~set_logic:false b + |> Iter.map (Smt.Solver.add_sexp solver) + |> Iter.for_all (function + | `List (`Atom "error" :: body) as s -> + Printf.fprintf chan "solver error: %s" (CCSexp.to_string s); + false + | _ -> true) + then Effect.Deep.continue k () + | effect Verify (b, (proc, stmt)), k -> + Smt.Solver.push solver; + SMTLib2.commands_to_sexp b + |> Iter.map (Smt.Solver.add_sexp solver) + |> Iter.iter (const ()); + let result = Smt.Solver.check solver in + (match result with + | Unknown -> + Printf.fprintf chan "\nUnknown Assertion:\n%s\n" + (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt) + | Sat -> ( Printf.fprintf chan "\nFailing Assertion: %s\n" (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt); Printf.fprintf chan "Belonging to procedure: %s\n" (ID.name @@ Procedure.id proc); Printf.fprintf chan "Counterexample:\n"; let model = Smt.Solver.get_model solver in - (match model with + match model with | `Atom a -> Printf.fprintf chan "%s\n" (Sexp.to_string model) | `List l -> l |> List.to_iter @@ -189,69 +216,23 @@ let eval_single chan (solver : Smt.Solver.t) (prog : Program.t) | `List (`Atom "define-fun" :: `Atom var :: _ :: `Atom typ :: _) -> Procedure.lookup_local_decl proc var |> Option.is_some - || Program.get_decl_by_name var prog |> Option.is_some + || Program.get_decl_by_name var program |> Option.is_some | _ -> false) |> flip Iter.for_each (fun s -> - Printf.fprintf chan "%s\n" (Sexp.to_string s))); - (`Fail, Some (Procedure.id proc)) - | { stmt = Some stmt; proc = Some proc; vc = true }, `Atom "unknown" -> - Printf.fprintf chan "\nUnknown Assertion:\n%s\n" - (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt); - (`Unknown, Some (Procedure.id proc)) - | { proc = Some proc; vc = true }, _ -> - (`Success, Some (Procedure.id proc)) - | _ -> (`Skip, None)) - -let eval_program chan (program : Program.t) = - flush chan; - let solver = - Bincaml_util.Smt.Solver.create - { - Bincaml_util.Smt.Config.cvc5 with - log = Bincaml_util.Smt.Config.quiet_log; - } - in - let builders = build_program program in - (* Join the builders together for computing unified declarations/preamble. *) - let builder = join_builders builders in - let preamble = SMTLib2.preamble_to_sexp builder in - let decls = SMTLib2.decls_to_sexp builder in - Iter.append preamble decls - |> flip Iter.for_each (fun sexp -> Smt.Solver.add_command solver sexp); - let results = - builders |> List.to_iter - |> Iter.flat_map @@ eval_single chan solver program - |> Iter.filter_map (fun (a, b) -> Option.map (fun i -> (a, i)) b) - |> Iter.map (fun (a, b) -> (b, a)) - |> Hashtbl.of_iter_count - in - Program.procs program - |> Iter.filter (snd %> Procedure.graph %> Option.is_some) - |> Iter.map fst - |> flip Iter.for_each (fun id -> - Printf.fprintf chan "\nProcedure %s verified with:\n" (ID.name id); - [ `Success; `Fail; `Unknown ] - |> List.to_iter - |> flip Iter.for_each (fun res -> - let count = Hashtbl.get_or ~default:0 results (id, res) in - Printf.fprintf chan "%d %s assertions.\n" count - (match res with - | `Success -> "succeeding" - | `Fail -> "failing" - | _ -> "unknown"))); - flush chan - -let pretty_program (program : Program.t) : Containers_pp.t = - let open Containers_pp in - let builders = build_program program in - let builder = join_builders builders in - Expr_smt.SMTLib2.to_sexp ~set_logic:true builder - |> Iter.map (Sexp.to_string %> text) - |> Iter.to_list |> append_nl - -let pretty_to_chan chan (p : Program.t) = - let p = pretty_program p in - flush chan; - let fmt = Format.formatter_of_out_channel chan in - Containers_pp.Pretty.to_format ~width:80 fmt p; - Format.flush fmt () + Printf.fprintf chan "%s\n" (Sexp.to_string s))) + | Unsat -> ()); + results := + IDMap.update (Procedure.id proc) + Option.( + or_ ~else_:(Some M.empty) + %> map (M.update result (or_ ~else_:(Some 0) %> map (( + ) 1)))) + !results; + Smt.Solver.pop solver; + Effect.Deep.continue k ()); + Smt.Solver.stop solver; + flip IDMap.iter !results (fun id map -> + Printf.fprintf chan "Procedure %s verified with:\n" (ID.name id); + [ Unknown; Sat; Unsat ] + |> List.iter (fun k -> + M.get_or ~default:0 k map + |> Printf.fprintf chan "\t %s: %d\n" (Smt.Solver.show_result k))) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index a7f712595..d6eb29c1f 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -384,7 +384,7 @@ module SMTLib2 = struct | `INTADD -> atom "+" | `INTMUL -> atom "*" | `INTSUB -> atom "-" - | `INTDIV -> atom "/" + | `INTDIV -> atom "div" | `INTLT -> atom "<" | `INTLE -> atom "<=" | #Ops.AllOps.unary as o -> atom @@ Ops.AllOps.to_string o diff --git a/lib/passes.ml b/lib/passes.ml index c1b737779..3d94c55da 100644 --- a/lib/passes.ml +++ b/lib/passes.ml @@ -64,7 +64,7 @@ module PassManager = struct apply = Prog (fun prog -> - Backends.Smt.pretty_to_chan out_channel prog; + Backends.Smt.smt_offline out_channel prog; prog); } @@ -76,7 +76,7 @@ module PassManager = struct apply = Prog (fun prog -> - Backends.Smt.eval_program out_channel prog; + Backends.Smt.smt_online out_channel prog; prog); } diff --git a/lib/util/smt.ml b/lib/util/smt.ml index 936cce517..1d52dcba8 100644 --- a/lib/util/smt.ml +++ b/lib/util/smt.ml @@ -607,7 +607,7 @@ module Solver : sig type t (** result type *) - type result = Unsat | Unknown | Sat + type result = Unsat | Unknown | Sat [@@deriving eq,ord] val pp_result : Format.formatter -> result -> unit (** print result *) @@ -678,7 +678,7 @@ end = struct | `Atom "success" -> () | ans -> raise (UnexpectedSolverResponse ans) - type result = Unsat | Unknown | Sat [@@deriving show] + type result = Unsat | Unknown | Sat [@@deriving show, eq, ord] (** Check if the current set of assumptions are consistent. Throws {!UnexpectedSolverResponse}. *) From 216f6339b646cb3b6431823bec5c5b527a3400eb Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Mon, 31 Aug 2026 17:11:17 +1000 Subject: [PATCH 66/67] Declaration dependency graph pt1 --- lib/lang/program.ml | 59 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 59 insertions(+) diff --git a/lib/lang/program.ml b/lib/lang/program.ml index 6aea97dab..96610caab 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -367,6 +367,65 @@ let empty ?name () = spec = { rely = []; guarantee = [] }; } +module DependencyGraph = struct + module Vert = struct + type t = ID.t [@@deriving show { with_path = false }, eq, ord] + + let hash id = ID.hash id + end + + module G = Graph.Persistent.Digraph.Concrete (Vert) + + (** Return ids of all declarations immediately depended on by decl. *) + let rec type_depends_on (prog : t) : Types.t -> IDSet.t = function + | Map (k, v) -> + IDSet.union (type_depends_on prog k) (type_depends_on prog v) + | Sort (name, variants) -> + variants + |> List.flat_map (fun { fields } -> fields) + |> List.map (fun { field; typ } -> type_depends_on prog typ) + |> List.fold_left IDSet.union IDSet.empty + | Struct fields -> + StringMap.to_list fields + |> List.map (fun (_, { typ }) -> typ) + |> List.map (type_depends_on prog) + |> List.fold_left IDSet.union IDSet.empty + | Pointer { lower; upper } -> + IDSet.union (type_depends_on prog lower) (type_depends_on prog upper) + | Variable name -> + (* Base case. Should always be a type, no other decl. *) + get_decl_by_name_id name prog + |> Option.flat_map (function id, Type _ -> Some id | _ -> None) + |> Option.map_or IDSet.singleton ~default:IDSet.empty + | _ -> IDSet.empty + + let var_depends_on (prog : t) (var : Var.t) : IDSet.t = + type_depends_on prog @@ Var.typ var + + let expr_depends_on (prog : t) (e : e) : IDSet.t = IDSet.empty + let stmt_depends_on (prog : t) (stmt : stmt) : IDSet.t = IDSet.empty + let proc_depends_on (prog : t) (proc : proc) : IDSet.t = IDSet.empty + + (** Return ids of all declarations immediately depended on by decl. *) + let decl_depends_on (prog : t) : declaration -> IDSet.t = function + | Variable { binding; classification } -> var_depends_on prog binding + | Type { binding; typ } -> type_depends_on prog typ + | Procedure { definition } -> proc_depends_on prog definition + | Function { binding; definition = Axiom body | Function body } -> + IDSet.union (var_depends_on prog binding) (expr_depends_on prog body) + | Function { binding; definition = Uninterpreted } -> + var_depends_on prog binding + + let make_dependency_graph (prog : t) : G.t = + declarations prog + |> Iter.map @@ Pair.map_snd @@ decl_depends_on prog + |> Iter.fold + (fun acc (id, children) -> + G.add_vertex acc id + |> IDSet.fold (fun child acc -> G.add_edge acc id child) children) + G.empty +end + module CallGraph = struct module Vert = struct type t = From 233ff97db4cdc231b91d3694f99494cdef9ecb4e Mon Sep 17 00:00:00 2001 From: McArthur-Alford Date: Fri, 4 Sep 2026 14:29:58 +1000 Subject: [PATCH 67/67] Dependency ordered iteration and const deduplication --- lib/backends/smt.ml | 140 ++++++++++++++++++++++++------------------- lib/lang/program.ml | 138 ++++++++++++++++++++++++++++++++++++++---- lib/lang/program.mli | 86 ++++++++++++++++++++++++++ 3 files changed, 293 insertions(+), 71 deletions(-) diff --git a/lib/backends/smt.ml b/lib/backends/smt.ml index 5a5c72782..9c5fc37c6 100644 --- a/lib/backends/smt.ml +++ b/lib/backends/smt.ml @@ -49,25 +49,6 @@ let rvar_map (program : Program.t) = (v, sexp)) |> VarMap.of_iter -(** Remove all variable declarations from a builder which conflict with a sort - declaration. *) -let dedup_decls (builder : SMTLib2.builder) : SMTLib2.builder = - let removals = - VarMap.to_iter builder.var_decls - |> Iter.filter_map (fun (var, _) -> - match Var.typ var with - | Sort (name, _) -> Some (Var.copy ~typ:(Types.Variable name) var) - | _ -> None) - |> VarSet.of_iter - in - - { - builder with - var_decls = - builder.var_decls - |> VarMap.filter (fun var _ -> not @@ VarSet.mem var removals); - } - let visit_stmt procedure rvars = function | Stmt.Instr_Assert { body } as stmt -> (* Verify negation of assertion is unsat. *) @@ -131,9 +112,12 @@ let visit_program (program : Program.t) = let program = (Transforms.Ssa.set_params ~skip_observable:false ~skip_maps:false) program in + let g = Program.DependencyGraph.make_dependency_graph ~rev:true program in + let module Topo = Graph.Topological.Make (Program.DependencyGraph.G) in let rvars = rvar_map program in - Program.declarations program - |> Iter.map snd + + Iter.from_iter (flip Topo.iter g) + |> Iter.filter_map (flip Program.get_decl program) |> flip Iter.for_each (function | Program.Procedure { definition } -> visit_procedure ~rvars program definition @@ -146,31 +130,59 @@ let smt_offline chan (program : Program.t) : unit = let builder = ref SMTLib2.empty in (try visit_program program with | effect Push b, k -> + (* Push the builder as is. *) builder := SMTLib2.append !builder b; Effect.Deep.continue k () | effect Verify (b, c), k -> + (* Push, wrapped in a scope + check sat. *) builder := snd @@ SMTLib2.push !builder; builder := SMTLib2.append !builder b; builder := snd @@ SMTLib2.check_sat !builder; builder := snd @@ SMTLib2.pop !builder; Effect.Deep.continue k ()); - let p = - Expr_smt.SMTLib2.to_sexp ~set_logic:true !builder - |> Iter.map (Sexp.to_string %> text) - |> Iter.to_list |> append_nl - in - flush chan; + + (* Pretty print the output. *) let fmt = Format.formatter_of_out_channel chan in - Containers_pp.Pretty.to_format ~width:80 fmt p; + Expr_smt.SMTLib2.to_sexp ~set_logic:true !builder + |> flip Iter.for_each (fun s -> + Containers_pp.pp fmt (Sexp.to_string s |> text); + Containers_pp.pp fmt newline); + flush chan; Format.flush fmt () +(** check satisfiability on the live solver, returning the result and printing + failures + counterexamples to the output channel. *) +let check_sat chan stmt solver proc program = + let result = Smt.Solver.check solver in + (match result with + | (Unknown : Smt.Solver.result) -> + Printf.fprintf chan "\nUnknown Assertion:\n%s\n" + (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt) + | Sat -> ( + Printf.fprintf chan "\nFailing Assertion: %s\n" + (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt); + Printf.fprintf chan "Belonging to procedure: %s\n" + (ID.name @@ Procedure.id proc); + Printf.fprintf chan "Counterexample:\n"; + let model = Smt.Solver.get_model solver in + match model with + | `Atom a -> Printf.fprintf chan "%s\n" (Sexp.to_string model) + | `List l -> + l |> List.to_iter + |> Iter.filter (function + | `List (`Atom "define-fun" :: `Atom var :: _ :: `Atom typ :: _) -> + Procedure.lookup_local_decl proc var |> Option.is_some + || Program.get_decl_by_name var program |> Option.is_some + | _ -> false) + |> flip Iter.for_each (fun s -> + Printf.fprintf chan "%s\n" (Sexp.to_string s))) + | Unsat -> ()); + result + (** Online SMT backend. Starts up a solver and feeds program one statement at a time to it. Prints more useful messages for failing VCs and tracks stats for entire procedures. *) let smt_online chan (program : Program.t) : unit = - let module M = Map.Make (struct - type t = Smt.Solver.result [@@deriving eq, ord] - end) in flush chan; let solver = Bincaml_util.Smt.Solver.create @@ -179,48 +191,50 @@ let smt_online chan (program : Program.t) : unit = log = Bincaml_util.Smt.Config.printf_log; } in + + (* Track a map of procedure,result to number of occurences. *) + let module M = Map.Make (struct + type t = Smt.Solver.result [@@deriving eq, ord] + end) in let results : int M.t IDMap.t ref = ref IDMap.empty in + + (* Track declare-const sexps that have already been sent to avoid + repeating them.*) + let module DeclSet = Set.Make (struct + type t = string * string [@@deriving eq, ord] + end) in + let declared = ref DeclSet.empty in + + let filter_declared = function + | `List [ `Atom "declare-const"; `Atom name; typ ] -> + let typ = Sexp.to_string typ in + if DeclSet.mem (name, typ) !declared then false + else ( + declared := DeclSet.add (name, typ) !declared; + true) + | _ -> true + in + (try visit_program program with | effect Push b, k -> if SMTLib2.to_sexp ~set_logic:false b + |> Iter.filter filter_declared |> Iter.map (Smt.Solver.add_sexp solver) |> Iter.for_all (function | `List (`Atom "error" :: body) as s -> Printf.fprintf chan "solver error: %s" (CCSexp.to_string s); + (* Exit early on any error. *) false | _ -> true) then Effect.Deep.continue k () | effect Verify (b, (proc, stmt)), k -> Smt.Solver.push solver; SMTLib2.commands_to_sexp b - |> Iter.map (Smt.Solver.add_sexp solver) - |> Iter.iter (const ()); - let result = Smt.Solver.check solver in - (match result with - | Unknown -> - Printf.fprintf chan "\nUnknown Assertion:\n%s\n" - (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt) - | Sat -> ( - Printf.fprintf chan "\nFailing Assertion: %s\n" - (Stmt.to_string Var.pretty Var.pretty BasilExpr.pretty stmt); - Printf.fprintf chan "Belonging to procedure: %s\n" - (ID.name @@ Procedure.id proc); - Printf.fprintf chan "Counterexample:\n"; - let model = Smt.Solver.get_model solver in - match model with - | `Atom a -> Printf.fprintf chan "%s\n" (Sexp.to_string model) - | `List l -> - l |> List.to_iter - |> Iter.filter (function - | `List (`Atom "define-fun" :: `Atom var :: _ :: `Atom typ :: _) - -> - Procedure.lookup_local_decl proc var |> Option.is_some - || Program.get_decl_by_name var program |> Option.is_some - | _ -> false) - |> flip Iter.for_each (fun s -> - Printf.fprintf chan "%s\n" (Sexp.to_string s))) - | Unsat -> ()); + |> Iter.filter filter_declared + |> Iter.iter (Smt.Solver.add_sexp solver %> ignore); + let result = check_sat chan stmt solver proc program in + (* Increment the counter for procedure/result type: *) results := IDMap.update (Procedure.id proc) Option.( @@ -229,10 +243,14 @@ let smt_online chan (program : Program.t) : unit = !results; Smt.Solver.pop solver; Effect.Deep.continue k ()); - Smt.Solver.stop solver; - flip IDMap.iter !results (fun id map -> + + (* Print out the counts of sat/unsat/unknown for each procedure. *) + !results + |> IDMap.iter (fun id map -> Printf.fprintf chan "Procedure %s verified with:\n" (ID.name id); [ Unknown; Sat; Unsat ] |> List.iter (fun k -> M.get_or ~default:0 k map - |> Printf.fprintf chan "\t %s: %d\n" (Smt.Solver.show_result k))) + |> Printf.fprintf chan "\t %s: %d\n" (Smt.Solver.show_result k))); + + Smt.Solver.stop solver diff --git a/lib/lang/program.ml b/lib/lang/program.ml index 96610caab..970e1fd3e 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -376,7 +376,7 @@ module DependencyGraph = struct module G = Graph.Persistent.Digraph.Concrete (Vert) - (** Return ids of all declarations immediately depended on by decl. *) + (** Get all type declarations immediately depended on by this type. *) let rec type_depends_on (prog : t) : Types.t -> IDSet.t = function | Map (k, v) -> IDSet.union (type_depends_on prog k) (type_depends_on prog v) @@ -399,16 +399,130 @@ module DependencyGraph = struct |> Option.map_or IDSet.singleton ~default:IDSet.empty | _ -> IDSet.empty - let var_depends_on (prog : t) (var : Var.t) : IDSet.t = - type_depends_on prog @@ Var.typ var - - let expr_depends_on (prog : t) (e : e) : IDSet.t = IDSet.empty - let stmt_depends_on (prog : t) (stmt : stmt) : IDSet.t = IDSet.empty - let proc_depends_on (prog : t) (proc : proc) : IDSet.t = IDSet.empty + (** Get all type declarations immediately depended on by this variable. + Include this variable if include_self is true and the variable is global. + *) + let var_depends_on ?(include_self = true) (prog : t) (var : Var.t) : IDSet.t = + IDSet.union + (type_depends_on prog @@ Var.typ var) + (if include_self && Var.is_global var then + get_decl_by_name_id (Var.name var) prog + |> Option.flat_map (function + | id, Variable _ | id, Function _ -> Some id + | _ -> None) + |> Option.map_or IDSet.singleton ~default:IDSet.empty + else IDSet.empty) + + (** Get all declarations depended on by vars in a phi. *) + let phi_depends_on (prog : t) (phi : Var.t Block.phi) : IDSet.t = + phi.rhs |> List.to_iter |> Iter.map snd + |> Iter.map (var_depends_on prog) + |> Iter.fold IDSet.union (var_depends_on prog phi.lhs) + + (** Get all declarations depended on by an expr. *) + let rec expr_depends_on (prog : t) (e : e) : IDSet.t = + match BasilExpr.unfix e with + | RVar { id; typ } -> + IDSet.union (var_depends_on prog id) (type_depends_on prog typ) + | Constant { typ } -> type_depends_on prog typ + | UnaryExpr { arg; typ } -> + IDSet.union (expr_depends_on prog arg) (type_depends_on prog typ) + | BinaryExpr { arg1; arg2; typ } -> + [ + expr_depends_on prog arg1; + expr_depends_on prog arg2; + type_depends_on prog typ; + ] + |> List.fold_left IDSet.union IDSet.empty + | ApplyIntrin { args; typ } -> + args + |> List.map (expr_depends_on prog) + |> List.fold_left IDSet.union (type_depends_on prog typ) + | ApplyFun { func; args; typ } -> + func :: args + |> List.map (expr_depends_on prog) + |> List.fold_left IDSet.union (type_depends_on prog typ) + | Lambda { triggers; bound_vars; in_body; typ } -> + [ + triggers |> List.flatten |> List.map (expr_depends_on prog); + bound_vars |> List.map (var_depends_on prog); + [ expr_depends_on prog in_body ]; + ] + |> List.flatten + |> List.fold_left IDSet.union (type_depends_on prog typ) + | Let { bound_vars; in_body; typ } -> IDSet.empty + + (** Get all declarations depended on by a stmt. *) + let stmt_depends_on (prog : t) (stmt : stmt) : IDSet.t = + match stmt with + | Instr_Assign { al } -> + al + |> List.map + (Pair.map (var_depends_on prog) (expr_depends_on prog) + %> Pair.merge IDSet.union) + |> List.fold_left IDSet.union IDSet.empty + | Instr_Assert { body } -> expr_depends_on prog body + | Instr_Assume { body; branch } -> expr_depends_on prog body + | Instr_Load { lhs; rhs; addr } -> + [ + var_depends_on prog lhs; + var_depends_on prog rhs; + (match addr with + | Addr { addr } -> expr_depends_on prog addr + | _ -> IDSet.empty); + ] + |> List.fold_left IDSet.union IDSet.empty + | Instr_Store { lhs; rhs; value; addr } -> + [ + var_depends_on prog lhs; + var_depends_on prog rhs; + (match addr with + | Addr { addr } -> expr_depends_on prog addr + | _ -> IDSet.empty); + expr_depends_on prog value; + ] + |> List.fold_left IDSet.union IDSet.empty + | Instr_IntrinCall { lhs; name; args } -> + [ + List.map (var_depends_on prog) lhs; + List.map (expr_depends_on prog) args; + ] + |> List.flatten + |> List.fold_left IDSet.union IDSet.empty + | Instr_Call { lhs; procid; args } -> + [ + StringMap.values lhs |> Iter.map (var_depends_on prog); + StringMap.values args |> Iter.map (expr_depends_on prog); + Iter.singleton (IDSet.singleton procid); + ] + |> List.to_iter |> Iter.concat + |> Iter.fold IDSet.union IDSet.empty + | Instr_IndirectCall { target } -> expr_depends_on prog target + + (** Get all declarations depended on by a procedure. *) + let proc_depends_on (prog : t) (proc : proc) : IDSet.t = + let deps = + [ + Procedure.formal_in_params proc |> StringMap.values; + Procedure.formal_out_params proc |> StringMap.values; + Procedure.local_decls proc |> Hashtbl.values; + ] + |> List.to_iter |> Iter.concat + |> Iter.map (var_depends_on prog) + |> Iter.fold IDSet.union IDSet.empty + in + Procedure.iter_blocks proc |> Iter.map snd + |> Iter.fold + (Block.fold_forwards + ~phi:(fun a -> + List.map (phi_depends_on prog) %> List.fold_left IDSet.union a) + ~f:(fun a stmt -> IDSet.union a (stmt_depends_on prog stmt))) + deps (** Return ids of all declarations immediately depended on by decl. *) let decl_depends_on (prog : t) : declaration -> IDSet.t = function - | Variable { binding; classification } -> var_depends_on prog binding + | Variable { binding; classification } -> + var_depends_on ~include_self:false prog binding | Type { binding; typ } -> type_depends_on prog typ | Procedure { definition } -> proc_depends_on prog definition | Function { binding; definition = Axiom body | Function body } -> @@ -416,13 +530,17 @@ module DependencyGraph = struct | Function { binding; definition = Uninterpreted } -> var_depends_on prog binding - let make_dependency_graph (prog : t) : G.t = + let make_dependency_graph ?(rev = false) (prog : t) : G.t = declarations prog |> Iter.map @@ Pair.map_snd @@ decl_depends_on prog |> Iter.fold (fun acc (id, children) -> G.add_vertex acc id - |> IDSet.fold (fun child acc -> G.add_edge acc id child) children) + |> IDSet.fold + (fun child acc -> + if rev then G.add_edge acc child id + else G.add_edge acc id child) + children) G.empty end diff --git a/lib/lang/program.mli b/lib/lang/program.mli index e306ed691..d3252a534 100644 --- a/lib/lang/program.mli +++ b/lib/lang/program.mli @@ -119,6 +119,92 @@ val create_single_proc : val empty : ?name:string -> unit -> t +module DependencyGraph : sig + module Vert : sig + type t = ID.t + + val pp : + Ppx_deriving_runtime.Format.formatter -> t -> Ppx_deriving_runtime.unit + + val show : t -> Ppx_deriving_runtime.string + val equal : t -> t -> Ppx_deriving_runtime.bool + val compare : t -> t -> Ppx_deriving_runtime.int + val hash : t -> Containers.Hash.hash + end + + module G : sig + type t = Graph.Persistent.Digraph.Concrete(Vert).t + + module V : sig + type t = Vert.t + + val compare : t -> t -> int + val hash : t -> int + val equal : t -> t -> bool + + type label = t + + val create : label -> t + val label : t -> label + end + + type vertex = Vert.t + + module E : sig + type t = vertex * vertex + + val compare : t -> t -> int + + type vertex = Vert.t + + val src : t -> vertex + val dst : t -> vertex + end + + type edge = E.t + + val is_directed : bool + val is_empty : t -> bool + val nb_vertex : t -> int + val nb_edges : t -> int + val out_degree : t -> vertex -> int + val in_degree : t -> vertex -> int + val mem_vertex : t -> vertex -> bool + val mem_edge : t -> vertex -> vertex -> bool + val mem_edge_e : t -> edge -> bool + val find_edge : t -> vertex -> vertex -> edge + val find_all_edges : t -> vertex -> vertex -> edge list + val succ : t -> vertex -> vertex list + val pred : t -> vertex -> vertex list + val succ_e : t -> vertex -> edge list + val pred_e : t -> vertex -> edge list + val iter_vertex : (vertex -> unit) -> t -> unit + val fold_vertex : (vertex -> 'a -> 'a) -> t -> 'a -> 'a + val iter_edges : (vertex -> vertex -> unit) -> t -> unit + val fold_edges : (vertex -> vertex -> 'a -> 'a) -> t -> 'a -> 'a + val iter_edges_e : (edge -> unit) -> t -> unit + val fold_edges_e : (edge -> 'a -> 'a) -> t -> 'a -> 'a + val map_vertex : (vertex -> vertex) -> t -> t + val iter_succ : (vertex -> unit) -> t -> vertex -> unit + val iter_pred : (vertex -> unit) -> t -> vertex -> unit + val fold_succ : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val fold_pred : (vertex -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val iter_succ_e : (edge -> unit) -> t -> vertex -> unit + val fold_succ_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val iter_pred_e : (edge -> unit) -> t -> vertex -> unit + val fold_pred_e : (edge -> 'a -> 'a) -> t -> vertex -> 'a -> 'a + val empty : t + val add_vertex : t -> vertex -> t + val remove_vertex : t -> vertex -> t + val add_edge : t -> vertex -> vertex -> t + val add_edge_e : t -> edge -> t + val remove_edge : t -> vertex -> vertex -> t + val remove_edge_e : t -> edge -> t + end + + val make_dependency_graph : ?rev:bool -> t -> G.t +end + module CallGraph : sig module Vert : sig type t =