From 4019977a36a087b5a13b0873fcb045954a8a4aa0 Mon Sep 17 00:00:00 2001 From: agle Date: Fri, 19 Jun 2026 16:16:34 +1000 Subject: [PATCH 01/22] var allocator --- lib/gtirb/conf.ml | 6 +- lib/gtirb/gfir_to_bincaml.ml | 33 +++---- lib/lang/algsimp.ml | 5 +- lib/lang/expr_eval.ml | 3 +- lib/lang/procedure.ml | 36 ++++---- lib/lang/program.ml | 35 ++++++-- lib/lang/program.mli | 19 +++- lib/loadir.ml | 28 +++--- lib/util/ID.ml | 2 - lib/util/var.ml | 165 +++++++++++++++++++---------------- 10 files changed, 187 insertions(+), 145 deletions(-) diff --git a/lib/gtirb/conf.ml b/lib/gtirb/conf.ml index ce40c0ad..b976b0cc 100644 --- a/lib/gtirb/conf.ml +++ b/lib/gtirb/conf.ml @@ -2,12 +2,12 @@ open Lang.Common type config = { opcode_length : int; (** arm64 opcode size constant *) - pc_var : Var.t; (* variable to use as PC*) + pc_var : (string * Types.t); (* variable to use as PC*) disas : bool; (** include disassembly of opcodes if llvm-mc is available *) direct : bool; (** when true, don't attempt to perform any cleanup of gtirb's cfg *) } -let conf = - let pc_var = Var.create "$PC" ~scope:Var.GlobalVar (Bitvector 64) in +let conf = + let pc_var = ("$PC" , Types.(Bitvector 64)) in { opcode_length = 4; pc_var; disas = false; direct = false } diff --git a/lib/gtirb/gfir_to_bincaml.ml b/lib/gtirb/gfir_to_bincaml.ml index 85a7a044..1f2681d2 100644 --- a/lib/gtirb/gfir_to_bincaml.ml +++ b/lib/gtirb/gfir_to_bincaml.ml @@ -13,21 +13,21 @@ open Gfir open Conf open struct - let addr_equal_expr addr = + let addr_equal_expr pc_var addr = Lang.Expr.BasilExpr.( - binexp ~op:`EQ (bvconst (Bitvec.of_int ~size:64 addr)) (rvar conf.pc_var)) + binexp ~op:`EQ (bvconst (Bitvec.of_int ~size:64 addr)) (pc_var)) let sanitize_proc_name p = List.fold_left (fun a sub -> String.replace ~sub ~by:"" a) p [ "@"; "." ] end -let add_proxy_block ?(attrib = StringMap.empty) succ_addr (proc, blockmap) uuid +let add_proxy_block pc_var ?(attrib = StringMap.empty) succ_addr (proc, blockmap) uuid = let open Lang in let open Option in let ensure = succ_addr uuid - |> Iter.map (fun addr -> addr_equal_expr addr) + |> Iter.map (fun addr -> addr_equal_expr pc_var addr) |> Iter.to_list |> Expr.BasilExpr.applyintrin ~op:`OR in @@ -42,13 +42,13 @@ let add_proxy_block ?(attrib = StringMap.empty) succ_addr (proc, blockmap) uuid (* Update (procedure, uuidmap) with a newly created IR block containing stmts and PC address contract*) -let add_new_simple_block ?(name_suffix = "") ?(attrib = StringMap.empty) +let add_new_simple_block pc_var ?(name_suffix = "") ?(attrib = StringMap.empty) succ_addr (proc, blockmap) (uuid, addr, stmts) = let open Lang in let open Option in let guard = let* addr = addr in - let guard = addr_equal_expr addr in + let guard = addr_equal_expr pc_var addr in let guard = Stmt.Instr_Assume { body = guard; branch = false; attrib = Attrib.empty } in @@ -56,7 +56,7 @@ let add_new_simple_block ?(name_suffix = "") ?(attrib = StringMap.empty) in let ensure = succ_addr uuid - |> Iter.map (fun addr -> addr_equal_expr addr) + |> Iter.map (fun addr -> addr_equal_expr pc_var addr) |> Iter.to_list |> Expr.BasilExpr.applyintrin ~op:`OR in @@ -73,7 +73,7 @@ let add_new_simple_block ?(name_suffix = "") ?(attrib = StringMap.empty) (* Update (procedure, uuidmap) with a newly created IR block with opcodes and PC address contract *) -let add_new_code_block (all_blocks : block UUIDMap.t) temp_proc succ_addr +let add_new_code_block pc_var (all_blocks : block UUIDMap.t) temp_proc succ_addr (proc, blockmap) (b : Gtirb.block) = let open Lang in let open Option in @@ -130,11 +130,11 @@ let add_new_code_block (all_blocks : block UUIDMap.t) temp_proc succ_addr match b with | Code { address } | Data { address } -> Some - (add_new_simple_block ~name_suffix:"_code" ~attrib succ_addr + (add_new_simple_block pc_var ~name_suffix:"_code" ~attrib succ_addr (proc, blockmap) (Gtirb.uuid b, Some address, instrs)) | Proxy uuid -> - Some (add_proxy_block ~attrib succ_addr (proc, blockmap) uuid) + Some (add_proxy_block pc_var ~attrib succ_addr (proc, blockmap) uuid) in Option.get_or ~default:(proc, blockmap) bl @@ -242,7 +242,7 @@ let transform_cfg_calls procs = { p with cfg }) procs -let temp_proc_to_ir_proc all_blocks m (p : temp_proc) = +let temp_proc_to_ir_proc pc_var all_blocks m (p : temp_proc) = let entry_addrs = UUIDSet.to_iter p.entries |> Iter.filter_map (fun x -> UUIDMap.find x p.code_blocks |> Gtirb.address) @@ -252,7 +252,7 @@ let temp_proc_to_ir_proc all_blocks m (p : temp_proc) = entry_addrs |> Iter.map (fun i -> Lang.Expr.BasilExpr.( - binexp ~op:`EQ (bvconst (Bitvec.of_int ~size:64 i)) (rvar conf.pc_var))) + binexp ~op:`EQ (bvconst (Bitvec.of_int ~size:64 i)) (pc_var))) |> Iter.to_list |> fun conj -> Lang.Expr.BasilExpr.applyintrin ~op:`OR conj |> fun pc_init -> [ pc_init ] @@ -278,7 +278,7 @@ let temp_proc_to_ir_proc all_blocks m (p : temp_proc) = let proc, blocks = p.code_blocks |> UUIDMap.to_iter |> Iter.map snd |> Iter.fold - (add_new_code_block all_blocks p succ_addr) + (add_new_code_block pc_var all_blocks p succ_addr) (proc, UUIDMap.empty) in let proc, blocks = @@ -294,7 +294,7 @@ let temp_proc_to_ir_proc all_blocks m (p : temp_proc) = (UUIDMap.find_opt uuid all_blocks) | _ -> None) |> Iter.fold - (add_new_simple_block ~name_suffix:"_ext" succ_addr) + (add_new_simple_block pc_var ~name_suffix:"_ext" succ_addr) (proc, blocks) in @@ -314,7 +314,8 @@ let temp_proc_to_ir_proc all_blocks m (p : temp_proc) = (** Convert Gtirb Protobuf module to a Bincaml IR program*) let module_to_ir_prog ir_cfg (m : Module.t) = let prog = Lang.Program.empty ~name:m.name () in - let prog = Lang.Program.decl_global prog conf.pc_var in + let pc_n, pc_ty = conf.pc_var in + let prog, pc_var = Lang.Program.decl_global_var prog pc_n GlobalVar pc_ty in (* (1) build Gfir CFG *) let entry_proc, procs = gtirb_to_gfir prog ir_cfg m in (* collect map of all blocks in order to fixup interprocedural control-flow @@ -337,7 +338,7 @@ let module_to_ir_prog ir_cfg (m : Module.t) = *) let prog = UUIDMap.fold - (fun _ proc prog -> temp_proc_to_ir_proc all_blocks prog proc) + (fun _ proc prog -> temp_proc_to_ir_proc pc_var all_blocks prog proc) procs prog in let entry_proc = UUIDMap.find entry_proc procs in diff --git a/lib/lang/algsimp.ml b/lib/lang/algsimp.ml index 1988d689..ff8551a6 100644 --- a/lib/lang/algsimp.ml +++ b/lib/lang/algsimp.ml @@ -324,13 +324,14 @@ let normalise e = BasilExpr.rewrite_typed_two normalise e let%expect_test "normalise" = + let gs = Var.mk_gen () in let e = BasilExpr.boolnot @@ BasilExpr.boolnot @@ BasilExpr.boolnot @@ BasilExpr.applyintrin ~op:`AND [ BasilExpr.boolnot - (BasilExpr.boolnot (BasilExpr.rvar (Var.create "b" Boolean))); - BasilExpr.rvar (Var.create "a" Boolean); + (BasilExpr.boolnot (BasilExpr.rvar (gs.fresh Boolean))); + BasilExpr.rvar (gs.fresh Boolean); ] in print_endline (BasilExpr.to_string e); diff --git a/lib/lang/expr_eval.ml b/lib/lang/expr_eval.ml index 37aafe14..b7f976f9 100644 --- a/lib/lang/expr_eval.ml +++ b/lib/lang/expr_eval.ml @@ -118,10 +118,11 @@ let%expect_test _ = let%expect_test _ = let open BasilExpr in let ten = bv_of_int ~size:10 10 in + let vg = Var.mk_gen () in let e = binexp ~op:`BVMUL (applyintrin ~op:`BVADD [ ten; ten ]) - (BasilExpr.rvar (Var.create "beans" Types.(Bitvector 10))) + (BasilExpr.rvar (vg.fresh ~name:"beans" Types.(Bitvector 10))) in print_endline (to_string e); let r = to_string @@ partial_eval_expr e in diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index f77d0bca..57c4444f 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -110,6 +110,7 @@ module PG : sig val create : ID.t -> + ?local_id_gen:ID.generator -> ?is_stub:bool -> ?formal_in_params:'a StringMap.t -> ?formal_out_params:'a StringMap.t -> @@ -139,7 +140,7 @@ module PG : sig val local_ids : ('a, 'b) t -> ID.generator (** return mutable generator for fresh local variable IDS *) - val local_decls : ('a, 'b) t -> 'a Var.Decls.t + val local_decls : ('a, 'b) t -> (string, 'a) Hashtbl.t (** return mutable declaration map for local var IDS *) val formal_in_params : ('a, 'b) t -> 'a StringMap.t @@ -173,7 +174,7 @@ end = struct formal_in_params : 'v StringMap.t; formal_out_params : 'v StringMap.t; graph : G.t option; - locals : 'v Var.Decls.t; + locals : (string, 'v) Hashtbl.t; topo_fwd : Vert.t Graph.WeakTopological.t lazy_t; topo_rev : Vert.t Graph.WeakTopological.t lazy_t; local_ids : ID.generator; @@ -231,19 +232,24 @@ end = struct let graph = G.add_vertex graph Return in graph - let create id ?(is_stub = false) ?(formal_in_params = StringMap.empty) + let create id ?local_id_gen ?(is_stub = false) ?(formal_in_params = StringMap.empty) ?(formal_out_params = StringMap.empty) ?(captures_globs = []) ?(modifies_globs = []) ?(requires = []) ?(ensures = []) ?(rely = []) ?(guarantee = []) ?(attrib = Attrib.empty) () = let specification = { captures_globs; modifies_globs; requires; ensures; rely; guarantee } in - let local_ids = ID.make_gen () in + let local_ids = match local_id_gen with + | Some g -> g + | None -> let g = ID.make_gen () in + (* Oh no: we could have used a _different_ generator to build the in-params *) + StringMap.iter (fun k v -> ignore @@ g.decl_exn k) formal_in_params; + StringMap.iter (fun k v -> ignore @@ g.decl_exn k) formal_out_params; + g + in let block_ids = ID.make_gen () in - StringMap.iter (fun k v -> ignore @@ local_ids.decl_exn k) formal_in_params; - StringMap.iter (fun k v -> ignore @@ local_ids.decl_exn k) formal_out_params; - let locals = Var.Decls.empty () in - Var.Decls.add_iter locals + let locals = Hashtbl.create (StringMap.cardinal formal_in_params + StringMap.cardinal formal_out_params) in + Hashtbl.add_iter locals (Iter.append (StringMap.to_iter formal_in_params) (StringMap.to_iter formal_out_params)); @@ -442,23 +448,23 @@ let replace_edge p id (block : (Var.t, BasilExpr.t) Block.t) = update_block p id block let lookup_local_decl p v = - Var.Decls.find_opt (local_decls p) v + Hashtbl.find_opt (local_decls p) v |> Option.or_lazy ~else_:(fun () -> StringMap.find_opt v (formal_out_params p)) |> Option.or_lazy ~else_:(fun () -> StringMap.find_opt v (formal_in_params p)) -let decl_local p v = - let _ = (local_ids p).decl_or_get (Var.name v) in - Var.Decls.replace (local_decls p) (Var.name v) v; +let decl_local _var p ?(pure = false) name typ : Var.t = + let scope = if pure then Var.LocalConst else LocalVar in + let v = Var.create_exn (local_ids p) name ~scope typ in + Hashtbl.replace (local_decls p) (Var.name v) v; v let fresh_var p ?(pure = false) ?name typ : Var.t = let name = Option.map (String.drop_while (Char.equal '$')) name in let name = Option.get_or ~default:"v" name in - let n = ID.name @@ (local_ids p).fresh ~name () in let scope = if pure then Var.LocalConst else LocalVar in - let v = Var.create n typ ~scope in - Var.Decls.replace (local_decls p) (Var.name v) v; + let v = Var.fresh (local_ids p) name typ ~scope in + Hashtbl.replace (local_decls p) (Var.name v) v; v let blocks_to_list p = diff --git a/lib/lang/program.ml b/lib/lang/program.ml index 9353a856..6919a2b7 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -53,7 +53,7 @@ let decl_binding = function | Type { binding } -> binding | Variable { binding } -> Var.name binding | Function { binding } -> Var.name binding - | Procedure { definition } -> ID.to_string (Procedure.id definition) + | Procedure { definition } -> ID.name (Procedure.id definition) let pretty_proc p = let show_lvar v = Containers_pp.text @@ Var.to_string_il_lvar v in @@ -185,15 +185,14 @@ let declare_name_exn name prog = prog.global_names.decl_exn name let declare_name name prog = prog.global_names.decl_or_get name let get_id_by_name name prog = prog.global_names.get_id name -let add_decl ?(attrib = StringMap.empty) p decl = - let d = p.global_names.decl_or_get (decl_binding decl) in - { p with declarations = IDMap.add d decl p.declarations } - let remove_decl p decl = let d = p.global_names.decl_or_get (decl_binding decl) in { p with declarations = IDMap.remove d p.declarations } let update_decl ?(attrib = StringMap.empty) prog decl = + let d = p.global_names.decl_or_get (decl_binding decl) in + { p with declarations = IDMap.add id decl p.declarations } + add_decl ~attrib prog decl let add_proc p prog = @@ -285,11 +284,29 @@ let pretty_to_chan chan (p : t) = Containers_pp.Pretty.to_format ~width:80 fmt p; Format.flush fmt () -let decl_global ?(attrib = StringMap.empty) ?(classification = None) p v = - let id : ID.t = p.global_names.decl_exn (Var.name v) in - let decl = Variable { binding = v; attrib; classification } in + (* + +Variable { binding = v; attrib; classification } + + *) + +let decl_global p name f = + let id : ID.t = p.global_names.decl_exn name in + let decl = f id in + { p with declarations = IDMap.add id decl p.declarations } + +let add_decl p name decl = + let id : ID.t = p.global_names.decl_exn name in + let decl = f id in { p with declarations = IDMap.add id decl p.declarations } + +let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name scope typ = + let f v = let r = ref None in match r with Some v -> v | None -> r := Some v ; v in + let p = decl_global p name (fun id -> Variable { binding = f (Var.create id ~scope typ) ; attrib; classification }) in + (p, f (failwith "")) + + let decl_typ ?(attrib = StringMap.empty) p t = match t with | Sort (type_name, []) as s -> @@ -313,7 +330,7 @@ let decl_typ ?(attrib = StringMap.empty) p t = let args = List.map (function { field; typ } -> typ) fields in let ty = Types.curry args s in let constructor = - Var.create (ID.name variant) ty ~scope:GlobalConst + Var.create (variant) ty ~scope:GlobalConst in ( variant, VariantCase diff --git a/lib/lang/program.mli b/lib/lang/program.mli index 850f083e..f3beb40c 100644 --- a/lib/lang/program.mli +++ b/lib/lang/program.mli @@ -77,7 +77,6 @@ val get_proc_by_name : string -> t -> proc val get_implicit_decl_by_name : string -> t -> implicit_declaration option val declare_name : string -> t -> ID.t val declare_name_exn : string -> t -> ID.t -val add_decl : ?attrib:'a Types.StringMap.t -> t -> declaration -> t val remove_decl : t -> declaration -> t val update_decl : ?attrib:'a Types.StringMap.t -> t -> declaration -> t val add_proc : (Var.t, Expr.BasilExpr.t) Procedure.t -> t -> t @@ -98,12 +97,24 @@ val flat_map_decls : (ID.t -> declaration -> declaration Iter.t) -> t -> t val pretty_to_chan : out_channel -> t -> unit val decl_global : - ?attrib:Attrib.t Types.StringMap.t -> - ?classification:e option -> t -> - Var.t -> + string -> + ID.t -> declaration -> + t + +val add_decl: + t -> + string -> + ID.t -> declaration -> t +val decl_global_var : + t -> + ?attrib:Attrib.t Types.StringMap.t -> + ?classification:e option -> + string -> Var.scope -> Types.t -> t + + val decl_typ : ?attrib:'a Types.StringMap.t -> t -> Types.t -> t val create_single_proc : diff --git a/lib/loadir.ml b/lib/loadir.ml index 048f8965..90d84734 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -179,6 +179,7 @@ module BasilASTLoader = struct | TypeAssign_Sum (localIdent, typeT) -> let n = unsafe_unsigil (`Type localIdent) in ( n, + Types.mk_adt n (typeT |> List.map (function @@ -207,20 +208,17 @@ module BasilASTLoader = struct let scope = var_modifiers_shared modifiers in map_prog (fun p -> - Program.decl_global p ~classification - (Var.create + Program.decl_global_var p ~classification (unsafe_unsigil (`Global bident)) - ~scope (trans_type type'))) + scope (trans_type type')) prog | Decl_Var (modifiers, bident, type', spec) -> let classification = trans_varspec prog spec in let scope = var_modifiers_shared modifiers in map_prog (fun p -> - Program.decl_global p ~classification - (Var.create - (unsafe_unsigil (`Global bident)) - ~scope (trans_type type'))) + Program.decl_global_var p ~classification + (unsafe_unsigil (`Global bident)) scope (trans_type type')) prog | Decl_ProgEmpty (ProcIdent (_, id), attr) -> prog | Decl_ProgWithSpec (ProcIdent (_, id), attr, spec) -> prog @@ -228,28 +226,24 @@ module BasilASTLoader = struct let ftype = trans_type rettype in map_prog (fun p -> - Program.decl_global p - (Var.create - (unsafe_unsigil (`Global glident)) - ~scope:GlobalConst ftype)) + Program.decl_global_var p + (unsafe_unsigil (`Global glident)) GlobalConst ftype) prog | Decl_FunNoType (glident, _, _) -> prog | Decl_Fun (glident, params, _, typ, _) -> let bound = unpac_lambdaparen ~bound:StringMap.empty prog params in let arg_types = List.map Var.typ bound in let rtype = Types.curry arg_types (trans_type typ) in - let bvar = - Var.create (unsafe_unsigil (`Global glident)) ~scope:GlobalConst rtype - in - let fundef : Program.declaration = + let name = (unsafe_unsigil (`Global glident)) in + let fundef id : Program.declaration = Function { attrib = StringMap.empty; - binding = bvar; + binding = Var.create id ~scope:GlobalConst rtype definition = Uninterpreted; } in - map_prog (fun prog -> Program.add_decl prog fundef) prog + map_prog (fun prog -> Program.add_decl prog name fundef) prog | Decl_Axiom (name, _, _) -> let bvar = Var.create (unsafe_unsigil (`Global name)) ~scope:GlobalConst Boolean diff --git a/lib/util/ID.ml b/lib/util/ID.ml index 118263cd..1e3e389e 100644 --- a/lib/util/ID.ml +++ b/lib/util/ID.ml @@ -176,8 +176,6 @@ module ID : ID_Pub = struct end include ID -module Map = Map.Make (ID) -module Set = Set.Make (ID) (** return a previously declared unique integer identifier for a name *) let get_id (g : generator) = g.get_id diff --git a/lib/util/var.ml b/lib/util/var.ml index 1ba6d057..f15f7413 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -1,71 +1,33 @@ open Containers open Mtypes + + type scope = LocalConst | LocalVar | GlobalVar | GlobalConst | GlobalVarShared [@@deriving show, eq, ord] -open struct - module V = struct - type t = { name : string; typ : Types.t; scope : scope } - [@@deriving eq, ord, show] - - let hash v = - Hash.(combine3 (Hash.string v.name) (Hash.poly v.scope) (Hash.poly v.typ)) - end -end - -(** variables are interned *) - -module H = Fix.HashCons.ForHashedTypeWeak (V) - -include ( - struct - type t = V.t Fix.HashCons.cell - - 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 } - - let copy ?name ?scope ?typ (v : t) = - let v = Fix.HashCons.data v in - H.make - { - name = Option.get_or ~default:v.name name; - typ = Option.get_or ~default:v.typ typ; - scope = Option.get_or ~default:v.scope scope; - } - - let to_int (v : V.t Fix.HashCons.cell) = v.id - let show v = V.show (Fix.HashCons.data v) - let equal (a : t) (b : t) : bool = Fix.HashCons.equal a b - let compare (a : t) (b : t) : int = Fix.HashCons.compare a b - let name (e : t) = (Fix.HashCons.data e).name - let scope (e : t) = (Fix.HashCons.data e).scope - let typ (e : t) = (Fix.HashCons.data e).typ - let hash (a : t) = Fix.HashCons.hash a - let to_string v = name v ^ ":" ^ Types.to_string @@ typ v - let pp fmt v = Format.pp_print_string fmt (to_string v) - let pretty v = Containers_pp.text (to_string v) - end : - sig - type t - - val to_int : t -> int - - include HASH_TYPE with type t := t - include PRETTY with type t := t - - val create : string -> ?scope:scope -> Types.t -> t - val pp : Format.formatter -> t -> unit - val to_string : t -> string - val name : t -> string - val scope : t -> scope - val typ : t -> Types.t - val hash : t -> int - val copy : ?name:string -> ?scope:scope -> ?typ:Types.t -> t -> t - end) +type t = { name : ID.t; typ : Types.t; scope : scope } +[@@deriving eq, ord, show] + +let hash v = + Hash.(combine3 (ID.hash v.name) (Hash.poly v.scope) (Hash.poly v.typ)) + + +let copy ?name ?scope ?typ (v : t) = + { + name = Option.get_or ~default:v.name name; + typ = Option.get_or ~default:v.typ typ; + scope = Option.get_or ~default:v.scope scope; + } + +let to_int (v : t) = ID.index (v.name) +let name (e : t) = ID.name @@ e.name +let scope (e : t) = e.scope +let typ (e : t) = e.typ +let to_string v = name v ^ ":" ^ Types.to_string @@ typ v +let pp fmt v = Format.pp_print_string fmt (to_string v) +let pretty v = Containers_pp.text (to_string v) + let is_local (v : t) = match scope v with LocalVar -> true | LocalConst -> true | _ -> false @@ -102,20 +64,71 @@ let to_decl_string_il v = let modifiers = if is_shared v then "observable " else "" in "var " ^ modifiers ^ to_string v -module Decls = struct - include Hashtbl +(** Variable Generators *) + + +type generator = { + fresh: ?name:string -> ?scope:scope -> Types.t -> t; + (** generate a fresh unique name optional string prefix hint *) + with_name: string -> ?scope:scope -> Types.t -> t; + (** Create or return variable with name*) + create_exn: string -> ?scope:scope -> Types.t -> t; + (** Create variable or throw exception if it was previously declared *) + generator: ID.generator; + (** The internal ID generator this closes over *) +} + + +type ('t, 'a, 'g) any_gen = { + call: 'a -> 't; + (** Create variable or throw exception if it was previously declared *) + inner: 'g +} + + +let create name ?(scope = LocalVar) typ = + (* disallow creating local const as its too hard to have declaration order *) + match scope with + | LocalConst -> { name; typ; scope = LocalVar } + | _ -> { name; typ; scope } + +let to_gen (a:generator) = + let call = function + | `Fresh (g: (string option* scope option * Types.t)) -> let (name, scope, typ) = g in a.fresh ?name ?scope typ + | `WithName (g : (string * scope option * Types.t)) -> let (name, scope, typ) = g in a.with_name name ?scope typ + | `CreateExn g -> let (name, scope, typ) = g in a.create_exn name ?scope typ in + { + call; + inner=a + } + + +let fresh (id_gen: ID.generator) name ?scope typ = + let name = id_gen.fresh ~name () in + create name ?scope typ + +let with_name (id_gen: ID.generator) name ?scope typ = + let name = id_gen.decl_or_get name in + create name ?scope typ + +let create_exn (id_gen: ID.generator) name ?scope typ = + let name = id_gen.decl_exn name in + create name ?scope typ + + +let mk_gen ?id_generator ?(default_name="v") () = + let id_gen = Option.get_or ~default:(ID.make_gen ()) id_generator in + + let fresh ?name ?scope typ = + let name = Option.get_or ~default:default_name name in + fresh id_gen name ?scope typ + in - type 'v t = (string, 'v) Hashtbl.t + { + fresh ; + with_name= with_name id_gen; + create_exn = create_exn id_gen; + generator=id_gen; + } - let find_opt m name = Hashtbl.find_opt m name - let empty () : 'v t = Hashtbl.create 30 - (*let add m vn v = - let d = find_opt m (name vn) in - match d with - | Some e when equal e v -> () - | Some _ -> - failwith @@ "Already declared diff var with that name: " ^ name v - | None -> Hashtbl.add m (name vn) v - *) -end From d425b264ea1170d7e550a5e01433c66887ca783e Mon Sep 17 00:00:00 2001 From: agle Date: Wed, 24 Jun 2026 18:14:29 +1000 Subject: [PATCH 02/22] wip --- examples | 2 +- lib/analysis/sva.ml | 16 +- lib/gtirb/gfir_to_bincaml.ml | 16 +- lib/lang/procedure.ml | 35 ++- lib/lang/program.ml | 70 +++-- lib/lang/program.mli | 24 +- lib/loadir.ml | 166 ++++++------ lib/transforms/boogie_prepass.ml | 14 +- lib/transforms/function_summaries.ml | 12 +- lib/transforms/gamma_vars.ml | 365 +++++++++++++++------------ lib/transforms/livevars.ml | 7 +- lib/transforms/memory_encoding.ml | 94 ++++--- lib/transforms/ssa.ml | 2 +- lib/util/var.ml | 3 + 14 files changed, 469 insertions(+), 357 deletions(-) diff --git a/examples b/examples index 92a27e32..51d12f65 160000 --- a/examples +++ b/examples @@ -1 +1 @@ -Subproject commit 92a27e32df5de3de4631554b72c3064defda44e9 +Subproject commit 51d12f6565ee284ea50a86e823c5d65177275941 diff --git a/lib/analysis/sva.ml b/lib/analysis/sva.ml index e7260eb0..6a3a39f1 100644 --- a/lib/analysis/sva.ml +++ b/lib/analysis/sva.ml @@ -163,9 +163,9 @@ module Eval = Intra_analysis.EvalStmt (SVAAbstractionBasil) module Domain = struct include StateAbstraction - let stack_pointer = Var.create ~scope:LocalConst "R31_in" @@ Bitvector 64 - let link_register = Var.create ~scope:LocalConst "R30_in" @@ Bitvector 64 - let frame_pointer = Var.create ~scope:LocalConst "R29_in" @@ Bitvector 64 + let stack_pointer p = Procedure.get_local p "R31_in" (Bitvector 64) + let link_register p = Procedure.get_local p "R30_in" (Bitvector 64) + let frame_pointer p = Procedure.get_local p "R29_in" (Bitvector 64) (* These registers are preserved over calls and are not real params, so we can ignore later *) let call_preserve = @@ -191,18 +191,18 @@ module Domain = struct SymAddrSetLattice.singleton (Par { name; param }) @@ IntervalDomain.init @@ Bitvec.zero ~size )) |> Iter.cons - ( stack_pointer, + ( stack_pointer proc, SymAddrSetLattice.singleton (SymBase.Stack name) @@ IntervalDomain.init @@ Bitvec.zero ~size:64 ) |> Iter.cons - ( link_register, + ( link_register proc, SymAddrSetLattice.singleton - (SymBase.Par { name; param = link_register }) + (SymBase.Par { name; param = link_register proc }) @@ IntervalDomain.init @@ Bitvec.zero ~size:64 ) |> Iter.cons - ( frame_pointer, + ( frame_pointer proc, SymAddrSetLattice.singleton - (SymBase.Par { name; param = frame_pointer }) + (SymBase.Par { name; param = frame_pointer proc }) @@ IntervalDomain.init @@ Bitvec.zero ~size:64 ) |> Iter.fold (fun m (v, d) -> update v d m) bottom diff --git a/lib/gtirb/gfir_to_bincaml.ml b/lib/gtirb/gfir_to_bincaml.ml index 1f2681d2..eb8523ad 100644 --- a/lib/gtirb/gfir_to_bincaml.ml +++ b/lib/gtirb/gfir_to_bincaml.ml @@ -15,14 +15,16 @@ open Conf open struct let addr_equal_expr pc_var addr = Lang.Expr.BasilExpr.( - binexp ~op:`EQ (bvconst (Bitvec.of_int ~size:64 addr)) (pc_var)) + binexp ~op:`EQ + (bvconst (Bitvec.of_int ~size:64 addr)) + (Lang.Expr.BasilExpr.rvar pc_var)) let sanitize_proc_name p = List.fold_left (fun a sub -> String.replace ~sub ~by:"" a) p [ "@"; "." ] end -let add_proxy_block pc_var ?(attrib = StringMap.empty) succ_addr (proc, blockmap) uuid - = +let add_proxy_block pc_var ?(attrib = StringMap.empty) succ_addr + (proc, blockmap) uuid = let open Lang in let open Option in let ensure = @@ -73,8 +75,8 @@ let add_new_simple_block pc_var ?(name_suffix = "") ?(attrib = StringMap.empty) (* Update (procedure, uuidmap) with a newly created IR block with opcodes and PC address contract *) -let add_new_code_block pc_var (all_blocks : block UUIDMap.t) temp_proc succ_addr - (proc, blockmap) (b : Gtirb.block) = +let add_new_code_block (pc_var : Var.t) (all_blocks : block UUIDMap.t) temp_proc + succ_addr (proc, blockmap) (b : Gtirb.block) = let open Lang in let open Option in let attrib = @@ -252,7 +254,9 @@ let temp_proc_to_ir_proc pc_var all_blocks m (p : temp_proc) = entry_addrs |> Iter.map (fun i -> Lang.Expr.BasilExpr.( - binexp ~op:`EQ (bvconst (Bitvec.of_int ~size:64 i)) (pc_var))) + binexp ~op:`EQ + (bvconst (Bitvec.of_int ~size:64 i)) + (Lang.Expr.BasilExpr.rvar pc_var))) |> Iter.to_list |> fun conj -> Lang.Expr.BasilExpr.applyintrin ~op:`OR conj |> fun pc_init -> [ pc_init ] diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index 57c4444f..d202e9a9 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -232,23 +232,31 @@ end = struct let graph = G.add_vertex graph Return in graph - let create id ?local_id_gen ?(is_stub = false) ?(formal_in_params = StringMap.empty) + + let create id ?local_id_gen ?(is_stub = false) + ?(formal_in_params = StringMap.empty) ?(formal_out_params = StringMap.empty) ?(captures_globs = []) ?(modifies_globs = []) ?(requires = []) ?(ensures = []) ?(rely = []) ?(guarantee = []) ?(attrib = Attrib.empty) () = let specification = { captures_globs; modifies_globs; requires; ensures; rely; guarantee } in - let local_ids = match local_id_gen with - | Some g -> g - | None -> let g = ID.make_gen () in + let local_ids = + match local_id_gen with + | Some g -> g + | None -> + let g = ID.make_gen () in (* Oh no: we could have used a _different_ generator to build the in-params *) StringMap.iter (fun k v -> ignore @@ g.decl_exn k) formal_in_params; StringMap.iter (fun k v -> ignore @@ g.decl_exn k) formal_out_params; g - in + in let block_ids = ID.make_gen () in - let locals = Hashtbl.create (StringMap.cardinal formal_in_params + StringMap.cardinal formal_out_params) in + let locals = + Hashtbl.create + (StringMap.cardinal formal_in_params + + StringMap.cardinal formal_out_params) + in Hashtbl.add_iter locals (Iter.append (StringMap.to_iter formal_in_params) @@ -453,7 +461,20 @@ let lookup_local_decl p v = StringMap.find_opt v (formal_out_params p)) |> Option.or_lazy ~else_:(fun () -> StringMap.find_opt v (formal_in_params p)) -let decl_local _var p ?(pure = false) name typ : Var.t = +let lookup_local_decl_exn p v = + Hashtbl.find_opt (local_decls p) v + |> Option.or_lazy ~else_:(fun () -> + StringMap.find_opt v (formal_out_params p)) + |> Option.or_lazy ~else_:(fun () -> StringMap.find_opt v (formal_in_params p)) + |> Option.get_exn_or ("no local decl : " ^ v) + +let get_local p ?(pure = false) name typ : Var.t = + let scope = if pure then Var.LocalConst else LocalVar in + let v = Var.with_name (local_ids p) name ~scope typ in + Hashtbl.replace (local_decls p) (Var.name v) v; + v + +let decl_local p ?(pure = false) name typ : Var.t = let scope = if pure then Var.LocalConst else LocalVar in let v = Var.create_exn (local_ids p) name ~scope typ in Hashtbl.replace (local_decls p) (Var.name v) v; diff --git a/lib/lang/program.ml b/lib/lang/program.ml index 6919a2b7..d7d41f42 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -36,7 +36,7 @@ type implicit_declaration = } type declaration = - | Type of { binding : string; typ : Types.t } + | Type of { binding : ID.t; typ : Types.t } | Function of { binding : Var.t; attrib : Attrib.attrib_map; @@ -55,6 +55,13 @@ let decl_binding = function | Function { binding } -> Var.name binding | Procedure { definition } -> ID.name (Procedure.id definition) +let decl_id = function + | Type { binding } -> binding + | Variable { binding } -> (Var.id binding) + | Function { binding } -> (Var.id binding) + | Procedure { definition } -> (Procedure.id definition) + + let pretty_proc p = let show_lvar v = Containers_pp.text @@ Var.to_string_il_lvar v in let show_var v = Containers_pp.text @@ Var.to_string_il_rvar v in @@ -189,12 +196,10 @@ let remove_decl p decl = let d = p.global_names.decl_or_get (decl_binding decl) in { p with declarations = IDMap.remove d p.declarations } -let update_decl ?(attrib = StringMap.empty) prog decl = - let d = p.global_names.decl_or_get (decl_binding decl) in +let update_decl ?(attrib = StringMap.empty) p decl = + let id = p.global_names.decl_or_get (decl_binding decl) in { p with declarations = IDMap.add id decl p.declarations } - add_decl ~attrib prog decl - let add_proc p prog = let id = Procedure.id p in { @@ -284,28 +289,57 @@ let pretty_to_chan chan (p : t) = Containers_pp.Pretty.to_format ~width:80 fmt p; Format.flush fmt () - (* +(* Variable { binding = v; attrib; classification } *) -let decl_global p name f = - let id : ID.t = p.global_names.decl_exn name in - let decl = f id in - { p with declarations = IDMap.add id decl p.declarations } +let add_decl p decl = + { p with declarations = IDMap.add (decl_id decl) decl p.declarations } -let add_decl p name decl = +let decl_global p name f = let id : ID.t = p.global_names.decl_exn name in let decl = f id in - { p with declarations = IDMap.add id decl p.declarations } + add_decl p id decl + +let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name + scope typ = + let f v = + let r = ref None in + match !r with + | Some v -> v + | None -> + r := Some v; + v + in + let p = + decl_global p name (fun id -> + Variable + { binding = f (Var.create id ~scope typ); attrib; classification }) + in + (p, f (failwith "")) +(** add var decl for with id exising in generator *) +let add_var_decl p ?(attrib = Attrib.empty) ?classification v = + let id = Var.id v in + (try p.global_names.get_name (ID.index id) |> ignore + with Not_found -> failwith "Id not created with programs' generator"); + { + p with + declarations = + IDMap.add id + (Variable { attrib; classification; binding = v }) + p.declarations; + } -let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name scope typ = - let f v = let r = ref None in match r with Some v -> v | None -> r := Some v ; v in - let p = decl_global p name (fun id -> Variable { binding = f (Var.create id ~scope typ) ; attrib; classification }) in - (p, f (failwith "")) +let global_ids p = p.global_names +let decl_or_get_var p name scope typ = + let id : ID.t = p.global_names.decl_or_get name in + IDMap.find_opt id p.declarations |> function + | Some (Variable { binding }) -> (p, binding) + | _ -> decl_global_var p name scope typ let decl_typ ?(attrib = StringMap.empty) p t = match t with @@ -329,9 +363,7 @@ let decl_typ ?(attrib = StringMap.empty) p t = let variant = p.global_names.decl_exn variant in let args = List.map (function { field; typ } -> typ) fields in let ty = Types.curry args s in - let constructor = - Var.create (variant) ty ~scope:GlobalConst - in + let constructor = Var.create variant ty ~scope:GlobalConst in ( variant, VariantCase { variant = ID.name variant; belongs_to = s; constructor } diff --git a/lib/lang/program.mli b/lib/lang/program.mli index f3beb40c..07a8a39a 100644 --- a/lib/lang/program.mli +++ b/lib/lang/program.mli @@ -51,6 +51,7 @@ type declaration = | Procedure of { definition : proc } val decl_binding : declaration -> string +val decl_id : declaration -> ID.t val pretty_proc : (Var.t, 'a) Procedure.t -> Containers_pp.t val pretty_declaration : declaration -> Containers_pp.t @@ -95,26 +96,23 @@ val map_decls : (ID.t -> declaration -> declaration) -> t -> t val filter_map_decls : (ID.t -> declaration -> declaration option) -> t -> t val flat_map_decls : (ID.t -> declaration -> declaration Iter.t) -> t -> t val pretty_to_chan : out_channel -> t -> unit +val decl_global : t -> string -> (ID.t -> declaration) -> t +val add_decl : t -> declaration -> t -val decl_global : - t -> - string -> - ID.t -> declaration -> - t - -val add_decl: - t -> - string -> - ID.t -> declaration -> - t +val add_var_decl : + t -> ?attrib:Attrib.attrib_map -> ?classification:e -> Var.t -> t val decl_global_var : t -> ?attrib:Attrib.t Types.StringMap.t -> ?classification:e option -> - string -> Var.scope -> Types.t -> t - + string -> + Var.scope -> + Types.t -> + t * Var.t +val decl_or_get_var : t -> string -> Var.scope -> Types.t -> t * Var.t +val global_ids : t -> ID.generator val decl_typ : ?attrib:'a Types.StringMap.t -> t -> Types.t -> t val create_single_proc : diff --git a/lib/loadir.ml b/lib/loadir.ml index 90d84734..a40da927 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -179,7 +179,6 @@ module BasilASTLoader = struct | TypeAssign_Sum (localIdent, typeT) -> let n = unsafe_unsigil (`Type localIdent) in ( n, - Types.mk_adt n (typeT |> List.map (function @@ -208,7 +207,8 @@ module BasilASTLoader = struct let scope = var_modifiers_shared modifiers in map_prog (fun p -> - Program.decl_global_var p ~classification + fst + @@ Program.decl_global_var p ~classification (unsafe_unsigil (`Global bident)) scope (trans_type type')) prog @@ -217,8 +217,10 @@ module BasilASTLoader = struct let scope = var_modifiers_shared modifiers in map_prog (fun p -> - Program.decl_global_var p ~classification - (unsafe_unsigil (`Global bident)) scope (trans_type type')) + fst + @@ Program.decl_global_var p ~classification + (unsafe_unsigil (`Global bident)) + scope (trans_type type')) prog | Decl_ProgEmpty (ProcIdent (_, id), attr) -> prog | Decl_ProgWithSpec (ProcIdent (_, id), attr, spec) -> prog @@ -226,30 +228,34 @@ module BasilASTLoader = struct let ftype = trans_type rettype in map_prog (fun p -> - Program.decl_global_var p - (unsafe_unsigil (`Global glident)) GlobalConst ftype) + fst + @@ Program.decl_global_var p + (unsafe_unsigil (`Global glident)) + GlobalConst ftype) prog | Decl_FunNoType (glident, _, _) -> prog | Decl_Fun (glident, params, _, typ, _) -> let bound = unpac_lambdaparen ~bound:StringMap.empty prog params in let arg_types = List.map Var.typ bound in let rtype = Types.curry arg_types (trans_type typ) in - let name = (unsafe_unsigil (`Global glident)) in + let name = unsafe_unsigil (`Global glident) in let fundef id : Program.declaration = Function { attrib = StringMap.empty; - binding = Var.create id ~scope:GlobalConst rtype + binding = Var.create id ~scope:GlobalConst rtype; definition = Uninterpreted; } in - map_prog (fun prog -> Program.add_decl prog name fundef) prog + map_prog + (fun prog -> + let p = Program.decl_global prog name fundef in + p) + prog | Decl_Axiom (name, _, _) -> - let bvar = - Var.create (unsafe_unsigil (`Global name)) ~scope:GlobalConst Boolean - in - - let fundef : Program.declaration = + let name = unsafe_unsigil (`Global name) in + let fundef id : Program.declaration = + let bvar = Var.create id ~scope:GlobalConst Boolean in Function { attrib = StringMap.empty; @@ -257,7 +263,7 @@ module BasilASTLoader = struct definition = Uninterpreted; } in - map_prog (fun prog -> Program.add_decl prog fundef) prog + map_prog (fun prog -> Program.decl_global prog name fundef) prog | Decl_Proc ( ProcIdent (id_pos, id), _, @@ -269,18 +275,21 @@ module BasilASTLoader = struct attrib, spec, definition ) -> + let ids = ID.make_gen () in let proc_id = Program.declare_name id prog.prog in - let formal_in_params_order = List.map param_to_formal in_params in + let formal_in_params_order = List.map (param_to_formal ids) in_params in let formal_in_params = formal_in_params_order |> StringMap.of_list in - let formal_out_params_order = List.map param_to_formal out_params in + let formal_out_params_order = + List.map (param_to_formal ids) out_params + in let formal_out_params = StringMap.of_list formal_out_params_order in let _, attrib = trans_attrib_set prog ~binds:formal_in_params attrib in Hashtbl.add prog.params_order id (formal_in_params_order, formal_out_params_order); let is_stub = Stdlib.(definition = ProcDef_Empty) in let p = - Procedure.create proc_id ~attrib ~is_stub ~formal_in_params - ~formal_out_params () + Procedure.create proc_id ~local_id_gen:ids ~attrib ~is_stub + ~formal_in_params ~formal_out_params () in let prog = map_prog (Program.add_proc p) prog in prog @@ -336,14 +345,12 @@ module BasilASTLoader = struct })) in let _, attrib = trans_attrib_set ~binds:StringMap.empty prog attrList in - let binding = - Var.create (unsafe_unsigil (`Global glident)) ~scope:GlobalConst rtype - in - - let fundef : Program.declaration = + let name = unsafe_unsigil (`Global glident) in + let fundef id : Program.declaration = + let binding = Var.create id ~scope:GlobalConst rtype in Function { attrib; binding; definition } in - map_prog (fun prog -> Program.add_decl prog fundef) prog + map_prog (fun prog -> Program.decl_global prog name fundef) prog (** Second pass: resolve the full definition of all declarations. *) and trans_definition prog (x : decl) : load_st = @@ -357,14 +364,13 @@ module BasilASTLoader = struct | Decl_Axiom (name, attr, body) -> let _, attrib = trans_attrib_set ~binds:StringMap.empty prog attr in let body = trans_expr prog body in - let bvar = - Var.create (unsafe_unsigil (`Global name)) ~scope:GlobalConst Boolean - in + let name = unsafe_unsigil (`Global name) in - let fundef : Program.declaration = + let fundef id : Program.declaration = + let bvar = Var.create id ~scope:GlobalConst Boolean in Function { attrib; binding = bvar; definition = Axiom body } in - map_prog (fun prog -> Program.add_decl prog fundef) prog + map_prog (fun prog -> Program.decl_global prog name fundef) prog | Decl_ProgEmpty (ProcIdent (_, id), attr) -> let _, nattrib = trans_attrib_set ~binds:StringMap.empty prog attr in prog @@ -396,6 +402,7 @@ module BasilASTLoader = struct spec_list, proc_def ) -> let p = Program.get_proc_by_name id prog.prog in + let id_gen = Procedure.local_ids p in let prog = { prog with curr_proc = Some p } in let prog, blocks = match proc_def with @@ -406,7 +413,9 @@ module BasilASTLoader = struct if List.is_empty blocks then p else Procedure.add_empty_impl p in let open Procedure.Vert in - let formal_out_params_order = List.map param_to_formal out_params in + let formal_out_params_order = + List.map (param_to_formal id_gen) out_params + in (* add blocks *) let p, blocks_id = List.fold_left @@ -536,10 +545,11 @@ module BasilASTLoader = struct | VarLocalVar (LocalTyped (localVar, ty)) -> ( try lookup_local_decl ~binds localVar p_st with e -> + let name = unsafe_unsigil (`Local localVar) in let v = - Var.create ~scope:LocalVar - (unsafe_unsigil (`Local localVar)) - (trans_type ty) + Procedure.get_local + (p_st.curr_proc |> Option.get_exn_or "") + name (trans_type ty) in Logs.warn (fun m -> m "global undeclared %s. assuming mutable unshared" @@ Var.name v); @@ -547,12 +557,12 @@ module BasilASTLoader = struct | VarLocalVar (LocalUntyped localVar) -> lookup_local_decl ~binds localVar p_st | VarGlobalVar (GlobalTyped (globalVar, ty)) -> ( + let name = unsafe_unsigil (`Global globalVar) in + try lookup_global_decl globalVar p_st with e -> - let v = - Var.create ~scope:GlobalVar - (unsafe_unsigil (`Global globalVar)) - (trans_type ty) + let p, v = + Program.decl_or_get_var p_st.prog name GlobalVar (trans_type ty) in Logs.warn (fun m -> m "Warn: global undeclared %s. assuming mutable unshared" @@ -880,7 +890,10 @@ module BasilASTLoader = struct lvs |> List.map (function | LocalTyped (i, t) -> - Var.create ~scope (unsafe_unsigil (`Local i)) (trans_type t) + Procedure.get_local + (p_st.curr_proc |> Option.get_exn_or "") + (unsafe_unsigil (`Local i)) + (trans_type t) | LocalUntyped i -> lookup_local_decl ~binds:bound i p_st) and unpac_lambdaparen ?(bound = StringMap.empty) p_st lvs : Var.t list = @@ -900,8 +913,7 @@ module BasilASTLoader = struct and assign_var (prog : load_st) v = let p = Option.get_exn_or "no active proc" prog.curr_proc in match Var.scope v with - | Var.LocalVar | Var.LocalConst -> - (prog, Procedure.decl_local p v) (* decl is side-effecting *) + | Var.LocalVar | Var.LocalConst -> (prog, v) | Var.GlobalVar | Var.GlobalVarShared -> (map_curr_proc (fun p -> write_global p v) prog, v) | Var.GlobalConst -> failwith "assignment to global constant" @@ -919,31 +931,21 @@ module BasilASTLoader = struct Attrib.attr_of_loc l and trans_lvar prog (x : BasilIR.AbsBasilIR.lVar) : load_st * Var.t = + let proc = prog.curr_proc |> Option.get_exn_or "" in match x with | LVar_Local (LocalTyped (bident, type')) -> assign_var prog - (Var.create ~scope:LocalVar + @@ Procedure.decl_local proc (unsafe_unsigil (`Local bident)) - (trans_type type')) + ~pure:false (trans_type type') | LVar_LocalConst (LocalTyped (bident, type')) -> assign_var prog - (Var.create ~scope:LocalConst + @@ Procedure.decl_local proc (unsafe_unsigil (`Local bident)) - (trans_type type')) + ~pure:true (trans_type type') | LVar_LocalConst (LocalUntyped _) -> failwith "type annotation needed" | LVar_Global (GlobalTyped (bident, type')) -> - let v = - try lookup_global_decl bident prog - with e -> - let v = - Var.create ~scope:GlobalVar - (unsafe_unsigil (`Global bident)) - (trans_type type') - in - print_endline @@ "Warn: global undeclared " ^ Var.name v - ^ " assuming mutable unshared"; - v - in + let v = lookup_global_decl bident prog in assign_var prog v | LVar_Local (LocalUntyped bident) -> let v = lookup_local_decl bident prog in @@ -1032,13 +1034,10 @@ module BasilASTLoader = struct EndList _ ) -> tx name attribs phi statements jump - and param_to_lvar (pp : params) : Var.t = + and param_to_formal (p : ID.generator) (pp : params) : string * Var.t = match pp with - | Params1 (LocalIdent (pos, id), t) -> Var.create id (trans_type t) - - and param_to_formal (pp : params) : string * Var.t = - match pp with - | Params1 (LocalIdent (pos, id), t) -> (id, Var.create id (trans_type t)) + | Params1 (LocalIdent (pos, id), t) -> + (id, Var.create (p.decl_or_get id) (trans_type t)) and trans_funspec prog bound_post (spec : (Var.t, BasilExpr.t) Procedure.proc_spec) (s : funSpec) : @@ -1237,19 +1236,7 @@ module BasilASTLoader = struct | Expr_Global (GlobalUntyped g) -> BasilExpr.rvar @@ lookup_global_decl g p_st | Expr_Global (GlobalTyped (g, type')) -> - let v = - try lookup_global_decl g p_st - with e -> - let v = - Var.create ~scope:GlobalVar - (unsafe_unsigil (`Global g)) - (trans_type type') - in - Logs.warn (fun m -> - m "Warn: undeclared global referenced in expr, %s" - (Var.to_string v)); - v - in + let v = lookup_global_decl g p_st in BasilExpr.rvar v | Expr_Local (LocalUntyped g) -> BasilExpr.rvar @@ lookup_local_decl ~binds g p_st @@ -1257,7 +1244,8 @@ module BasilASTLoader = struct try BasilExpr.rvar @@ lookup_local_decl ~binds g p_st with Not_found | LoadError _ -> let v = - Var.create ~scope:LocalVar + Procedure.get_local + (p_st.curr_proc |> Option.get_exn_or "") (unsafe_unsigil (`Local g)) (trans_type type') in @@ -1347,10 +1335,20 @@ module BasilASTLoader = struct let _, attrib = trans_attrib_set ~binds p_st attrs in BasilExpr.lambda ~attrib ~bound (trans_expr ~nbinds:bound e) | Expr_Let (id, param, rt, body, in_expr) -> - let id = unsafe_unsigil (`Local id) in let bound = unpac_lambdaparen ~bound:StringMap.empty p_st param in let funct = Types.curry (List.map Var.typ bound) (trans_type rt) in - let funvar = Var.create id funct ~scope:LocalConst in + let id = unsafe_unsigil (`Local id) in + let idg = + p_st.curr_proc + |> Option.map Procedure.local_ids + |> Option.get_or ~default:(Program.global_ids p_st.prog) + (* FIXME: generally the semantics of nested definitions is bad; e.g. + local lookups are wrong and here its unclear what generator to use; + we should probably pass through which id generator is currently in + use *) + in + (* assume no shadowing *) + let funvar = Var.create (idg.decl_or_get id) funct ~scope:LocalConst in let func = match bound with | [] -> trans_expr ~nbinds:bound body @@ -1603,16 +1601,6 @@ let load_single_block_proc ?(proc = "") ?input lexbuf = in let proc = Procedure.map_formal_in_params (fun _ -> inparam) proc in let prog = Program.add_proc proc prog in - let prog = - Iter.append (Block.read_vars_iter bl) (Block.assigned_vars_iter bl) - |> Iter.filter Var.is_global - |> Iter.fold - (fun prog v -> - Program.add_decl prog - (Program.Variable - { binding = v; attrib = StringMap.empty; classification = None })) - prog - in (prog, proc, bl) let load_single_block ?proc ~input lexbuf = diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index 7752d7e9..4fbf2cbf 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -151,14 +151,14 @@ module Builtins = struct s.rely |> List.iter (iexpr f); s.guarantee |> List.iter (iexpr f) - let function_for_op op args ret = + let function_for_op (pid : ID.generator) op args ret = Var.create ~scope:Var.GlobalConst (match name op (args @ [ ret ]) with - | Function s -> s + | Function s -> pid.decl_or_get s | _ -> failwith "unexpected") (Types.curry args ret) - let transform_op_to_decl op args ret = + let transform_op_to_decl pid op args ret = let boogie_attribs = StringMap.of_list [ @@ -171,7 +171,7 @@ module Builtins = struct (Function { attrib = attribs; - binding = function_for_op op args ret; + binding = function_for_op pid op args ret; definition = Uninterpreted; } : Program.declaration) @@ -184,10 +184,12 @@ module Builtins = struct |> Iter.filter_map (function op, args, ret -> (match op with | `Load _ -> None - | #builtin as op -> transform_op_to_decl op args ret + | #builtin as op -> + transform_op_to_decl (Program.global_ids p) op args ret | _ -> None)) |> Iter.to_list - |> List.fold_left Program.add_decl p + |> List.fold_left (fun p v -> + Program.add_decl p v) p end module Instructions = struct diff --git a/lib/transforms/function_summaries.ml b/lib/transforms/function_summaries.ml index 9649af41..03c4e7e0 100644 --- a/lib/transforms/function_summaries.ml +++ b/lib/transforms/function_summaries.ml @@ -22,11 +22,11 @@ module type FunctionSummaryAnnotation = sig end (** Replace gamma expressions with gamma variables for an smt query *) -let normalise_gamma = +let normalise_gamma p = let open Expr.AbstractExpr in let open Expr.BasilExpr in let make_gamma_var v = - rvar (Var.create ("Gamma_" ^ Var.name v) ~scope:(Var.scope v) Boolean) + rvar (Procedure.get_local p ("Gamma_" ^ Var.name v) Boolean) in Expr.BasilExpr.rewrite ~rw_fun:(function | UnaryExpr { op = `Gamma; arg } -> ( @@ -41,7 +41,7 @@ let normalise_gamma = (** `redundant p ps` returns true if the conjunction of `p :: ps` is equivalent to that of `ps`. *) -let redundant (solver : Bincaml_util.Smt.Solver.t) p ps = +let redundant proc (solver : Bincaml_util.Smt.Solver.t) p ps = if Expr.BasilExpr.equal p (Expr.BasilExpr.boolconst true) then Bincaml_util.Smt.Solver.Unsat else if List.is_empty ps then Bincaml_util.Smt.Solver.Sat @@ -49,7 +49,7 @@ let redundant (solver : Bincaml_util.Smt.Solver.t) p ps = try let conj = Expr.BasilExpr.applyintrin ~op:`AND ps in let q = - normalise_gamma @@ Expr.BasilExpr.boolnot + normalise_gamma proc @@ Expr.BasilExpr.boolnot @@ Expr.BasilExpr.binexp ~op:`IMPLIES conj p in let open Expr_smt in @@ -102,7 +102,7 @@ let extra_summary (solver : Bincaml_util.Smt.Solver.t) wp_dual_requires (module S) proc |> List.fold_left (fun rs r -> - match redundant solver r (List.append rs cur_req) with + match redundant proc solver r (List.append rs cur_req) with | Unsat -> rs | Sat -> r :: rs | Unknown -> @@ -114,7 +114,7 @@ let extra_summary (solver : Bincaml_util.Smt.Solver.t) sp_ensures (module S) proc |> List.fold_left (fun rs r -> - match redundant solver r (List.append rs cur_ens) with + match redundant proc solver r (List.append rs cur_ens) with | Unsat -> rs | Sat -> r :: rs | Unknown -> diff --git a/lib/transforms/gamma_vars.ml b/lib/transforms/gamma_vars.ml index 5aa04aff..23d5aae9 100644 --- a/lib/transforms/gamma_vars.ml +++ b/lib/transforms/gamma_vars.ml @@ -18,162 +18,38 @@ open Common variables with gammas are tained by i/o variables, and not actual gamma uses. *) -let check_var v = - assert (not @@ String.starts_with ~prefix:"Gamma_" @@ Var.name v) - -let gamma_of v = - let args, r = Types.uncurry (Var.typ v) in - let typ = Types.curry args Boolean in - Var.copy ~name:("Gamma_" ^ Var.name v) ~typ v - -let add_decl proc gv = - if Var.is_local gv then - Hashtbl.replace (Procedure.local_decls proc) (Var.name gv) gv +let transform_proc ?(check_names = false) (add : ID.t -> Var.t -> bool) prog + (proc : Program.proc) = + let check_var v = + assert (not @@ String.starts_with ~prefix:"Gamma_" @@ Var.name v) + in -let add_globals ?(check_names = false) (add : Var.t -> bool) (p : Program.t) = - Program.declarations p - |> Iter.fold - (fun p (s, decl) -> - match decl with - | Program.Variable { binding; attrib } when add binding -> - if check_names then check_var binding; - Program.decl_global ~attrib p (gamma_of binding) - | _ -> p) - p + (* keep track of introduced vars *) + let added = ref VarSet.empty in -let gamma_expr ?(check_names = false) (add : Var.t -> bool) - (e : Expr.BasilExpr.t) = - (* TODO handle maps ? *) - let vars = - Expr.BasilExpr.free_vars_iter e - |> Iter.map (fun v -> - if check_names then check_var v; + let gamma_of v = + let args, r = Types.uncurry (Var.typ v) in + let name = "Gamma_" ^ Var.name v in + let typ = Types.curry args Boolean in + let v = + if Var.is_global v then ( + let v = + Var.create ~scope:(Var.scope v) + ((Program.global_ids prog).fresh ~name ()) + typ + in + added := VarSet.add v !added; v) - |> Iter.map gamma_of - |> Iter.map Expr.BasilExpr.rvar - |> List.of_iter + else Procedure.fresh_var proc ~name typ + in + v + in + + let add_decl proc gv = + if Var.is_local gv then + Hashtbl.replace (Procedure.local_decls proc) (Var.name gv) gv in - match vars with - | [] -> Expr.BasilExpr.boolconst true - | [ v ] -> v - | l -> Expr.BasilExpr.applyintrin ~op:`AND l - -let update_expr ?(check_names = false) (add : Var.t -> bool) = - (* TODO handle maps ? *) - let open Expr.AbstractExpr in - let open Expr.BasilExpr in - Expr.BasilExpr.rewrite ~rw_fun:(function - | UnaryExpr { attrib; op = `Gamma; arg } -> - replace [%here] (gamma_expr ~check_names add arg) - | _ -> Keep) - -let update_lhs ?(check_names = false) add_cur add_target proc m = - StringMap.fold - (fun s v m -> - if add_cur v && add_target s then ( - if check_names then check_var v; - let gv = gamma_of v in - add_decl proc gv; - StringMap.add ("Gamma_" ^ s) gv m) - else m) - m m - -let update_args ?(check_names = false) add_cur add_target m = - StringMap.fold - (fun s e m -> - let m = StringMap.add s (update_expr ~check_names add_cur e) m in - if add_target s then - StringMap.add ("Gamma_" ^ s) (gamma_expr ~check_names add_cur e) m - else m) - m StringMap.empty - -let update_stmts ?(check_names = false) (add : ID.t -> Var.t -> bool) pid - (prog : Program.t) (b : (Var.t, Expr.BasilExpr.t) Block.t) = - let open Stmt in - let update_expr = update_expr ~check_names (add pid) in - let proc = Program.proc prog pid in - Block.map - ~phi:(fun a -> - List.flat_map - (fun (p : Var.t Block.phi) -> - if add pid p.lhs then ( - if check_names then check_var p.lhs; - let (g : Var.t Block.phi) = - { - lhs = gamma_of p.lhs; - rhs = List.map (fun (id, v) -> (id, gamma_of v)) p.rhs; - } - in - [ p; g ]) - else [ p ]) - a) - (function - | Instr_Assign { al; attrib } -> - let al = - al - |> List.flat_map (fun (l, e) -> - if add pid l then ( - if check_names then check_var l; - let gl = gamma_of l in - let ge = gamma_expr ~check_names (add pid) e in - add_decl proc gl; - [ (gl, ge); (l, e) ]) - else [ (l, e) ]) - in - Instr_Assign { attrib; al } - | Instr_Assert { body; attrib } -> - Instr_Assert { body = update_expr body; attrib } - | Instr_Assume { body; branch; attrib } -> - Instr_Assume { body = update_expr body; branch; attrib } - (* TODO Need atomic statement blocks to capture a "simultaneous op" from normal and gamma mem *) - | Instr_Load _ as s -> s - | Instr_Store _ as s -> s - | Instr_IntrinCall { lhs; name; args; attrib } -> - (* cursed *) - let to_sm lhs = - List.mapi (fun i v -> (Int.to_string i, v)) lhs |> StringMap.of_list - in - let of_sm lhs k = - List.mapi (fun i _ -> StringMap.find (Int.to_string i) k) lhs - in - Instr_IntrinCall - { - lhs = - update_lhs ~check_names (add pid) - (fun _ -> true) - proc (to_sm lhs) - |> of_sm lhs; - name; - attrib; - args = - update_args ~check_names (add pid) (fun _ -> true) (to_sm args) - |> of_sm args; - } - | Instr_Call { lhs; procid; args; attrib } -> - let callee = Program.proc prog procid in - Instr_Call - { - lhs = - update_lhs ~check_names (add pid) - (fun s -> - add procid - (StringMap.find s (Procedure.formal_out_params callee))) - proc lhs; - procid; - attrib; - args = - update_args ~check_names (add pid) - (fun s -> - add procid - (StringMap.find s (Procedure.formal_in_params callee))) - args; - } - | Instr_IndirectCall { target; attrib } -> - Instr_IndirectCall { target = update_expr target; attrib }) - b -let transform_proc ?(check_names = false) (add : ID.t -> Var.t -> bool) prog - (proc : Program.proc) = (* Add gamma in/out vars *) let add_param s v m = if add (Procedure.id proc) v then ( @@ -187,6 +63,146 @@ let transform_proc ?(check_names = false) (add : ID.t -> Var.t -> bool) prog |> Procedure.map_formal_in_params (fun s -> StringMap.fold add_param s s) |> Procedure.map_formal_out_params (fun s -> StringMap.fold add_param s s) in + + let gamma_expr ?(check_names = false) (add : Var.t -> bool) + (e : Expr.BasilExpr.t) = + (* TODO handle maps ? *) + let vars = + Expr.BasilExpr.free_vars_iter e + |> Iter.map (fun v -> + if check_names then check_var v; + v) + |> Iter.map gamma_of + |> Iter.map Expr.BasilExpr.rvar + |> List.of_iter + in + match vars with + | [] -> Expr.BasilExpr.boolconst true + | [ v ] -> v + | l -> Expr.BasilExpr.applyintrin ~op:`AND l + in + + let update_expr ?(check_names = false) (add : Var.t -> bool) = + (* TODO handle maps ? *) + let open Expr.AbstractExpr in + let open Expr.BasilExpr in + Expr.BasilExpr.rewrite ~rw_fun:(function + | UnaryExpr { attrib; op = `Gamma; arg } -> + replace [%here] (gamma_expr ~check_names add arg) + | _ -> Keep) + in + + let update_lhs ?(check_names = false) add_cur add_target proc m = + StringMap.fold + (fun s v m -> + if add_cur v && add_target s then ( + if check_names then check_var v; + let gv = gamma_of v in + add_decl proc gv; + StringMap.add ("Gamma_" ^ s) gv m) + else m) + m m + in + + let update_args ?(check_names = false) add_cur add_target m = + StringMap.fold + (fun s e m -> + let m = StringMap.add s (update_expr ~check_names add_cur e) m in + if add_target s then + StringMap.add ("Gamma_" ^ s) (gamma_expr ~check_names add_cur e) m + else m) + m StringMap.empty + in + + let update_stmts ?(check_names = false) (add : ID.t -> Var.t -> bool) pid + (prog : Program.t) (b : (Var.t, Expr.BasilExpr.t) Block.t) = + let open Stmt in + let update_expr = update_expr ~check_names (add pid) in + let proc = Program.proc prog pid in + Block.map + ~phi:(fun a -> + List.flat_map + (fun (p : Var.t Block.phi) -> + if add pid p.lhs then ( + if check_names then check_var p.lhs; + let (g : Var.t Block.phi) = + { + lhs = gamma_of p.lhs; + rhs = List.map (fun (id, v) -> (id, gamma_of v)) p.rhs; + } + in + [ p; g ]) + else [ p ]) + a) + (function + | Instr_Assign { al; attrib } -> + let al = + al + |> List.flat_map (fun (l, e) -> + if add pid l then ( + if check_names then check_var l; + let gl = gamma_of l in + let ge = gamma_expr ~check_names (add pid) e in + add_decl proc gl; + [ (gl, ge); (l, e) ]) + else [ (l, e) ]) + in + Instr_Assign { attrib; al } + | Instr_Assert { body; attrib } -> + Instr_Assert { body = update_expr body; attrib } + | Instr_Assume { body; branch; attrib } -> + Instr_Assume { body = update_expr body; branch; attrib } + (* TODO Need atomic statement blocks to capture a "simultaneous op" from normal and gamma mem *) + | Instr_Load _ as s -> s + | Instr_Store _ as s -> s + | Instr_IntrinCall { lhs; name; args; attrib } -> + (* cursed *) + let to_sm lhs = + List.mapi (fun i v -> (Int.to_string i, v)) lhs + |> StringMap.of_list + in + let of_sm lhs k = + List.mapi (fun i _ -> StringMap.find (Int.to_string i) k) lhs + in + Instr_IntrinCall + { + lhs = + update_lhs ~check_names (add pid) + (fun _ -> true) + proc (to_sm lhs) + |> of_sm lhs; + name; + attrib; + args = + update_args ~check_names (add pid) + (fun _ -> true) + (to_sm args) + |> of_sm args; + } + | Instr_Call { lhs; procid; args; attrib } -> + let callee = Program.proc prog procid in + Instr_Call + { + lhs = + update_lhs ~check_names (add pid) + (fun s -> + add procid + (StringMap.find s (Procedure.formal_out_params callee))) + proc lhs; + procid; + attrib; + args = + update_args ~check_names (add pid) + (fun s -> + add procid + (StringMap.find s (Procedure.formal_in_params callee))) + args; + } + | Instr_IndirectCall { target; attrib } -> + Instr_IndirectCall { target = update_expr target; attrib }) + b + in + (* Update specs *) let update_expr = update_expr ~check_names (add (Procedure.id proc)) in let and_gamma v = [ gamma_of v; v ] in @@ -202,19 +218,42 @@ let transform_proc ?(check_names = false) (add : ID.t -> Var.t -> bool) prog in let proc = Procedure.set_specification proc spec in + let add_globals (p : Program.t) = + VarSet.to_iter !added + |> Iter.fold + (fun p v -> + Program.add_decl p (Var.id v) + Program.( + Variable + { + binding = v; + classification = None; + attrib = StringMap.empty; + })) + p + in + (* Update statements *) let blocks = Procedure.blocks_to_list proc in - List.fold_left - (fun proc b -> - match b with - | Procedure.Vert.Begin id, (b : (Var.t, Expr.BasilExpr.t) Block.t) -> - update_stmts ~check_names add (Procedure.id proc) prog b - |> Procedure.update_block proc id - | _ -> proc) - proc blocks + let proc = + List.fold_left + (fun proc b -> + match b with + | Procedure.Vert.Begin id, (b : (Var.t, Expr.BasilExpr.t) Block.t) -> + update_stmts ~check_names add (Procedure.id proc) prog b + |> Procedure.update_block proc id + | _ -> proc) + proc blocks + in + (add_globals prog, proc) let transform ?(check_names = false) (p : Program.t) = - let p = add_globals ~check_names (fun v -> true) p in - Program.map_procedures - (fun i proc -> transform_proc ~check_names (fun pid v -> true) p proc) - p + Program.procs p + |> Iter.fold + (fun prog (pid, proc) -> + let prog, proc = + transform_proc ~check_names (fun pid v -> true) p proc + in + let prog = Program.update_proc pid (fun _ -> Some proc) prog in + prog) + p diff --git a/lib/transforms/livevars.ml b/lib/transforms/livevars.ml index 6a5b739d..88346b10 100644 --- a/lib/transforms/livevars.ml +++ b/lib/transforms/livevars.ml @@ -69,9 +69,10 @@ let print_live_vars_dot fmt p = let%expect_test _ = let open BasilExpr in - let v1 = Var.create "v1" (Types.bv 0x1) in - let v2 = Var.create "v2" (Types.bv 0x1) in - let v3 = Var.create "v3" (Types.bv 0x1) in + let g = Var.mk_gen () in + let v1 = g.with_name "v1" (Types.bv 0x1) in + let v2 = g.with_name "v2" (Types.bv 0x1) in + let v3 = g.with_name "v3" (Types.bv 0x1) in let e1 = BasilExpr.forall ~bound:[ v2 ] diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index f3604956..c238e18b 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -7,23 +7,31 @@ let live = Bitvec.of_int 1 ~size:2 let dead = Bitvec.of_int 2 ~size:2 module Globals = struct + open Var + let mem_encoding_typ_name = "memory_encoding" let mem_encoding_typ = Types.Variable mem_encoding_typ_name - let mem_encoding = - Var.create "$mem_encoding" ~scope:Var.GlobalVar mem_encoding_typ + let mem_encoding v = + v.with_name "$mem_encoding" ~scope:Var.GlobalVar mem_encoding_typ end -module Calls = struct +module Calls (N : sig + val global_ids : Var.generator +end) = +struct + open Var open BasilExpr + let v = N.global_ids + (** [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)) + (v.with_name "$me_addr_is_heap" ~scope:Var.GlobalConst Types.Boolean)) args (** [alloc_base args] returns the base address of a supplied allocation id. @@ -32,7 +40,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_alloc_base" ~scope:Var.GlobalConst + (v.with_name "$me_alloc_base" ~scope:Var.GlobalConst (Types.Bitvector 64))) args @@ -43,7 +51,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_alloc_live" ~scope:Var.GlobalConst + (v.with_name "$me_alloc_live" ~scope:Var.GlobalConst (Types.Bitvector 2))) args @@ -53,7 +61,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_alloc_size" ~scope:Var.GlobalConst + (v.with_name "$me_alloc_size" ~scope:Var.GlobalConst (Types.Bitvector 64))) args @@ -63,7 +71,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_addr_alloc" ~scope:Var.GlobalConst + (v.with_name "$me_addr_alloc" ~scope:Var.GlobalConst (Types.Bitvector 64))) args @@ -73,7 +81,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_addr_offset" ~scope:Var.GlobalConst + (v.with_name "$me_addr_offset" ~scope:Var.GlobalConst (Types.Bitvector 64))) args @@ -84,7 +92,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_alloc_size_update" ~scope:Var.GlobalConst + (v.with_name "$me_alloc_size_update" ~scope:Var.GlobalConst Globals.mem_encoding_typ)) args @@ -95,7 +103,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_alloc_live_update" ~scope:Var.GlobalConst + (v.with_name "$me_alloc_live_update" ~scope:Var.GlobalConst Globals.mem_encoding_typ)) args @@ -105,7 +113,7 @@ module Calls = struct let allocate ?attrib args = apply_fun ?attrib ~func: - (rvar (Var.create "$me_allocate" ~scope:Var.GlobalConst Types.Boolean)) + (rvar (v.with_name "$me_allocate" ~scope:Var.GlobalConst Types.Boolean)) args (** [can_alloc args] Returns whether an alloc, performed by [allocate], is @@ -115,7 +123,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_can_allocate" ~scope:Var.GlobalConst Types.Boolean)) + (v.with_name "$me_can_allocate" ~scope:Var.GlobalConst Types.Boolean)) args (** [init_encoding args] Returns if a memory encoding is initialized. args(0) @@ -124,7 +132,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_init_encoding" ~scope:Var.GlobalConst Types.Boolean)) + (v.with_name "$me_init_encoding" ~scope:Var.GlobalConst Types.Boolean)) args (** [valid_access args] Checks if an access is valid. args(0) is the memory @@ -134,7 +142,7 @@ module Calls = struct apply_fun ?attrib ~func: (rvar - (Var.create "$me_valid_access" ~scope:Var.GlobalConst Types.Boolean)) + (v.with_name "$me_valid_access" ~scope:Var.GlobalConst Types.Boolean)) args end @@ -164,17 +172,17 @@ module type MemoryEncoding = sig end module MemoryEncoder (Encoding : MemoryEncoding) = struct - let add_decl ?(attrib = Attrib.empty) (p : Program.t) (name : string) + let add_decl (p : Program.t) (name : string) (bindings : Var.t list) (body : BasilExpr.t) = let name = "$" ^ name in - Lang.Program.add_decl ~attrib p - (Lang.Program.Function + Lang.Program.decl_global p name + (fun id -> Lang.Program.Function { binding = - Bincaml_util.Common.Var.create name ~scope:GlobalConst + Bincaml_util.Common.Var.create id ~scope:GlobalConst (Types.curry (List.map Var.typ bindings) @@ Lang.Expr.BasilExpr.type_of body); - attrib; + attrib=Attrib.empty; definition : Lang.Program.func_type = Function (Lang.Expr.BasilExpr.lambda ~bound:bindings body); }) @@ -290,6 +298,7 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct Encoding.valid_access_body let add_decls (p : Lang.Program.t) = + let vg = Var.mk_gen ~id_generator:(Program.global_ids p) in List.fold_left (fun acc f -> f acc) p @@ -312,8 +321,14 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct let transform (p : Lang.Program.t) = add_decls p end -module FlatMemory : MemoryEncoding = struct +module FlatMemory (M : sig + val global_ids : Var.generator + val local_ids : Var.generator +end) : MemoryEncoding = struct open BasilExpr + module Calls = Calls (M) + let l = M.local_ids + let v = M.global_ids let mem_encoding_type : Types.t = Types.Sort @@ -346,15 +361,15 @@ module FlatMemory : MemoryEncoding = struct module Locals = struct let mem_encoding : Var.t = - Var.create "mem_encoding" ~scope:Var.LocalVar mem_encoding_type + l.with_name "mem_encoding" ~scope:Var.LocalVar mem_encoding_type let mem_encoding_out : Var.t = - Var.create "mem_encoding_out" ~scope:Var.LocalVar mem_encoding_type + l.with_name "mem_encoding_out" ~scope:Var.LocalVar mem_encoding_type - let alloc = Var.create "alloc" ~scope:Var.LocalVar Types.Integer - let addr = Var.create "addr" ~scope:Var.LocalVar (Types.Bitvector 64) - let size = Var.create "size" ~scope:Var.LocalVar (Types.Bitvector 64) - let live = Var.create "live" ~scope:Var.LocalVar (Types.Bitvector 2) + let alloc = l.with_name "alloc" ~scope:Var.LocalVar Types.Integer + let addr = l.with_name "addr" ~scope:Var.LocalVar (Types.Bitvector 64) + let size = l.with_name "size" ~scope:Var.LocalVar (Types.Bitvector 64) + let live = l.with_name "live" ~scope:Var.LocalVar (Types.Bitvector 2) let alloc_live_access_h me = unexp ~op:(`ReadField "alloc_live") (rvar me) let alloc_live_access = alloc_live_access_h mem_encoding let alloc_size_access_h me = unexp ~op:(`ReadField "alloc_size") (rvar me) @@ -546,9 +561,15 @@ module FlatMemory : MemoryEncoding = struct ]) end -module SplitMemory : MemoryEncoding = struct +module SplitMemory (M : sig + val global_ids : Var.generator + val local_ids : Var.generator +end) : MemoryEncoding = struct open BasilExpr + module Calls = Calls (M) + let v = M.global_ids + let l = M.local_ids let offset_size = 32 let addr_size = 64 - offset_size @@ -569,15 +590,15 @@ module SplitMemory : MemoryEncoding = struct module Locals = struct let mem_encoding = - Var.create "mem_encoding" ~scope:Var.LocalVar mem_encoding_type + l.with_name "mem_encoding" ~scope:Var.LocalVar mem_encoding_type let mem_encoding_out : Var.t = - Var.create "mem_encoding_out" ~scope:Var.LocalVar mem_encoding_type + l.with_name "mem_encoding_out" ~scope:Var.LocalVar mem_encoding_type - let alloc = Var.create "alloc" ~scope:Var.LocalVar (Types.Bitvector 64) - let addr = Var.create "addr" ~scope:Var.LocalVar (Types.Bitvector 64) - let size = Var.create "size" ~scope:Var.LocalVar (Types.Bitvector 64) - let live = Var.create "live" ~scope:Var.LocalVar (Types.Bitvector 2) + let alloc = l.with_name "alloc" ~scope:Var.LocalVar (Types.Bitvector 64) + let addr = l.with_name "addr" ~scope:Var.LocalVar (Types.Bitvector 64) + let size = l.with_name "size" ~scope:Var.LocalVar (Types.Bitvector 64) + let live = l.with_name "live" ~scope:Var.LocalVar (Types.Bitvector 2) let alloc_live_access = unexp ~op:(`ReadField "alloc_live") (rvar mem_encoding) @@ -733,7 +754,10 @@ module SplitMemory : MemoryEncoding = struct end let split_transform (p : Program.t) = - let module E = MemoryEncoder (SplitMemory) in + let module E = MemoryEncoder (SplitMemory(struct + let local_ids = failwith "oops" + let global_ids = Program.global_ids p + end)) in E.transform p let flat_transform (p : Program.t) = diff --git a/lib/transforms/ssa.ml b/lib/transforms/ssa.ml index 860503c8..d659b10c 100644 --- a/lib/transforms/ssa.ml +++ b/lib/transforms/ssa.ml @@ -46,7 +46,7 @@ let drop_unused_var_declarations_proc p = |> Iter.fold (fun acc i -> VarSet.add i acc) acc) VarSet.empty p in - Var.Decls.filter_map_inplace + Hashtbl.filter_map_inplace (fun _ v -> if VarSet.mem v used then Some v else None) (Procedure.local_decls p); VarSet.filter Var.is_global used diff --git a/lib/util/var.ml b/lib/util/var.ml index f15f7413..474af3c5 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -22,6 +22,9 @@ let copy ?name ?scope ?typ (v : t) = let to_int (v : t) = ID.index (v.name) let name (e : t) = ID.name @@ e.name + +let id v = v.name + let scope (e : t) = e.scope let typ (e : t) = e.typ let to_string v = name v ^ ":" ^ Types.to_string @@ typ v From 6c72800d478104493b89aea83f3bd6f2dfcedabc Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 25 Jun 2026 14:53:58 +1000 Subject: [PATCH 03/22] minor --- lib/analysis/linear_const.ml | 16 ++++++++-------- lib/loadir.ml | 3 +-- lib/transforms/boogie_prepass.ml | 3 +-- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/lib/analysis/linear_const.ml b/lib/analysis/linear_const.ml index df9c26ef..85b9a952 100644 --- a/lib/analysis/linear_const.ml +++ b/lib/analysis/linear_const.ml @@ -106,7 +106,7 @@ module LF = struct Linear (a, b) | _ -> Join (a, b, c) - (* Should make join edges with top become TopEdges (and probably similar for effectively id Linear and Join edges...) *) + (** Should make join edges with top become TopEdges (and probably similar for effectively id Linear and Join edges...) *) let join a b = assert (canonical a && canonical b); match (a, b) with @@ -347,9 +347,7 @@ module LinearIDE = struct |> Iter.map (fun v -> (v, Value.Top)) end -module LinearConstAnalysis = IDESSI (LinearIDE) - -(* For each linear assign and phi node, we create edges from the lhs to all +(** For each linear assign and phi node, we create edges from the lhs to all copied-from variables. For assignments we associate a function encoding the linear expression. The function should be thought of pointing opposite to the direction of the edge, so we compose functions backwards (opposite @@ -361,9 +359,9 @@ module LinearConstAnalysis = IDESSI (LinearIDE) variables and functions for all successor vertices are all equal, and if so we create a path from the parent of these successors. (This is probably hard to follow with words, so here is an example: - ``` + [v if ( * ) { x1 = a + 1 } else { x2 = a + 1 } x3 = phi(x1, x2) - ``` + v] in this hypothetical program, x3 points to x1 and x2, which both point to a with (+1), so we can update x3 to point to a with (+1). This gives an analysis that works through phi nodes! @@ -375,15 +373,17 @@ module LinearConstAnalysis = IDESSI (LinearIDE) procedure, and see whether all input variables that map into the output variable are linear expressions such that their composite functions are all equal. (Example: - ``` + [v proc f(x) = { return g(x + 1, x) } proc g(x, y) = { if ( * ) { z1 = x - 1 } else { z2 = y } return phi(z1, x2) } - ``` + v] here the return value of g is the same from the call of f! Hence f's output is a function of x. In this case, we can create an edge from the output variable in the caller graph to the input variable that copies into it. If this ever actually happens, we'll want to re-iterate on this procedure as we may have new edges to propagate to other procedures. *) +module LinearConstAnalysis = IDESSI (LinearIDE) + module CopyNode = struct type content = { diff --git a/lib/loadir.ml b/lib/loadir.ml index a40da927..29ee198e 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -1768,8 +1768,7 @@ proc @f (ZF_in:bv1, VF_in:bv1) -> (); |}] let%expect_test "prop type from decl" = - let p = - ast_of_string + let p = ast_of_string {| var $NF: bv1; var $ZF: bv1; diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index 4fbf2cbf..be0e8a02 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -188,8 +188,7 @@ module Builtins = struct transform_op_to_decl (Program.global_ids p) op args ret | _ -> None)) |> Iter.to_list - |> List.fold_left (fun p v -> - Program.add_decl p v) p + |> List.fold_left (fun p v -> Program.add_decl p v) p end module Instructions = struct From 84a79031f44baef068007525b78d9e204fce7d68 Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 25 Jun 2026 19:54:07 +1000 Subject: [PATCH 04/22] wip function var allocs and memory enc --- lib/lang/expr_smt.ml | 5 +- lib/lang/program.ml | 18 +- lib/lang/program.mli | 3 +- lib/loadir.ml | 43 +- lib/transforms/boogie_prepass.ml | 41 +- lib/transforms/cf_tx.ml | 4 +- lib/transforms/gamma_vars.ml | 12 +- lib/transforms/memory_encoding.ml | 846 ++++++++++++++----------- lib/transforms/memory_specification.ml | 342 +++++----- 9 files changed, 733 insertions(+), 581 deletions(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 528f9aad..620bfdbc 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -448,13 +448,14 @@ module SMTLib2 = struct end let%expect_test "datatypes" = + let g = (ID.make_gen ()) in let x : Program.declaration = - Type { binding = "test"; typ = Types.mk_sort "Opaque" } + Type { binding = g.decl_or_get "test"; typ = Types.mk_sort "Opaque" } in let y : Program.declaration = Type { - binding = "list"; + binding = g.decl_or_get "list"; typ = Types.mk_adt "list" [ diff --git a/lib/lang/program.ml b/lib/lang/program.ml index d7d41f42..13245c32 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -30,7 +30,7 @@ type func_type = Axiom of e | Uninterpreted | Function of e type implicit_declaration = | VariantCase of { - variant : string; + variant : ID.t; belongs_to : Types.t; constructor : Var.t; (* function to construct a value of this case *) } @@ -50,7 +50,7 @@ type declaration = | Procedure of { definition : proc } let decl_binding = function - | Type { binding } -> binding + | Type { binding } -> ID.name binding | Variable { binding } -> Var.name binding | Function { binding } -> Var.name binding | Procedure { definition } -> ID.name (Procedure.id definition) @@ -301,7 +301,7 @@ let add_decl p decl = let decl_global p name f = let id : ID.t = p.global_names.decl_exn name in let decl = f id in - add_decl p id decl + add_decl p decl let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name scope typ = @@ -345,17 +345,11 @@ let decl_typ ?(attrib = StringMap.empty) p t = match t with | Sort (type_name, []) as s -> let id : ID.t = p.global_names.decl_exn type_name in - { - p with - declarations = - IDMap.add id (Type { binding = type_name; typ = s }) p.declarations; - } + add_decl p (Type { binding = id; typ = s }) | Sort (name, variants) as s -> let id : ID.t = p.global_names.decl_exn name in { - p with - declarations = - IDMap.add id (Type { binding = name; typ = s }) p.declarations; + {(add_decl p (Type { binding = id; typ = s })) with implicit_decls = IDMap.add_list p.implicit_decls (variants @@ -366,7 +360,7 @@ let decl_typ ?(attrib = StringMap.empty) p t = let constructor = Var.create variant ty ~scope:GlobalConst in ( variant, VariantCase - { variant = ID.name variant; belongs_to = s; constructor } + { variant ; belongs_to = s; constructor } ))); } | _ -> failwith "not declarable type" diff --git a/lib/lang/program.mli b/lib/lang/program.mli index 07a8a39a..cbe2a4c8 100644 --- a/lib/lang/program.mli +++ b/lib/lang/program.mli @@ -37,9 +37,10 @@ type implicit_declaration = } type declaration = - | Type of { binding : string; typ : Types.t } + | Type of { binding : ID.t; typ : Types.t } | Function of { binding : Var.t; + var_gen : Var.generator; attrib : Attrib.attrib_map; definition : func_type; } diff --git a/lib/loadir.ml b/lib/loadir.ml index 29ee198e..99790a4f 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -36,6 +36,7 @@ let rec to_attrib k l : Attrib.t option = type load_st = { prog : Program.t; curr_proc : Program.proc option; + local_id_gen : ID.generator option; params_order : (string, (string * Var.t) list * (string * Var.t) list) Hashtbl.t; } @@ -45,6 +46,7 @@ let load_st_empty ?(name = "") () = prog = Program.empty ~name (); params_order = Hashtbl.create 30; curr_proc = None; + local_id_gen = None; } exception @@ -243,6 +245,7 @@ module BasilASTLoader = struct Function { attrib = StringMap.empty; + var_gen = Var.mk_gen (); binding = Var.create id ~scope:GlobalConst rtype; definition = Uninterpreted; } @@ -259,6 +262,7 @@ module BasilASTLoader = struct Function { attrib = StringMap.empty; + var_gen = Var.mk_gen (); binding = bvar; definition = Uninterpreted; } @@ -348,7 +352,7 @@ module BasilASTLoader = struct let name = unsafe_unsigil (`Global glident) in let fundef id : Program.declaration = let binding = Var.create id ~scope:GlobalConst rtype in - Function { attrib; binding; definition } + Function { attrib; binding; definition; var_gen = Var.mk_gen () } in map_prog (fun prog -> Program.decl_global prog name fundef) prog @@ -363,14 +367,23 @@ module BasilASTLoader = struct create_fun prog glident args attrList (Some typ) (Some body) | Decl_Axiom (name, attr, body) -> let _, attrib = trans_attrib_set ~binds:StringMap.empty prog attr in + let v = ID.make_gen () in + let prog = { prog with local_id_gen = Some v } in let body = trans_expr prog body in let name = unsafe_unsigil (`Global name) in let fundef id : Program.declaration = let bvar = Var.create id ~scope:GlobalConst Boolean in - Function { attrib; binding = bvar; definition = Axiom body } + Function + { + attrib; + binding = bvar; + definition = Axiom body; + var_gen = Var.mk_gen ~id_generator:v (); + } in map_prog (fun prog -> Program.decl_global prog name fundef) prog + |> fun p -> { p with local_id_gen = None } | Decl_ProgEmpty (ProcIdent (_, id), attr) -> let _, nattrib = trans_attrib_set ~binds:StringMap.empty prog attr in prog @@ -403,7 +416,9 @@ module BasilASTLoader = struct proc_def ) -> let p = Program.get_proc_by_name id prog.prog in let id_gen = Procedure.local_ids p in - let prog = { prog with curr_proc = Some p } in + let prog = + { prog with curr_proc = Some p; local_id_gen = Some id_gen } + in let prog, blocks = match proc_def with | ProcDef_Some (bl, blocks, el) -> sequence_st prog trans_block blocks @@ -911,7 +926,6 @@ module BasilASTLoader = struct | Jump_ProcReturn -> `ProcReturn and assign_var (prog : load_st) v = - let p = Option.get_exn_or "no active proc" prog.curr_proc in match Var.scope v with | Var.LocalVar | Var.LocalConst -> (prog, v) | Var.GlobalVar | Var.GlobalVarShared -> @@ -1339,13 +1353,8 @@ module BasilASTLoader = struct let funct = Types.curry (List.map Var.typ bound) (trans_type rt) in let id = unsafe_unsigil (`Local id) in let idg = - p_st.curr_proc - |> Option.map Procedure.local_ids - |> Option.get_or ~default:(Program.global_ids p_st.prog) - (* FIXME: generally the semantics of nested definitions is bad; e.g. - local lookups are wrong and here its unclear what generator to use; - we should probably pass through which id generator is currently in - use *) + p_st.local_id_gen + |> Option.get_exn_or "failure: no local id context defined" in (* assume no shadowing *) let funvar = Var.create (idg.decl_or_get id) funct ~scope:LocalConst in @@ -1580,7 +1589,14 @@ let protect_parse parsefun = let load_single_block_proc ?(proc = "") ?input lexbuf = let block = protect_parse BasilIR.ParBasilIR.pBlock input lexbuf in let prog, proc = Program.create_single_proc ~name:proc () in - let st = { prog; params_order = Hashtbl.create 30; curr_proc = Some proc } in + let st = + { + prog; + params_order = Hashtbl.create 30; + curr_proc = Some proc; + local_id_gen = Some (Procedure.local_ids proc); + } + in let st, bl = BasilASTLoader.trans_block st block in let bl = BasilASTLoader.conv_lblock [] proc bl in let proc, bid = @@ -1768,7 +1784,8 @@ proc @f (ZF_in:bv1, VF_in:bv1) -> (); |}] let%expect_test "prop type from decl" = - let p = ast_of_string + let p = + ast_of_string {| var $NF: bv1; var $ZF: bv1; diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index be0e8a02..2637d457 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -194,15 +194,17 @@ end module Instructions = struct let unique_stores_loads (prog : Program.t) = let visit_procs proc = Procedure.iter_stmt_topo_fwd proc in + (* we only care about the type of these vars to generate placeholder memory ops *) + let g = Var.mk_gen () in let load_exprs : (Var.t, Var.t, Program.e) Stmt.t Iter.t = Builtins.used_ops prog |> Iter.filter_map (function op, args, ret -> (match op with | `Load (endian, size) -> - let lhs = Var.create "" ret in - let rhs = Var.create "" (List.hd args) in + let lhs = g.fresh ret in + let rhs = g.fresh (List.hd args) in let addr = - Expr.BasilExpr.rvar @@ Var.create "" (List.hd @@ List.tl args) + Expr.BasilExpr.rvar @@ g.fresh (List.hd @@ List.tl args) in Some (Stmt.Instr_Load @@ -227,12 +229,14 @@ module Instructions = struct |> Iter.sort_uniq let store_body ?(be = false) mem_typ val_size addr_size = - let memory = Var.create ~scope:Var.LocalVar "#memory" mem_typ in + let v = Var.mk_gen () in + (** FIXME: function-local variables *) + let memory = v.with_name ~scope:Var.LocalVar "#memory" mem_typ in let value = - Var.create ~scope:Var.LocalVar "#value" (Types.Bitvector val_size) + v.with_name ~scope:Var.LocalVar "#value" (Types.Bitvector val_size) in let index = - Var.create ~scope:Var.LocalVar "#index" (Types.Bitvector addr_size) + v.with_name ~scope:Var.LocalVar "#index" (Types.Bitvector addr_size) in (* TODO: maybe generalize to non 8 bit stores, based on mem typ value? *) let steps = val_size / 8 in @@ -256,12 +260,13 @@ module Instructions = struct ]) (Expr.BasilExpr.rvar memory) in - Expr.BasilExpr.lambda ~bound:[ memory; index; value ] body + v, Expr.BasilExpr.lambda ~bound:[ memory; index; value ] body let load_body ?(be = false) mem_typ val_size addr_size = - let memory = Var.create ~scope:Var.LocalVar "#memory" mem_typ in + let v = Var.mk_gen () in + let memory = v.with_name ~scope:Var.LocalVar "#memory" mem_typ in let index = - Var.create ~scope:Var.LocalVar "#index" (Types.Bitvector addr_size) + v.with_name ~scope:Var.LocalVar "#index" (Types.Bitvector addr_size) in let steps = val_size / 8 in let body = @@ -286,9 +291,9 @@ module Instructions = struct (Bitvec.of_int ~size:addr_size (if be then 0 else steps - 1))))) in - Expr.BasilExpr.lambda ~bound:[ memory; index ] body + v, Expr.BasilExpr.lambda ~bound:[ memory; index ] body - let store_load_decl (s : Program.stmt) = + let store_load_decl (global_vargen : Var.generator) (s : Program.stmt) = match s with | Stmt.Instr_Store { lhs; rhs; value; addr = Addr { addr; size; endian } } -> @@ -296,7 +301,7 @@ module Instructions = struct StringMap.of_list [ (".extern", `List []); (".define", `List []) ] in let attribs = StringMap.singleton ".boogie" (`Assoc boogie_attribs) in - let body = + let var_gen,body = store_body (Var.typ rhs) (match Expr.BasilExpr.type_of value with | Types.Bitvector s -> s @@ -309,8 +314,9 @@ module Instructions = struct (Function { attrib = attribs; + var_gen ; binding = - Var.create ~scope:Var.GlobalConst + global_vargen.with_name ~scope:Var.GlobalConst (Printf.sprintf "store%d_%s" size (Lang.Stmt.show_endian endian)) (Lang.Expr.BasilExpr.type_of value); @@ -322,7 +328,7 @@ module Instructions = struct let attribs = StringMap.of_list [ (".boogie", `Assoc boogie_attribs) ] in - let body = + let var_gen, body = load_body (Var.typ rhs) (match Var.typ lhs with | Types.Bitvector s -> s @@ -335,8 +341,9 @@ module Instructions = struct (Function { attrib = attribs; + var_gen; binding = - Var.create ~scope:Var.GlobalConst + global_vargen.with_name ~scope:Var.GlobalConst (Printf.sprintf "load%d_%s" size (Stmt.show_endian endian)) (Var.typ lhs); definition = Function body; @@ -346,7 +353,9 @@ module Instructions = struct let transform_add_store_load_decls (prog : Program.t) = unique_stores_loads prog - |> Iter.filter_map store_load_decl + |> Iter.filter_map + (store_load_decl + (Var.mk_gen ~id_generator:(Program.global_ids prog) ())) |> Iter.fold Program.add_decl prog end diff --git a/lib/transforms/cf_tx.ml b/lib/transforms/cf_tx.ml index fed14ffe..3c07ebdb 100644 --- a/lib/transforms/cf_tx.ml +++ b/lib/transforms/cf_tx.ml @@ -49,7 +49,7 @@ let simplify_prog_exprs rewriter ?visit (p : Program.t) = Program.( fun id -> (function - | Function { binding; attrib; definition } -> + | Function { binding; attrib; definition ; var_gen } -> let definition = match definition with | Axiom b -> @@ -58,7 +58,7 @@ let simplify_prog_exprs rewriter ?visit (p : Program.t) = | Function b -> Function (rewriter ?visit b) | Uninterpreted -> Uninterpreted in - Function { binding; attrib; definition } + Function { binding; attrib; definition ; var_gen } | o -> o)) p diff --git a/lib/transforms/gamma_vars.ml b/lib/transforms/gamma_vars.ml index 23d5aae9..941edc51 100644 --- a/lib/transforms/gamma_vars.ml +++ b/lib/transforms/gamma_vars.ml @@ -220,17 +220,7 @@ let transform_proc ?(check_names = false) (add : ID.t -> Var.t -> bool) prog let add_globals (p : Program.t) = VarSet.to_iter !added - |> Iter.fold - (fun p v -> - Program.add_decl p (Var.id v) - Program.( - Variable - { - binding = v; - classification = None; - attrib = StringMap.empty; - })) - p + |> Iter.fold (fun p v -> Program.add_var_decl p v) p in (* Update statements *) diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index c238e18b..9c70f5c1 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -6,6 +6,8 @@ let fresh = Bitvec.of_int 0 ~size:2 let live = Bitvec.of_int 1 ~size:2 let dead = Bitvec.of_int 2 ~size:2 +type function_body = Var.generator * Expr.BasilExpr.t + module Globals = struct open Var @@ -147,52 +149,58 @@ struct end module type MemoryEncoding = sig + val global_ids : Var.generator + module Locals : sig - val mem_encoding : Var.t - val mem_encoding_out : Var.t - val alloc : Var.t - val addr : Var.t - val size : Var.t - val live : Var.t + val mem_encoding : Var.generator -> Var.t + val mem_encoding_out : Var.generator -> Var.t + val alloc : Var.generator -> Var.t + val addr : Var.generator -> Var.t + val size : Var.generator -> Var.t + val live : Var.generator -> Var.t end val mem_encoding_type : Types.t - val can_allocate_body : Lang.Program.e - val alloc_size_body : Lang.Program.e - val alloc_base_body : Lang.Program.e - val addr_alloc_body : Lang.Program.e - val alloc_live_body : Lang.Program.e - val addr_offset_body : Lang.Program.e - val addr_is_heap_body : Lang.Program.e - val alloc_size_update_body : Lang.Program.e - val alloc_live_update_body : Lang.Program.e - val allocate_body : Lang.Program.e - val init_encoding_body : Lang.Program.e - val valid_access_body : Lang.Program.e + val can_allocate_body : function_body + val alloc_size_body : function_body + val alloc_base_body : function_body + val addr_alloc_body : function_body + val alloc_live_body : function_body + val addr_offset_body : function_body + val addr_is_heap_body : function_body + val alloc_size_update_body : function_body + val alloc_live_update_body : function_body + val allocate_body : function_body + val init_encoding_body : function_body + val valid_access_body : function_body end module MemoryEncoder (Encoding : MemoryEncoding) = struct - let add_decl (p : Program.t) (name : string) - (bindings : Var.t list) (body : BasilExpr.t) = + let decl_global ?(attrib = Attrib.empty) (p : Program.t) (name : string) + (bindings : (Var.generator -> Var.t) list) (body : function_body) = let name = "$" ^ name in - Lang.Program.decl_global p name - (fun id -> Lang.Program.Function - { - binding = - Bincaml_util.Common.Var.create id ~scope:GlobalConst - (Types.curry (List.map Var.typ bindings) - @@ Lang.Expr.BasilExpr.type_of body); - attrib=Attrib.empty; - definition : Lang.Program.func_type = - Function (Lang.Expr.BasilExpr.lambda ~bound:bindings body); - }) + let var_gen, body = body in + let bindings = List.map (fun f -> f var_gen) bindings in + Lang.Program.decl_global p name (fun id -> + Lang.Program.Function + { + var_gen; + binding = + Bincaml_util.Common.Var.create id ~scope:GlobalConst + (Types.curry (List.map Var.typ bindings) + @@ Lang.Expr.BasilExpr.type_of body); + attrib; + definition : Lang.Program.func_type = + Function (Lang.Expr.BasilExpr.lambda ~bound:bindings body); + }) let add_mem_encoding p = + let gids : ID.generator = Program.global_ids p in let p = Lang.Program.add_decl p (Lang.Program.Type { - binding = Globals.mem_encoding_typ_name; + binding = gids.decl_or_get Globals.mem_encoding_typ_name; typ = Encoding.mem_encoding_type; }) in @@ -200,7 +208,7 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct Lang.Program.add_decl p (Lang.Program.Variable { - binding = Globals.mem_encoding; + binding = Globals.mem_encoding (Var.mk_gen ~id_generator:gids ()); attrib = Attrib.empty; classification = None; }) @@ -221,14 +229,14 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct ] let add_can_allocate p = - add_decl ~attrib p "me_can_allocate" + decl_global ~attrib p "me_can_allocate" [ Encoding.Locals.mem_encoding; Encoding.Locals.addr; Encoding.Locals.size; ] Encoding.can_allocate_body let add_allocate p = - add_decl ~attrib p "me_allocate" + decl_global ~attrib p "me_allocate" [ Encoding.Locals.mem_encoding; Encoding.Locals.mem_encoding_out; @@ -238,37 +246,37 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct Encoding.allocate_body let add_alloc_size p = - add_decl ~attrib p "me_alloc_size" + decl_global ~attrib p "me_alloc_size" [ Encoding.Locals.mem_encoding; Encoding.Locals.alloc ] Encoding.alloc_size_body let add_addr_alloc p = - add_decl ~attrib p "me_addr_alloc" + decl_global ~attrib p "me_addr_alloc" [ Encoding.Locals.mem_encoding; Encoding.Locals.addr ] Encoding.addr_alloc_body let add_alloc_live p = - add_decl ~attrib p "me_alloc_live" + decl_global ~attrib p "me_alloc_live" [ Encoding.Locals.mem_encoding; Encoding.Locals.alloc ] Encoding.alloc_live_body let add_addr_offset p = - add_decl ~attrib p "me_addr_offset" + decl_global ~attrib p "me_addr_offset" [ Encoding.Locals.mem_encoding; Encoding.Locals.addr ] Encoding.addr_offset_body let add_alloc_base p = - add_decl ~attrib p "me_alloc_base" + decl_global ~attrib p "me_alloc_base" [ Encoding.Locals.mem_encoding; Encoding.Locals.alloc ] Encoding.alloc_base_body let add_addr_is_heap p = - add_decl ~attrib p "me_addr_is_heap" + decl_global ~attrib p "me_addr_is_heap" [ Encoding.Locals.mem_encoding; Encoding.Locals.addr ] Encoding.addr_is_heap_body let add_alloc_size_update p = - add_decl ~attrib p "me_alloc_size_update" + decl_global ~attrib p "me_alloc_size_update" [ Encoding.Locals.mem_encoding; Encoding.Locals.alloc; @@ -277,7 +285,7 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct Encoding.alloc_size_update_body let add_alloc_live_update p = - add_decl ~attrib p "me_alloc_live_update" + decl_global ~attrib p "me_alloc_live_update" [ Encoding.Locals.mem_encoding; Encoding.Locals.alloc; @@ -286,19 +294,18 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct Encoding.alloc_live_update_body let add_init_encoding p = - add_decl ~attrib p "me_init_encoding" + decl_global ~attrib p "me_init_encoding" [ Encoding.Locals.mem_encoding ] Encoding.init_encoding_body let add_valid_access_body p = - add_decl ~attrib p "me_valid_access" + decl_global ~attrib p "me_valid_access" [ Encoding.Locals.mem_encoding; Encoding.Locals.addr; Encoding.Locals.size; ] Encoding.valid_access_body - let add_decls (p : Lang.Program.t) = - let vg = Var.mk_gen ~id_generator:(Program.global_ids p) in + let decl_globals (p : Lang.Program.t) = List.fold_left (fun acc f -> f acc) p @@ -318,17 +325,21 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct add_valid_access_body; ] - let transform (p : Lang.Program.t) = add_decls p + let transform (p : Lang.Program.t) = decl_globals p end -module FlatMemory (M : sig +(** Access to variable allocation functions for getting the handle for global + functions and local variables for the procedure we are encoding *) +module type IDAllocs = sig val global_ids : Var.generator - val local_ids : Var.generator -end) : MemoryEncoding = struct +end + +module FlatMemory (M : IDAllocs) : MemoryEncoding = struct open BasilExpr module Calls = Calls (M) - let l = M.local_ids + let v = M.global_ids + let global_ids = v let mem_encoding_type : Types.t = Types.Sort @@ -360,216 +371,284 @@ end) : MemoryEncoding = struct ] ) module Locals = struct - let mem_encoding : Var.t = + open Var + + let mem_encoding l : Var.t = l.with_name "mem_encoding" ~scope:Var.LocalVar mem_encoding_type - let mem_encoding_out : Var.t = + let mem_encoding_out l : Var.t = l.with_name "mem_encoding_out" ~scope:Var.LocalVar mem_encoding_type - let alloc = l.with_name "alloc" ~scope:Var.LocalVar Types.Integer - let addr = l.with_name "addr" ~scope:Var.LocalVar (Types.Bitvector 64) - let size = l.with_name "size" ~scope:Var.LocalVar (Types.Bitvector 64) - let live = l.with_name "live" ~scope:Var.LocalVar (Types.Bitvector 2) + let alloc l = l.with_name "alloc" ~scope:Var.LocalVar Types.Integer + let addr l = l.with_name "addr" ~scope:Var.LocalVar (Types.Bitvector 64) + let size l = l.with_name "size" ~scope:Var.LocalVar (Types.Bitvector 64) + let live l = l.with_name "live" ~scope:Var.LocalVar (Types.Bitvector 2) let alloc_live_access_h me = unexp ~op:(`ReadField "alloc_live") (rvar me) - let alloc_live_access = alloc_live_access_h mem_encoding + let alloc_live_access l = alloc_live_access_h (mem_encoding l) let alloc_size_access_h me = unexp ~op:(`ReadField "alloc_size") (rvar me) - let alloc_size_access = alloc_size_access_h mem_encoding + let alloc_size_access l = alloc_size_access_h (mem_encoding l) - let alloc_base_access = - unexp ~op:(`ReadField "alloc_base") (rvar mem_encoding) + let alloc_base_access l = + unexp ~op:(`ReadField "alloc_base") (rvar @@ mem_encoding l) - let addr_is_heap_access = - unexp ~op:(`ReadField "addr_is_heap") (rvar mem_encoding) + let addr_is_heap_access l = + unexp ~op:(`ReadField "addr_is_heap") (rvar @@ mem_encoding l) - let addr_alloc_access = - unexp ~op:(`ReadField "addr_alloc") (rvar mem_encoding) + let addr_alloc_access l = + unexp ~op:(`ReadField "addr_alloc") (rvar @@ mem_encoding l) - let addr_offset_access = - unexp ~op:(`ReadField "addr_offset") (rvar mem_encoding) + let addr_offset_access l = + unexp ~op:(`ReadField "addr_offset") (rvar @@ mem_encoding l) end let trigger e = [ [ e ] ] - let can_allocate_body : Lang.Program.e = boolconst true - - let alloc_size_body : Lang.Program.e = - binexp ~op:`MapAccess Locals.alloc_size_access (rvar Locals.alloc) - - let alloc_base_body : Lang.Program.e = - binexp ~op:`MapAccess Locals.alloc_base_access (rvar Locals.alloc) - - let addr_alloc_body : Lang.Program.e = - binexp ~op:`MapAccess Locals.addr_alloc_access (rvar Locals.addr) - - let alloc_live_body : Lang.Program.e = - binexp ~op:`MapAccess Locals.alloc_live_access (rvar Locals.alloc) - - let addr_offset_body : Lang.Program.e = - binexp ~op:`MapAccess Locals.addr_offset_access (rvar Locals.addr) + let can_allocate_body : function_body = (Var.mk_gen (), boolconst true) + + let alloc_size_body : function_body = + let l = Var.mk_gen () in + ( l, + binexp ~op:`MapAccess (Locals.alloc_size_access l) (rvar @@ Locals.alloc l) + ) + + let alloc_base_body : function_body = + let l = Var.mk_gen () in + let b = + binexp ~op:`MapAccess (Locals.alloc_base_access l) (rvar @@ Locals.alloc l) + in + (l, b) - let addr_is_heap_body : Lang.Program.e = - binexp ~op:`MapAccess Locals.addr_is_heap_access (rvar Locals.addr) + let addr_alloc_body : function_body = + let l = Var.mk_gen () in + let b = + binexp ~op:`MapAccess (Locals.addr_alloc_access l) (rvar @@ Locals.addr l) + in + (l, b) - let alloc_size_update_body : Lang.Program.e = - binexp ~op:(`WriteField "alloc_size") (rvar Locals.mem_encoding) - (applyintrin ~op:`MapUpdate - [ Locals.alloc_size_access; rvar Locals.alloc; rvar Locals.size ]) + let alloc_live_body : function_body = + let l = Var.mk_gen () in + let b = + binexp ~op:`MapAccess (Locals.alloc_live_access l) (rvar @@ Locals.alloc l) + in + (l, b) - let alloc_live_update_body : Lang.Program.e = - binexp ~op:(`WriteField "alloc_live") (rvar Locals.mem_encoding) - (applyintrin ~op:`MapUpdate - [ Locals.alloc_live_access; rvar Locals.alloc; rvar Locals.live ]) + let addr_offset_body : function_body = + let l = Var.mk_gen () in + let b = + binexp ~op:`MapAccess (Locals.addr_offset_access l) (rvar @@ Locals.addr l) + in + (l, b) + + let addr_is_heap_body : function_body = + let l = Var.mk_gen () in + let b = + binexp ~op:`MapAccess + (Locals.addr_is_heap_access l) + (rvar @@ Locals.addr l) + in + (l, b) + + let alloc_size_update_body : function_body = + let l = Var.mk_gen () in + let b = + binexp ~op:(`WriteField "alloc_size") + (rvar @@ Locals.mem_encoding l) + (applyintrin ~op:`MapUpdate + [ + Locals.alloc_size_access l; + rvar @@ Locals.alloc l; + rvar @@ Locals.size l; + ]) + in + (l, b) + + let alloc_live_update_body : function_body = + let l = Var.mk_gen () in + let b = + binexp ~op:(`WriteField "alloc_live") + (rvar @@ Locals.mem_encoding l) + (applyintrin ~op:`MapUpdate + [ + Locals.alloc_live_access l; + rvar @@ Locals.alloc l; + rvar @@ Locals.live l; + ]) + in + (l, b) - let allocate_body : Lang.Program.e = - let i = Var.create "i" ~scope:Var.LocalVar (Types.Bitvector 64) in + let allocate_body : function_body = + let l = Var.mk_gen () in + let i = l.with_name "i" ~scope:Var.LocalVar (Types.Bitvector 64) in let in_bounds = applyintrin ~op:`AND [ - binexp ~op:`BVULE (rvar Locals.addr) (rvar i); + binexp ~op:`BVULE (rvar @@ Locals.addr l) (rvar i); binexp ~op:`BVULT (rvar i) - (binexp ~op:`BVADD (rvar Locals.addr) (rvar Locals.size)); + (binexp ~op:`BVADD (rvar @@ Locals.addr l) (rvar @@ Locals.size l)); ] in (* alloc for i and addr are the same *) - let same_alloc = + let same_alloc l = binexp ~op:`EQ - (Calls.addr_alloc [ rvar Locals.mem_encoding_out; rvar i ]) - (Calls.addr_alloc [ rvar Locals.mem_encoding_out; rvar Locals.addr ]) + (Calls.addr_alloc [ rvar @@ Locals.mem_encoding_out l; rvar i ]) + (Calls.addr_alloc + [ rvar @@ Locals.mem_encoding_out l; rvar @@ Locals.addr l ]) in - applyintrin ~op:`AND - [ - (* update addr_alloc for all pointers in the range [addr, addr+size) + let b = + applyintrin ~op:`AND + [ + (* update addr_alloc for all pointers in the range [addr, addr+size) to point to the old allocation counter. *) - forall ~bound:[ i ] - ~triggers: - (trigger - (Calls.addr_alloc [ rvar Locals.mem_encoding_out; rvar i ])) - (binexp ~op:`IMPLIES in_bounds - (binexp ~op:`EQ - (Calls.addr_alloc [ rvar Locals.mem_encoding_out; rvar i ]) - (unexp ~op:(`ReadField "alloc_counter") - (rvar Locals.mem_encoding)))); - (* Preserve all other addr_alloc entries. *) - forall ~bound:[ i ] - ~triggers: - (trigger - (Calls.addr_alloc [ rvar Locals.mem_encoding_out; rvar i ])) - (binexp ~op:`IMPLIES - (unexp ~op:`BoolNOT in_bounds) - (binexp ~op:`EQ - (Calls.addr_alloc [ rvar Locals.mem_encoding_out; rvar i ]) - (Calls.addr_alloc [ rvar Locals.mem_encoding; rvar i ]))); - (* Update offsets for all pointers in allocation. *) - forall ~bound:[ i ] - ~triggers: - (trigger - (Calls.addr_offset [ rvar Locals.mem_encoding_out; rvar i ])) - (binexp ~op:`IMPLIES same_alloc - (binexp ~op:`EQ - (Calls.addr_offset [ rvar Locals.mem_encoding_out; rvar i ]) - (binexp ~op:`BVSUB (rvar i) (rvar Locals.addr)))); - (* Preserve all other addr offsets. *) - forall ~bound:[ i ] - ~triggers: - (trigger - (Calls.addr_offset [ rvar Locals.mem_encoding_out; rvar i ])) - (binexp ~op:`IMPLIES - (unexp ~op:`BoolNOT same_alloc) - (binexp ~op:`EQ - (Calls.addr_offset [ rvar Locals.mem_encoding_out; rvar i ]) - (Calls.addr_offset [ rvar Locals.mem_encoding; rvar i ]))); - (* Update the size of the allocation. *) - binexp ~op:`EQ - (Locals.alloc_size_access_h Locals.mem_encoding_out) - (applyintrin ~op:`MapUpdate - [ - Locals.alloc_size_access; - Calls.addr_alloc - [ rvar Locals.mem_encoding_out; rvar Locals.addr ]; - rvar Locals.size; - ]); - (* Update the liveness of the allocation. *) - binexp ~op:`EQ - (Locals.alloc_live_access_h Locals.mem_encoding_out) - (applyintrin ~op:`MapUpdate - [ - Locals.alloc_live_access; - Calls.addr_alloc - [ rvar Locals.mem_encoding_out; rvar Locals.addr ]; - bvconst live; - ]); - (* The allocation at addr was fresh. *) - binexp ~op:`EQ - (Calls.alloc_live - [ - rvar Locals.mem_encoding; - Calls.addr_alloc - [ rvar Locals.mem_encoding_out; rvar Locals.addr ]; - ]) - (bvconst fresh); - (* The allocation at addr was/is on the heap. *) - Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar Locals.addr ]; - (* addr_is_heap is unchanged. *) - binexp ~op:`EQ - (unexp ~op:(`ReadField "addr_is_heap") (rvar Locals.mem_encoding)) - (unexp ~op:(`ReadField "addr_is_heap") (rvar Locals.mem_encoding_out)); - ] - - let init_encoding_body : Lang.Program.e = - let o = Var.create "o" ~scope:Var.LocalVar Types.Integer in - let i = Var.create "i" ~scope:Var.LocalVar (Types.Bitvector 64) in - applyintrin ~op:`AND - [ - (* allocation counter starts at 0 *) - binexp ~op:`EQ - (unexp ~op:(`ReadField "alloc_counter") (rvar Locals.mem_encoding)) - (intconst @@ Z.of_int 0); - (* all objects are initially fresh *) - forall ~bound:[ o ] - ~triggers: - (trigger (Calls.alloc_live [ rvar Locals.mem_encoding; rvar o ])) - (binexp ~op:`EQ - (Calls.alloc_live [ rvar Locals.mem_encoding; rvar o ]) - (bvconst fresh)); - (* stack/heap separation, TODO: compute this smartly *) - forall ~bound:[ i ] - ~triggers: - (trigger (Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar i ])) - (binexp ~op:`EQ - (Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar i ]) - (unexp ~op:`BoolNOT - @@ binexp ~op:`BVULE (rvar i) (bv_of_int ~size:64 100000000))); - ] - - let valid_access_body : Lang.Program.e = - let alloc = - Calls.addr_alloc [ rvar Locals.mem_encoding; rvar Locals.addr ] + forall ~bound:[ i ] + ~triggers: + (trigger + (Calls.addr_alloc + [ rvar @@ Locals.mem_encoding_out l; rvar i ])) + (binexp ~op:`IMPLIES in_bounds + (binexp ~op:`EQ + (Calls.addr_alloc + [ rvar @@ Locals.mem_encoding_out l; rvar i ]) + (unexp ~op:(`ReadField "alloc_counter") + (rvar @@ Locals.mem_encoding l)))); + (* Preserve all other addr_alloc entries. *) + forall ~bound:[ i ] + ~triggers: + (trigger + (Calls.addr_alloc + [ rvar @@ Locals.mem_encoding_out l; rvar i ])) + (binexp ~op:`IMPLIES + (unexp ~op:`BoolNOT in_bounds) + (binexp ~op:`EQ + (Calls.addr_alloc + [ rvar @@ Locals.mem_encoding_out l; rvar i ]) + (Calls.addr_alloc [ rvar @@ Locals.mem_encoding l; rvar i ]))); + (* Update offsets for all pointers in allocation. *) + forall ~bound:[ i ] + ~triggers: + (trigger + (Calls.addr_offset + [ rvar @@ Locals.mem_encoding_out l; rvar i ])) + (binexp ~op:`IMPLIES (same_alloc l) + (binexp ~op:`EQ + (Calls.addr_offset + [ rvar @@ Locals.mem_encoding_out l; rvar i ]) + (binexp ~op:`BVSUB (rvar i) (rvar @@ Locals.addr l)))); + (* Preserve all other addr offsets. *) + forall ~bound:[ i ] + ~triggers: + (trigger + (Calls.addr_offset + [ rvar @@ Locals.mem_encoding_out l; rvar i ])) + (binexp ~op:`IMPLIES + (unexp ~op:`BoolNOT (same_alloc l)) + (binexp ~op:`EQ + (Calls.addr_offset + [ rvar @@ Locals.mem_encoding_out l; rvar i ]) + (Calls.addr_offset [ rvar @@ Locals.mem_encoding l; rvar i ]))); + (* Update the size of the allocation. *) + binexp ~op:`EQ + (Locals.alloc_size_access_h (Locals.mem_encoding_out l)) + (applyintrin ~op:`MapUpdate + [ + Locals.alloc_size_access l; + Calls.addr_alloc + [ rvar @@ Locals.mem_encoding_out l; rvar @@ Locals.addr l ]; + rvar (Locals.size l); + ]); + (* Update the liveness of the allocation. *) + binexp ~op:`EQ + (Locals.alloc_live_access_h @@ Locals.mem_encoding_out l) + (applyintrin ~op:`MapUpdate + [ + Locals.alloc_live_access l; + Calls.addr_alloc + [ rvar @@ Locals.mem_encoding_out l; rvar @@ Locals.addr l ]; + bvconst live; + ]); + (* The allocation at addr was fresh. *) + binexp ~op:`EQ + (Calls.alloc_live + [ + rvar @@ Locals.mem_encoding l; + Calls.addr_alloc + [ rvar @@ Locals.mem_encoding_out l; rvar @@ Locals.addr l ]; + ]) + (bvconst fresh); + (* The allocation at addr was/is on the heap. *) + Calls.addr_is_heap + [ rvar @@ Locals.mem_encoding l; rvar @@ Locals.addr l ]; + (* addr_is_heap is unchanged. *) + binexp ~op:`EQ + (unexp ~op:(`ReadField "addr_is_heap") + (rvar @@ Locals.mem_encoding l)) + (unexp ~op:(`ReadField "addr_is_heap") + (rvar @@ Locals.mem_encoding_out l)); + ] + in + (l, b) + + let init_encoding_body : function_body = + let l = Var.mk_gen () in + let o = l.with_name "o" ~scope:Var.LocalVar Types.Integer in + let i = l.with_name "i" ~scope:Var.LocalVar (Types.Bitvector 64) in + let b = + begin + applyintrin ~op:`AND + [ + (* allocation counter starts at 0 *) + binexp ~op:`EQ + (unexp ~op:(`ReadField "alloc_counter") + (rvar @@ Locals.mem_encoding l)) + (intconst @@ Z.of_int 0); + (* all objects are initially fresh *) + forall ~bound:[ o ] + ~triggers: + (trigger + (Calls.alloc_live [ rvar @@ Locals.mem_encoding l; rvar o ])) + (binexp ~op:`EQ + (Calls.alloc_live [ rvar @@ Locals.mem_encoding l; rvar o ]) + (bvconst fresh)); + (* stack/heap separation, TODO: compute this smartly *) + forall ~bound:[ i ] + ~triggers: + (trigger + (Calls.addr_is_heap + [ rvar @@ Locals.mem_encoding l; rvar i ])) + (binexp ~op:`EQ + (Calls.addr_is_heap [ rvar @@ Locals.mem_encoding l; rvar i ]) + (unexp ~op:`BoolNOT + @@ binexp ~op:`BVULE (rvar i) (bv_of_int ~size:64 100000000))); + ] + end in - let offset = - Calls.addr_offset [ rvar Locals.mem_encoding; rvar Locals.addr ] + (l, b) + + let valid_access_body : function_body = + let l = Var.mk_gen () in + let me = rvar (Locals.mem_encoding l) in + let addr = rvar (Locals.addr l) in + let alloc = Calls.addr_alloc [ me; addr ] in + let offset = Calls.addr_offset [ me; addr ] in + let b = + binexp ~op:`IMPLIES + (Calls.addr_is_heap [ me; addr ]) + (applyintrin ~op:`AND + [ + binexp ~op:`EQ (Calls.alloc_live [ me; alloc ]) (bvconst live); + binexp ~op:`BVULE (bv_of_int 0 ~size:64) offset; + binexp ~op:`BVULE + (binexp ~op:`BVADD (rvar @@ Locals.size l) offset) + (Calls.alloc_size [ me; alloc ]); + ]) in - binexp ~op:`IMPLIES - (Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar Locals.addr ]) - (applyintrin ~op:`AND - [ - binexp ~op:`EQ - (Calls.alloc_live [ rvar Locals.mem_encoding; alloc ]) - (bvconst live); - binexp ~op:`BVULE (bv_of_int 0 ~size:64) offset; - binexp ~op:`BVULE - (binexp ~op:`BVADD (rvar Locals.size) offset) - (Calls.alloc_size [ rvar Locals.mem_encoding; alloc ]); - ]) + (l, b) end -module SplitMemory (M : sig - val global_ids : Var.generator - val local_ids : Var.generator -end) : MemoryEncoding = struct +module SplitMemory (M : IDAllocs) : MemoryEncoding = struct open BasilExpr module Calls = Calls (M) let v = M.global_ids - let l = M.local_ids + let global_ids = v let offset_size = 32 let addr_size = 64 - offset_size @@ -589,177 +668,224 @@ end) : MemoryEncoding = struct ] ) module Locals = struct - let mem_encoding = + open Var + + let mem_encoding l = l.with_name "mem_encoding" ~scope:Var.LocalVar mem_encoding_type - let mem_encoding_out : Var.t = + let mem_encoding_out l : Var.t = l.with_name "mem_encoding_out" ~scope:Var.LocalVar mem_encoding_type - let alloc = l.with_name "alloc" ~scope:Var.LocalVar (Types.Bitvector 64) - let addr = l.with_name "addr" ~scope:Var.LocalVar (Types.Bitvector 64) - let size = l.with_name "size" ~scope:Var.LocalVar (Types.Bitvector 64) - let live = l.with_name "live" ~scope:Var.LocalVar (Types.Bitvector 2) + let alloc l = l.with_name "alloc" ~scope:Var.LocalVar (Types.Bitvector 64) + let addr l = l.with_name "addr" ~scope:Var.LocalVar (Types.Bitvector 64) + let size l = l.with_name "size" ~scope:Var.LocalVar (Types.Bitvector 64) + let live l = l.with_name "live" ~scope:Var.LocalVar (Types.Bitvector 2) - let alloc_live_access = - unexp ~op:(`ReadField "alloc_live") (rvar mem_encoding) + let alloc_live_access l = + unexp ~op:(`ReadField "alloc_live") (rvar @@ mem_encoding l) - let alloc_size_access = - unexp ~op:(`ReadField "alloc_size") (rvar mem_encoding) + let alloc_size_access l = + unexp ~op:(`ReadField "alloc_size") (rvar @@ mem_encoding l) - let addr_is_heap_access = - unexp ~op:(`ReadField "addr_is_heap") (rvar mem_encoding) + let addr_is_heap_access l = + unexp ~op:(`ReadField "addr_is_heap") (rvar @@ mem_encoding l) end - let can_allocate_body = - applyintrin ~op:`AND - [ - (* Addr must be on the heap: *) - Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar Locals.addr ]; - (* Address is a base address *) - binexp ~op:`EQ - (Calls.alloc_base [ rvar Locals.mem_encoding; rvar Locals.addr ]) - (rvar Locals.addr); - (* Adddress is fresh *) - binexp ~op:`EQ - (Calls.alloc_live - [ - rvar Locals.mem_encoding; - Calls.addr_alloc [ rvar Locals.mem_encoding; rvar Locals.addr ]; - ]) - (bvconst fresh); - (* Size is within bounds *) - binexp ~op:`BVULE (rvar Locals.size) - (bv_of_int ~size:64 (Int.pow 2 offset_size - 1)); - binexp ~op:`BVULT (bv_of_int ~size:64 0) (rvar Locals.size); - ] - - let alloc_size_body = - binexp ~op:`MapAccess Locals.alloc_size_access (rvar Locals.alloc) - - let alloc_base_body = - binexp ~op:`BVAND (rvar Locals.alloc) - (bv_of_int ~size:64 (Int.lnot (Int.pow 2 addr_size - 1))) - - let addr_alloc_body = rvar Locals.addr + let can_allocate_body : function_body = + let v = Var.mk_gen () in + ( v, + applyintrin ~op:`AND + [ + (* Addr must be on the heap: *) + Calls.addr_is_heap + [ rvar @@ Locals.mem_encoding v; rvar @@ Locals.addr v ]; + (* Address is a base address *) + binexp ~op:`EQ + (Calls.alloc_base + [ rvar @@ Locals.mem_encoding v; rvar @@ Locals.addr v ]) + (rvar @@ Locals.addr v); + (* Adddress is fresh *) + binexp ~op:`EQ + (Calls.alloc_live + [ + rvar @@ Locals.mem_encoding v; + Calls.addr_alloc + [ rvar @@ Locals.mem_encoding v; rvar @@ Locals.addr v ]; + ]) + (bvconst fresh); + (* Size is within bounds *) + binexp ~op:`BVULE + (rvar @@ Locals.size v) + (bv_of_int ~size:64 (Int.pow 2 offset_size - 1)); + binexp ~op:`BVULT (bv_of_int ~size:64 0) (rvar @@ Locals.size v); + ] ) - let alloc_live_body = - binexp ~op:`MapAccess Locals.alloc_live_access (rvar Locals.alloc) + let alloc_size_body : function_body = + let v = Var.mk_gen () in + ( v, + binexp ~op:`MapAccess (Locals.alloc_size_access v) (rvar @@ Locals.alloc v) + ) + + let alloc_base_body : function_body = + let v = Var.mk_gen () in + ( v, + binexp ~op:`BVAND + (rvar (Locals.alloc v)) + (bv_of_int ~size:64 (Int.lnot (Int.pow 2 addr_size - 1))) ) + + let addr_alloc_body : function_body = + let v = Var.mk_gen () in + (v, rvar (Locals.addr v)) + + let alloc_live_body : function_body = + let v = Var.mk_gen () in + ( v, + binexp ~op:`MapAccess (Locals.alloc_live_access v) (rvar @@ Locals.alloc v) + ) let addr_offset_body = - binexp ~op:`BVAND (rvar Locals.addr) - (bv_of_int ~size:64 (Int.pow 2 offset_size - 1)) + let l = Var.mk_gen () in + let b = + binexp ~op:`BVAND + (rvar @@ Locals.addr l) + (bv_of_int ~size:64 (Int.pow 2 offset_size - 1)) + in + (l, b) let addr_is_heap_body = - binexp ~op:`MapAccess Locals.addr_is_heap_access (rvar Locals.addr) + let l = Var.mk_gen () in + ( l, + binexp ~op:`MapAccess + (Locals.addr_is_heap_access l) + (rvar @@ Locals.addr l) ) let alloc_size_update_body = - binexp ~op:(`WriteField "alloc_size") (rvar Locals.mem_encoding) - (applyintrin ~op:`MapUpdate - [ Locals.alloc_size_access; rvar Locals.alloc; rvar Locals.size ]) + let l = Var.mk_gen () in + let b = + binexp ~op:(`WriteField "alloc_size") + (rvar @@ Locals.mem_encoding l) + (applyintrin ~op:`MapUpdate + [ + Locals.alloc_size_access l; + rvar @@ Locals.alloc l; + rvar @@ Locals.size l; + ]) + in + (l, b) let alloc_live_update_body = - binexp ~op:(`WriteField "alloc_live") (rvar Locals.mem_encoding) - (applyintrin ~op:`MapUpdate - [ Locals.alloc_live_access; rvar Locals.alloc; rvar Locals.live ]) + let l = Var.mk_gen () in + let b = + binexp ~op:(`WriteField "alloc_live") + (rvar @@ Locals.mem_encoding l) + (applyintrin ~op:`MapUpdate + [ + Locals.alloc_live_access l; + rvar (Locals.alloc l); + rvar (Locals.live l); + ]) + in + (l, b) let allocate_body = + let l = Var.mk_gen () in let alloc = - Calls.addr_alloc [ rvar Locals.mem_encoding; rvar Locals.addr ] + Calls.addr_alloc [ rvar (Locals.mem_encoding l); rvar (Locals.addr l) ] in - let updated = Calls.alloc_size_update [ Calls.alloc_live_update - [ rvar Locals.mem_encoding; alloc; bvconst live ]; + [ rvar (Locals.mem_encoding l); alloc; bvconst live ]; alloc; - rvar Locals.size; + rvar (Locals.size l); ] in - - binexp ~op:`EQ updated (rvar Locals.mem_encoding_out) + (l, binexp ~op:`EQ updated (rvar @@ Locals.mem_encoding_out l)) let init_encoding_body = - let i = Var.create "i" ~scope:Var.LocalVar (Types.Bitvector 64) in + let l = Var.mk_gen () in + let i = l.with_name "i" ~scope:Var.LocalVar (Types.Bitvector 64) in + let mem_enc = rvar (Locals.mem_encoding l) in let trigger e = [ [ e ] ] in - applyintrin ~op:`AND - [ - (* Ensure that all heap addresses are bigger than the largest global address *) - forall - ~triggers: - (trigger (Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar i ])) - ~bound:[ i ] - (binexp ~op:`EQ - (binexp ~op:`BVULT - (* TODO compute this value somehow *) - (bv_of_int 100000000 ~size:64) - (rvar i)) - (Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar i ])); - (* Heap addresses are initially fresh *) - forall - ~triggers: - (trigger (Calls.alloc_live [ rvar Locals.mem_encoding; rvar i ])) - ~bound:[ i ] - (binexp ~op:`IMPLIES - (Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar i ]) - (binexp ~op:`EQ - (Calls.alloc_live [ rvar Locals.mem_encoding; rvar i ]) - (bvconst fresh))); - (* Non heap addresses are dead *) - forall - ~triggers: - (trigger (Calls.alloc_live [ rvar Locals.mem_encoding; rvar i ])) - ~bound:[ i ] - (binexp ~op:`IMPLIES - (boolnot (Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar i ])) - (binexp ~op:`EQ - (Calls.alloc_live [ rvar Locals.mem_encoding; rvar i ]) - (bvconst dead))); - ] + let b = + applyintrin ~op:`AND + [ + (* Ensure that all heap addresses are bigger than the largest global address *) + forall + ~triggers:(trigger (Calls.addr_is_heap [ mem_enc; rvar i ])) + ~bound:[ i ] + (binexp ~op:`EQ + (binexp ~op:`BVULT + (* TODO compute this value somehow *) + (bv_of_int 100000000 ~size:64) + (rvar i)) + (Calls.addr_is_heap [ mem_enc; rvar i ])); + (* Heap addresses are initially fresh *) + forall + ~triggers:(trigger (Calls.alloc_live [ mem_enc; rvar i ])) + ~bound:[ i ] + (binexp ~op:`IMPLIES + (Calls.addr_is_heap [ mem_enc; rvar i ]) + (binexp ~op:`EQ + (Calls.alloc_live [ mem_enc; rvar i ]) + (bvconst fresh))); + (* Non heap addresses are dead *) + forall + ~triggers:(trigger (Calls.alloc_live [ mem_enc; rvar i ])) + ~bound:[ i ] + (binexp ~op:`IMPLIES + (boolnot (Calls.addr_is_heap [ mem_enc; rvar i ])) + (binexp ~op:`EQ + (Calls.alloc_live [ mem_enc; rvar i ]) + (bvconst dead))); + ] + in + (l, b) let valid_access_body = - binexp ~op:`IMPLIES - (Calls.addr_is_heap [ rvar Locals.mem_encoding; rvar Locals.addr ]) - (applyintrin ~op:`AND - [ - binexp ~op:`EQ - (Calls.alloc_live - [ - rvar Locals.mem_encoding; - Calls.alloc_base - [ - rvar Locals.mem_encoding; - Calls.addr_alloc - [ rvar Locals.mem_encoding; rvar Locals.addr ]; - ]; - ]) - (bvconst live); - binexp ~op:`BVULE - (Calls.addr_offset - [ - rvar Locals.mem_encoding; - binexp ~op:`BVADD (rvar Locals.addr) (rvar Locals.size); - ]) - (Calls.alloc_size - [ - rvar Locals.mem_encoding; - Calls.alloc_base - [ - rvar Locals.mem_encoding; - Calls.addr_alloc - [ rvar Locals.mem_encoding; rvar Locals.addr ]; - ]; - ]); - ]) + let l = Var.mk_gen () in + let mem_enc = rvar (Locals.mem_encoding l) in + let addr = rvar (Locals.addr l) in + let b = + binexp ~op:`IMPLIES + (Calls.addr_is_heap [ mem_enc; addr ]) + (applyintrin ~op:`AND + [ + binexp ~op:`EQ + (Calls.alloc_live + [ + mem_enc; + Calls.alloc_base + [ mem_enc; Calls.addr_alloc [ mem_enc; addr ] ]; + ]) + (bvconst live); + binexp ~op:`BVULE + (Calls.addr_offset + [ mem_enc; binexp ~op:`BVADD addr (rvar @@ Locals.size l) ]) + (Calls.alloc_size + [ + mem_enc; + Calls.alloc_base + [ mem_enc; Calls.addr_alloc [ mem_enc; addr ] ]; + ]); + ]) + in + (l, b) end let split_transform (p : Program.t) = - let module E = MemoryEncoder (SplitMemory(struct - let local_ids = failwith "oops" - let global_ids = Program.global_ids p - end)) in + let module I : IDAllocs = struct + let global_ids = Var.mk_gen ~id_generator:(Program.global_ids p) () + end + in + let module E = MemoryEncoder (SplitMemory (I)) in E.transform p let flat_transform (p : Program.t) = - let module E = MemoryEncoder (FlatMemory) in + let module I : IDAllocs = struct + let global_ids = Var.mk_gen ~id_generator:(Program.global_ids p) () + end + in + let module E = MemoryEncoder (FlatMemory (I)) in E.transform p diff --git a/lib/transforms/memory_specification.ml b/lib/transforms/memory_specification.ml index 42c84ebd..dfe56093 100644 --- a/lib/transforms/memory_specification.ml +++ b/lib/transforms/memory_specification.ml @@ -3,178 +3,192 @@ open Lang.Common open Lang.Expr open Memory_encoding -let make_msg_attrib msg = - StringMap.of_list - [ (".boogie", `Assoc (StringMap.of_list [ (".msg", `String msg) ])) ] +module T (I : sig + val global_ids : Var.generator +end) = +struct + module Calls = Calls (I) -let old e = BasilExpr.unexp ~op:`Old e -let i = Var.create ~scope:Var.LocalConst "i" (Types.Bitvector 64) + let make_msg_attrib msg = + StringMap.of_list + [ (".boogie", `Assoc (StringMap.of_list [ (".msg", `String msg) ])) ] -let r n = - BasilExpr.rvar - (Var.create ~scope:Var.GlobalVar (Printf.sprintf "$R%d" n) - (Types.Bitvector 64)) + let old e = BasilExpr.unexp ~op:`Old e -let r_in n = - BasilExpr.rvar - (Var.create ~scope:Var.LocalVar - (Printf.sprintf "R%d_in" n) - (Types.Bitvector 64)) + open Var -let r_out n = - BasilExpr.rvar - (Var.create ~scope:Var.LocalVar - (Printf.sprintf "R%d_out" n) - (Types.Bitvector 64)) + let r p n = + BasilExpr.rvar + (p.with_name ~scope:Var.GlobalVar (Printf.sprintf "$R%d" n) + (Types.Bitvector 64)) -let transform_main p = - (* TODO: Specify Gammas Oneday *) - let spec = Procedure.specification p in - Procedure.set_specification p - { - spec with - requires = - spec.requires - (* Require memory is initialized. *) - @ [ Calls.init_encoding [ BasilExpr.rvar Globals.mem_encoding ] ]; - (* Ensure there are no memory leaks. *) - ensures = - spec.ensures - @ [ - BasilExpr.forall - ~attrib:(make_msg_attrib "Memory Error: Memory Leak") - ~bound:[ i ] - @@ BasilExpr.binexp ~op:`IMPLIES - (Calls.addr_is_heap - [ BasilExpr.rvar Globals.mem_encoding; BasilExpr.rvar i ]) - (BasilExpr.binexp ~op:`NEQ - (Calls.alloc_live - [ - BasilExpr.rvar Globals.mem_encoding; - Calls.addr_alloc - [ - BasilExpr.rvar Globals.mem_encoding; - BasilExpr.rvar i; - ]; - ]) - (BasilExpr.bvconst live)); - ]; - modifies_globs = spec.modifies_globs @ [ Globals.mem_encoding ]; - captures_globs = spec.captures_globs @ [ Globals.mem_encoding ]; - } + let r_in p n = + BasilExpr.rvar + (p.with_name ~scope:Var.LocalVar + (Printf.sprintf "R%d_in" n) + (Types.Bitvector 64)) -let transform_malloc p = - (* TODO: Specify Gammas Oneday *) - let spec = Procedure.specification p in - let open BasilExpr in - Procedure.set_specification p - { - spec with - ensures = - spec.ensures - @ [ - (* Can allocate at new r0 with size old r0 *) - Calls.can_alloc - [ old @@ rvar Globals.mem_encoding; r_out 0; r_in 0 ]; - (* Offset of return address r0 is 0 *) - binexp ~op:`EQ - (Calls.addr_offset [ rvar Globals.mem_encoding; r_out 0 ]) - (bv_of_int ~size:64 0); - (* Base of associated allocation is r(0) *) - binexp ~op:`EQ - (Calls.alloc_base - [ - rvar Globals.mem_encoding; - Calls.addr_alloc [ rvar Globals.mem_encoding; r_out 0 ]; - ]) - (r_out 0); - (* Update the memory encoding: *) - Calls.allocate - [ - old @@ rvar Globals.mem_encoding; - rvar Globals.mem_encoding; - r_out 0; - r_in 0; - ]; - ]; - modifies_globs = spec.modifies_globs @ [ Globals.mem_encoding ]; - captures_globs = spec.captures_globs @ [ Globals.mem_encoding ]; - } + let r_out p n = + BasilExpr.rvar + (p.with_name ~scope:Var.LocalVar + (Printf.sprintf "R%d_out" n) + (Types.Bitvector 64)) -let transform_free p = - (* TODO: Specify Gammas Oneday *) - let spec = Procedure.specification p in - let open BasilExpr in - Procedure.set_specification p - { - spec with - requires = - spec.requires - @ [ - (* Only free heap values *) - Calls.addr_is_heap - ~attrib: - (make_msg_attrib "Memory Error: Invalid Free (non heap object)") - [ rvar Globals.mem_encoding; r_in 0 ]; - (* Only free if offset is 0 *) - binexp - ~attrib: - (make_msg_attrib "Memory Error: Invalid Free (not base address)") - ~op:`EQ (bv_of_int ~size:64 0) - (Calls.addr_offset [ rvar Globals.mem_encoding; r_in 0 ]); - (* The object must be live to free *) - binexp - ~attrib: - (make_msg_attrib "Memory Error: Invalid Free (object not live)") - ~op:`EQ - (Calls.alloc_live - [ - rvar Globals.mem_encoding; - Calls.addr_alloc [ rvar Globals.mem_encoding; r_in 0 ]; - ]) - (bvconst live); - ]; - ensures = - spec.ensures - @ [ - binexp ~op:`EQ - ~attrib:(make_msg_attrib "Memory Error: Invalid Free") - (rvar Globals.mem_encoding) - (Calls.alloc_live_update - [ - old @@ rvar Globals.mem_encoding; - Calls.addr_alloc [ old @@ rvar Globals.mem_encoding; r_in 0 ]; - BasilExpr.bvconst dead; - ]); - ]; - modifies_globs = spec.modifies_globs @ [ Globals.mem_encoding ]; - captures_globs = spec.captures_globs @ [ Globals.mem_encoding ]; - } + let transform_main (p : Program.proc) = + (* TODO: Specify Gammas Oneday *) + let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding I.global_ids in + let spec = Procedure.specification p in + let i = Procedure.fresh_var p ~name:"i" ~pure:true (Types.Bitvector 64) in + Procedure.set_specification p + { + spec with + requires = + spec.requires + (* Require memory is initialized. *) + @ [ Calls.init_encoding [ mem_encoding ] ]; + (* Ensure there are no memory leaks. *) + ensures = + spec.ensures + @ [ + BasilExpr.forall + ~attrib:(make_msg_attrib "Memory Error: Memory Leak") + ~bound:[ i ] + @@ BasilExpr.binexp ~op:`IMPLIES + (Calls.addr_is_heap [ mem_encoding; BasilExpr.rvar i ]) + (BasilExpr.binexp ~op:`NEQ + (Calls.alloc_live + [ + mem_encoding; + Calls.addr_alloc [ mem_encoding; BasilExpr.rvar i ]; + ]) + (BasilExpr.bvconst live)); + ]; + modifies_globs = + spec.modifies_globs @ [ Globals.mem_encoding I.global_ids ]; + captures_globs = + spec.captures_globs @ [ Globals.mem_encoding I.global_ids ]; + } -let transform_stmt (s : Program.stmt) = - (match s with - | Stmt.Instr_Store { lhs; rhs; addr = Addr { addr; size; endian }; attrib } - | Stmt.Instr_Load { lhs; rhs; addr = Addr { addr; size; endian }; attrib } - -> ( - let valid_assert = - Stmt.Instr_Assert - { - attrib = make_msg_attrib "Memory Error: Invalid Access"; - body = - BasilExpr.( - Calls.valid_access - [ - rvar Globals.mem_encoding; - addr; - bv_of_int ~size:64 (size / 8); - ]); - } - in - match Var.name rhs with "$mem" -> [ valid_assert; s ] | _ -> [ s ]) - | _ -> [ s ]) - |> List.to_iter + let transform_malloc p = + (* TODO: Specify Gammas Oneday *) + let spec = Procedure.specification p in + let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding I.global_ids in + let pid = Var.mk_gen ~id_generator:(Procedure.local_ids p) () in + let r_in = r_in pid in + let r_out = r_out pid in + let open BasilExpr in + Procedure.set_specification p + { + spec with + ensures = + spec.ensures + @ [ + (* Can allocate at new r0 with size old r0 *) + Calls.can_alloc [ old @@ mem_encoding; r_out 0; r_in 0 ]; + (* Offset of return address r0 is 0 *) + binexp ~op:`EQ + (Calls.addr_offset [ mem_encoding; r_out 0 ]) + (bv_of_int ~size:64 0); + (* Base of associated allocation is r(0) *) + binexp ~op:`EQ + (Calls.alloc_base + [ mem_encoding; Calls.addr_alloc [ mem_encoding; r_out 0 ] ]) + (r_out 0); + (* Update the memory encoding: *) + Calls.allocate + [ old @@ mem_encoding; mem_encoding; r_out 0; r_in 0 ]; + ]; + modifies_globs = + spec.modifies_globs @ [ Globals.mem_encoding I.global_ids ]; + captures_globs = + spec.captures_globs @ [ Globals.mem_encoding I.global_ids ]; + } -let transform_proc entry _ (p : Program.proc) = + let transform_free p = + (* TODO: Specify Gammas Oneday *) + let spec = Procedure.specification p in + let open BasilExpr in + let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding I.global_ids in + let pid = Var.mk_gen ~id_generator:(Procedure.local_ids p) () in + let r_in = r_in pid in + Procedure.set_specification p + { + spec with + requires = + spec.requires + @ [ + (* Only free heap values *) + Calls.addr_is_heap + ~attrib: + (make_msg_attrib + "Memory Error: Invalid Free (non heap object)") + [ mem_encoding; r_in 0 ]; + (* Only free if offset is 0 *) + binexp + ~attrib: + (make_msg_attrib + "Memory Error: Invalid Free (not base address)") + ~op:`EQ (bv_of_int ~size:64 0) + (Calls.addr_offset [ mem_encoding; r_in 0 ]); + (* The object must be live to free *) + binexp + ~attrib: + (make_msg_attrib + "Memory Error: Invalid Free (object not live)") + ~op:`EQ + (Calls.alloc_live + [ mem_encoding; Calls.addr_alloc [ mem_encoding; r_in 0 ] ]) + (bvconst live); + ]; + ensures = + spec.ensures + @ [ + binexp ~op:`EQ + ~attrib:(make_msg_attrib "Memory Error: Invalid Free") + mem_encoding + (Calls.alloc_live_update + [ + old @@ mem_encoding; + Calls.addr_alloc [ old @@ mem_encoding; r_in 0 ]; + BasilExpr.bvconst dead; + ]); + ]; + modifies_globs = + spec.modifies_globs @ [ Globals.mem_encoding I.global_ids ]; + captures_globs = + spec.captures_globs @ [ Globals.mem_encoding I.global_ids ]; + } + + let transform_stmt (s : Program.stmt) = + (match s with + | Stmt.Instr_Store + { lhs; rhs; addr = Addr { addr; size; endian }; attrib } + | Stmt.Instr_Load { lhs; rhs; addr = Addr { addr; size; endian }; attrib } + -> ( + let valid_assert = + Stmt.Instr_Assert + { + attrib = make_msg_attrib "Memory Error: Invalid Access"; + body = + BasilExpr.( + Calls.valid_access + [ + rvar (Globals.mem_encoding I.global_ids); + addr; + bv_of_int ~size:64 (size / 8); + ]); + } + in + match Var.name rhs with "$mem" -> [ valid_assert; s ] | _ -> [ s ]) + | _ -> [ s ]) + |> List.to_iter +end + +let transform_proc prog entry _ (p : Program.proc) = + let module TR = T (struct + let global_ids = Var.mk_gen ~id_generator:(Program.global_ids prog) () + end) in + let open TR in let p = Procedure.map_blocks_nondet (fun (i, b) -> Block.flat_map ~phi:Fun.id transform_stmt b) @@ -195,5 +209,5 @@ let transform_proc entry _ (p : Program.proc) = let transform (p : Program.t) = let entry = Program.entry_proc_exn p |> Procedure.id %> ID.name in - let p = Program.map_procedures (transform_proc entry) p in + let p = Program.map_procedures (transform_proc p entry) p in (fun prog -> Spec_modifies.set_modsets ~add_only:false prog) p From ddf40b92503fc643d771abf5ea16d677b9b74c0b Mon Sep 17 00:00:00 2001 From: agle Date: Fri, 26 Jun 2026 17:20:41 +1000 Subject: [PATCH 05/22] compiling; bugs in id gen order --- lib/analysis/linear_const.ml | 72 ++++++------- lib/backends/boogie.ml | 3 +- lib/gtirb/conf.ml | 6 +- lib/gtirb/gfir_to_bincaml.ml | 2 +- lib/lang/algsimp.ml | 2 +- lib/lang/check.ml | 64 +++++------ lib/lang/expr_smt.ml | 2 +- lib/lang/interp.ml | 32 +++--- lib/lang/procedure.ml | 17 +-- lib/lang/program.ml | 65 +++++------ lib/lang/program.mli | 11 +- lib/lang/spec_modifies.ml | 2 +- lib/loadir.ml | 75 +++++++------ lib/script.ml | 7 +- lib/transforms/boogie_prepass.ml | 52 +++++---- lib/transforms/cf_tx.ml | 4 +- lib/transforms/function_summaries.ml | 4 +- lib/transforms/gamma_vars.ml | 7 +- lib/transforms/memory_encoding.ml | 98 ++++++++--------- lib/transforms/memory_specification.ml | 12 +-- lib/transforms/ssa.ml | 7 +- lib/util/ID.ml | 12 ++- lib/util/var.ml | 144 ++++++++++--------------- 23 files changed, 327 insertions(+), 373 deletions(-) diff --git a/lib/analysis/linear_const.ml b/lib/analysis/linear_const.ml index 85b9a952..8a70ea1e 100644 --- a/lib/analysis/linear_const.ml +++ b/lib/analysis/linear_const.ml @@ -106,7 +106,8 @@ module LF = struct Linear (a, b) | _ -> Join (a, b, c) - (** Should make join edges with top become TopEdges (and probably similar for effectively id Linear and Join edges...) *) + (** Should make join edges with top become TopEdges (and probably similar for + effectively id Linear and Join edges...) *) let join a b = assert (canonical a && canonical b); match (a, b) with @@ -347,43 +348,40 @@ module LinearIDE = struct |> Iter.map (fun v -> (v, Value.Top)) end -(** For each linear assign and phi node, we create edges from the lhs to all - copied-from variables. For assignments we associate a function encoding the - linear expression. The function should be thought of pointing opposite to - the direction of the edge, so we compose functions backwards (opposite - category). We perform path compression (with composition) on linear paths of - this graph to get a partial intraprocedural copy propagation analysis! - However with just this, we miss out on propagation through phi nodes, where - every variable in a phi is a function, and the same function, from the same - source. To fix this, we recursively check whether the copied-from (parent) - variables and functions for all successor vertices are all equal, and if so - we create a path from the parent of these successors. (This is probably hard - to follow with words, so here is an example: - [v - if ( * ) { x1 = a + 1 } else { x2 = a + 1 } x3 = phi(x1, x2) - v] - in this hypothetical program, x3 points to x1 and x2, which both point to a - with (+1), so we can update x3 to point to a with (+1). This gives an - analysis that works through phi nodes! - - To make it interprocedural, we perform a some small iteration steps. For - each output variable of each procedure, we see whether it is a function of - only input variables, by doing an all-path-tracking dfs on the path - compressed graph. If this is the case, we go to every caller of this - procedure, and see whether all input variables that map into the output - variable are linear expressions such that their composite functions are all - equal. (Example: - [v - proc f(x) = { return g(x + 1, x) } - proc g(x, y) = { if ( * ) { z1 = x - 1 } else { z2 = y } return phi(z1, x2) } - v] - here the return value of g is the same from the call of f! Hence f's output - is a function of x. In this case, we can create an edge from the output - variable in the caller graph to the input variable that copies into it. If - this ever actually happens, we'll want to re-iterate on this procedure as we - may have new edges to propagate to other procedures. *) module LinearConstAnalysis = IDESSI (LinearIDE) - +(** For each linear assign and phi node, we create edges from the lhs to all + copied-from variables. For assignments we associate a function encoding the + linear expression. The function should be thought of pointing opposite to + the direction of the edge, so we compose functions backwards (opposite + category). We perform path compression (with composition) on linear paths of + this graph to get a partial intraprocedural copy propagation analysis! + However with just this, we miss out on propagation through phi nodes, where + every variable in a phi is a function, and the same function, from the same + source. To fix this, we recursively check whether the copied-from (parent) + variables and functions for all successor vertices are all equal, and if so + we create a path from the parent of these successors. (This is probably hard + to follow with words, so here is an example: + {v if ( * ) { x1 = a + 1 } else { x2 = a + 1 } x3 = phi(x1, x2) v} + in this hypothetical program, x3 points to x1 and x2, which both point to a + with (+1), so we can update x3 to point to a with (+1). This gives an + analysis that works through phi nodes! + + To make it interprocedural, we perform a some small iteration steps. For + each output variable of each procedure, we see whether it is a function of + only input variables, by doing an all-path-tracking dfs on the path + compressed graph. If this is the case, we go to every caller of this + procedure, and see whether all input variables that map into the output + variable are linear expressions such that their composite functions are all + equal. (Example: + {v + proc f(x) = { return g(x + 1, x) } + proc g(x, y) = { if ( * ) { z1 = x - 1 } else { z2 = y } return phi(z1, x2) } + v} + here the return value of g is the same from the call of f! Hence f's output + is a function of x. In this case, we can create an edge from the output + variable in the caller graph to the input variable that copies into it. If + this ever actually happens, we'll want to re-iterate on this procedure as we + may have new edges to propagate to other procedures. *) module CopyNode = struct type content = { diff --git a/lib/backends/boogie.ml b/lib/backends/boogie.ml index 2f1f2734..e2c119c4 100644 --- a/lib/backends/boogie.ml +++ b/lib/backends/boogie.ml @@ -503,7 +503,8 @@ let pretty_declaration (d : Program.declaration) = ")" ^ bracket " returns (" (text (type_to_string rt)) ")" ^ text ";" - | Program.Type { binding; typ } -> pretty_type_declaration binding typ + | Program.Type { binding; typ } -> + pretty_type_declaration (ID.name binding) typ | Procedure { definition } -> pretty_procedure definition let pretty_program (p : Program.t) = diff --git a/lib/gtirb/conf.ml b/lib/gtirb/conf.ml index b976b0cc..195f9adb 100644 --- a/lib/gtirb/conf.ml +++ b/lib/gtirb/conf.ml @@ -2,12 +2,12 @@ open Lang.Common type config = { opcode_length : int; (** arm64 opcode size constant *) - pc_var : (string * Types.t); (* variable to use as PC*) + pc_var : string * Types.t; (* variable to use as PC*) disas : bool; (** include disassembly of opcodes if llvm-mc is available *) direct : bool; (** when true, don't attempt to perform any cleanup of gtirb's cfg *) } -let conf = - let pc_var = ("$PC" , Types.(Bitvector 64)) in +let conf = + let pc_var = ("$PC", Types.(Bitvector 64)) in { opcode_length = 4; pc_var; disas = false; direct = false } diff --git a/lib/gtirb/gfir_to_bincaml.ml b/lib/gtirb/gfir_to_bincaml.ml index eb8523ad..75b0c763 100644 --- a/lib/gtirb/gfir_to_bincaml.ml +++ b/lib/gtirb/gfir_to_bincaml.ml @@ -319,7 +319,7 @@ let temp_proc_to_ir_proc pc_var all_blocks m (p : temp_proc) = let module_to_ir_prog ir_cfg (m : Module.t) = let prog = Lang.Program.empty ~name:m.name () in let pc_n, pc_ty = conf.pc_var in - let prog, pc_var = Lang.Program.decl_global_var prog pc_n GlobalVar pc_ty in + let prog, pc_var = Lang.Program.decl_global_var prog pc_n Var.None pc_ty in (* (1) build Gfir CFG *) let entry_proc, procs = gtirb_to_gfir prog ir_cfg m in (* collect map of all blocks in order to fixup interprocedural control-flow diff --git a/lib/lang/algsimp.ml b/lib/lang/algsimp.ml index ff8551a6..525bac0c 100644 --- a/lib/lang/algsimp.ml +++ b/lib/lang/algsimp.ml @@ -330,7 +330,7 @@ let%expect_test "normalise" = @@ BasilExpr.applyintrin ~op:`AND [ BasilExpr.boolnot - (BasilExpr.boolnot (BasilExpr.rvar (gs.fresh Boolean))); + (BasilExpr.boolnot (BasilExpr.rvar (gs.fresh Boolean))); BasilExpr.rvar (gs.fresh Boolean); ] in diff --git a/lib/lang/check.ml b/lib/lang/check.ml index d26f8130..2b2e2765 100644 --- a/lib/lang/check.ml +++ b/lib/lang/check.ml @@ -20,18 +20,14 @@ let formal_params p = let sigil_ok v = let s = Var.name v |> String.take 1 in - let sgl = Var.scope v in - match sgl with - | (Var.LocalVar | Var.LocalConst) when String.equal s "$" -> - raise - @@ IRWellformed - ("local " ^ Var.to_string v ^ "should not have global sigil $") - | (Var.GlobalVar | Var.GlobalVarShared | Var.GlobalConst) - when not @@ String.equal s "$" -> - raise - @@ IRWellformed - ("global " ^ Var.to_string v ^ " should have global sigil $") - | _ -> () + if Var.is_local v && String.equal s "$" then + raise + @@ IRWellformed + ("local " ^ Var.to_string v ^ "should not have global sigil $"); + if Var.is_global v && (not @@ String.equal s "$") then + raise + @@ IRWellformed ("global " ^ Var.to_string v ^ " should have global sigil $"); + () let variables_wf p = let ref_vars = ref StringMap.empty in @@ -49,33 +45,31 @@ let variables_wf p = let var_is_ok n = sigil_ok n; ref_var n; - match Var.scope n with - | Var.LocalConst | Var.LocalVar -> ( - try ignore @@ Procedure.lookup_local_decl p (Var.name n) - with Not_found -> - raise - (IRWellformed - ("local " ^ Var.to_string n ^ " is not declared in " - ^ ID.to_string (Procedure.id p)))) - | (Var.GlobalVar | Var.GlobalVarShared) - when not @@ List.exists (fun v -> Var.equal v n) spec.captures_globs -> - raise - (IRWellformed - ("global " ^ Var.to_string n ^ " is not in capture list of " - ^ (Procedure.id p |> ID.to_string))) - | _ -> () + (if Var.is_local n then + try ignore @@ Procedure.lookup_local_decl p (Var.name n) + with Not_found -> + raise + (IRWellformed + ("local " ^ Var.to_string n ^ " is not declared in " + ^ ID.to_string (Procedure.id p)))); + if + Var.is_global n + && (not @@ List.exists (fun v -> Var.equal v n) spec.captures_globs) + then + raise + (IRWellformed + ("global " ^ Var.to_string n ^ " is not in capture list of " + ^ (Procedure.id p |> ID.to_string))) in let m = ref VarSet.empty in let write v = - match Var.scope v with - | LocalConst -> - if VarSet.mem v !m then - raise - (IRWellformed - ("constant local written more than once: " ^ Var.to_string v)) - else m := VarSet.add v !m - | _ -> () + if Var.is_local v && Var.is_const v then + if VarSet.mem v !m then + raise + (IRWellformed + ("constant local written more than once: " ^ Var.to_string v)) + else m := VarSet.add v !m in let check_lvar v = (*sigil_ok v;*) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 620bfdbc..831a443b 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -448,7 +448,7 @@ module SMTLib2 = struct end let%expect_test "datatypes" = - let g = (ID.make_gen ()) in + let g = ID.make_gen () in let x : Program.declaration = Type { binding = g.decl_or_get "test"; typ = Types.mk_sort "Opaque" } in diff --git a/lib/lang/interp.ml b/lib/lang/interp.ml index 9c7c720c..afe06837 100644 --- a/lib/lang/interp.ml +++ b/lib/lang/interp.ml @@ -530,10 +530,9 @@ module IState = struct let stack_top st = List.hd st.stack let lookup_var v st = - (match Var.scope v with - | LocalVar | LocalConst -> VarMap.find_opt v (stack_top st).locals - | GlobalVar | GlobalVarShared | GlobalConst -> - VarMap.find_opt v st.globals) + (match Var.is_local v with + | true -> VarMap.find_opt v (stack_top st).locals + | false -> VarMap.find_opt v st.globals) |> function | Some v -> v | None -> raise (ReadUninit v) @@ -546,22 +545,21 @@ module IState = struct | _ -> failwith "unsupported memory type" let lookup_memory v st = - match Var.scope v with - | GlobalVar | GlobalConst | GlobalVarShared -> VarMap.find v st.memories - | _ -> failwith "unsupported" + if Var.is_global v then VarMap.find v st.memories + else failwith "unsupported" let write_var var value st = let value = IValue.of_constant value in - match Var.scope var with - | LocalVar | LocalConst -> - let stack = - match st.stack with - | h :: tl -> { h with locals = VarMap.add var value h.locals } :: tl - | _ -> failwith "no stack" - in - { st with stack } - | GlobalVar | GlobalVarShared | GlobalConst -> - { st with globals = VarMap.add var value st.globals } + if Var.is_local var then + let stack = + match st.stack with + | h :: tl -> { h with locals = VarMap.add var value h.locals } :: tl + | _ -> failwith "no stack" + in + { st with stack } + else if Var.is_global var then + { st with globals = VarMap.add var value st.globals } + else failwith "local and global mutually exclusive" let map f v = (fst v, f (snd v)) diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index d202e9a9..a25fe89a 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -232,7 +232,6 @@ end = struct let graph = G.add_vertex graph Return in graph - let create id ?local_id_gen ?(is_stub = false) ?(formal_in_params = StringMap.empty) ?(formal_out_params = StringMap.empty) ?(captures_globs = []) @@ -468,23 +467,27 @@ let lookup_local_decl_exn p v = |> Option.or_lazy ~else_:(fun () -> StringMap.find_opt v (formal_in_params p)) |> Option.get_exn_or ("no local decl : " ^ v) +let var_generator p = + let g = Var.mk_gen ~id_generator:(local_ids p) ~scope:`Local () in + g + let get_local p ?(pure = false) name typ : Var.t = - let scope = if pure then Var.LocalConst else LocalVar in - let v = Var.with_name (local_ids p) name ~scope typ in + let access = if pure then Var.Const else Var.None in + let v = (var_generator p).with_name name ~access typ in Hashtbl.replace (local_decls p) (Var.name v) v; v let decl_local p ?(pure = false) name typ : Var.t = - let scope = if pure then Var.LocalConst else LocalVar in - let v = Var.create_exn (local_ids p) name ~scope typ in + let access = if pure then Var.Const else Var.None in + let v = (var_generator p).create_exn name ~access typ in Hashtbl.replace (local_decls p) (Var.name v) v; v let fresh_var p ?(pure = false) ?name typ : Var.t = let name = Option.map (String.drop_while (Char.equal '$')) name in + let access = if pure then Var.Const else Var.None in let name = Option.get_or ~default:"v" name in - let scope = if pure then Var.LocalConst else LocalVar in - let v = Var.fresh (local_ids p) name typ ~scope in + let v = (var_generator p).fresh ~name typ ~access in Hashtbl.replace (local_decls p) (Var.name v) v; v diff --git a/lib/lang/program.ml b/lib/lang/program.ml index 13245c32..186e5ed3 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -39,6 +39,7 @@ type declaration = | Type of { binding : ID.t; typ : Types.t } | Function of { binding : Var.t; + var_gen : Common.Var.generator; attrib : Attrib.attrib_map; definition : func_type; } (** pure functions *) @@ -57,10 +58,9 @@ let decl_binding = function let decl_id = function | Type { binding } -> binding - | Variable { binding } -> (Var.id binding) - | Function { binding } -> (Var.id binding) - | Procedure { definition } -> (Procedure.id definition) - + | Variable { binding } -> Var.id binding + | Function { binding } -> Var.id binding + | Procedure { definition } -> Procedure.id definition let pretty_proc p = let show_lvar v = Containers_pp.text @@ Var.to_string_il_lvar v in @@ -245,6 +245,10 @@ let prog_pretty (p : t) = let declarations p = p.declarations |> IDMap.to_iter +let var_generator p = + let g = Var.mk_gen ~id_generator:p.global_names ~scope:`Global () in + g + let filter_decls f p = declarations p |> Iter.fold @@ -303,23 +307,6 @@ let decl_global p name f = let decl = f id in add_decl p decl -let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name - scope typ = - let f v = - let r = ref None in - match !r with - | Some v -> v - | None -> - r := Some v; - v - in - let p = - decl_global p name (fun id -> - Variable - { binding = f (Var.create id ~scope typ); attrib; classification }) - in - (p, f (failwith "")) - (** add var decl for with id exising in generator *) let add_var_decl p ?(attrib = Attrib.empty) ?classification v = let id = Var.id v in @@ -333,6 +320,13 @@ let add_var_decl p ?(attrib = Attrib.empty) ?classification v = p.declarations; } +let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name + access_tag typ = + let vg = var_generator p in + let v = vg.with_name name ~access:access_tag typ in + let p = add_var_decl p ~attrib ?classification v in + (p, v) + let global_ids p = p.global_names let decl_or_get_var p name scope typ = @@ -348,21 +342,20 @@ let decl_typ ?(attrib = StringMap.empty) p t = add_decl p (Type { binding = id; typ = s }) | Sort (name, variants) as s -> let id : ID.t = p.global_names.decl_exn name in - { - {(add_decl p (Type { binding = id; typ = s })) with - implicit_decls = - IDMap.add_list p.implicit_decls - (variants - |> List.map (function { variant; fields } -> - let variant = p.global_names.decl_exn variant in - let args = List.map (function { field; typ } -> typ) fields in - let ty = Types.curry args s in - let constructor = Var.create variant ty ~scope:GlobalConst in - ( variant, - VariantCase - { variant ; belongs_to = s; constructor } - ))); - } + let implicit_decls = + IDMap.add_list p.implicit_decls + (variants + |> List.map (function { variant; fields } -> + let args = List.map (function { field; typ } -> typ) fields in + let ty = Types.curry args s in + let vg = var_generator p in + let constructor = vg.with_name variant ~access:Var.Const ty in + ( Var.id constructor, + VariantCase + { variant = Var.id constructor; belongs_to = s; constructor } + ))) + in + { (add_decl p (Type { binding = id; typ = s })) with implicit_decls } | _ -> failwith "not declarable type" let create_single_proc ?(name = "") () = diff --git a/lib/lang/program.mli b/lib/lang/program.mli index cbe2a4c8..0aaf55e0 100644 --- a/lib/lang/program.mli +++ b/lib/lang/program.mli @@ -30,11 +30,7 @@ type prog_spec = { rely : e list; guarantee : e list } type func_type = Axiom of e | Uninterpreted | Function of e type implicit_declaration = - | VariantCase of { - variant : string; - belongs_to : Types.t; - constructor : Var.t; - } + | VariantCase of { variant : ID.t; belongs_to : Types.t; constructor : Var.t } type declaration = | Type of { binding : ID.t; typ : Types.t } @@ -99,6 +95,7 @@ val flat_map_decls : (ID.t -> declaration -> declaration Iter.t) -> t -> t val pretty_to_chan : out_channel -> t -> unit val decl_global : t -> string -> (ID.t -> declaration) -> t val add_decl : t -> declaration -> t +val var_generator : t -> Var.generator val add_var_decl : t -> ?attrib:Attrib.attrib_map -> ?classification:e -> Var.t -> t @@ -108,11 +105,11 @@ val decl_global_var : ?attrib:Attrib.t Types.StringMap.t -> ?classification:e option -> string -> - Var.scope -> + Var.access_tag -> Types.t -> t * Var.t -val decl_or_get_var : t -> string -> Var.scope -> Types.t -> t * Var.t +val decl_or_get_var : t -> string -> Var.access_tag -> Types.t -> t * Var.t val global_ids : t -> ID.generator val decl_typ : ?attrib:'a Types.StringMap.t -> t -> Types.t -> t diff --git a/lib/lang/spec_modifies.ml b/lib/lang/spec_modifies.ml index 9b2b324d..6915583d 100644 --- a/lib/lang/spec_modifies.ml +++ b/lib/lang/spec_modifies.ml @@ -77,7 +77,7 @@ let set_modsets ?(add_only = false) prog = |> Iter.filter Var.is_global |> VarSet.of_iter in let captures_globs = - List.filter (not % Var.is_constant) + List.filter (not % Var.is_const) @@ VarSet.elements @@ VarSet.union vs @@ VarSet.union exist_captures @@ VarSet.union read written diff --git a/lib/loadir.ml b/lib/loadir.ml index 99790a4f..8b11285f 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -41,6 +41,14 @@ type load_st = { (string, (string * Var.t) list * (string * Var.t) list) Hashtbl.t; } +let local_var_gen pst = + let idg = + pst.local_id_gen |> Option.get_exn_or "local id context not defiend" + in + Var.mk_gen ~id_generator:idg ~scope:`Local () + +let global_var_gen pst = pst.prog |> Program.var_generator + let load_st_empty ?(name = "") () = { prog = Program.empty ~name (); @@ -164,9 +172,8 @@ module BasilASTLoader = struct map_prog (fun prog -> Spec_modifies.set_modsets ~add_only:true prog) prog and var_modifiers_shared (m : varModifiers list) = - if not @@ List.exists (function Shared | Observable -> true) m then - Var.GlobalVar - else Var.GlobalVarShared + if not @@ List.exists (function Shared | Observable -> true) m then Var.None + else Var.Shared and trans_varspec prog (v : varSpec) = let trans_one v = @@ -233,7 +240,7 @@ module BasilASTLoader = struct fst @@ Program.decl_global_var p (unsafe_unsigil (`Global glident)) - GlobalConst ftype) + Const ftype) prog | Decl_FunNoType (glident, _, _) -> prog | Decl_Fun (glident, params, _, typ, _) -> @@ -241,24 +248,26 @@ module BasilASTLoader = struct let arg_types = List.map Var.typ bound in let rtype = Types.curry arg_types (trans_type typ) in let name = unsafe_unsigil (`Global glident) in - let fundef id : Program.declaration = + let vg = Program.var_generator prog.prog in + let fundef : Program.declaration = Function { attrib = StringMap.empty; var_gen = Var.mk_gen (); - binding = Var.create id ~scope:GlobalConst rtype; + binding = vg.with_name name ~access:Const rtype; definition = Uninterpreted; } in map_prog (fun prog -> - let p = Program.decl_global prog name fundef in + let p = Program.add_decl prog fundef in p) prog | Decl_Axiom (name, _, _) -> let name = unsafe_unsigil (`Global name) in - let fundef id : Program.declaration = - let bvar = Var.create id ~scope:GlobalConst Boolean in + let fundef : Program.declaration = + let vg = Program.var_generator prog.prog in + let bvar = vg.with_name name ~access:Const Boolean in Function { attrib = StringMap.empty; @@ -267,7 +276,7 @@ module BasilASTLoader = struct definition = Uninterpreted; } in - map_prog (fun prog -> Program.decl_global prog name fundef) prog + map_prog (fun prog -> Program.add_decl prog fundef) prog | Decl_Proc ( ProcIdent (id_pos, id), _, @@ -280,11 +289,12 @@ module BasilASTLoader = struct spec, definition ) -> let ids = ID.make_gen () in + let vg = Var.mk_gen ~id_generator:ids ~scope:`Local () in let proc_id = Program.declare_name id prog.prog in - let formal_in_params_order = List.map (param_to_formal ids) in_params in + let formal_in_params_order = List.map (param_to_formal vg) in_params in let formal_in_params = formal_in_params_order |> StringMap.of_list in let formal_out_params_order = - List.map (param_to_formal ids) out_params + List.map (param_to_formal vg) out_params in let formal_out_params = StringMap.of_list formal_out_params_order in let _, attrib = trans_attrib_set prog ~binds:formal_in_params attrib in @@ -350,11 +360,11 @@ module BasilASTLoader = struct in let _, attrib = trans_attrib_set ~binds:StringMap.empty prog attrList in let name = unsafe_unsigil (`Global glident) in - let fundef id : Program.declaration = - let binding = Var.create id ~scope:GlobalConst rtype in + let fundef : Program.declaration = + let binding = (global_var_gen prog).with_name name ~access:Const rtype in Function { attrib; binding; definition; var_gen = Var.mk_gen () } in - map_prog (fun prog -> Program.decl_global prog name fundef) prog + map_prog (fun prog -> Program.add_decl prog fundef) prog (** Second pass: resolve the full definition of all declarations. *) and trans_definition prog (x : decl) : load_st = @@ -372,8 +382,10 @@ module BasilASTLoader = struct let body = trans_expr prog body in let name = unsafe_unsigil (`Global name) in - let fundef id : Program.declaration = - let bvar = Var.create id ~scope:GlobalConst Boolean in + let fundef : Program.declaration = + let bvar = + (global_var_gen prog).with_name name ~access:Const Boolean + in Function { attrib; @@ -382,8 +394,8 @@ module BasilASTLoader = struct var_gen = Var.mk_gen ~id_generator:v (); } in - map_prog (fun prog -> Program.decl_global prog name fundef) prog - |> fun p -> { p with local_id_gen = None } + map_prog (fun prog -> Program.add_decl prog fundef) prog |> fun p -> + { p with local_id_gen = None } | Decl_ProgEmpty (ProcIdent (_, id), attr) -> let _, nattrib = trans_attrib_set ~binds:StringMap.empty prog attr in prog @@ -429,7 +441,7 @@ module BasilASTLoader = struct in let open Procedure.Vert in let formal_out_params_order = - List.map (param_to_formal id_gen) out_params + List.map (param_to_formal (local_var_gen prog)) out_params in (* add blocks *) let p, blocks_id = @@ -577,7 +589,7 @@ module BasilASTLoader = struct try lookup_global_decl globalVar p_st with e -> let p, v = - Program.decl_or_get_var p_st.prog name GlobalVar (trans_type ty) + Program.decl_or_get_var p_st.prog name Var.None (trans_type ty) in Logs.warn (fun m -> m "Warn: global undeclared %s. assuming mutable unshared" @@ -901,7 +913,7 @@ module BasilASTLoader = struct and unpack_local_lvars ?(bound = StringMap.empty) p_st const lvs : Var.t list = - let scope = if const then Var.LocalConst else LocalVar in + let scope = if const then Var.Const else Var.None in lvs |> List.map (function | LocalTyped (i, t) -> @@ -926,11 +938,10 @@ module BasilASTLoader = struct | Jump_ProcReturn -> `ProcReturn and assign_var (prog : load_st) v = - match Var.scope v with - | Var.LocalVar | Var.LocalConst -> (prog, v) - | Var.GlobalVar | Var.GlobalVarShared -> - (map_curr_proc (fun p -> write_global p v) prog, v) - | Var.GlobalConst -> failwith "assignment to global constant" + match Var.is_global v with + | true when Var.is_const v -> failwith "assign to global const" + | true -> (map_curr_proc (fun p -> write_global p v) prog, v) + | false -> (prog, v) and loc_lvar (x : BasilIR.AbsBasilIR.lVar) : Attrib.attrib_map = let l = @@ -1048,10 +1059,10 @@ module BasilASTLoader = struct EndList _ ) -> tx name attribs phi statements jump - and param_to_formal (p : ID.generator) (pp : params) : string * Var.t = + and param_to_formal (p : Var.generator) (pp : params) : string * Var.t = match pp with | Params1 (LocalIdent (pos, id), t) -> - (id, Var.create (p.decl_or_get id) (trans_type t)) + (id, p.with_name id ~access:None (trans_type t)) and trans_funspec prog bound_post (spec : (Var.t, BasilExpr.t) Procedure.proc_spec) (s : funSpec) : @@ -1352,12 +1363,8 @@ module BasilASTLoader = struct let bound = unpac_lambdaparen ~bound:StringMap.empty p_st param in let funct = Types.curry (List.map Var.typ bound) (trans_type rt) in let id = unsafe_unsigil (`Local id) in - let idg = - p_st.local_id_gen - |> Option.get_exn_or "failure: no local id context defined" - in (* assume no shadowing *) - let funvar = Var.create (idg.decl_or_get id) funct ~scope:LocalConst in + let funvar = (local_var_gen p_st).with_name id funct ~access:Const in let func = match bound with | [] -> trans_expr ~nbinds:bound body diff --git a/lib/script.ml b/lib/script.ml index cda2854c..5dc11f0d 100644 --- a/lib/script.ml +++ b/lib/script.ml @@ -312,7 +312,12 @@ let load_gtirb st fname = | Ok e -> Loader.Loadir.( Some - { prog = e; curr_proc = None; params_order = Hashtbl.create 0 }) + { + prog = e; + curr_proc = None; + params_order = Hashtbl.create 0; + local_id_gen = None; + }) | _ -> None in { st with load_st = p }) diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index 2637d457..b0f59b65 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -151,11 +151,13 @@ module Builtins = struct s.rely |> List.iter (iexpr f); s.guarantee |> List.iter (iexpr f) - let function_for_op (pid : ID.generator) op args ret = - Var.create ~scope:Var.GlobalConst + let function_for_op (pid : Var.generator) op args ret = + let name = (match name op (args @ [ ret ]) with - | Function s -> pid.decl_or_get s + | Function s -> s | _ -> failwith "unexpected") + in + pid.with_name name ~access:Var.Const (Types.curry args ret) let transform_op_to_decl pid op args ret = @@ -170,6 +172,7 @@ module Builtins = struct Some (Function { + var_gen = Var.mk_gen ~scope:`Local (); attrib = attribs; binding = function_for_op pid op args ret; definition = Uninterpreted; @@ -185,7 +188,7 @@ module Builtins = struct (match op with | `Load _ -> None | #builtin as op -> - transform_op_to_decl (Program.global_ids p) op args ret + transform_op_to_decl (Program.var_generator p) op args ret | _ -> None)) |> Iter.to_list |> List.fold_left (fun p v -> Program.add_decl p v) p @@ -229,14 +232,14 @@ module Instructions = struct |> Iter.sort_uniq let store_body ?(be = false) mem_typ val_size addr_size = - let v = Var.mk_gen () in + let v = Var.mk_gen ~scope:`Local () in (** FIXME: function-local variables *) - let memory = v.with_name ~scope:Var.LocalVar "#memory" mem_typ in + let memory = v.with_name "#memory" mem_typ in let value = - v.with_name ~scope:Var.LocalVar "#value" (Types.Bitvector val_size) + v.with_name "#value" (Types.Bitvector val_size) in let index = - v.with_name ~scope:Var.LocalVar "#index" (Types.Bitvector addr_size) + v.with_name "#index" (Types.Bitvector addr_size) in (* TODO: maybe generalize to non 8 bit stores, based on mem typ value? *) let steps = val_size / 8 in @@ -263,10 +266,10 @@ module Instructions = struct v, Expr.BasilExpr.lambda ~bound:[ memory; index; value ] body let load_body ?(be = false) mem_typ val_size addr_size = - let v = Var.mk_gen () in - let memory = v.with_name ~scope:Var.LocalVar "#memory" mem_typ in + let v = Var.mk_gen ~scope:`Local () in + let memory = v.with_name "#memory" mem_typ in let index = - v.with_name ~scope:Var.LocalVar "#index" (Types.Bitvector addr_size) + v.with_name "#index" (Types.Bitvector addr_size) in let steps = val_size / 8 in let body = @@ -316,7 +319,7 @@ module Instructions = struct attrib = attribs; var_gen ; binding = - global_vargen.with_name ~scope:Var.GlobalConst + global_vargen.with_name ~access:Var.Const (Printf.sprintf "store%d_%s" size (Lang.Stmt.show_endian endian)) (Lang.Expr.BasilExpr.type_of value); @@ -343,7 +346,7 @@ module Instructions = struct attrib = attribs; var_gen; binding = - global_vargen.with_name ~scope:Var.GlobalConst + global_vargen.with_name ~access:Var.Const (Printf.sprintf "load%d_%s" size (Stmt.show_endian endian)) (Var.typ lhs); definition = Function body; @@ -387,7 +390,7 @@ module Normalise = struct replace [%here] (BasilExpr.apply_fun ~attrib ~func: - (BasilExpr.rvar ~attrib (Var.copy ~name:(Var.name id) id)) + (BasilExpr.rvar ~attrib id) args) | _ -> replace [%here] (apply_fun_to_map func args)) | ApplyIntrin { op = `AND; args } -> @@ -410,7 +413,7 @@ module Normalise = struct open Stmt - let replace_stmt (s : Program.stmt) = + let replace_stmt ~(global_vars: Var.generator) (s : Program.stmt) = match s with | Instr_IndirectCall { attrib } -> Instr_Assert @@ -433,7 +436,7 @@ module Normalise = struct ( lhs, Expr.BasilExpr.fapply (Expr.BasilExpr.rvar - (Var.create ~scope:Var.GlobalConst fn_name (Var.typ lhs))) + (global_vars.with_name ~access:Var.Const fn_name (Var.typ lhs))) [ Expr.BasilExpr.rvar rhs; addr ] ); ]; attrib; @@ -450,7 +453,7 @@ module Normalise = struct ( lhs, Expr.BasilExpr.fapply (Expr.BasilExpr.rvar - (Var.create ~scope:Var.GlobalConst fn_name (Var.typ lhs))) + (global_vars.with_name ~access:Var.Const fn_name (Var.typ lhs))) [ Expr.BasilExpr.rvar rhs; addr; value ] ); ]; attrib; @@ -468,12 +471,13 @@ module Normalise = struct let replace_functions (p : Program.t) = let open Program in + let vg = Program.var_generator p in let prog = Program.flat_map_decls (fun k -> function - | Function { binding; attrib; definition } -> ( + | Function { binding; attrib; definition ; var_gen} -> ( let keep = - Iter.singleton (Function { binding; attrib; definition }) + Iter.singleton (Function { binding; attrib; definition ; var_gen}) in match definition with | Function b -> ( @@ -481,15 +485,16 @@ module Normalise = struct | Lambda { bound_vars; in_body } -> keep | body -> let axiom_name = - Program.declare_name_exn (ID.name k ^ "_funvalue") p + (ID.name k ^ "_funvalue") in Iter.doubleton (Function - { binding; definition = Uninterpreted; attrib }) + { binding; definition = Uninterpreted; attrib ; var_gen }) (Function { binding = - Var.copy ~name:(ID.name axiom_name) binding; + vg.with_name (axiom_name) ~access:(Var.access binding) (Var.typ binding); + var_gen; definition = Axiom (BasilExpr.binexp ~op:`EQ @@ -504,10 +509,11 @@ module Normalise = struct prog let replace_stmts (p : Program.t) = + let gids = Program.var_generator p in Program.map_procedures (fun _ p -> Procedure.map_blocks_nondet - (fun (id, b) -> Block.map ~phi:Fun.id replace_stmt b) + (fun (id, b) -> Block.map ~phi:Fun.id (replace_stmt ~global_vars:gids) b) p) p end diff --git a/lib/transforms/cf_tx.ml b/lib/transforms/cf_tx.ml index 3c07ebdb..3934b77c 100644 --- a/lib/transforms/cf_tx.ml +++ b/lib/transforms/cf_tx.ml @@ -49,7 +49,7 @@ let simplify_prog_exprs rewriter ?visit (p : Program.t) = Program.( fun id -> (function - | Function { binding; attrib; definition ; var_gen } -> + | Function { binding; attrib; definition; var_gen } -> let definition = match definition with | Axiom b -> @@ -58,7 +58,7 @@ let simplify_prog_exprs rewriter ?visit (p : Program.t) = | Function b -> Function (rewriter ?visit b) | Uninterpreted -> Uninterpreted in - Function { binding; attrib; definition ; var_gen } + Function { binding; attrib; definition; var_gen } | o -> o)) p diff --git a/lib/transforms/function_summaries.ml b/lib/transforms/function_summaries.ml index 03c4e7e0..a7d5dd81 100644 --- a/lib/transforms/function_summaries.ml +++ b/lib/transforms/function_summaries.ml @@ -148,8 +148,8 @@ let add_decls solver prog = Program.( function | Type { binding } -> true - | Variable { binding } -> Var.is_constant binding - | Function { binding } -> Var.is_constant binding + | Variable { binding } -> Var.is_const binding + | Function { binding } -> Var.is_const binding | Procedure { definition } -> false) |> Iter.map (fun d -> Expr_smt.SMTLib2.trans_decl d Expr_smt.SMTLib2.empty) |> Iter.map fst diff --git a/lib/transforms/gamma_vars.ml b/lib/transforms/gamma_vars.ml index 941edc51..a52cd2f3 100644 --- a/lib/transforms/gamma_vars.ml +++ b/lib/transforms/gamma_vars.ml @@ -34,9 +34,7 @@ let transform_proc ?(check_names = false) (add : ID.t -> Var.t -> bool) prog let v = if Var.is_global v then ( let v = - Var.create ~scope:(Var.scope v) - ((Program.global_ids prog).fresh ~name ()) - typ + (Program.var_generator prog).with_name ~access:(Var.access v) name typ in added := VarSet.add v !added; v) @@ -219,8 +217,7 @@ let transform_proc ?(check_names = false) (add : ID.t -> Var.t -> bool) prog let proc = Procedure.set_specification proc spec in let add_globals (p : Program.t) = - VarSet.to_iter !added - |> Iter.fold (fun p v -> Program.add_var_decl p v) p + VarSet.to_iter !added |> Iter.fold (fun p v -> Program.add_var_decl p v) p in (* Update statements *) diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index 9c70f5c1..d6d47ca7 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -13,9 +13,7 @@ module Globals = struct let mem_encoding_typ_name = "memory_encoding" let mem_encoding_typ = Types.Variable mem_encoding_typ_name - - let mem_encoding v = - v.with_name "$mem_encoding" ~scope:Var.GlobalVar mem_encoding_typ + let mem_encoding v = v.with_name "$mem_encoding" ~access:None mem_encoding_typ end module Calls (N : sig @@ -32,8 +30,7 @@ struct let addr_is_heap ?attrib args = apply_fun ?attrib ~func: - (rvar - (v.with_name "$me_addr_is_heap" ~scope:Var.GlobalConst Types.Boolean)) + (rvar (v.with_name "$me_addr_is_heap" ~access:Var.Const Types.Boolean)) args (** [alloc_base args] returns the base address of a supplied allocation id. @@ -42,8 +39,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_base" ~scope:Var.GlobalConst - (Types.Bitvector 64))) + (v.with_name "$me_alloc_base" ~access:Var.Const (Types.Bitvector 64))) args (** [alloc_live args] returns the liveness of an allocation. Returns value is @@ -53,8 +49,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_live" ~scope:Var.GlobalConst - (Types.Bitvector 2))) + (v.with_name "$me_alloc_live" ~access:Var.Const (Types.Bitvector 2))) args (** [alloc_size args] returns the size of an allocation. args(0) is the memory @@ -63,8 +58,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_size" ~scope:Var.GlobalConst - (Types.Bitvector 64))) + (v.with_name "$me_alloc_size" ~access:Var.Const (Types.Bitvector 64))) args (** [addr_alloc args] returns the allocation id of an address. args(0) is the @@ -73,8 +67,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_addr_alloc" ~scope:Var.GlobalConst - (Types.Bitvector 64))) + (v.with_name "$me_addr_alloc" ~access:Var.Const (Types.Bitvector 64))) args (** [addr_offset args] returns the offset an address is into its allocation. @@ -83,8 +76,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_addr_offset" ~scope:Var.GlobalConst - (Types.Bitvector 64))) + (v.with_name "$me_addr_offset" ~access:Var.Const (Types.Bitvector 64))) args (** [alloc_size_update args] returns a new memory encoding with the size of an @@ -94,7 +86,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_size_update" ~scope:Var.GlobalConst + (v.with_name "$me_alloc_size_update" ~access:Var.Const Globals.mem_encoding_typ)) args @@ -105,7 +97,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_live_update" ~scope:Var.GlobalConst + (v.with_name "$me_alloc_live_update" ~access:Var.Const Globals.mem_encoding_typ)) args @@ -114,8 +106,7 @@ struct allocated at. args(3) is the size of the allocation. *) let allocate ?attrib args = apply_fun ?attrib - ~func: - (rvar (v.with_name "$me_allocate" ~scope:Var.GlobalConst Types.Boolean)) + ~func:(rvar (v.with_name "$me_allocate" ~access:Var.Const Types.Boolean)) args (** [can_alloc args] Returns whether an alloc, performed by [allocate], is @@ -124,8 +115,7 @@ struct let can_alloc ?attrib args = apply_fun ?attrib ~func: - (rvar - (v.with_name "$me_can_allocate" ~scope:Var.GlobalConst Types.Boolean)) + (rvar (v.with_name "$me_can_allocate" ~access:Var.Const Types.Boolean)) args (** [init_encoding args] Returns if a memory encoding is initialized. args(0) @@ -133,8 +123,7 @@ struct let init_encoding ?attrib args = apply_fun ?attrib ~func: - (rvar - (v.with_name "$me_init_encoding" ~scope:Var.GlobalConst Types.Boolean)) + (rvar (v.with_name "$me_init_encoding" ~access:Var.Const Types.Boolean)) args (** [valid_access args] Checks if an access is valid. args(0) is the memory @@ -143,8 +132,7 @@ struct let valid_access ?attrib args = apply_fun ?attrib ~func: - (rvar - (v.with_name "$me_valid_access" ~scope:Var.GlobalConst Types.Boolean)) + (rvar (v.with_name "$me_valid_access" ~access:Var.Const Types.Boolean)) args end @@ -181,18 +169,20 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct let name = "$" ^ name in let var_gen, body = body in let bindings = List.map (fun f -> f var_gen) bindings in - Lang.Program.decl_global p name (fun id -> - Lang.Program.Function - { - var_gen; - binding = - Bincaml_util.Common.Var.create id ~scope:GlobalConst - (Types.curry (List.map Var.typ bindings) - @@ Lang.Expr.BasilExpr.type_of body); - attrib; - definition : Lang.Program.func_type = - Function (Lang.Expr.BasilExpr.lambda ~bound:bindings body); - }) + let decl = + Lang.Program.Function + { + var_gen; + binding = + (Program.var_generator p).with_name name ~access:Const + (Types.curry (List.map Var.typ bindings) + @@ Lang.Expr.BasilExpr.type_of body); + attrib; + definition : Lang.Program.func_type = + Function (Lang.Expr.BasilExpr.lambda ~bound:bindings body); + } + in + Lang.Program.add_decl p decl let add_mem_encoding p = let gids : ID.generator = Program.global_ids p in @@ -373,16 +363,15 @@ module FlatMemory (M : IDAllocs) : MemoryEncoding = struct module Locals = struct open Var - let mem_encoding l : Var.t = - l.with_name "mem_encoding" ~scope:Var.LocalVar mem_encoding_type + let mem_encoding l : Var.t = l.with_name "mem_encoding" mem_encoding_type let mem_encoding_out l : Var.t = - l.with_name "mem_encoding_out" ~scope:Var.LocalVar mem_encoding_type + l.with_name "mem_encoding_out" mem_encoding_type - let alloc l = l.with_name "alloc" ~scope:Var.LocalVar Types.Integer - let addr l = l.with_name "addr" ~scope:Var.LocalVar (Types.Bitvector 64) - let size l = l.with_name "size" ~scope:Var.LocalVar (Types.Bitvector 64) - let live l = l.with_name "live" ~scope:Var.LocalVar (Types.Bitvector 2) + let alloc l = l.with_name "alloc" Types.Integer + let addr l = l.with_name "addr" (Types.Bitvector 64) + let size l = l.with_name "size" (Types.Bitvector 64) + let live l = l.with_name "live" (Types.Bitvector 2) let alloc_live_access_h me = unexp ~op:(`ReadField "alloc_live") (rvar me) let alloc_live_access l = alloc_live_access_h (mem_encoding l) let alloc_size_access_h me = unexp ~op:(`ReadField "alloc_size") (rvar me) @@ -477,7 +466,7 @@ module FlatMemory (M : IDAllocs) : MemoryEncoding = struct let allocate_body : function_body = let l = Var.mk_gen () in - let i = l.with_name "i" ~scope:Var.LocalVar (Types.Bitvector 64) in + let i = l.with_name "i" (Types.Bitvector 64) in let in_bounds = applyintrin ~op:`AND [ @@ -588,8 +577,8 @@ module FlatMemory (M : IDAllocs) : MemoryEncoding = struct let init_encoding_body : function_body = let l = Var.mk_gen () in - let o = l.with_name "o" ~scope:Var.LocalVar Types.Integer in - let i = l.with_name "i" ~scope:Var.LocalVar (Types.Bitvector 64) in + let o = l.with_name "o" Types.Integer in + let i = l.with_name "i" (Types.Bitvector 64) in let b = begin applyintrin ~op:`AND @@ -670,16 +659,15 @@ module SplitMemory (M : IDAllocs) : MemoryEncoding = struct module Locals = struct open Var - let mem_encoding l = - l.with_name "mem_encoding" ~scope:Var.LocalVar mem_encoding_type + let mem_encoding l = l.with_name "mem_encoding" mem_encoding_type let mem_encoding_out l : Var.t = - l.with_name "mem_encoding_out" ~scope:Var.LocalVar mem_encoding_type + l.with_name "mem_encoding_out" mem_encoding_type - let alloc l = l.with_name "alloc" ~scope:Var.LocalVar (Types.Bitvector 64) - let addr l = l.with_name "addr" ~scope:Var.LocalVar (Types.Bitvector 64) - let size l = l.with_name "size" ~scope:Var.LocalVar (Types.Bitvector 64) - let live l = l.with_name "live" ~scope:Var.LocalVar (Types.Bitvector 2) + let alloc l = l.with_name "alloc" (Types.Bitvector 64) + let addr l = l.with_name "addr" (Types.Bitvector 64) + let size l = l.with_name "size" (Types.Bitvector 64) + let live l = l.with_name "live" (Types.Bitvector 2) let alloc_live_access l = unexp ~op:(`ReadField "alloc_live") (rvar @@ mem_encoding l) @@ -805,7 +793,7 @@ module SplitMemory (M : IDAllocs) : MemoryEncoding = struct let init_encoding_body = let l = Var.mk_gen () in - let i = l.with_name "i" ~scope:Var.LocalVar (Types.Bitvector 64) in + let i = l.with_name "i" (Types.Bitvector 64) in let mem_enc = rvar (Locals.mem_encoding l) in let trigger e = [ [ e ] ] in let b = diff --git a/lib/transforms/memory_specification.ml b/lib/transforms/memory_specification.ml index dfe56093..8da5f742 100644 --- a/lib/transforms/memory_specification.ml +++ b/lib/transforms/memory_specification.ml @@ -18,21 +18,15 @@ struct open Var let r p n = - BasilExpr.rvar - (p.with_name ~scope:Var.GlobalVar (Printf.sprintf "$R%d" n) - (Types.Bitvector 64)) + BasilExpr.rvar (p.with_name (Printf.sprintf "$R%d" n) (Types.Bitvector 64)) let r_in p n = BasilExpr.rvar - (p.with_name ~scope:Var.LocalVar - (Printf.sprintf "R%d_in" n) - (Types.Bitvector 64)) + (p.with_name (Printf.sprintf "R%d_in" n) (Types.Bitvector 64)) let r_out p n = BasilExpr.rvar - (p.with_name ~scope:Var.LocalVar - (Printf.sprintf "R%d_out" n) - (Types.Bitvector 64)) + (p.with_name (Printf.sprintf "R%d_out" n) (Types.Bitvector 64)) let transform_main (p : Program.proc) = (* TODO: Specify Gammas Oneday *) diff --git a/lib/transforms/ssa.ml b/lib/transforms/ssa.ml index d659b10c..facee62b 100644 --- a/lib/transforms/ssa.ml +++ b/lib/transforms/ssa.ml @@ -71,7 +71,7 @@ let should_lift ~skip_observable ~skip_maps v = let skip = (skip_observable && Var.is_shared v) || (skip_maps && Var.typ v |> function Map _ -> true | _ -> false) - || (Var.is_global v && Var.is_constant v) + || (Var.is_global v && Var.is_const v) in not skip @@ -236,7 +236,7 @@ let lift_procedure_params prog ~skip_observable ~skip_maps all_lifted procid let alg node = match node with | UnaryExpr { op = `Old; arg } -> replace [%here] arg - | RVar { id } when Var.is_constant id -> Keep + | RVar { id } when Var.is_const id -> Keep | RVar { id } -> ( match StringMap.find_opt (Var.name id) glob_to_inparam with | Some v -> replace [%here] (rvar v) @@ -266,8 +266,7 @@ let lift_procedure_params prog ~skip_observable ~skip_maps all_lifted procid let alg node = match node with | UnaryExpr { op = `Old; arg } -> replace [%here] (rewrite_old_expr arg) - | RVar { id } when Var.is_constant id || (not @@ VarSet.mem id fvs) -> - Keep + | RVar { id } when Var.is_const id || (not @@ VarSet.mem id fvs) -> Keep | RVar { id } -> ( match StringMap.find_opt (Var.name id) glob_to_outparam with | Some v -> replace [%here] (rvar v) diff --git a/lib/util/ID.ml b/lib/util/ID.ml index 1e3e389e..74b9e770 100644 --- a/lib/util/ID.ml +++ b/lib/util/ID.ml @@ -23,6 +23,7 @@ open struct type cache type generator = { + gen_id : string; (** unique id for this generator *) get_id : string -> t; (** return a previously declared unique integer identifier for a name *) @@ -38,7 +39,7 @@ open struct get_declared : unit -> M.t; } - val make_gen : unit -> generator + val make_gen : ?scope_name:string -> unit -> generator end end @@ -142,6 +143,7 @@ module ID : ID_Pub = struct (name, id) type generator = { + gen_id : string; get_id : string -> t; (** return a previously declared unique integer identifier for a name *) get_name : int -> t; (** get name for a given unique integer identifier *) @@ -155,9 +157,14 @@ module ID : ID_Pub = struct get_declared : unit -> M.t; } + let gen_ids = Fix.Gensym.make () + (** return a generator for unique hash-consed string identifiers. general implementation of a declaration *) - let make_gen () : generator = + let make_gen ?scope_name () : generator = + let gen_id = + Option.get_or ~default:(Int.to_string (gen_ids ())) scope_name + in let c = { names = ref M.empty; @@ -166,6 +173,7 @@ module ID : ID_Pub = struct } in { + gen_id; get_id = get_id c; get_name = get_name c; fresh = fresh c; diff --git a/lib/util/var.ml b/lib/util/var.ml index 474af3c5..7c8e9c5b 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -1,67 +1,44 @@ open Containers open Mtypes +type access_tag = Const | Shared | None [@@deriving show, eq, ord] +type scope_tag = Global of string | Local of string [@@deriving show, eq, ord] - -type scope = LocalConst | LocalVar | GlobalVar | GlobalConst | GlobalVarShared -[@@deriving show, eq, ord] - -type t = { name : ID.t; typ : Types.t; scope : scope } +type t = { name : ID.t; scope : scope_tag; typ : Types.t; tags : access_tag } [@@deriving eq, ord, show] let hash v = - Hash.(combine3 (ID.hash v.name) (Hash.poly v.scope) (Hash.poly v.typ)) - + Hash.(combine3 (ID.hash v.name) (Hash.poly v.tags) (Hash.poly v.typ)) +(* let copy ?name ?scope ?typ (v : t) = { name = Option.get_or ~default:v.name name; typ = Option.get_or ~default:v.typ typ; scope = Option.get_or ~default:v.scope scope; - } + } *) -let to_int (v : t) = ID.index (v.name) +let to_int (v : t) = ID.index v.name let name (e : t) = ID.name @@ e.name - let id v = v.name - -let scope (e : t) = e.scope +let tags (e : t) = e.tags let typ (e : t) = e.typ let to_string v = name v ^ ":" ^ Types.to_string @@ typ v let pp fmt v = Format.pp_print_string fmt (to_string v) let pretty v = Containers_pp.text (to_string v) - - -let is_local (v : t) = - match scope v with LocalVar -> true | LocalConst -> true | _ -> false - -let is_global (v : t) = - match scope v with - | GlobalVar -> true - | GlobalConst -> true - | GlobalVarShared -> true - | _ -> false - -let is_mutable (v : t) = - match scope v with GlobalVar -> true | LocalVar -> true | _ -> false - -let is_constant (v : t) = - match scope v with LocalConst -> true | GlobalConst -> true | _ -> false - -let is_pure (v : t) = is_constant v - -let is_shared (v : t) = - match scope v with GlobalVarShared -> true | _ -> false - +let is_local (v : t) = match v.scope with Local _ -> true | Global _ -> false +let is_global (v : t) = not (is_local v) +let is_const (v : t) = match v.tags with Const -> true | _ -> false +let access (v : t) = v.tags +let is_shared (v : t) = match v.tags with Shared -> true | _ -> false let to_string_il_rvar v = to_string v let to_string_il_lvar v = - match scope v with - | LocalVar -> "var " ^ to_string v - | LocalConst -> "let " ^ to_string v - | GlobalVar -> to_string v - | GlobalVarShared -> to_string v - | GlobalConst -> "let " ^ to_string v + match (v.scope, v.tags) with + | _, Const -> "let " ^ to_string v + | Local _, _ -> "var " ^ to_string v + | Global _, None -> to_string v + | Global _, Shared -> to_string v let to_decl_string_il v = let modifiers = if is_shared v then "observable " else "" in @@ -69,69 +46,58 @@ let to_decl_string_il v = (** Variable Generators *) - type generator = { - fresh: ?name:string -> ?scope:scope -> Types.t -> t; - (** generate a fresh unique name optional string prefix hint *) - with_name: string -> ?scope:scope -> Types.t -> t; - (** Create or return variable with name*) - create_exn: string -> ?scope:scope -> Types.t -> t; - (** Create variable or throw exception if it was previously declared *) - generator: ID.generator; - (** The internal ID generator this closes over *) + scope : scope_tag; + fresh : ?name:string -> ?access:access_tag -> Types.t -> t; + (** generate a fresh unique name optional string prefix hint *) + with_name : string -> ?access:access_tag -> Types.t -> t; + (** Create or return variable with name*) + create_exn : string -> ?access:access_tag -> Types.t -> t; + (** Create variable or throw exception if it was previously declared *) + generator : ID.generator; (** The internal ID generator this closes over *) } - type ('t, 'a, 'g) any_gen = { - call: 'a -> 't; - (** Create variable or throw exception if it was previously declared *) - inner: 'g + call : 'a -> 't; + (** Create variable or throw exception if it was previously declared *) + inner : 'g; } - -let create name ?(scope = LocalVar) typ = +open struct + let create name id_gen ?(access = None) typ = (* disallow creating local const as its too hard to have declaration order *) - match scope with - | LocalConst -> { name; typ; scope = LocalVar } - | _ -> { name; typ; scope } - -let to_gen (a:generator) = - let call = function - | `Fresh (g: (string option* scope option * Types.t)) -> let (name, scope, typ) = g in a.fresh ?name ?scope typ - | `WithName (g : (string * scope option * Types.t)) -> let (name, scope, typ) = g in a.with_name name ?scope typ - | `CreateExn g -> let (name, scope, typ) = g in a.create_exn name ?scope typ in - { - call; - inner=a - } + { name; scope = id_gen; typ; tags = access } + let fresh gt (gen : ID.generator) name ?access typ = + let name = gen.fresh ~name () in + create name gt ?access typ -let fresh (id_gen: ID.generator) name ?scope typ = - let name = id_gen.fresh ~name () in - create name ?scope typ + let with_name gt (id_gen : ID.generator) name ?access typ = + let name = id_gen.decl_or_get name in + create name gt ?access typ -let with_name (id_gen: ID.generator) name ?scope typ = - let name = id_gen.decl_or_get name in - create name ?scope typ + let create_exn gt (id_gen : ID.generator) name ?access typ = + let name = id_gen.decl_exn name in + create name gt ?access typ +end -let create_exn (id_gen: ID.generator) name ?scope typ = - let name = id_gen.decl_exn name in - create name ?scope typ - - -let mk_gen ?id_generator ?(default_name="v") () = +let mk_gen ?id_generator ?(scope = `Local) ?(default_name = "v") () = let id_gen = Option.get_or ~default:(ID.make_gen ()) id_generator in + let gt = + match scope with + | `Local -> Local id_gen.gen_id + | `Global -> Global id_gen.gen_id + in - let fresh ?name ?scope typ = + let fresh ?name ?access typ = let name = Option.get_or ~default:default_name name in - fresh id_gen name ?scope typ + fresh gt id_gen name ?access typ in { - fresh ; - with_name= with_name id_gen; - create_exn = create_exn id_gen; - generator=id_gen; + scope = gt; + fresh; + with_name = with_name gt id_gen; + create_exn = create_exn gt id_gen; + generator = id_gen; } - - From 17690f048c6c9310608b6e68f4963a7bc57a3ac1 Mon Sep 17 00:00:00 2001 From: agle Date: Mon, 29 Jun 2026 11:56:33 +1000 Subject: [PATCH 06/22] fixes --- lib/analysis/linear_const.ml | 2 +- lib/lang/algsimp.ml | 4 ++-- lib/loadir.ml | 37 +++++++++++++++++++----------------- test/cram/concat.il | 1 + test/lang/test_stmt.ml | 9 +++++---- 5 files changed, 29 insertions(+), 24 deletions(-) diff --git a/lib/analysis/linear_const.ml b/lib/analysis/linear_const.ml index 8a70ea1e..7ca22f40 100644 --- a/lib/analysis/linear_const.ml +++ b/lib/analysis/linear_const.ml @@ -547,7 +547,7 @@ module CopyGraph = struct let default_vertex_attributes _ = [] let graph_attributes _ = [] let default_edge_attributes _ = [] - let get_subgraph _ = None + let get_subgraph _ = Option.None let edge_attributes (_, f, _) = match f with diff --git a/lib/lang/algsimp.ml b/lib/lang/algsimp.ml index 525bac0c..8225eacd 100644 --- a/lib/lang/algsimp.ml +++ b/lib/lang/algsimp.ml @@ -339,6 +339,6 @@ let%expect_test "normalise" = print_endline (BasilExpr.to_string e); [%expect {| - boolnot(boolnot(boolnot(booland(boolnot(boolnot(b:bool)), a:bool)))) - boolor(boolnot(b:bool), boolnot(a:bool)) + boolnot(boolnot(boolnot(booland(boolnot(boolnot(v_1:bool)), v:bool)))) + boolor(boolnot(v_1:bool), boolnot(v:bool)) |}] diff --git a/lib/loadir.ml b/lib/loadir.ml index 8b11285f..c9b954eb 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -575,7 +575,7 @@ module BasilASTLoader = struct let name = unsafe_unsigil (`Local localVar) in let v = Procedure.get_local - (p_st.curr_proc |> Option.get_exn_or "") + (p_st.curr_proc |> Option.get_exn_or "no current proc") name (trans_type ty) in Logs.warn (fun m -> @@ -585,8 +585,7 @@ module BasilASTLoader = struct lookup_local_decl ~binds localVar p_st | VarGlobalVar (GlobalTyped (globalVar, ty)) -> ( let name = unsafe_unsigil (`Global globalVar) in - - try lookup_global_decl globalVar p_st + try lookup_global_decl ~typ:(trans_type ty) globalVar p_st with e -> let p, v = Program.decl_or_get_var p_st.prog name Var.None (trans_type ty) @@ -918,7 +917,7 @@ module BasilASTLoader = struct |> List.map (function | LocalTyped (i, t) -> Procedure.get_local - (p_st.curr_proc |> Option.get_exn_or "") + (p_st.curr_proc |> Option.get_exn_or "no current proc") (unsafe_unsigil (`Local i)) (trans_type t) | LocalUntyped i -> lookup_local_decl ~binds:bound i p_st) @@ -956,21 +955,22 @@ module BasilASTLoader = struct Attrib.attr_of_loc l and trans_lvar prog (x : BasilIR.AbsBasilIR.lVar) : load_st * Var.t = - let proc = prog.curr_proc |> Option.get_exn_or "" in match x with | LVar_Local (LocalTyped (bident, type')) -> + let proc = prog.curr_proc |> Option.get_exn_or "no current proc" in assign_var prog - @@ Procedure.decl_local proc + @@ Procedure.get_local proc (unsafe_unsigil (`Local bident)) ~pure:false (trans_type type') | LVar_LocalConst (LocalTyped (bident, type')) -> + let proc = prog.curr_proc |> Option.get_exn_or "no current proc" in assign_var prog - @@ Procedure.decl_local proc + @@ Procedure.get_local proc (unsafe_unsigil (`Local bident)) ~pure:true (trans_type type') | LVar_LocalConst (LocalUntyped _) -> failwith "type annotation needed" | LVar_Global (GlobalTyped (bident, type')) -> - let v = lookup_global_decl bident prog in + let v = lookup_global_decl bident ~typ:(trans_type type') prog in assign_var prog v | LVar_Local (LocalUntyped bident) -> let v = lookup_local_decl bident prog in @@ -1147,22 +1147,25 @@ module BasilASTLoader = struct | _ -> fail ()) | _ -> fail () - and lookup_global_decl ident p_st = + and lookup_global_decl ?typ ident p_st = + (* FIXME: evantually should not need lookup, should be able to locally construct compatible var*) let vn = unsafe_unsigil (`Global ident) in let token_char_offset_range = Some (loc_ident (`Global ident)) in - match Program.get_decl_by_name vn p_st.prog with - | Some (Variable { binding }) -> binding - | Some (Function { binding }) -> binding - | Some (Type _) -> + match (typ, Program.get_decl_by_name vn p_st.prog) with + | _, Some (Variable { binding }) -> binding + | _, Some (Function { binding }) -> binding + | _, Some (Type _) -> let msg = "found type declaration when looking for variable:" ^ vn in raise (LoadError { token_char_offset_range; msg; input = None }) - | None -> ( + | Some ty, None -> + Program.var_generator p_st.prog |> fun v -> v.with_name vn ty + | None, None -> ( match Program.get_implicit_decl_by_name vn p_st.prog with | Some (VariantCase { constructor }) -> constructor | None -> let msg = "global variable used before declaration : " ^ vn in raise (LoadError { token_char_offset_range; msg; input = None })) - | Some (Procedure _) -> failwith "" + | _, Some (Procedure _) -> failwith "got proc when expecting global var" and trans_bv_val v : Bitvec.t = match v with @@ -1270,7 +1273,7 @@ module BasilASTLoader = struct with Not_found | LoadError _ -> let v = Procedure.get_local - (p_st.curr_proc |> Option.get_exn_or "") + (p_st.curr_proc |> Option.get_exn_or "no current proc") (unsafe_unsigil (`Local g)) (trans_type type') in @@ -1616,7 +1619,7 @@ let load_single_block_proc ?(proc = "") ?input lexbuf = Procedure.G.add_edge g (End bid) Return) proc in - let bl = Procedure.get_block proc bid |> Option.get_exn_or "" in + let bl = Procedure.get_block proc bid |> Option.get_exn_or "no current proc" in let inparam = Block.free_vars bl |> VarSet.filter Var.is_local |> VarSet.to_list |> List.map (fun x -> (Var.name x, x)) diff --git a/test/cram/concat.il b/test/cram/concat.il index 04217d06..c8808267 100644 --- a/test/cram/concat.il +++ b/test/cram/concat.il @@ -2,6 +2,7 @@ var $R28:bv64; var $R0:bv64; var $R30:bv64; +var $__BranchTaken; prog entry @main_4204352; proc @main_4204352() -> () [ diff --git a/test/lang/test_stmt.ml b/test/lang/test_stmt.ml index 0c46d2e7..e181ad46 100644 --- a/test/lang/test_stmt.ml +++ b/test/lang/test_stmt.ml @@ -4,15 +4,16 @@ open Lang.Common open Expr let%expect_test "frees" = + let v = Var.mk_gen ~scope:`Local () in let s = Instr_Assign { al = [ - ( Var.create "v1" Types.Boolean, - BasilExpr.rvar @@ Var.create "v2" Types.Boolean ); - ( Var.create "v3" Types.Boolean, - BasilExpr.rvar @@ Var.create "v4" Types.Boolean ); + ( v.with_name "v1" Types.Boolean, + BasilExpr.rvar @@ v.with_name "v2" Types.Boolean ); + ( v.with_name "v3" Types.Boolean, + BasilExpr.rvar @@ v.with_name "v4" Types.Boolean ); ]; attrib = Attrib.empty; } From 46f77bf2e7df86fd5c026745238bf8882f7df7c4 Mon Sep 17 00:00:00 2001 From: agle Date: Mon, 29 Jun 2026 14:54:28 +1000 Subject: [PATCH 07/22] compiling --- lib/lang/expr_smt.ml | 12 ++++--- lib/transforms/aslp/aslp_lexpr.ml | 42 ++++++++++++++++------ lib/transforms/aslp/aslp_state.ml | 47 +++++++------------------ lib/transforms/aslp/bincaml_ibi.ml | 8 +++-- lib/transforms/aslp/bincaml_ibi_make.ml | 20 +++++++---- lib/transforms/chc_infer.ml | 9 ++--- lib/util/var.ml | 27 ++++++++++---- test/transforms/test_aslp.ml | 10 +++--- test/transforms/test_aslp_ibi.ml | 2 +- 9 files changed, 102 insertions(+), 75 deletions(-) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index e0c144e8..573e3ca9 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -202,19 +202,23 @@ module SMTLib2 = struct Some (Types.Map (k, v)) | _ -> None - let expr_of_smt vardefs (e : Sexp.t) = + let expr_of_smt ?(vargen: Var.generator option) vardefs (e : Sexp.t) = let open Option.Infix in let module T = List.Traverse (Option) in (* One generator for the whole decode. Reserve every Basil variable already in scope -- the free vars of the values of [vardefs] -- so the quantifier binders minted below stay disjoint from them. *) - let gen = ID.make_gen () in + let vargen = match vargen with + | Some v -> v + | None -> Var.mk_gen () + in StringMap.iter (fun _ e -> BasilExpr.free_vars_iter e - |> Iter.iter (fun v -> ignore (gen.decl_or_get (Var.name v)))) + (* reserve used names *) + |> Iter.iter (fun v -> ignore (vargen.with_name (Var.name v) (Var.typ v)))) vardefs; - let fresh_var typ = Var.create (ID.name (gen.fresh ~name:"x" ())) typ in + let fresh_var typ = vargen.fresh ~name:"x" typ in (* Give each binder a fresh variable rather than reusing the name the solver chose. This accounts for names that are not valid identifiers (e.g., include [!]) and names that clash with existing variables. *) diff --git a/lib/transforms/aslp/aslp_lexpr.ml b/lib/transforms/aslp/aslp_lexpr.ml index 92f3727f..fb217332 100644 --- a/lib/transforms/aslp/aslp_lexpr.ml +++ b/lib/transforms/aslp/aslp_lexpr.ml @@ -65,15 +65,37 @@ let name = function | R None | Z None -> failwith "name_of_lexpr: array lexpr has no bincaml name" | v -> show v -let scope = function - | Local _ -> Var.LocalVar - | BranchTaken | BTypeCompatible | BTypeNext -> LocalVar - | _ -> GlobalVar +type aslp_ids = { local_var : Var.generator; global_var : Var.generator } +(** Generators for unique IDs used by the offline lifter. The {!aslp_ids} is + stateful and the same {!aslp_ids} should be used by all opcodes within the + same procedure, to ensure that IDs are unique.*) -let to_var x = - let ty = typ x and name = name x and scope = scope x in - let name = match scope with GlobalVar -> "$" ^ name | _ -> name in - Var.create ~scope name ty +(** Construct a new {!aslp_ids} with no pre-existing IDs. -let pc_var = to_var PC -let branchtaken_var = to_var BranchTaken + Be careful! You should use {!aslp_ids_from_generators} if you will use the + lifted statements within an existing Bincaml IR. *) +let empty_aslp_ids () = + let local_var = Var.mk_gen () in + let global_var = Var.mk_gen ~scope:`Global () in + { local_var; global_var } + +(** {2 ID-generating functions} *) + +(** Construct a {!aslp_ids} with the given {!Bincaml_util.ID.generator}s as + underlying generators. + + This will ensure that ASLp's local variable and block names do not clash + with existing names. *) +let aslp_ids_from_generators ~local_var ~global_var = + { local_var ; global_var} +let scope st = function + | Local _ -> st.local_var + | BranchTaken | BTypeCompatible | BTypeNext -> st.local_var + | _ -> st.global_var + +let to_var st x = + let ty = typ x and name = name x and scope = scope st x in + scope.with_name name ty + +let pc_var st = to_var st PC +let branchtaken_var st = to_var st BranchTaken diff --git a/lib/transforms/aslp/aslp_state.ml b/lib/transforms/aslp/aslp_state.ml index 97b7a4e3..048d061e 100644 --- a/lib/transforms/aslp/aslp_state.ml +++ b/lib/transforms/aslp/aslp_state.ml @@ -34,19 +34,13 @@ type aslp_diamond = aslp_block Diamond.diamond [@@deriving show] it is not the representation which is used {i during} lifting. For the "in-progress" representation, see {!diamond}. *) -type aslp_ids = { local_id : unit -> string } -(** Generators for unique IDs used by the offline lifter. - - The {!aslp_ids} is stateful and the same {!aslp_ids} should be used by all - opcodes within the same procedure, to ensure that IDs are unique.*) - type lifter_state = { address : Bitvec.t option; (** Byte address of the instruction currently being lifted. *) diamond : aslp_block Diamond.diamond_zipper; (** Lifter state representing a control flow diamond while it is being built. *) - generator : aslp_ids; [@opaque] (** Generators for ID names. *) + generator : Aslp_lexpr.aslp_ids; [@opaque] (** Generators for ID names. *) names : (string, string) Hashtbl.t; (** Map of ASLp local variable names to the "ID-ified" names produced for Bincaml. @@ -83,24 +77,6 @@ let empty_lifter_state ~generator () = generator; } -(** Construct a new {!aslp_ids} with no pre-existing IDs. - - Be careful! You should use {!aslp_ids_from_generators} if you will use the - lifted statements within an existing Bincaml IR. *) -let empty_aslp_ids () = - let local_id = Fix.Gensym.make () %> Printf.sprintf "var_%d" in - { local_id } - -(** {2 ID-generating functions} *) - -(** Construct a {!aslp_ids} with the given {!Bincaml_util.ID.generator}s as - underlying generators. - - This will ensure that ASLp's local variable and block names do not clash - with existing names. *) -let aslp_ids_from_generators ~local_ids = - let local_id = ID.fresh ~name:"var" local_ids %> ID.name in - { local_id } (** {1 State manipulation functions} *) @@ -110,11 +86,11 @@ let aslp_ids_from_generators ~local_ids = is assumed that [PC] is assigned at most once on any straight-line path. Raises an exception if the statement is an assignment to [PC] and {!pc_assign} is already set. *) -let add_stmt_to_block blk ~stmt = +let add_stmt_to_block gen blk ~stmt = let pc_assign = match stmt with | Stmt.Instr_Assign { al = assigns; _ } -> - assigns |> List.Assoc.get ~eq:Var.equal Aslp_lexpr.pc_var + assigns |> List.Assoc.get ~eq:Var.equal (Aslp_lexpr.pc_var gen) | _ -> None in match (pc_assign, blk.pc_assign) with @@ -128,24 +104,27 @@ let add_stmt_to_block blk ~stmt = let add_stmt_to_active stmt (lifter_state : lifter_state) = let diamond = lifter_state.diamond in - let diamond = diamond |> Diamond.modify (add_stmt_to_block ~stmt) in + let diamond = + diamond |> Diamond.modify (add_stmt_to_block lifter_state.generator ~stmt) + in { lifter_state with diamond } (** {1 Program counter functions} *) (** Ensures that the focused block has a PC assignment. If it already has {!pc_assign}, no changes are made. *) -let ensure_pc_assigned ~address = +let ensure_pc_assigned generator ~address = Diamond.modify (function | { pc_assign = None } as block -> let incremented = Expr.BasilExpr.bvconst Bitvec.(add address (of_int ~size:64 4)) and ff = Expr.BasilExpr.boolconst false in - let bt = Aslp_lexpr.branchtaken_var and pc = Aslp_lexpr.pc_var in + let bt = Aslp_lexpr.branchtaken_var generator in + let pc = Aslp_lexpr.pc_var generator in let al = [ (bt, ff); (pc, incremented) ] in block - |> add_stmt_to_block + |> add_stmt_to_block generator ~stmt:(Stmt.Instr_Assign { attrib = Attrib.empty; al }) | block -> block) @@ -167,7 +146,7 @@ let ensure_pc_assigned ~address = This is used to maintain the invariant that at every control flow point, the [PC] variable is either assigned on all paths or assigned on no paths (from the beginning of the instruction). *) -let ensure_pc_consistency ~address state = +let ensure_pc_consistency gen ~address state = let before_skel = Diamond.skeleton state in let left = state |> Diamond.move_in_to `L |> Result.get_ok and right = state |> Diamond.move_in_to `R |> Result.get_ok in @@ -175,8 +154,8 @@ let ensure_pc_consistency ~address state = (* Make PCs of left and right agree. Resulting state is at left or right. *) let state = match ((Diamond.focus left).pc_assign, (Diamond.focus right).pc_assign) with - | Some _, None -> right |> ensure_pc_assigned ~address - | None, Some _ -> left |> ensure_pc_assigned ~address + | Some _, None -> right |> ensure_pc_assigned gen ~address + | None, Some _ -> left |> ensure_pc_assigned gen ~address | None, None | Some _, Some _ -> left (* arbitrary *) in diff --git a/lib/transforms/aslp/bincaml_ibi.ml b/lib/transforms/aslp/bincaml_ibi.ml index db35f36b..fe47480a 100644 --- a/lib/transforms/aslp/bincaml_ibi.ml +++ b/lib/transforms/aslp/bincaml_ibi.ml @@ -27,6 +27,8 @@ let from_generator generator : (module IBI) = (** Builds a new {!IBI} where the ID generators are derived from the given procedure. *) -let from_bincaml_procedure proc : (module IBI) = - let local_ids = Procedure.local_ids proc in - from_generator (Aslp_state.aslp_ids_from_generators ~local_ids) +let from_bincaml_procedure prog proc : (module IBI) = + from_generator + (Aslp_lexpr.aslp_ids_from_generators + ~local_var:(Procedure.var_generator proc) + ~global_var:(Program.var_generator prog)) diff --git a/lib/transforms/aslp/bincaml_ibi_make.ml b/lib/transforms/aslp/bincaml_ibi_make.ml index 28d79833..4353f946 100644 --- a/lib/transforms/aslp/bincaml_ibi_make.ml +++ b/lib/transforms/aslp/bincaml_ibi_make.ml @@ -36,9 +36,9 @@ struct let id_name = match Hashtbl.find_opt !bincaml_lifter_state.names name with | None -> - let id_name = !bincaml_lifter_state.generator.local_id () in - Hashtbl.replace !bincaml_lifter_state.names name id_name; - id_name + let id_name = !bincaml_lifter_state.generator.local_var.fresh ty in + Hashtbl.replace !bincaml_lifter_state.names name (Var.name id_name); + Var.name id_name | Some x -> x in Aslp_lexpr.Local (id_name, ty) @@ -71,7 +71,11 @@ struct | `M -> let address = bincaml_get_address () and diamond = !bincaml_lifter_state.diamond in - let diamond = diamond |> Aslp_state.ensure_pc_consistency ~address in + let diamond = + diamond + |> Aslp_state.ensure_pc_consistency !bincaml_lifter_state.generator + ~address + in bincaml_lifter_state := { !bincaml_lifter_state with diamond } (** {2 IR extraction} *) @@ -83,7 +87,9 @@ struct let get_ir () = let diamond = !bincaml_lifter_state.diamond and address = bincaml_get_address () in - diamond |> Aslp_state.ensure_pc_assigned ~address |> Diamond.of_zipper + diamond + |> Aslp_state.ensure_pc_assigned !bincaml_lifter_state.generator ~address + |> Diamond.of_zipper (** {2 Instruction building interface implementation} *) @@ -247,13 +253,13 @@ struct let f_decl_bool : string -> lexpr = fun _ -> failwith "f_decl_bool" let f_gen_load : lexpr -> expr = - fun lhs -> Expr.BasilExpr.rvar (Aslp_lexpr.to_var lhs) + fun lhs -> Expr.BasilExpr.rvar (Aslp_lexpr.to_var !bincaml_lifter_state.generator lhs) let f_gen_store : lexpr -> expr -> unit = fun lhs rhs -> bincaml_emit (Stmt.Instr_Assign - { attrib = Attrib.empty; al = [ (Aslp_lexpr.to_var lhs, rhs) ] }) + { attrib = Attrib.empty; al = [ (Aslp_lexpr.to_var !bincaml_lifter_state.generator lhs, rhs) ] }) let f_gen_array_load : lexpr -> bigint -> expr = fun array idx -> diff --git a/lib/transforms/chc_infer.ml b/lib/transforms/chc_infer.ml index 6628516c..7211f46a 100644 --- a/lib/transforms/chc_infer.ml +++ b/lib/transforms/chc_infer.ml @@ -126,15 +126,17 @@ module Encoder = struct mutable premises : Sexp.t list; mutable vars : VarSet.t; (** the clause binders for the eventual [forall] *) - mutable counter : int; + vargen: Var.generator; } let create ~initial_vars = + let vargen = Var.mk_gen () in + List.iter (fun i -> ignore @@ vargen.with_name (Var.name i) (Var.typ i)) initial_vars ; { delta = VarMap.empty; premises = []; vars = VarSet.of_list initial_vars; - counter = 0; + vargen ; } let lookup t v = @@ -153,8 +155,7 @@ module Encoder = struct v let fresh t v = - t.counter <- t.counter + 1; - let nv = Var.copy ~name:(Var.name v ^ "!" ^ string_of_int t.counter) v in + let nv = t.vargen.fresh ~name:(Var.name v) (Var.typ v) in t.delta <- VarMap.add v nv t.delta; t.vars <- VarSet.add nv t.vars; nv diff --git a/lib/util/var.ml b/lib/util/var.ml index 7c8e9c5b..c5d22a8f 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -64,40 +64,53 @@ type ('t, 'a, 'g) any_gen = { } open struct + let force_sigil sigil s : string = + if String.starts_with ~prefix:sigil s then s else sigil ^ s + let create name id_gen ?(access = None) typ = (* disallow creating local const as its too hard to have declaration order *) { name; scope = id_gen; typ; tags = access } - let fresh gt (gen : ID.generator) name ?access typ = + let fresh gt (gen : ID.generator) sgl name ?access typ = + let name = force_sigil sgl name in let name = gen.fresh ~name () in create name gt ?access typ - let with_name gt (id_gen : ID.generator) name ?access typ = + let with_name gt (id_gen : ID.generator) sgl name ?access typ = + let name = force_sigil sgl name in let name = id_gen.decl_or_get name in create name gt ?access typ - let create_exn gt (id_gen : ID.generator) name ?access typ = + let create_exn gt (id_gen : ID.generator) sgl name ?access typ = + let name = force_sigil sgl name in let name = id_gen.decl_exn name in create name gt ?access typ end -let mk_gen ?id_generator ?(scope = `Local) ?(default_name = "v") () = +let mk_gen ?id_generator ?(req_sigil = Option.None) ?(scope = `Local) + ?(default_name = "v") () = let id_gen = Option.get_or ~default:(ID.make_gen ()) id_generator in let gt = match scope with | `Local -> Local id_gen.gen_id | `Global -> Global id_gen.gen_id in + let sgl = + match (req_sigil, scope) with + | Some s, _ -> s + | None, `Local -> "" + | None, `Global -> "$" + in let fresh ?name ?access typ = let name = Option.get_or ~default:default_name name in - fresh gt id_gen name ?access typ + fresh gt id_gen sgl name ?access typ in { scope = gt; fresh; - with_name = with_name gt id_gen; - create_exn = create_exn gt id_gen; + with_name = with_name gt id_gen sgl; + create_exn = create_exn gt id_gen sgl; generator = id_gen; } diff --git a/test/transforms/test_aslp.ml b/test/transforms/test_aslp.ml index 3c6969c4..ea67e5f2 100644 --- a/test/transforms/test_aslp.ml +++ b/test/transforms/test_aslp.ml @@ -3,7 +3,7 @@ open Common open Transforms.Aslp let%expect_test "lift empty" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_code_block (module I) ~address:(Bitvec.of_int ~size:64 0x2000) @@ -13,7 +13,7 @@ let%expect_test "lift empty" = [%expect {| |}] let%expect_test "lift: add x1, x2, x3, lsl #4" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_opcode @@ -34,7 +34,7 @@ let%expect_test "lift: add x1, x2, x3, lsl #4" = |}] let%expect_test "lift 2x: mov x1, #0xabcd" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_code_block (module I) ~address:(Bitvec.of_int ~size:64 0x2000) @@ -60,7 +60,7 @@ let%expect_test "lift 2x: mov x1, #0xabcd" = |}] let%expect_test "lift: b.eq #1024" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_opcode @@ -90,7 +90,7 @@ let%expect_test "lift: b.eq #1024" = |}] let%expect_test "lift: b #16" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_opcode diff --git a/test/transforms/test_aslp_ibi.ml b/test/transforms/test_aslp_ibi.ml index 7469cb14..6d26a0e5 100644 --- a/test/transforms/test_aslp_ibi.ml +++ b/test/transforms/test_aslp_ibi.ml @@ -3,7 +3,7 @@ open Common open Transforms.Aslp let%expect_test "nested diamonds" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in I.bincaml_set_address (Bitvec.of_int ~size:64 0xbadbadbad000); let branch1 = I.f_gen_branch (I.f_gen_bool_lit true) in From 51d827ff3e17441b05222ec7134ed52224b35739 Mon Sep 17 00:00:00 2001 From: agle Date: Mon, 29 Jun 2026 16:01:51 +1000 Subject: [PATCH 08/22] fix some tests --- lib/analysis/ide_live.ml | 6 +++--- lib/analysis/wp_dual.ml | 9 +++------ lib/lang/interp.ml | 15 ++++++++++---- lib/lang/procedure.ml | 6 +++--- lib/loadir.ml | 37 +++++++++++++++++++++++++--------- lib/transforms/gamma_vars.ml | 2 +- test/analysis/test_ide_live.ml | 3 +++ test/cram/chc_mem_call.il | 2 +- test/cram/concat.il | 2 +- test/cram/expr_smt.t | 5 ++--- test/cram/memassign.il | 4 ++-- test/transforms/test_aslp.ml | 8 ++++---- 12 files changed, 61 insertions(+), 38 deletions(-) diff --git a/lib/analysis/ide_live.ml b/lib/analysis/ide_live.ml index 565c69d3..2241f522 100644 --- a/lib/analysis/ide_live.ml +++ b/lib/analysis/ide_live.ml @@ -330,11 +330,11 @@ proc @fun2(f:bv64, global_in:bv64) -> (out2:bv64) { } {| @fun2 (L,L->IdEdge), (L,f->ConstEdge true), (L,f_2->ConstEdge true), (L,f_1->ConstEdge true), (out2,global_in->IdEdge), (out2,out2->IdEdge), (out2,global_1->IdEdge), (out2,g_2->IdEdge), (out2,g_1->IdEdge), (out2,f_3->IdEdge), (out2,g_3->IdEdge) - global_in, f, out2, global_1, f_2, g_2, f_1, g_1, f_3, g_3 + f, global_in, out2, global_1, f_2, g_2, f_1, g_1, f_3, g_3 @main (L,L->IdEdge), (L,b->ConstEdge true), (L,global_in->ConstEdge true), (L,y->ConstEdge true), (L,global_1->ConstEdge true), (L,a->ConstEdge true), (L,x->ConstEdge true), (L,b_1->ConstEdge true), (L,x_1->ConstEdge true), (L,y_1->ConstEdge true) b, global_in, y, global_1, a, x, b_1, x_1, y_1 @fun1 - (L,L->IdEdge), (L,d->ConstEdge true), (out,global_in->IdEdge), (out,c->IdEdge), (out,out->IdEdge), (out,global_1->IdEdge), (out,e->IdEdge) - global_in, c, d, out, global_1, e + (L,L->IdEdge), (L,d->ConstEdge true), (out,c->IdEdge), (out,global_in->IdEdge), (out,out->IdEdge), (out,global_1->IdEdge), (out,e->IdEdge) + c, d, global_in, out, global_1, e |}] diff --git a/lib/analysis/wp_dual.ml b/lib/analysis/wp_dual.ml index 8f0e094c..b5d5d99c 100644 --- a/lib/analysis/wp_dual.ml +++ b/lib/analysis/wp_dual.ml @@ -178,6 +178,8 @@ let%expect_test "wp_dual" = let prog = (Loader.Loadir.ast_of_string {| +var $x:bv64; + prog entry @main; proc @main () -> () [ @@ -212,9 +214,4 @@ proc @main () -> () IntraAnalysis.A.M.find Procedure.Vert.Entry res |> IntraDomain.to_pred |> BasilExpr.to_string |> print_endline; [%expect - {| - Warn: global undeclared $x assuming mutable unshared - Warn: global undeclared $x assuming mutable unshared - Warn: global undeclared $x assuming mutable unshared - true - |}] + {| true |}] diff --git a/lib/lang/interp.ml b/lib/lang/interp.ml index afe06837..df133d2c 100644 --- a/lib/lang/interp.ml +++ b/lib/lang/interp.ml @@ -420,6 +420,11 @@ module IState = struct exception InterpreterError of (t * string) + let () = + Printexc.register_printer (function + | InterpreterError (_, msg) -> Some ("InterpreterError: " ^ msg) + | _ -> None) + let tick st = match st.fuel with | None -> st @@ -545,7 +550,11 @@ module IState = struct | _ -> failwith "unsupported memory type" let lookup_memory v st = - if Var.is_global v then VarMap.find v st.memories + if Var.is_global v then + VarMap.find_opt v st.memories + |> Option.get_exn_or + ("no memory found : " ^ Var.show v ^ " in " + ^ Iter.to_string Var.show (VarMap.keys st.memories)) else failwith "unsupported" let write_var var value st = @@ -654,9 +663,7 @@ module IState = struct | Stmt.Instr_IndirectCall _ -> failwith "unsupported" and eval_stmt (stmt : Program.stmt) (st : t) = - try eval_stmt_unsafe stmt st with - | AssumeFail _ as e -> raise e - | e -> raise (InterpreterError (st, Printexc.to_string e)) + try eval_stmt_unsafe stmt st with AssumeFail _ as e -> raise e and exec_edge st e = let b, l, e = e in diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index d2858177..cca82a06 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -476,20 +476,20 @@ let var_generator p = g let get_local p ?(pure = false) name typ : Var.t = - let access = if pure then Var.Const else Var.None in + let access = Var.None in let v = (var_generator p).with_name name ~access typ in Hashtbl.replace (local_decls p) (Var.name v) v; v let decl_local p ?(pure = false) name typ : Var.t = - let access = if pure then Var.Const else Var.None in + let access = Var.None in let v = (var_generator p).create_exn name ~access typ in Hashtbl.replace (local_decls p) (Var.name v) v; v let fresh_var p ?(pure = false) ?name typ : Var.t = let name = Option.map (String.drop_while (Char.equal '$')) name in - let access = if pure then Var.Const else Var.None in + let access = Var.None in let name = Option.get_or ~default:"v" name in let v = (var_generator p).fresh ~name typ ~access in Hashtbl.replace (local_decls p) (Var.name v) v; diff --git a/lib/loadir.ml b/lib/loadir.ml index c9b954eb..2d1858f2 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -244,17 +244,20 @@ module BasilASTLoader = struct prog | Decl_FunNoType (glident, _, _) -> prog | Decl_Fun (glident, params, _, typ, _) -> + let local_id_gen = Some (ID.make_gen ()) in + let prog = { prog with local_id_gen } in let bound = unpac_lambdaparen ~bound:StringMap.empty prog params in let arg_types = List.map Var.typ bound in let rtype = Types.curry arg_types (trans_type typ) in let name = unsafe_unsigil (`Global glident) in - let vg = Program.var_generator prog.prog in let fundef : Program.declaration = Function { attrib = StringMap.empty; - var_gen = Var.mk_gen (); - binding = vg.with_name name ~access:Const rtype; + var_gen = local_var_gen prog; + binding = + (Program.var_generator prog.prog).with_name name ~access:Const + rtype; definition = Uninterpreted; } in @@ -263,15 +266,18 @@ module BasilASTLoader = struct let p = Program.add_decl prog fundef in p) prog + |> fun p -> { p with local_id_gen = None } | Decl_Axiom (name, _, _) -> let name = unsafe_unsigil (`Global name) in + let local_id_gen = Some (ID.make_gen ()) in + let prog = { prog with local_id_gen } in let fundef : Program.declaration = let vg = Program.var_generator prog.prog in let bvar = vg.with_name name ~access:Const Boolean in Function { attrib = StringMap.empty; - var_gen = Var.mk_gen (); + var_gen = local_var_gen prog; binding = bvar; definition = Uninterpreted; } @@ -324,6 +330,8 @@ module BasilASTLoader = struct (** desugar let definition function *) and create_fun prog glident args attrList typ body = + let v = ID.make_gen () in + let prog = { prog with local_id_gen = Some v } in let bound = unpac_lambdaparen ~bound:StringMap.empty prog args in let definition : Program.func_type = match body with @@ -912,12 +920,11 @@ module BasilASTLoader = struct and unpack_local_lvars ?(bound = StringMap.empty) p_st const lvs : Var.t list = - let scope = if const then Var.Const else Var.None in + (* let scope = if const then Var.Const else Var.None in*) lvs |> List.map (function | LocalTyped (i, t) -> - Procedure.get_local - (p_st.curr_proc |> Option.get_exn_or "no current proc") + (local_var_gen p_st).with_name (unsafe_unsigil (`Local i)) (trans_type t) | LocalUntyped i -> lookup_local_decl ~binds:bound i p_st) @@ -940,7 +947,12 @@ module BasilASTLoader = struct match Var.is_global v with | true when Var.is_const v -> failwith "assign to global const" | true -> (map_curr_proc (fun p -> write_global p v) prog, v) - | false -> (prog, v) + | false -> + ignore + @@ Option.map + (fun proc -> Procedure.get_local proc (Var.name v) (Var.typ v)) + prog.curr_proc; + (prog, v) and loc_lvar (x : BasilIR.AbsBasilIR.lVar) : Attrib.attrib_map = let l = @@ -1619,7 +1631,9 @@ let load_single_block_proc ?(proc = "") ?input lexbuf = Procedure.G.add_edge g (End bid) Return) proc in - let bl = Procedure.get_block proc bid |> Option.get_exn_or "no current proc" in + let bl = + Procedure.get_block proc bid |> Option.get_exn_or "no current proc" + in let inparam = Block.free_vars bl |> VarSet.filter Var.is_local |> VarSet.to_list |> List.map (fun x -> (Var.name x, x)) @@ -1872,6 +1886,8 @@ proc @c() -> () ]; |} in + print_endline "globals: "; + print_endline (Program.global_vars prog.prog |> Iter.to_string Var.show); let res = analyse prog.prog in Iter.iter (fun (pid, proc) -> @@ -1890,7 +1906,7 @@ proc @c() -> () written: $mem:(bv64->bv8) |}] -let%test_unit "parses parenthesised lambda param" = +let%expect_test "parses parenthesised lambda param" = let s = {| let $memory_load32_le : (bv64 -> bv8) -> bv64 -> bv32 = fun (#memory: bv64 -> bv8), (#index: bv64) :: @@ -1900,6 +1916,7 @@ let%test_unit "parses parenthesised lambda param" = load_le(8, #memory, #index))))); |} in + Printexc.record_backtrace true; let _ = ast_of_string ~__LINE__ ~__FILE__ ~__FUNCTION__ s in () diff --git a/lib/transforms/gamma_vars.ml b/lib/transforms/gamma_vars.ml index a52cd2f3..82388c2a 100644 --- a/lib/transforms/gamma_vars.ml +++ b/lib/transforms/gamma_vars.ml @@ -38,7 +38,7 @@ let transform_proc ?(check_names = false) (add : ID.t -> Var.t -> bool) prog in added := VarSet.add v !added; v) - else Procedure.fresh_var proc ~name typ + else Procedure.get_local proc name typ in v in diff --git a/test/analysis/test_ide_live.ml b/test/analysis/test_ide_live.ml index 020bacb7..ecd74b1d 100644 --- a/test/analysis/test_ide_live.ml +++ b/test/analysis/test_ide_live.ml @@ -12,6 +12,9 @@ let%expect_test "intra_checks" = Loader.Loadir.ast_of_string {| memory shared $mem : (bv64 -> bv8); +var $x: bv64; +var $y: bv64; +var $z: bv64; prog entry @main; diff --git a/test/cram/chc_mem_call.il b/test/cram/chc_mem_call.il index b7fbf2cd..bc0cacfa 100644 --- a/test/cram/chc_mem_call.il +++ b/test/cram/chc_mem_call.il @@ -29,7 +29,7 @@ proc @foo() -> () proc @main() -> () [ block %entry [ - $mem := store le $mem 0x100:bv64 secret:bv8 8; + $mem := store le $mem 0x100:bv64 $secret:bv8 8; call @foo (); var v:bv8 := load le $mem 0x100:bv64 8; assert eq(v:bv8, bvadd($secret, 5:bv8)); diff --git a/test/cram/concat.il b/test/cram/concat.il index c8808267..78b757c1 100644 --- a/test/cram/concat.il +++ b/test/cram/concat.il @@ -2,7 +2,7 @@ var $R28:bv64; var $R0:bv64; var $R30:bv64; -var $__BranchTaken; +var $__BranchTaken:bv1; prog entry @main_4204352; proc @main_4204352() -> () [ diff --git a/test/cram/expr_smt.t b/test/cram/expr_smt.t index ad6416f5..dd7506ef 100644 --- a/test/cram/expr_smt.t +++ b/test/cram/expr_smt.t @@ -6,7 +6,6 @@ Should output no errors (load-il ../../examples/cntlm-output.il) (run-transforms cf-expressions-smtcheck) (load-il concat.il) - Warn: global undeclared $__BranchTaken assuming mutable unshared (dump-il before.il) (run-transforms cf-expressions-smtcheck) (dump-il after.il) @@ -14,7 +13,7 @@ Should output no errors Check concat rewrites work $ diff before.il after.il - 16,82c16,18 + 17,83c17,19 < $R28:bv64 := bvor(bvand(bvconcat(extract(1,0, bvlshr(var1_4206396_bv64:bv64, < 0x1f:bv64)), extract(1,0, bvlshr(var1_4206396_bv64:bv64, 0x1f:bv64)), < extract(1,0, bvlshr(var1_4206396_bv64:bv64, 0x1f:bv64)), @@ -86,7 +85,7 @@ Check concat rewrites work > $R28:bv64 := bvor(bvand(sign_extend(63, > extract(32,31, var1_4206396_bv64:bv64)), 0xffffffff00000000:bv64), > bvand(var1_4206396_bv64:bv64, 0xffffffff:bv64, 0xffffffff:bv64)); - 87,88c23 + 88,89c24 < $R0:bv64 := bvor(var1_4206400_bv64:bv64, < bvshl(var2_4206400_bv64:bv64, 0x0:bv64)); --- diff --git a/test/cram/memassign.il b/test/cram/memassign.il index cdf0bef6..1b4bf67d 100644 --- a/test/cram/memassign.il +++ b/test/cram/memassign.il @@ -11,10 +11,10 @@ type record = Record of {a : bv64; b: bv32; c:bv64}; type ilist = Cons of {head:bv64; tail:ilist} | Nil ; -let $a = UninterpSort; +let $a = $UninterpSort; -let $b = Record {a=1:bv64; b=2:bv64; c=3:bv64}; +let $b = $Record (1:bv64, 2:bv64, 3:bv64); let $mul_2 (a:bv64), (b:bv64) : bv64 = bvadd(b, bvmul(a, 2:bv64)); let $three = let func (a:bv64) : bv64 = bvadd(a, 1:bv64) in func($mul_2(2:bv64, 1:bv64)); diff --git a/test/transforms/test_aslp.ml b/test/transforms/test_aslp.ml index ea67e5f2..f404e8a7 100644 --- a/test/transforms/test_aslp.ml +++ b/test/transforms/test_aslp.ml @@ -27,8 +27,8 @@ let%expect_test "lift: add x1, x2, x3, lsl #4" = (Leaf { Aslp_state.assume = true; stmts = - [var var_0:bv64 := $R2; var var_1:bv64 := $R3; - $R1:bv64 := bvadd(var_0:bv64, bvshl(var_1:bv64, 0x4:bv12)); + [var v:bv64 := $R2; var v_1:bv64 := $R3; + $R1:bv64 := bvadd(v:bv64, bvshl(v_1:bv64, 0x4:bv12)); (var BranchTaken:bool := false, $PC:bv64 := 0x2004:bv64)]; pc_assign = (Some 0x2004:bv64) }) |}] @@ -104,8 +104,8 @@ let%expect_test "lift: b #16" = (Leaf { Aslp_state.assume = true; stmts = - [var var_0:bv64 := $R2; var var_1:bv64 := $R3; - $R1:bv64 := bvadd(var_0:bv64, bvshl(var_1:bv64, 0x4:bv12)); + [var v:bv64 := $R2; var v_1:bv64 := $R3; + $R1:bv64 := bvadd(v:bv64, bvshl(v_1:bv64, 0x4:bv12)); (var BranchTaken:bool := false, $PC:bv64 := 0x2004:bv64)]; pc_assign = (Some 0x2004:bv64) }) |}] From b98c078a07e9cec8514275d1acdf82777166ed0d Mon Sep 17 00:00:00 2001 From: agle Date: Tue, 30 Jun 2026 14:41:35 +1000 Subject: [PATCH 09/22] fixes for boogie gen --- lib/backends/boogie.ml | 2 +- lib/lang/dune | 1 + lib/lang/expr.ml | 11 ++++++ lib/lang/program.ml | 7 ++++ lib/lang/spec_modifies.ml | 18 ++++++--- lib/loadir.ml | 12 ++++-- lib/transforms/boogie_prepass.ml | 52 +++++++++++++++++++++++--- lib/transforms/memory_encoding.ml | 4 +- lib/transforms/memory_specification.ml | 2 +- lib/util/var.ml | 12 +++--- test/analysis/test_ide_live.ml | 15 ++++---- test/cram/expr_smt.t | 5 +++ test/cram/malloc_free.t | 3 -- 13 files changed, 109 insertions(+), 35 deletions(-) diff --git a/lib/backends/boogie.ml b/lib/backends/boogie.ml index f7fb2d34..f7a497f4 100644 --- a/lib/backends/boogie.ml +++ b/lib/backends/boogie.ml @@ -176,7 +176,7 @@ let pretty_apply_intrinsic (op : Ops.AllOps.intrin) match args with | [ (ty1, arg1); (ty2, arg2) ] -> ( match Transforms.Boogie_prepass.Builtins.name op [ ty1; ty2; t ] with - | Function name -> text name ^ pretty_call_args [ arg1; arg2 ] + | Function name -> text "$" ^ text name ^ pretty_call_args [ arg1; arg2 ] | Infix name -> bracket "(" (arg1 ^+ text name ^+ arg2) ")" | _ -> failwith "Unsupported binary-reduced intrinsic expr ") | _ -> diff --git a/lib/lang/dune b/lib/lang/dune index e2cd189a..063af74f 100644 --- a/lib/lang/dune +++ b/lib/lang/dune @@ -2,6 +2,7 @@ (public_name bincaml.ast) (name lang) (modules + rewrite abstract_expr attrib spec_modifies diff --git a/lib/lang/expr.ml b/lib/lang/expr.ml index 0bfc1223..879866f5 100644 --- a/lib/lang/expr.ml +++ b/lib/lang/expr.ml @@ -469,6 +469,17 @@ module BasilExpr = struct (** substitute subexpression sbased on parameter *) let rewrite ?visit ~(rw_fun : t abstract_expr -> rewrite) (expr : t) = + let rw_alg e = + let orig s = fix s in + match rw_fun e with + | SomeInfo { v; __LINE__; __FILE__ } -> + log_rw visit ~__LINE__ ~__FILE__ (fix e) v + | Keep -> orig e + in + cata rw_alg expr + + (** substitute subexpression sbased on parameter *) + let rewrite_checktype ?visit ~(rw_fun : t abstract_expr -> rewrite) (expr : t) = let rw_alg e = let orig s = fix s in match rw_fun e with diff --git a/lib/lang/program.ml b/lib/lang/program.ml index 62638f78..27de81e5 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -62,6 +62,12 @@ let decl_id = function | Function { binding } -> Var.id binding | Procedure { definition } -> Procedure.id definition +let decl_var = function + | Variable { binding } -> Some binding + | Function { binding } -> Some binding + | _ -> None + + let pretty_proc p = let show_lvar v = Containers_pp.text @@ Var.to_string_il_lvar v in let show_var v = Containers_pp.text @@ Var.to_string_il_rvar v in @@ -326,6 +332,7 @@ let add_var_decl p ?(attrib = Attrib.empty) ?classification v = p.declarations; } + let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name access_tag typ = let vg = var_generator p in diff --git a/lib/lang/spec_modifies.ml b/lib/lang/spec_modifies.ml index 6915583d..94c273bb 100644 --- a/lib/lang/spec_modifies.ml +++ b/lib/lang/spec_modifies.ml @@ -5,6 +5,7 @@ open Common module RWSets = struct type property = VarSet.t * VarSet.t [@@deriving eq, ord] + (** (read, written) *) let bottom = (VarSet.empty, VarSet.empty) let equal = equal_property @@ -26,9 +27,17 @@ end module FixProp = Fix.Fix.ForOrderedType (ID) (RWSets) -let solve (prog : Program.t) = +let solve ?(add_existing = false) (prog : Program.t) = let local_rw (p : ID.t) (valuations : FixProp.valuation) = let p = Program.proc prog p in + let spec_read = + if not add_existing then VarSet.empty + else VarSet.of_list (Procedure.specification p).captures_globs + in + let spec_write = + if not add_existing then VarSet.empty + else VarSet.of_list (Procedure.specification p).modifies_globs + in let read, written = match Procedure.graph p with | Some _ -> @@ -48,8 +57,7 @@ let solve (prog : Program.t) = | _ -> None) in Iter.cons local calls |> Iter.fold RWSets.leq_join a) - (VarSet.empty, VarSet.empty) - p + (spec_read, spec_write) p | None -> let globs = Program.global_vars prog |> VarSet.of_iter in (globs, globs) @@ -59,7 +67,7 @@ let solve (prog : Program.t) = FixProp.lfp local_rw let set_modsets ?(add_only = false) prog = - let rwset = solve prog in + let rwset = solve ~add_existing:false prog in prog |> Program.map_procedures (fun i p -> let read, written = rwset i in @@ -91,4 +99,4 @@ let set_modsets ?(add_only = false) prog = let spec = { spec with captures_globs; modifies_globs } in Procedure.set_specification p spec) -let analyse prog = solve prog +let analyse prog = solve ~add_existing:false prog diff --git a/lib/loadir.ml b/lib/loadir.ml index 2d1858f2..3c42f75d 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -172,8 +172,8 @@ module BasilASTLoader = struct map_prog (fun prog -> Spec_modifies.set_modsets ~add_only:true prog) prog and var_modifiers_shared (m : varModifiers list) = - if not @@ List.exists (function Shared | Observable -> true) m then Var.None - else Var.Shared + if List.exists (function Shared | Observable -> true) m then Var.Shared + else Var.None and trans_varspec prog (v : varSpec) = let trans_one v = @@ -1217,7 +1217,8 @@ module BasilASTLoader = struct failwith ("Invalid type constuctor name: " ^ g ^ " must start with lowercase.") - | `Global (GlobalIdent (pos, g)) -> g + | `Global (GlobalIdent (pos, g)) -> + String.chop_prefix ~pre:"$" g |> Option.get_or ~default:g | `Local (LocalIdent (pos, g)) -> g | `Proc (ProcIdent (pos, g)) -> g | `Block (BlockIdent (pos, g)) -> g @@ -1895,6 +1896,11 @@ proc @c() -> () (Program.procs prog.prog); [%expect {| + globals: + { Var.name = ("$R0", 0); scope = (Var.Global "23"); typ = bv64; + tags = Var.None }, { Var.name = ("$R1", 1); scope = (Var.Global "23"); typ = bv64; + tags = Var.None }, { Var.name = ("$mem", 2); scope = (Var.Global "23"); typ = (bv64->bv8); + tags = Var.Shared } @entry: read: $R0:bv64,$R1:bv64,$mem:(bv64->bv8) written: $R0:bv64,$mem:(bv64->bv8) diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index b0f59b65..74f2a27f 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -63,8 +63,8 @@ module Builtins = struct | `BVNEG -> "bvneg" | `ZeroExtend sz -> Printf.sprintf "zero_extend %d" sz | `SignExtend sz -> Printf.sprintf "sign_extend %d" sz - | `Load (`Big, i) -> Printf.sprintf "load%d_be" i - | `Load (`Little, i) -> Printf.sprintf "load%d_le" i + | `Load (`Big, i) -> Printf.sprintf "$load%d_be" i + | `Load (`Little, i) -> Printf.sprintf "$load%d_le" i (** Returns the monomorphized builtin name *) let monomorphize_builtin (op : builtin) targs = @@ -182,6 +182,44 @@ module Builtins = struct let used_ops (p : Program.t) = Iter.from_iter (fun f -> iprog f p) |> Iter.sort_uniq + + let expr_ops vargen (e : Types.t Expr.BasilExpr.abstract_expr) = + let open Expr.AbstractExpr in + let open Ops.AllOps in + let get_ty (op : [ unary | binary | intrin ]) o = + match o with + | Fun { ret; args } -> + Some (function_for_op vargen op args ret) + | _ -> None + in + match e with + | UnaryExpr { op = #unary as op; arg; _ } -> + ret_type_unary op arg |> get_ty op + | BinaryExpr { op = #binary as op; arg1 = l; arg2 = r; _ } -> + ret_type_bin op l r |> get_ty op + | ApplyIntrin { op = #intrin as op; args; _ } -> + ret_type_intrin op args |> get_ty op + | _ -> None + + let transform_builtin_decls (p : Program.t) : Program.t = + let v = Program.var_generator p in + let bvop_alg : (Program.e * Types.t) Expr.BasilExpr.abstract_expr -> + Program.e option += fun e -> + let open Expr.AbstractExpr in + let types = map snd e in + let ex = map fst e in + match ex with + | ApplyIntrin {op=`BVConcat | `AND | `OR | `Cases | `MapUpdate } -> None + | ApplyIntrin {op; args} -> (match expr_ops v types with + | Some (func) -> Some (Expr.BasilExpr.apply_fun ~func:(Expr.BasilExpr.rvar func) (args)) + | None -> None) + | _ -> None + in + let rw_expr ?visit (e: Expr.BasilExpr.t) = Expr.BasilExpr.rewrite_typed bvop_alg e in + Lang.Rewrite.rewrite_prog_exprs rw_expr p + + let transform_add_builtin_decls (p : Program.t) : Program.t = used_ops p |> Iter.filter_map (function op, args, ret -> @@ -320,7 +358,7 @@ module Instructions = struct var_gen ; binding = global_vargen.with_name ~access:Var.Const - (Printf.sprintf "store%d_%s" size + (Printf.sprintf "$store%d_%s" size (Lang.Stmt.show_endian endian)) (Lang.Expr.BasilExpr.type_of value); definition = Lang.Program.Function body; @@ -347,7 +385,7 @@ module Instructions = struct var_gen; binding = global_vargen.with_name ~access:Var.Const - (Printf.sprintf "load%d_%s" size (Stmt.show_endian endian)) + (Printf.sprintf "$load%d_%s" size (Stmt.show_endian endian)) (Var.typ lhs); definition = Function body; } @@ -386,6 +424,7 @@ module Normalise = struct (* function application in boogie becomes a map access when on lambdas (identified by local vars) *) | ApplyFun { func; args } -> ( match unfix func with + | RVar { attrib; id } when Var.is_local id -> failwith ( "is local var: " ^ Var.show id) | RVar { attrib; id } when Var.is_global id -> replace [%here] (BasilExpr.apply_fun ~attrib @@ -427,7 +466,7 @@ module Normalise = struct Instr_Assign { al = [ (lhs, value) ]; attrib } | Instr_Load { lhs; rhs; addr = Addr { addr; size; endian }; attrib } -> let fn_name = - Printf.sprintf "load%d_%s" size (Stmt.show_endian endian) + Printf.sprintf "$load%d_%s" size (Stmt.show_endian endian) in Instr_Assign { @@ -444,7 +483,7 @@ module Normalise = struct | Instr_Store { lhs; rhs; value; addr = Addr { addr; size; endian }; attrib } -> let fn_name = - Printf.sprintf "store%d_%s" size (Stmt.show_endian endian) + Printf.sprintf "$store%d_%s" size (Stmt.show_endian endian) in Stmt.Instr_Assign { @@ -522,3 +561,4 @@ let transform (p : Program.t) = p |> Normalise.replace_functions |> Normalise.replace_exprs |> Instructions.transform_add_store_load_decls |> Normalise.replace_stmts |> Builtins.transform_add_builtin_decls + |> Builtins.transform_builtin_decls diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index d6d47ca7..fac2e255 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -868,7 +868,7 @@ let split_transform (p : Program.t) = end in let module E = MemoryEncoder (SplitMemory (I)) in - E.transform p + E.transform p |> fun prog -> Spec_modifies.set_modsets ~add_only:true prog let flat_transform (p : Program.t) = let module I : IDAllocs = struct @@ -876,4 +876,4 @@ let flat_transform (p : Program.t) = end in let module E = MemoryEncoder (FlatMemory (I)) in - E.transform p + E.transform p |> fun prog -> Spec_modifies.set_modsets ~add_only:true prog diff --git a/lib/transforms/memory_specification.ml b/lib/transforms/memory_specification.ml index 8da5f742..94b3862a 100644 --- a/lib/transforms/memory_specification.ml +++ b/lib/transforms/memory_specification.ml @@ -180,7 +180,7 @@ end let transform_proc prog entry _ (p : Program.proc) = let module TR = T (struct - let global_ids = Var.mk_gen ~id_generator:(Program.global_ids prog) () + let global_ids = Program.var_generator prog end) in let open TR in let p = diff --git a/lib/util/var.ml b/lib/util/var.ml index c5d22a8f..a6bbed0a 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -19,15 +19,15 @@ let copy ?name ?scope ?typ (v : t) = } *) let to_int (v : t) = ID.index v.name -let name (e : t) = ID.name @@ e.name let id v = v.name let tags (e : t) = e.tags let typ (e : t) = e.typ +let is_local (v : t) = match v.scope with Local _ -> true | Global _ -> false +let is_global (v : t) = match v.scope with Global _ -> true | Local _ -> false +let name (e : t) = if is_global e then "$" ^ ID.name e.name else ID.name e.name let to_string v = name v ^ ":" ^ Types.to_string @@ typ v let pp fmt v = Format.pp_print_string fmt (to_string v) let pretty v = Containers_pp.text (to_string v) -let is_local (v : t) = match v.scope with Local _ -> true | Global _ -> false -let is_global (v : t) = not (is_local v) let is_const (v : t) = match v.tags with Const -> true | _ -> false let access (v : t) = v.tags let is_shared (v : t) = match v.tags with Shared -> true | _ -> false @@ -65,7 +65,7 @@ type ('t, 'a, 'g) any_gen = { open struct let force_sigil sigil s : string = - if String.starts_with ~prefix:sigil s then s else sigil ^ s + match String.chop_prefix ~pre:sigil s with Some s -> s | None -> s let create name id_gen ?(access = None) typ = (* disallow creating local const as its too hard to have declaration order *) @@ -92,8 +92,8 @@ let mk_gen ?id_generator ?(req_sigil = Option.None) ?(scope = `Local) let id_gen = Option.get_or ~default:(ID.make_gen ()) id_generator in let gt = match scope with - | `Local -> Local id_gen.gen_id - | `Global -> Global id_gen.gen_id + | `Local -> Local "" + | `Global -> Global "" in let sgl = match (req_sigil, scope) with diff --git a/test/analysis/test_ide_live.ml b/test/analysis/test_ide_live.ml index ecd74b1d..fb2c2ce5 100644 --- a/test/analysis/test_ide_live.ml +++ b/test/analysis/test_ide_live.ml @@ -47,17 +47,16 @@ proc @main (a:bv64, b:bv64, c:bv64, d:bv64, e:bv64) -> () print_lives results main; [%expect {| - Warn: global undeclared $x assuming mutable unshared - Warn: global undeclared $y assuming mutable unshared - Warn: global undeclared $z assuming mutable unshared @main $mem:(bv64->bv8) a:bv64 + $x:bv64 b:bv64 + $y:bv64 c:bv64 + $z:bv64 d:bv64 e:bv64 - $x:bv64 |}] let%expect_test "phi_loop" = @@ -192,13 +191,13 @@ proc @fun2 (f:bv64) -> (out2:bv64) [%expect {| @main + $global:bv64 b:bv64 y:bv64 - $global:bv64 @fun1 + $global:bv64 c:bv64 d:bv64 - $global:bv64 @fun2 $global:bv64 f:bv64 @@ -259,13 +258,13 @@ proc @fun2 (f:bv64) -> (out2:bv64) [%expect {| @main + $global:bv64 b:bv64 y:bv64 - $global:bv64 @fun1 + $global:bv64 c:bv64 d:bv64 - $global:bv64 @fun2 $global:bv64 f:bv64 diff --git a/test/cram/expr_smt.t b/test/cram/expr_smt.t index dd7506ef..155be2bb 100644 --- a/test/cram/expr_smt.t +++ b/test/cram/expr_smt.t @@ -90,4 +90,9 @@ Check concat rewrites work < bvshl(var2_4206400_bv64:bv64, 0x0:bv64)); --- > $R0:bv64 := bvor(var1_4206400_bv64:bv64, var2_4206400_bv64:bv64); + 95a31,34 + > var $R28:bv64; + > var $R0:bv64; + > var $R30:bv64; + > var $__BranchTaken:bv1; [1] diff --git a/test/cram/malloc_free.t b/test/cram/malloc_free.t index e89c58a2..9e7cd9a8 100644 --- a/test/cram/malloc_free.t +++ b/test/cram/malloc_free.t @@ -476,9 +476,6 @@ ) == 1bv2); -<<<<<<< HEAD -======= ->>>>>>> origin/main $ boogie ./bad.bpl Memory Error: Invalid Access From 3352af87eac90ddd838837e8dec90380a14757e6 Mon Sep 17 00:00:00 2001 From: agle Date: Tue, 30 Jun 2026 14:43:07 +1000 Subject: [PATCH 10/22] fixes for boogie gen 2 --- lib/analysis/wp_dual.ml | 3 +- lib/backends/boogie.ml | 3 +- lib/lang/check.ml | 1 + lib/lang/expr.ml | 3 +- lib/lang/expr_smt.ml | 15 ++--- lib/lang/program.ml | 2 - lib/lang/rewrite.ml | 74 +++++++++++++++++++++++++ lib/loadir.ml | 6 +- lib/transforms/aslp/aslp_lexpr.ml | 4 +- lib/transforms/aslp/aslp_state.ml | 1 - lib/transforms/aslp/bincaml_ibi_make.ml | 8 ++- lib/transforms/boogie_prepass.ml | 9 ++- lib/transforms/chc_infer.ml | 8 ++- lib/transforms/may_read_uninit.ml | 14 ++--- lib/transforms/memory_encoding.ml | 18 +++--- lib/util/var.ml | 6 +- 16 files changed, 125 insertions(+), 50 deletions(-) create mode 100644 lib/lang/rewrite.ml diff --git a/lib/analysis/wp_dual.ml b/lib/analysis/wp_dual.ml index b5d5d99c..8954b98d 100644 --- a/lib/analysis/wp_dual.ml +++ b/lib/analysis/wp_dual.ml @@ -213,5 +213,4 @@ proc @main () -> () in IntraAnalysis.A.M.find Procedure.Vert.Entry res |> IntraDomain.to_pred |> BasilExpr.to_string |> print_endline; - [%expect - {| true |}] + [%expect {| true |}] diff --git a/lib/backends/boogie.ml b/lib/backends/boogie.ml index f7a497f4..1c4bd361 100644 --- a/lib/backends/boogie.ml +++ b/lib/backends/boogie.ml @@ -176,7 +176,8 @@ let pretty_apply_intrinsic (op : Ops.AllOps.intrin) match args with | [ (ty1, arg1); (ty2, arg2) ] -> ( match Transforms.Boogie_prepass.Builtins.name op [ ty1; ty2; t ] with - | Function name -> text "$" ^ text name ^ pretty_call_args [ arg1; arg2 ] + | Function name -> + text "$" ^ text name ^ pretty_call_args [ arg1; arg2 ] | Infix name -> bracket "(" (arg1 ^+ text name ^+ arg2) ")" | _ -> failwith "Unsupported binary-reduced intrinsic expr ") | _ -> diff --git a/lib/lang/check.ml b/lib/lang/check.ml index 2b2e2765..ac7bfb68 100644 --- a/lib/lang/check.ml +++ b/lib/lang/check.ml @@ -54,6 +54,7 @@ let variables_wf p = ^ ID.to_string (Procedure.id p)))); if Var.is_global n + && (not (Var.is_const n)) && (not @@ List.exists (fun v -> Var.equal v n) spec.captures_globs) then raise diff --git a/lib/lang/expr.ml b/lib/lang/expr.ml index 879866f5..44562389 100644 --- a/lib/lang/expr.ml +++ b/lib/lang/expr.ml @@ -479,7 +479,8 @@ module BasilExpr = struct cata rw_alg expr (** substitute subexpression sbased on parameter *) - let rewrite_checktype ?visit ~(rw_fun : t abstract_expr -> rewrite) (expr : t) = + let rewrite_checktype ?visit ~(rw_fun : t abstract_expr -> rewrite) (expr : t) + = let rw_alg e = let orig s = fix s in match rw_fun e with diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 573e3ca9..7021fa2e 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -202,23 +202,20 @@ module SMTLib2 = struct Some (Types.Map (k, v)) | _ -> None - let expr_of_smt ?(vargen: Var.generator option) vardefs (e : Sexp.t) = + let expr_of_smt ?(vargen : Var.generator option) vardefs (e : Sexp.t) = let open Option.Infix in let module T = List.Traverse (Option) in (* One generator for the whole decode. Reserve every Basil variable already in scope -- the free vars of the values of [vardefs] -- so the quantifier binders minted below stay disjoint from them. *) - let vargen = match vargen with - | Some v -> v - | None -> Var.mk_gen () - in + let vargen = match vargen with Some v -> v | None -> Var.mk_gen () in StringMap.iter (fun _ e -> - BasilExpr.free_vars_iter e - (* reserve used names *) - |> Iter.iter (fun v -> ignore (vargen.with_name (Var.name v) (Var.typ v)))) + BasilExpr.free_vars_iter e (* reserve used names *) + |> Iter.iter (fun v -> + ignore (vargen.with_name (Var.name v) (Var.typ v)))) vardefs; - let fresh_var typ = vargen.fresh ~name:"x" typ in + let fresh_var typ = vargen.fresh ~name:"x" typ in (* Give each binder a fresh variable rather than reusing the name the solver chose. This accounts for names that are not valid identifiers (e.g., include [!]) and names that clash with existing variables. *) diff --git a/lib/lang/program.ml b/lib/lang/program.ml index 27de81e5..e777dbf8 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -67,7 +67,6 @@ let decl_var = function | Function { binding } -> Some binding | _ -> None - let pretty_proc p = let show_lvar v = Containers_pp.text @@ Var.to_string_il_lvar v in let show_var v = Containers_pp.text @@ Var.to_string_il_rvar v in @@ -332,7 +331,6 @@ let add_var_decl p ?(attrib = Attrib.empty) ?classification v = p.declarations; } - let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name access_tag typ = let vg = var_generator p in diff --git a/lib/lang/rewrite.ml b/lib/lang/rewrite.ml new file mode 100644 index 00000000..1a85c325 --- /dev/null +++ b/lib/lang/rewrite.ml @@ -0,0 +1,74 @@ +open Common + +let rewrite_proc_exprs ?visit + (rewriter : ?visit:'a -> Expr.BasilExpr.t -> Expr.BasilExpr.t) + (p : (Var.t, Expr.BasilExpr.t) Procedure.t) = + let open Procedure in + let simplify_proc_exprs p = + p + |> map_blocks_nondet (fun (i, b) -> + let b = + Block.map ~phi:Fun.id + (Stmt.map ~f_lvar:Fun.id ~f_rvar:Fun.id ~f_expr:(rewriter ?visit)) + b + in + b) + in + + let simplify_proc_spec_exprs p = + let s = specification p in + let s = + { + s with + requires = List.map (rewriter ?visit) s.requires; + ensures = List.map (rewriter ?visit) s.ensures; + rely = List.map (rewriter ?visit) s.rely; + guarantee = List.map (rewriter ?visit) s.guarantee; + } + in + set_specification p s + in + p |> simplify_proc_exprs |> simplify_proc_spec_exprs + +let rewrite_prog_exprs rewriter ?visit (p : Program.t) = + let open Program in + let simplify_prog_spec_exprs (p : t) = + map_procedures + (fun _ proc -> + (fun ?visit rewriter p -> + let s = Procedure.specification p in + let s = + { + s with + requires = List.map (rewriter ?visit) s.requires; + ensures = List.map (rewriter ?visit) s.ensures; + rely = List.map (rewriter ?visit) s.rely; + guarantee = List.map (rewriter ?visit) s.guarantee; + } + in + Procedure.set_specification p s) + rewriter ?visit proc) + p + in + + let simplify_decls p = + map_decls + (fun id -> + (function + | Function { binding; attrib; definition; var_gen } -> + let definition = + match definition with + | Axiom b -> + let rw = rewriter ?visit b in + Axiom rw + | Function b -> Function (rewriter ?visit b) + | Uninterpreted -> Uninterpreted + in + Function { binding; attrib; definition; var_gen } + | o -> o)) + p + in + p + |> Program.map_procedures (fun _ proc -> + rewrite_proc_exprs rewriter ?visit proc) + |> simplify_decls |> simplify_prog_spec_exprs diff --git a/lib/loadir.ml b/lib/loadir.ml index 3c42f75d..d1cb58ce 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -1897,9 +1897,9 @@ proc @c() -> () [%expect {| globals: - { Var.name = ("$R0", 0); scope = (Var.Global "23"); typ = bv64; - tags = Var.None }, { Var.name = ("$R1", 1); scope = (Var.Global "23"); typ = bv64; - tags = Var.None }, { Var.name = ("$mem", 2); scope = (Var.Global "23"); typ = (bv64->bv8); + { Var.name = ("R0", 0); scope = (Var.Global ""); typ = bv64; tags = Var.None + }, { Var.name = ("R1", 1); scope = (Var.Global ""); typ = bv64; tags = Var.None + }, { Var.name = ("mem", 2); scope = (Var.Global ""); typ = (bv64->bv8); tags = Var.Shared } @entry: read: $R0:bv64,$R1:bv64,$mem:(bv64->bv8) diff --git a/lib/transforms/aslp/aslp_lexpr.ml b/lib/transforms/aslp/aslp_lexpr.ml index fb217332..8b87720c 100644 --- a/lib/transforms/aslp/aslp_lexpr.ml +++ b/lib/transforms/aslp/aslp_lexpr.ml @@ -86,8 +86,8 @@ let empty_aslp_ids () = This will ensure that ASLp's local variable and block names do not clash with existing names. *) -let aslp_ids_from_generators ~local_var ~global_var = - { local_var ; global_var} +let aslp_ids_from_generators ~local_var ~global_var = { local_var; global_var } + let scope st = function | Local _ -> st.local_var | BranchTaken | BTypeCompatible | BTypeNext -> st.local_var diff --git a/lib/transforms/aslp/aslp_state.ml b/lib/transforms/aslp/aslp_state.ml index 048d061e..0640b350 100644 --- a/lib/transforms/aslp/aslp_state.ml +++ b/lib/transforms/aslp/aslp_state.ml @@ -77,7 +77,6 @@ let empty_lifter_state ~generator () = generator; } - (** {1 State manipulation functions} *) (** Appends the given statement to the given block. diff --git a/lib/transforms/aslp/bincaml_ibi_make.ml b/lib/transforms/aslp/bincaml_ibi_make.ml index 4353f946..8514ecee 100644 --- a/lib/transforms/aslp/bincaml_ibi_make.ml +++ b/lib/transforms/aslp/bincaml_ibi_make.ml @@ -253,13 +253,17 @@ struct let f_decl_bool : string -> lexpr = fun _ -> failwith "f_decl_bool" let f_gen_load : lexpr -> expr = - fun lhs -> Expr.BasilExpr.rvar (Aslp_lexpr.to_var !bincaml_lifter_state.generator lhs) + fun lhs -> + Expr.BasilExpr.rvar (Aslp_lexpr.to_var !bincaml_lifter_state.generator lhs) let f_gen_store : lexpr -> expr -> unit = fun lhs rhs -> bincaml_emit (Stmt.Instr_Assign - { attrib = Attrib.empty; al = [ (Aslp_lexpr.to_var !bincaml_lifter_state.generator lhs, rhs) ] }) + { + attrib = Attrib.empty; + al = [ (Aslp_lexpr.to_var !bincaml_lifter_state.generator lhs, rhs) ]; + }) let f_gen_array_load : lexpr -> bigint -> expr = fun array idx -> diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index 74f2a27f..99489cf6 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -189,7 +189,8 @@ module Builtins = struct let get_ty (op : [ unary | binary | intrin ]) o = match o with | Fun { ret; args } -> - Some (function_for_op vargen op args ret) + try Some (function_for_op vargen op args ret) with + | Failure _ -> None | _ -> None in match e with @@ -211,6 +212,10 @@ module Builtins = struct let ex = map fst e in match ex with | ApplyIntrin {op=`BVConcat | `AND | `OR | `Cases | `MapUpdate } -> None + | BinaryExpr {op ;arg1; arg2} -> + (match expr_ops v types with + | Some (func) -> Some (Expr.BasilExpr.apply_fun ~func:(Expr.BasilExpr.rvar func) ([arg1; arg2])) + | None -> None) | ApplyIntrin {op; args} -> (match expr_ops v types with | Some (func) -> Some (Expr.BasilExpr.apply_fun ~func:(Expr.BasilExpr.rvar func) (args)) | None -> None) @@ -424,7 +429,7 @@ module Normalise = struct (* function application in boogie becomes a map access when on lambdas (identified by local vars) *) | ApplyFun { func; args } -> ( match unfix func with - | RVar { attrib; id } when Var.is_local id -> failwith ( "is local var: " ^ Var.show id) + (*| RVar { attrib; id } when Var.is_local id -> failwith ( "is local var: " ^ Var.show id)*) | RVar { attrib; id } when Var.is_global id -> replace [%here] (BasilExpr.apply_fun ~attrib diff --git a/lib/transforms/chc_infer.ml b/lib/transforms/chc_infer.ml index 7211f46a..342692d5 100644 --- a/lib/transforms/chc_infer.ml +++ b/lib/transforms/chc_infer.ml @@ -126,17 +126,19 @@ module Encoder = struct mutable premises : Sexp.t list; mutable vars : VarSet.t; (** the clause binders for the eventual [forall] *) - vargen: Var.generator; + vargen : Var.generator; } let create ~initial_vars = let vargen = Var.mk_gen () in - List.iter (fun i -> ignore @@ vargen.with_name (Var.name i) (Var.typ i)) initial_vars ; + List.iter + (fun i -> ignore @@ vargen.with_name (Var.name i) (Var.typ i)) + initial_vars; { delta = VarMap.empty; premises = []; vars = VarSet.of_list initial_vars; - vargen ; + vargen; } let lookup t v = diff --git a/lib/transforms/may_read_uninit.ml b/lib/transforms/may_read_uninit.ml index ca7610a9..b8d49e1c 100644 --- a/lib/transforms/may_read_uninit.ml +++ b/lib/transforms/may_read_uninit.ml @@ -157,12 +157,10 @@ let%expect_test "fold_block" = in [%expect {| - Warn: global undeclared $stack assuming mutable unshared - Warn: global undeclared $mem assuming mutable unshared - (R31_in->RU, $stack->RU, R0_in->RU, _->⊥) - (R31_in->RU, $stack->RU, R0_in->RU, load45_1->W, _->⊥) - (R31_in->RU, $stack->RU, R0_in->RU, load45_1->W, R1_4->W, _->⊥) - (R31_in->RU, $stack->RU, R0_in->RU, load45_1->W, R1_4->W, $mem->RU, _->⊥) - (R31_in->RU, $stack->RU, R0_in->RU, load45_1->W, R1_4->W, $mem->RU, load46_1->W, _->⊥) - (R31_in->RU, $stack->RU, R0_in->RU, load45_1->W, R1_4->W, $mem->RU, load46_1->W, R0_10->W, _->⊥) + (R31_in->RU, R0_in->RU, _->⊥) + (R31_in->RU, R0_in->RU, load45_1->W, _->⊥) + (R31_in->RU, R0_in->RU, load45_1->W, R1_4->W, _->⊥) + (R31_in->RU, R0_in->RU, load45_1->W, R1_4->W, _->⊥) + (R31_in->RU, R0_in->RU, load45_1->W, R1_4->W, load46_1->W, _->⊥) + (R31_in->RU, R0_in->RU, load45_1->W, R1_4->W, load46_1->W, R0_10->W, _->⊥) |}] diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index fac2e255..a4d9266b 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -30,7 +30,7 @@ struct let addr_is_heap ?attrib args = apply_fun ?attrib ~func: - (rvar (v.with_name "$me_addr_is_heap" ~access:Var.Const Types.Boolean)) + (rvar (v.with_name "me_addr_is_heap" ~access:Var.Const Types.Boolean)) args (** [alloc_base args] returns the base address of a supplied allocation id. @@ -39,7 +39,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_base" ~access:Var.Const (Types.Bitvector 64))) + (v.with_name "me_alloc_base" ~access:Var.Const (Types.Bitvector 64))) args (** [alloc_live args] returns the liveness of an allocation. Returns value is @@ -49,7 +49,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_live" ~access:Var.Const (Types.Bitvector 2))) + (v.with_name "me_alloc_live" ~access:Var.Const (Types.Bitvector 2))) args (** [alloc_size args] returns the size of an allocation. args(0) is the memory @@ -58,7 +58,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_size" ~access:Var.Const (Types.Bitvector 64))) + (v.with_name "me_alloc_size" ~access:Var.Const (Types.Bitvector 64))) args (** [addr_alloc args] returns the allocation id of an address. args(0) is the @@ -67,7 +67,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_addr_alloc" ~access:Var.Const (Types.Bitvector 64))) + (v.with_name "me_addr_alloc" ~access:Var.Const (Types.Bitvector 64))) args (** [addr_offset args] returns the offset an address is into its allocation. @@ -76,7 +76,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_addr_offset" ~access:Var.Const (Types.Bitvector 64))) + (v.with_name "me_addr_offset" ~access:Var.Const (Types.Bitvector 64))) args (** [alloc_size_update args] returns a new memory encoding with the size of an @@ -86,7 +86,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_size_update" ~access:Var.Const + (v.with_name "me_alloc_size_update" ~access:Var.Const Globals.mem_encoding_typ)) args @@ -864,7 +864,7 @@ end let split_transform (p : Program.t) = let module I : IDAllocs = struct - let global_ids = Var.mk_gen ~id_generator:(Program.global_ids p) () + let global_ids = Program.var_generator p end in let module E = MemoryEncoder (SplitMemory (I)) in @@ -872,7 +872,7 @@ let split_transform (p : Program.t) = let flat_transform (p : Program.t) = let module I : IDAllocs = struct - let global_ids = Var.mk_gen ~id_generator:(Program.global_ids p) () + let global_ids = Program.var_generator p end in let module E = MemoryEncoder (FlatMemory (I)) in diff --git a/lib/util/var.ml b/lib/util/var.ml index a6bbed0a..c8e70739 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -90,11 +90,7 @@ end let mk_gen ?id_generator ?(req_sigil = Option.None) ?(scope = `Local) ?(default_name = "v") () = let id_gen = Option.get_or ~default:(ID.make_gen ()) id_generator in - let gt = - match scope with - | `Local -> Local "" - | `Global -> Global "" - in + let gt = match scope with `Local -> Local "" | `Global -> Global "" in let sgl = match (req_sigil, scope) with | Some s, _ -> s From 77390c63d402f24bae5a087be2ba72a5e523e68f Mon Sep 17 00:00:00 2001 From: agle Date: Tue, 30 Jun 2026 14:50:38 +1000 Subject: [PATCH 11/22] fixes for block parse --- lib/loadir.ml | 4 + test/cram/malloc_free.t | 262 ++++++++++++++++++++------------------ test/cram/memory_safety.t | 79 ++++-------- 3 files changed, 168 insertions(+), 177 deletions(-) diff --git a/lib/loadir.ml b/lib/loadir.ml index d1cb58ce..eaee5db9 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -1635,6 +1635,10 @@ let load_single_block_proc ?(proc = "") ?input lexbuf = let bl = Procedure.get_block proc bid |> Option.get_exn_or "no current proc" in + let prog = + Block.free_vars bl |> VarSet.filter Var.is_global |> fun vs -> + VarSet.fold (fun v p -> Program.add_var_decl p v) vs prog + in let inparam = Block.free_vars bl |> VarSet.filter Var.is_local |> VarSet.to_list |> List.map (fun x -> (Var.name x, x)) diff --git a/test/cram/malloc_free.t b/test/cram/malloc_free.t index 9e7cd9a8..c72b9bda 100644 --- a/test/cram/malloc_free.t +++ b/test/cram/malloc_free.t @@ -13,24 +13,30 @@ var $stack: [bv64]bv8; datatype memory_encoding {MemEncoding(alloc_live: [bv64]bv2, alloc_size: [bv64]bv64, addr_is_heap: [bv64]bool)} var $mem_encoding: memory_encoding; - function {:extern } {:inline } $me_addr_offset(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { - bvand_bv64(addr, 4294967295bv64) - } - function {:extern } {:inline } $me_alloc_base(mem_encoding: memory_encoding, alloc: bv64) returns (bv64) { - bvand_bv64(alloc, 18446744069414584320bv64) + function {:extern } {:inline } $me_addr_alloc(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { + addr } function {:extern } {:inline } $me_alloc_live(mem_encoding: memory_encoding, alloc: bv64) returns (bv2) { mem_encoding->alloc_live[alloc] } - function {:extern } {:inline } $me_alloc_size(mem_encoding: memory_encoding, alloc: bv64) returns (bv64) { - mem_encoding->alloc_size[alloc] - } - function {:extern } {:inline } $me_addr_alloc(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { - addr + function {:extern } {:inline } $me_alloc_base(mem_encoding: memory_encoding, alloc: bv64) returns (bv64) { + $bvand_bv64(alloc, 18446744069414584320bv64) } function {:extern } {:inline } $me_addr_is_heap(mem_encoding: memory_encoding, addr: bv64) returns (bool) { mem_encoding->addr_is_heap[addr] } + function {:extern } {:inline } $me_alloc_live_update(mem_encoding: memory_encoding, alloc: bv64, live: bv2) returns (memory_encoding) { + mem_encoding->(alloc_live := mem_encoding->alloc_live[alloc := live]) + } + function {:extern } {:inline } $me_alloc_size_update(mem_encoding: memory_encoding, alloc: bv64, size: bv64) returns (memory_encoding) { + mem_encoding->(alloc_size := mem_encoding->alloc_size[alloc := size]) + } + function {:extern } {:inline } $me_alloc_size(mem_encoding: memory_encoding, alloc: bv64) returns (bv64) { + mem_encoding->alloc_size[alloc] + } + function {:extern } {:inline } $me_addr_offset(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { + $bvand_bv64(addr, 4294967295bv64) + } function {:extern } {:inline } $me_can_allocate(mem_encoding: memory_encoding, addr: bv64, size: bv64) returns (bool) { (((($me_addr_is_heap(mem_encoding, addr) && @@ -38,15 +44,9 @@ && ($me_alloc_live(mem_encoding, $me_addr_alloc(mem_encoding, addr)) == 0bv2)) && - bvule_bv64_bv64_bool(size, 4294967295bv64)) + $bvule_bv64_bv64_bool(size, 4294967295bv64)) && - bvult_bv64_bv64_bool(0bv64, size)) - } - function {:extern } {:inline } $me_alloc_size_update(mem_encoding: memory_encoding, alloc: bv64, size: bv64) returns (memory_encoding) { - mem_encoding->(alloc_size := mem_encoding->alloc_size[alloc := size]) - } - function {:extern } {:inline } $me_alloc_live_update(mem_encoding: memory_encoding, alloc: bv64, live: bv2) returns (memory_encoding) { - mem_encoding->(alloc_live := mem_encoding->alloc_live[alloc := live]) + $bvult_bv64_bv64_bool(0bv64, size)) } function {:extern } {:inline } $me_allocate(mem_encoding: memory_encoding, mem_encoding_out: memory_encoding, addr: bv64, size: bv64) returns (bool) { ($me_alloc_size_update( @@ -63,7 +63,7 @@ (((forall i: bv64 :: {$me_addr_is_heap(mem_encoding, i)} - (bvult_bv64_bv64_bool(100000000bv64, i) == $me_addr_is_heap( + ($bvult_bv64_bv64_bool(100000000bv64, i) == $me_addr_is_heap( mem_encoding, i ))) @@ -84,55 +84,59 @@ $me_alloc_base(mem_encoding, $me_addr_alloc(mem_encoding, addr)) ) == 1bv2) && - bvule_bv64_bv64_bool( - $me_addr_offset(mem_encoding, bvadd_bv64(addr, size)), + $bvule_bv64_bv64_bool( + $me_addr_offset(mem_encoding, $bvadd_bv64(addr, size)), $me_alloc_size( mem_encoding, $me_alloc_base(mem_encoding, $me_addr_alloc(mem_encoding, addr)) ) ))) } - function {:extern } load64_le(#memory: [bv64]bv8, #index: bv64) returns (bv64) { - (((((((#memory[bvadd_bv64(#index, 7bv64)] + function {:extern } $load64_le(#memory: [bv64]bv8, #index: bv64) returns (bv64) { + (((((((#memory[$bvadd_bv64(#index, 7bv64)] ++ - #memory[bvadd_bv64(#index, 6bv64)]): bv16 + #memory[$bvadd_bv64(#index, 6bv64)]): bv16 ++ - #memory[bvadd_bv64(#index, 5bv64)]): bv24 + #memory[$bvadd_bv64(#index, 5bv64)]): bv24 ++ - #memory[bvadd_bv64(#index, 4bv64)]): bv32 + #memory[$bvadd_bv64(#index, 4bv64)]): bv32 ++ - #memory[bvadd_bv64(#index, 3bv64)]): bv40 + #memory[$bvadd_bv64(#index, 3bv64)]): bv40 ++ - #memory[bvadd_bv64(#index, 2bv64)]): bv48 + #memory[$bvadd_bv64(#index, 2bv64)]): bv48 ++ - #memory[bvadd_bv64(#index, 1bv64)]): bv56 + #memory[$bvadd_bv64(#index, 1bv64)]): bv56 ++ - #memory[bvadd_bv64(#index, 0bv64)]): bv64 + #memory[$bvadd_bv64(#index, 0bv64)]): bv64 } - function {:define } {:extern } store64_le(#memory: [bv64]bv8, #index: bv64, #value: bv64) returns ([bv64]bv8) { - #memory[#index := #value[8:0]][bvadd_bv64(#index, 1bv64) := #value[16:8]][bvadd_bv64( + function {:define } {:extern } $store64_le(#memory: [bv64]bv8, #index: bv64, #value: bv64) returns ([bv64]bv8) { + #memory[#index := #value[8:0]][$bvadd_bv64(#index, 1bv64) := #value[16:8]][$bvadd_bv64( #index, 2bv64 - ) := #value[24:16]][bvadd_bv64(#index, 3bv64) := #value[32:24]][bvadd_bv64( + ) := #value[24:16]][$bvadd_bv64(#index, 3bv64) := #value[32:24]][$bvadd_bv64( #index, 4bv64 - ) := #value[40:32]][bvadd_bv64(#index, 5bv64) := #value[48:40]][bvadd_bv64( + ) := #value[40:32]][$bvadd_bv64(#index, 5bv64) := #value[48:40]][$bvadd_bv64( #index, 6bv64 - ) := #value[56:48]][bvadd_bv64(#index, 7bv64) := #value[64:56]] + ) := #value[56:48]][$bvadd_bv64(#index, 7bv64) := #value[64:56]] } - function {:define } {:extern } store8_le(#memory: [bv64]bv8, #index: bv64, #value: bv8) returns ([bv64]bv8) { + function {:define } {:extern } $store8_le(#memory: [bv64]bv8, #index: bv64, #value: bv8) returns ([bv64]bv8) { #memory[#index := #value[8:0]] } - function {:bvbuiltin "bvadd"} {:extern } bvadd_bv64(bv64, bv64) returns (bv64); - function {:bvbuiltin "bvand"} {:extern } bvand_bv64(bv64, bv64) returns (bv64); - function {:bvbuiltin "bvule"} {:extern } bvule_bv64_bv64_bool(bv64, bv64) returns (bool); - function {:bvbuiltin "bvult"} {:extern } bvult_bv64_bv64_bool(bv64, bv64) returns (bool); + function {:bvbuiltin "bvadd"} {:extern } $bvadd_bv64(bv64, bv64) returns (bv64); + function {:bvbuiltin "bvand"} {:extern } $bvand_bv64(bv64, bv64) returns (bv64); + function {:bvbuiltin "bvule"} {:extern } $bvule_bv64_bv64_bool(bv64, bv64) returns (bool); + function {:bvbuiltin "bvult"} {:extern } $bvult_bv64_bv64_bool(bv64, bv64) returns (bool); + function {:bvbuiltin "bvadd"} {:extern } $bvadd_bv64(bv64, bv64) returns (bv64); + function {:bvbuiltin "bvand"} {:extern } $bvand_bv64(bv64, bv64) returns (bv64); + function {:bvbuiltin "bvule"} {:extern } $bvule_bv64_bv64_bool(bv64, bv64) returns (bool); + function {:bvbuiltin "bvult"} {:extern } $bvult_bv64_bv64_bool(bv64, bv64) returns (bool); procedure p$main_2276(R0_in: bv64, R16_in: bv64, R17_in: bv64, R1_in: bv64, R29_in: bv64, R30_in: bv64, R31_in: bv64, _PC_in: bv64) returns (R0_out: bv64, R17_out: bv64, R1_out: bv64, R29_out: bv64, R30_out: bv64); - modifies $mem_encoding, $mem, $stack; + modifies $mem, $stack, $mem_encoding; ensures {:msg "Memory Error: Memory Leak"} (forall i: bv64 :: @@ -144,22 +148,23 @@ implementation p$main_2276(R0_in: bv64, R16_in: bv64, R17_in: bv64, R1_in: bv64, R29_in: bv64, R30_in: bv64, R31_in: bv64, _PC_in: bv64) returns (R0_out: bv64, R17_out: bv64, R1_out: bv64, R29_out: bv64, R30_out: bv64) { + var Exp14__5_2_2: bv64; + var i: bv64; + var Exp14__5_1_2: bv64; var Exp18__5_25_2: bv64; var Exp14__5_21_2: bv64; var Exp14__5_22_2: bv64; var R0_4: bv64; var Exp16__5_24_2: bv64; - var Exp14__5_2_2: bv64; - var Exp14__5_1_2: bv64; b#main_entry: - $stack := store64_le( + $stack := $store64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551584bv64), + $bvadd_bv64(R31_in, 18446744073709551584bv64), R29_in ); - $stack := store64_le( + $stack := $store64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551592bv64), + $bvadd_bv64(R31_in, 18446744073709551592bv64), R30_in ); assert{:msg "Memory Error: Invalid Access"} $me_valid_access( @@ -167,47 +172,47 @@ 131088bv64, 8bv64 ); - Exp14__5_2_2 := load64_le($mem, 131088bv64); + Exp14__5_2_2 := $load64_le($mem, 131088bv64); assert true; call R0_4 := p$malloc(1bv64); goto b#phi_5; b#phi_5: - $stack := store64_le( + $stack := $store64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551608bv64), + $bvadd_bv64(R31_in, 18446744073709551608bv64), R0_4 ); - Exp14__5_21_2 := load64_le( + Exp14__5_21_2 := $load64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551608bv64) + $bvadd_bv64(R31_in, 18446744073709551608bv64) ); assert{:msg "Memory Error: Invalid Access"} $me_valid_access( $mem_encoding, Exp14__5_21_2, 1bv64 ); - $mem := store8_le($mem, Exp14__5_21_2, 121bv8); - Exp14__5_22_2 := load64_le( + $mem := $store8_le($mem, Exp14__5_21_2, 121bv8); + Exp14__5_22_2 := $load64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551608bv64) + $bvadd_bv64(R31_in, 18446744073709551608bv64) ); assert{:msg "Memory Error: Invalid Access"} $me_valid_access( $mem_encoding, 131112bv64, 8bv64 ); - Exp14__5_1_2 := load64_le($mem, 131112bv64); + Exp14__5_1_2 := $load64_le($mem, 131112bv64); assert true; call p$#free(Exp14__5_22_2); goto b#phi_6; b#phi_6: - Exp16__5_24_2 := load64_le( + Exp16__5_24_2 := $load64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551584bv64) + $bvadd_bv64(R31_in, 18446744073709551584bv64) ); - Exp18__5_25_2 := load64_le( + Exp18__5_25_2 := $load64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551592bv64) + $bvadd_bv64(R31_in, 18446744073709551592bv64) ); goto b#main_return; b#main_return: @@ -216,13 +221,13 @@ return; } procedure p$malloc(R0_in: bv64) returns (R0_out: bv64); - modifies $mem_encoding, $mem, $stack; + modifies $mem, $stack, $mem_encoding; ensures $me_can_allocate(old($mem_encoding), R0_out, R0_in); ensures ($me_addr_offset($mem_encoding, R0_out) == 0bv64); ensures ($me_alloc_base($mem_encoding, $me_addr_alloc($mem_encoding, R0_out)) == R0_out); ensures $me_allocate(old($mem_encoding), $mem_encoding, R0_out, R0_in); procedure p$#free(R0_in: bv64); - modifies $mem_encoding, $mem, $stack; + modifies $mem, $stack, $mem_encoding; ensures {:msg "Memory Error: Invalid Free"} ($mem_encoding == $me_alloc_live_update( old($mem_encoding), $me_addr_alloc(old($mem_encoding), R0_in), @@ -250,24 +255,30 @@ var $stack: [bv64]bv8; datatype memory_encoding {MemEncoding(alloc_live: [bv64]bv2, alloc_size: [bv64]bv64, addr_is_heap: [bv64]bool)} var $mem_encoding: memory_encoding; - function {:extern } {:inline } $me_addr_offset(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { - bvand_bv64(addr, 4294967295bv64) - } - function {:extern } {:inline } $me_alloc_base(mem_encoding: memory_encoding, alloc: bv64) returns (bv64) { - bvand_bv64(alloc, 18446744069414584320bv64) + function {:extern } {:inline } $me_addr_alloc(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { + addr } function {:extern } {:inline } $me_alloc_live(mem_encoding: memory_encoding, alloc: bv64) returns (bv2) { mem_encoding->alloc_live[alloc] } - function {:extern } {:inline } $me_alloc_size(mem_encoding: memory_encoding, alloc: bv64) returns (bv64) { - mem_encoding->alloc_size[alloc] - } - function {:extern } {:inline } $me_addr_alloc(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { - addr + function {:extern } {:inline } $me_alloc_base(mem_encoding: memory_encoding, alloc: bv64) returns (bv64) { + $bvand_bv64(alloc, 18446744069414584320bv64) } function {:extern } {:inline } $me_addr_is_heap(mem_encoding: memory_encoding, addr: bv64) returns (bool) { mem_encoding->addr_is_heap[addr] } + function {:extern } {:inline } $me_alloc_live_update(mem_encoding: memory_encoding, alloc: bv64, live: bv2) returns (memory_encoding) { + mem_encoding->(alloc_live := mem_encoding->alloc_live[alloc := live]) + } + function {:extern } {:inline } $me_alloc_size_update(mem_encoding: memory_encoding, alloc: bv64, size: bv64) returns (memory_encoding) { + mem_encoding->(alloc_size := mem_encoding->alloc_size[alloc := size]) + } + function {:extern } {:inline } $me_alloc_size(mem_encoding: memory_encoding, alloc: bv64) returns (bv64) { + mem_encoding->alloc_size[alloc] + } + function {:extern } {:inline } $me_addr_offset(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { + $bvand_bv64(addr, 4294967295bv64) + } function {:extern } {:inline } $me_can_allocate(mem_encoding: memory_encoding, addr: bv64, size: bv64) returns (bool) { (((($me_addr_is_heap(mem_encoding, addr) && @@ -275,15 +286,9 @@ && ($me_alloc_live(mem_encoding, $me_addr_alloc(mem_encoding, addr)) == 0bv2)) && - bvule_bv64_bv64_bool(size, 4294967295bv64)) + $bvule_bv64_bv64_bool(size, 4294967295bv64)) && - bvult_bv64_bv64_bool(0bv64, size)) - } - function {:extern } {:inline } $me_alloc_size_update(mem_encoding: memory_encoding, alloc: bv64, size: bv64) returns (memory_encoding) { - mem_encoding->(alloc_size := mem_encoding->alloc_size[alloc := size]) - } - function {:extern } {:inline } $me_alloc_live_update(mem_encoding: memory_encoding, alloc: bv64, live: bv2) returns (memory_encoding) { - mem_encoding->(alloc_live := mem_encoding->alloc_live[alloc := live]) + $bvult_bv64_bv64_bool(0bv64, size)) } function {:extern } {:inline } $me_allocate(mem_encoding: memory_encoding, mem_encoding_out: memory_encoding, addr: bv64, size: bv64) returns (bool) { ($me_alloc_size_update( @@ -300,7 +305,7 @@ (((forall i: bv64 :: {$me_addr_is_heap(mem_encoding, i)} - (bvult_bv64_bv64_bool(100000000bv64, i) == $me_addr_is_heap( + ($bvult_bv64_bv64_bool(100000000bv64, i) == $me_addr_is_heap( mem_encoding, i ))) @@ -321,55 +326,59 @@ $me_alloc_base(mem_encoding, $me_addr_alloc(mem_encoding, addr)) ) == 1bv2) && - bvule_bv64_bv64_bool( - $me_addr_offset(mem_encoding, bvadd_bv64(addr, size)), + $bvule_bv64_bv64_bool( + $me_addr_offset(mem_encoding, $bvadd_bv64(addr, size)), $me_alloc_size( mem_encoding, $me_alloc_base(mem_encoding, $me_addr_alloc(mem_encoding, addr)) ) ))) } - function {:extern } load64_le(#memory: [bv64]bv8, #index: bv64) returns (bv64) { - (((((((#memory[bvadd_bv64(#index, 7bv64)] + function {:extern } $load64_le(#memory: [bv64]bv8, #index: bv64) returns (bv64) { + (((((((#memory[$bvadd_bv64(#index, 7bv64)] ++ - #memory[bvadd_bv64(#index, 6bv64)]): bv16 + #memory[$bvadd_bv64(#index, 6bv64)]): bv16 ++ - #memory[bvadd_bv64(#index, 5bv64)]): bv24 + #memory[$bvadd_bv64(#index, 5bv64)]): bv24 ++ - #memory[bvadd_bv64(#index, 4bv64)]): bv32 + #memory[$bvadd_bv64(#index, 4bv64)]): bv32 ++ - #memory[bvadd_bv64(#index, 3bv64)]): bv40 + #memory[$bvadd_bv64(#index, 3bv64)]): bv40 ++ - #memory[bvadd_bv64(#index, 2bv64)]): bv48 + #memory[$bvadd_bv64(#index, 2bv64)]): bv48 ++ - #memory[bvadd_bv64(#index, 1bv64)]): bv56 + #memory[$bvadd_bv64(#index, 1bv64)]): bv56 ++ - #memory[bvadd_bv64(#index, 0bv64)]): bv64 + #memory[$bvadd_bv64(#index, 0bv64)]): bv64 } - function {:define } {:extern } store64_le(#memory: [bv64]bv8, #index: bv64, #value: bv64) returns ([bv64]bv8) { - #memory[#index := #value[8:0]][bvadd_bv64(#index, 1bv64) := #value[16:8]][bvadd_bv64( + function {:define } {:extern } $store64_le(#memory: [bv64]bv8, #index: bv64, #value: bv64) returns ([bv64]bv8) { + #memory[#index := #value[8:0]][$bvadd_bv64(#index, 1bv64) := #value[16:8]][$bvadd_bv64( #index, 2bv64 - ) := #value[24:16]][bvadd_bv64(#index, 3bv64) := #value[32:24]][bvadd_bv64( + ) := #value[24:16]][$bvadd_bv64(#index, 3bv64) := #value[32:24]][$bvadd_bv64( #index, 4bv64 - ) := #value[40:32]][bvadd_bv64(#index, 5bv64) := #value[48:40]][bvadd_bv64( + ) := #value[40:32]][$bvadd_bv64(#index, 5bv64) := #value[48:40]][$bvadd_bv64( #index, 6bv64 - ) := #value[56:48]][bvadd_bv64(#index, 7bv64) := #value[64:56]] + ) := #value[56:48]][$bvadd_bv64(#index, 7bv64) := #value[64:56]] } - function {:define } {:extern } store8_le(#memory: [bv64]bv8, #index: bv64, #value: bv8) returns ([bv64]bv8) { + function {:define } {:extern } $store8_le(#memory: [bv64]bv8, #index: bv64, #value: bv8) returns ([bv64]bv8) { #memory[#index := #value[8:0]] } - function {:bvbuiltin "bvadd"} {:extern } bvadd_bv64(bv64, bv64) returns (bv64); - function {:bvbuiltin "bvand"} {:extern } bvand_bv64(bv64, bv64) returns (bv64); - function {:bvbuiltin "bvule"} {:extern } bvule_bv64_bv64_bool(bv64, bv64) returns (bool); - function {:bvbuiltin "bvult"} {:extern } bvult_bv64_bv64_bool(bv64, bv64) returns (bool); + function {:bvbuiltin "bvadd"} {:extern } $bvadd_bv64(bv64, bv64) returns (bv64); + function {:bvbuiltin "bvand"} {:extern } $bvand_bv64(bv64, bv64) returns (bv64); + function {:bvbuiltin "bvule"} {:extern } $bvule_bv64_bv64_bool(bv64, bv64) returns (bool); + function {:bvbuiltin "bvult"} {:extern } $bvult_bv64_bv64_bool(bv64, bv64) returns (bool); + function {:bvbuiltin "bvadd"} {:extern } $bvadd_bv64(bv64, bv64) returns (bv64); + function {:bvbuiltin "bvand"} {:extern } $bvand_bv64(bv64, bv64) returns (bv64); + function {:bvbuiltin "bvule"} {:extern } $bvule_bv64_bv64_bool(bv64, bv64) returns (bool); + function {:bvbuiltin "bvult"} {:extern } $bvult_bv64_bv64_bool(bv64, bv64) returns (bool); procedure p$main_2276(R0_in: bv64, R16_in: bv64, R17_in: bv64, R1_in: bv64, R29_in: bv64, R30_in: bv64, R31_in: bv64, _PC_in: bv64) returns (R0_out: bv64, R17_out: bv64, R1_out: bv64, R29_out: bv64, R30_out: bv64); - modifies $mem_encoding, $mem, $stack; + modifies $mem, $stack, $mem_encoding; ensures {:msg "Memory Error: Memory Leak"} (forall i: bv64 :: @@ -381,22 +390,23 @@ implementation p$main_2276(R0_in: bv64, R16_in: bv64, R17_in: bv64, R1_in: bv64, R29_in: bv64, R30_in: bv64, R31_in: bv64, _PC_in: bv64) returns (R0_out: bv64, R17_out: bv64, R1_out: bv64, R29_out: bv64, R30_out: bv64) { + var Exp14__5_2_2: bv64; + var i: bv64; + var Exp14__5_1_2: bv64; var Exp18__5_25_2: bv64; var Exp14__5_21_2: bv64; var Exp14__5_22_2: bv64; var R0_4: bv64; var Exp16__5_24_2: bv64; - var Exp14__5_2_2: bv64; - var Exp14__5_1_2: bv64; b#main_entry: - $stack := store64_le( + $stack := $store64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551584bv64), + $bvadd_bv64(R31_in, 18446744073709551584bv64), R29_in ); - $stack := store64_le( + $stack := $store64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551592bv64), + $bvadd_bv64(R31_in, 18446744073709551592bv64), R30_in ); assert{:msg "Memory Error: Invalid Access"} $me_valid_access( @@ -404,47 +414,47 @@ 131088bv64, 8bv64 ); - Exp14__5_2_2 := load64_le($mem, 131088bv64); + Exp14__5_2_2 := $load64_le($mem, 131088bv64); assert true; call R0_4 := p$malloc(1bv64); goto b#phi_5; b#phi_5: - $stack := store64_le( + $stack := $store64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551608bv64), + $bvadd_bv64(R31_in, 18446744073709551608bv64), R0_4 ); - Exp14__5_21_2 := load64_le( + Exp14__5_21_2 := $load64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551608bv64) + $bvadd_bv64(R31_in, 18446744073709551608bv64) ); assert{:msg "Memory Error: Invalid Access"} $me_valid_access( $mem_encoding, - bvadd_bv64(Exp14__5_21_2, 7bv64), + $bvadd_bv64(Exp14__5_21_2, 7bv64), 1bv64 ); - $mem := store8_le($mem, bvadd_bv64(Exp14__5_21_2, 7bv64), 121bv8); - Exp14__5_22_2 := load64_le( + $mem := $store8_le($mem, $bvadd_bv64(Exp14__5_21_2, 7bv64), 121bv8); + Exp14__5_22_2 := $load64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551608bv64) + $bvadd_bv64(R31_in, 18446744073709551608bv64) ); assert{:msg "Memory Error: Invalid Access"} $me_valid_access( $mem_encoding, 131112bv64, 8bv64 ); - Exp14__5_1_2 := load64_le($mem, 131112bv64); + Exp14__5_1_2 := $load64_le($mem, 131112bv64); assert true; call p$#free(Exp14__5_22_2); goto b#phi_6; b#phi_6: - Exp16__5_24_2 := load64_le( + Exp16__5_24_2 := $load64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551584bv64) + $bvadd_bv64(R31_in, 18446744073709551584bv64) ); - Exp18__5_25_2 := load64_le( + Exp18__5_25_2 := $load64_le( $stack, - bvadd_bv64(R31_in, 18446744073709551592bv64) + $bvadd_bv64(R31_in, 18446744073709551592bv64) ); goto b#main_return; b#main_return: @@ -453,13 +463,13 @@ return; } procedure p$malloc(R0_in: bv64) returns (R0_out: bv64); - modifies $mem_encoding, $mem, $stack; + modifies $mem, $stack, $mem_encoding; ensures $me_can_allocate(old($mem_encoding), R0_out, R0_in); ensures ($me_addr_offset($mem_encoding, R0_out) == 0bv64); ensures ($me_alloc_base($mem_encoding, $me_addr_alloc($mem_encoding, R0_out)) == R0_out); ensures $me_allocate(old($mem_encoding), $mem_encoding, R0_out, R0_in); procedure p$#free(R0_in: bv64); - modifies $mem_encoding, $mem, $stack; + modifies $mem, $stack, $mem_encoding; ensures {:msg "Memory Error: Invalid Free"} ($mem_encoding == $me_alloc_live_update( old($mem_encoding), $me_addr_alloc(old($mem_encoding), R0_in), @@ -480,7 +490,7 @@ $ boogie ./bad.bpl Memory Error: Invalid Access Execution trace: - ./bad.bpl(143,3): b#main_entry + ./bad.bpl(148,3): b#main_entry Boogie program verifier finished with 0 verified, 1 error diff --git a/test/cram/memory_safety.t b/test/cram/memory_safety.t index 4462128e..a0698fdd 100644 --- a/test/cram/memory_safety.t +++ b/test/cram/memory_safety.t @@ -15,29 +15,21 @@ (run-transforms split-memory-encoding) (run-transforms memory-specification) (run-transforms ssa) - (run-transforms linear-const) - (run-transforms linear-copy) - (run-transforms dynamic-single-assignment) - (dump-il after.il) - (dump-boogie out.bpl) + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: (run-transforms ssa): Failure("not found: mem_encoding_in:memory_encoding likely a read-uninitialised variable") + + [123] $ boogie out.bpl - Memory Error: Invalid Free (object not live) - Execution trace: - out.bpl(190,3): b#inputs - Memory Error: Invalid Free (not base address) - Execution trace: - out.bpl(235,3): b#inputs - Memory Error: Invalid Access - Execution trace: - out.bpl(270,3): b#inputs - Memory Error: Invalid Access - Execution trace: - out.bpl(319,3): b#inputs - Memory Error: Memory Leak - Execution trace: - out.bpl(367,3): b#inputs - - Boogie program verifier finished with 1 verified, 5 errors + Error opening file "out.bpl": Could not find file '$TESTCASE_ROOT/out.bpl'. $ cat << EOF | bincaml script - > (load-il ../../examples/memory/memory_safety.il) @@ -56,34 +48,19 @@ (run-transforms flat-memory-encoding) (run-transforms memory-specification) (run-transforms ssa) - (run-transforms linear-const) - (run-transforms linear-copy) - (run-transforms dynamic-single-assignment) - (dump-il after.il) - (dump-boogie out.bpl) + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: [ERROR] formal parameter name differs from variable + bincaml: (run-transforms ssa): Failure("not found: mem_encoding_in:memory_encoding likely a read-uninitialised variable") + + [123] $ boogie out.bpl - Memory Error: Invalid Free (object not live) - Execution trace: - out.bpl(226,3): b#inputs - Memory Error: Invalid Free (not base address) - Execution trace: - out.bpl(271,3): b#inputs - Memory Error: Invalid Free (object not live) - Execution trace: - out.bpl(271,3): b#inputs - out.bpl(277,5): Error: a precondition for this call could not be proved - out.bpl(146,3): Related location: this is the precondition that could not be proved - Execution trace: - out.bpl(271,3): b#inputs - Memory Error: Invalid Access - Execution trace: - out.bpl(306,3): b#inputs - Memory Error: Invalid Access - Execution trace: - out.bpl(355,3): b#inputs - Memory Error: Memory Leak - Execution trace: - out.bpl(403,3): b#inputs - - Boogie program verifier finished with 1 verified, 7 errors + Error opening file "out.bpl": Could not find file '$TESTCASE_ROOT/out.bpl'. From 988a69d29cdf53bef5aafae85f149db5e5e86d08 Mon Sep 17 00:00:00 2001 From: agle Date: Tue, 30 Jun 2026 15:14:19 +1000 Subject: [PATCH 12/22] fix memspec --- lib/lang/check.ml | 12 +++++ lib/lang/program.ml | 1 + lib/loadir.ml | 1 + lib/transforms/memory_encoding.ml | 18 +++---- test/cram/memory_safety.t | 79 ++++++++++++++++++++----------- 5 files changed, 74 insertions(+), 37 deletions(-) diff --git a/lib/lang/check.ml b/lib/lang/check.ml index ac7bfb68..f0847da0 100644 --- a/lib/lang/check.ml +++ b/lib/lang/check.ml @@ -87,6 +87,18 @@ let variables_wf p = ^ (Procedure.id p |> ID.to_string)))) else () in + begin + let check_modset s vs = + vs |> List.filter Var.is_local |> function + | [] -> () + | ls -> + raise + (IRWellformed + ("local vars in " ^ s ^ " : " ^ List.to_string Var.show ls)) + in + check_modset "modifies" spec.modifies_globs; + check_modset "captures" spec.captures_globs + end; let check e = Expr.BasilExpr.free_vars_iter e |> Iter.iter var_is_ok in List.iter check spec.requires; List.iter check spec.ensures; diff --git a/lib/lang/program.ml b/lib/lang/program.ml index e777dbf8..295e24db 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -320,6 +320,7 @@ let decl_global p name f = (** add var decl for with id exising in generator *) let add_var_decl p ?(attrib = Attrib.empty) ?classification v = + assert (Var.is_global v) ; let id = Var.id v in (try p.global_names.get_name (ID.index id) |> ignore with Not_found -> failwith "Id not created with programs' generator"); diff --git a/lib/loadir.ml b/lib/loadir.ml index eaee5db9..3c6a5b40 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -1639,6 +1639,7 @@ let load_single_block_proc ?(proc = "") ?input lexbuf = Block.free_vars bl |> VarSet.filter Var.is_global |> fun vs -> VarSet.fold (fun v p -> Program.add_var_decl p v) vs prog in + let prog = Spec_modifies.set_modsets prog in let inparam = Block.free_vars bl |> VarSet.filter Var.is_local |> VarSet.to_list |> List.map (fun x -> (Var.name x, x)) diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index a4d9266b..aa7b0d05 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -13,7 +13,7 @@ module Globals = struct let mem_encoding_typ_name = "memory_encoding" let mem_encoding_typ = Types.Variable mem_encoding_typ_name - let mem_encoding v = v.with_name "$mem_encoding" ~access:None mem_encoding_typ + let mem_encoding v = v.with_name "mem_encoding" ~access:None mem_encoding_typ end module Calls (N : sig @@ -97,7 +97,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "$me_alloc_live_update" ~access:Var.Const + (v.with_name "me_alloc_live_update" ~access:Var.Const Globals.mem_encoding_typ)) args @@ -106,7 +106,7 @@ struct allocated at. args(3) is the size of the allocation. *) let allocate ?attrib args = apply_fun ?attrib - ~func:(rvar (v.with_name "$me_allocate" ~access:Var.Const Types.Boolean)) + ~func:(rvar (v.with_name "me_allocate" ~access:Var.Const Types.Boolean)) args (** [can_alloc args] Returns whether an alloc, performed by [allocate], is @@ -115,7 +115,7 @@ struct let can_alloc ?attrib args = apply_fun ?attrib ~func: - (rvar (v.with_name "$me_can_allocate" ~access:Var.Const Types.Boolean)) + (rvar (v.with_name "me_can_allocate" ~access:Var.Const Types.Boolean)) args (** [init_encoding args] Returns if a memory encoding is initialized. args(0) @@ -123,7 +123,7 @@ struct let init_encoding ?attrib args = apply_fun ?attrib ~func: - (rvar (v.with_name "$me_init_encoding" ~access:Var.Const Types.Boolean)) + (rvar (v.with_name "me_init_encoding" ~access:Var.Const Types.Boolean)) args (** [valid_access args] Checks if an access is valid. args(0) is the memory @@ -132,7 +132,7 @@ struct let valid_access ?attrib args = apply_fun ?attrib ~func: - (rvar (v.with_name "$me_valid_access" ~access:Var.Const Types.Boolean)) + (rvar (v.with_name "me_valid_access" ~access:Var.Const Types.Boolean)) args end @@ -198,7 +198,7 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct Lang.Program.add_decl p (Lang.Program.Variable { - binding = Globals.mem_encoding (Var.mk_gen ~id_generator:gids ()); + binding = Globals.mem_encoding (Program.var_generator p); attrib = Attrib.empty; classification = None; }) @@ -868,7 +868,7 @@ let split_transform (p : Program.t) = end in let module E = MemoryEncoder (SplitMemory (I)) in - E.transform p |> fun prog -> Spec_modifies.set_modsets ~add_only:true prog + E.transform p |> fun prog -> Spec_modifies.set_modsets prog let flat_transform (p : Program.t) = let module I : IDAllocs = struct @@ -876,4 +876,4 @@ let flat_transform (p : Program.t) = end in let module E = MemoryEncoder (FlatMemory (I)) in - E.transform p |> fun prog -> Spec_modifies.set_modsets ~add_only:true prog + E.transform p |> fun prog -> Spec_modifies.set_modsets prog diff --git a/test/cram/memory_safety.t b/test/cram/memory_safety.t index a0698fdd..46cc7b76 100644 --- a/test/cram/memory_safety.t +++ b/test/cram/memory_safety.t @@ -15,21 +15,29 @@ (run-transforms split-memory-encoding) (run-transforms memory-specification) (run-transforms ssa) - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: (run-transforms ssa): Failure("not found: mem_encoding_in:memory_encoding likely a read-uninitialised variable") - - [123] + (run-transforms linear-const) + (run-transforms linear-copy) + (run-transforms dynamic-single-assignment) + (dump-il after.il) + (dump-boogie out.bpl) $ boogie out.bpl - Error opening file "out.bpl": Could not find file '$TESTCASE_ROOT/out.bpl'. + Memory Error: Invalid Free (object not live) + Execution trace: + out.bpl(194,3): b#inputs + Memory Error: Invalid Free (not base address) + Execution trace: + out.bpl(239,3): b#inputs + Memory Error: Invalid Access + Execution trace: + out.bpl(274,3): b#inputs + Memory Error: Invalid Access + Execution trace: + out.bpl(323,3): b#inputs + Memory Error: Memory Leak + Execution trace: + out.bpl(371,3): b#inputs + + Boogie program verifier finished with 1 verified, 5 errors $ cat << EOF | bincaml script - > (load-il ../../examples/memory/memory_safety.il) @@ -48,19 +56,34 @@ (run-transforms flat-memory-encoding) (run-transforms memory-specification) (run-transforms ssa) - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: [ERROR] formal parameter name differs from variable - bincaml: (run-transforms ssa): Failure("not found: mem_encoding_in:memory_encoding likely a read-uninitialised variable") - - [123] + (run-transforms linear-const) + (run-transforms linear-copy) + (run-transforms dynamic-single-assignment) + (dump-il after.il) + (dump-boogie out.bpl) $ boogie out.bpl - Error opening file "out.bpl": Could not find file '$TESTCASE_ROOT/out.bpl'. + Memory Error: Invalid Free (object not live) + Execution trace: + out.bpl(230,3): b#inputs + Memory Error: Invalid Free (not base address) + Execution trace: + out.bpl(275,3): b#inputs + Memory Error: Invalid Free (object not live) + Execution trace: + out.bpl(275,3): b#inputs + out.bpl(281,5): Error: a precondition for this call could not be proved + out.bpl(150,3): Related location: this is the precondition that could not be proved + Execution trace: + out.bpl(275,3): b#inputs + Memory Error: Invalid Access + Execution trace: + out.bpl(310,3): b#inputs + Memory Error: Invalid Access + Execution trace: + out.bpl(359,3): b#inputs + Memory Error: Memory Leak + Execution trace: + out.bpl(407,3): b#inputs + + Boogie program verifier finished with 1 verified, 7 errors From 633012ff8e8ed9bba846844670a81e0a1ceb8986 Mon Sep 17 00:00:00 2001 From: agle Date: Tue, 30 Jun 2026 15:15:41 +1000 Subject: [PATCH 13/22] promote gammavars test --- test/cram/gammavars.t | 69 ++++--------------------------------------- 1 file changed, 6 insertions(+), 63 deletions(-) diff --git a/test/cram/gammavars.t b/test/cram/gammavars.t index 3a7eb06b..d93d9717 100644 --- a/test/cram/gammavars.t +++ b/test/cram/gammavars.t @@ -3,65 +3,10 @@ (load-il ../../examples/gamma.il) (dump-il before.il) (run-transforms gamma-vars) - bincaml: [ERROR] global Gamma_$x:bool should have global sigil $ (dump-il after.il) $ diff before.il after.il - 2,6c2,6 - < proc @main() -> (out:bv64) { } - < modifies $x:bv64 - < captures $x:bv64 - < requires gamma($x) - < ensures gamma($x) - --- - > proc @main() -> (Gamma_out:bool, out:bv64) { } - > modifies Gamma_$x:bool, $x:bv64 - > captures Gamma_$x:bool, $x:bv64 - > requires Gamma_$x - > ensures Gamma_$x - 9,10c9,16 - < block %main_entry [ ($x:bv64=out) := call @f(z=$x); goto (%main_return); ]; - < block %main_return [ var out:bv64 := $x; return; ] - --- - > block %main_entry [ - > (Gamma_$x:bool=Gamma_out, $x:bv64=out) := call @f(Gamma_z=Gamma_$x, z=$x); - > goto (%main_return); - > ]; - > block %main_return [ - > (var Gamma_out:bool := Gamma_$x, var out:bv64 := $x); - > return; - > ] - 12,14c18,20 - < proc @f(z:bv64) -> (out:bv64) { } - < requires gamma(z:bv64) - < ensures eq(gamma(out:bv64), old(gamma(z:bv64))) - --- - > proc @f(Gamma_z:bool, z:bv64) -> (Gamma_out:bool, out:bv64) { } - > requires Gamma_z:bool - > ensures eq(Gamma_out:bool, old(Gamma_z:bool)) - 18,19c24,26 - < (var out:bv64=out) := call @h(a=z:bv64, b=bvmul(z:bv64, z:bv64)); - < var out:bv64 := out:bv64; - --- - > (var Gamma_out:bool=Gamma_out, var out:bv64=out) := call @h(Gamma_a=Gamma_z:bool, - > Gamma_b=Gamma_z:bool, a=z:bv64, b=bvmul(z:bv64, z:bv64)); - > (var Gamma_out:bool := Gamma_out:bool, var out:bv64 := out:bv64); - 23,25c30,32 - < proc @g(a:bv64) -> (out:bv64) { } - < requires gamma(a:bv64) - < ensures eq(gamma(out:bv64), old(gamma(a:bv64))) - --- - > proc @g(Gamma_a:bool, a:bv64) -> (Gamma_out:bool, out:bv64) { } - > requires Gamma_a:bool - > ensures eq(Gamma_out:bool, old(Gamma_a:bool)) - 29,30c36,38 - < (var out:bv64=out) := call @h(a=a:bv64, b=bvsub(a:bv64, 0x1:bv64)); - < var out:bv64 := out:bv64; - --- - > (var Gamma_out:bool=Gamma_out, var out:bv64=out) := call @h(Gamma_a=Gamma_a:bool, - > Gamma_b=Gamma_a:bool, a=a:bv64, b=bvsub(a:bv64, 0x1:bv64)); - > (var Gamma_out:bool := Gamma_out:bool, var out:bv64 := out:bv64); - 34,37c42,45 + 34,37c34,37 < proc @h(a:bv64, b:bv64) -> (out:bv64) { } < requires booland(gamma(a:bv64), gamma(b:bv64)) < ensures boolor(boolnot(booland(old(gamma(a:bv64)), old(gamma(b:bv64)))), @@ -71,30 +16,28 @@ > requires booland(Gamma_a:bool, Gamma_b:bool) > ensures boolor(boolnot(booland(old(Gamma_a:bool), old(Gamma_b:bool))), > Gamma_out:bool) - 42c50 + 42c42 < assert gamma(a:bv64); --- > assert Gamma_a:bool; - 44c52 + 44c44 < var c:bv64 := b:bv64; --- > (var Gamma_c:bool := Gamma_b:bool, var c:bv64 := b:bv64); - 48c56 + 48c48 < assert gamma(a:bv64); --- > assert Gamma_a:bool; - 50c58,59 + 50c50,51 < (var c:bv64=out) := call @g(a=bvadd(a:bv64, b:bv64)); --- > (var Gamma_c:bool=Gamma_out, var c:bv64=out) := call @g(Gamma_a=booland(Gamma_a:bool, > Gamma_b:bool), a=bvadd(a:bv64, b:bv64)); - 53c62,65 + 53c54,57 < block %h_return [ var out:bv64 := bvadd(c:bv64, 0x1:bv64); return; ] --- > block %h_return [ > (var Gamma_out:bool := Gamma_c:bool, var out:bv64 := bvadd(c:bv64, 0x1:bv64)); > return; > ] - 54a67 - > var Gamma_$x:bool; [1] From 475aead11504175b77a4d998a6a5bed0676eb466 Mon Sep 17 00:00:00 2001 From: agle Date: Tue, 30 Jun 2026 17:47:44 +1000 Subject: [PATCH 14/22] test fixes for smtlib output --- lib/lang/check.ml | 3 +- lib/lang/expr_smt.ml | 17 +++--- lib/lang/procedure.ml | 2 +- lib/lang/program.ml | 31 ++++------- lib/lang/program.mli | 3 +- lib/loadir.ml | 7 +-- lib/transforms/boogie_prepass.ml | 5 +- lib/transforms/cf_tx.ml | 2 +- lib/transforms/function_summaries.ml | 46 +++++++++++----- lib/transforms/memory_encoding.ml | 75 ++++++++++++++++++-------- lib/transforms/memory_specification.ml | 21 ++++---- lib/util/var.ml | 19 ++++++- test/cram/expr_smt.t | 5 -- test/cram/malloc_free.t | 24 ++++----- test/cram/memory_safety.t | 28 +++++----- test/cram/roundtrip.t | 4 +- test/cram/sva.t | 6 ++- test/lang/test_expr_eval_qcheck.ml | 2 +- test/lang/test_interp.ml | 1 - test/lang/test_stmt.ml | 2 - 20 files changed, 176 insertions(+), 127 deletions(-) diff --git a/lib/lang/check.ml b/lib/lang/check.ml index f0847da0..90a803d4 100644 --- a/lib/lang/check.ml +++ b/lib/lang/check.ml @@ -109,8 +109,9 @@ let variables_wf p = Procedure.iter_blocks p (fun (_, b) -> Block.assigned_vars_iter b |> Iter.iter check_lvar) + let wf_checks p = try formal_params p; - variables_wf p + variables_wf p; with IRWellformed e -> Logs.err (fun m -> m "%s" e) diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 7021fa2e..3a7c6494 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -17,15 +17,17 @@ module SMTLib2 = struct preamble : CCSexp.t list; commands : CCSexp.t list; var_decls : var_decl VarMap.t; + var_gen : Var.generator; logics : LSet.t; } - let empty = + let empty () = { preamble = []; commands = []; var_decls = VarMap.empty; logics = LSet.empty; + var_gen = Var.mk_gen (); } type 'e t = builder -> 'e * builder @@ -86,7 +88,7 @@ module SMTLib2 = struct let commands = List.rev b.commands |> List.to_iter in preamble <+> decls <+> commands - let run (e : 'e t) = e empty + let run (e : 'e t) = e (empty ()) let extract s = let* b = get s in @@ -315,6 +317,7 @@ module SMTLib2 = struct go vardefs e let decl_var (v : Var.t) s = + let v = s.var_gen.of_var v in VarMap.find_opt v s.var_decls |> function | Some { decl_cmd; var } -> (var, s) | None -> @@ -451,7 +454,7 @@ module SMTLib2 = struct let e = (BasilExpr.rewrite_typed_two Algsimp.drop_assoc) e in BasilExpr.cata smt_alg e b - let of_bexpr e = fst @@ (bind_of_bexpr e) empty + let of_bexpr e = fst @@ (bind_of_bexpr e) (empty ()) let trans_decl (decl : Program.declaration) = let* x = return () in @@ -523,11 +526,11 @@ module SMTLib2 = struct let* _ = assert_bexpr e in add_command (list [ atom "check-sat" ]) in - let ex = (extract x) empty in + let ex = (extract x) (empty ()) in fst ex let%expect_test _ = - let assert_bexpr e = fst @@ (assert_bexpr e |> extract) empty in + let assert_bexpr e = fst @@ (assert_bexpr e |> extract) (empty ()) in let open BasilExpr in let e = binexp ~op:`EQ @@ -566,8 +569,8 @@ let%expect_test "datatypes" = } in - fst @@ SMTLib2.trans_decl x SMTLib2.empty |> Sexp.to_string |> print_endline; - fst @@ SMTLib2.trans_decl y SMTLib2.empty |> Sexp.to_string |> print_endline; + fst @@ SMTLib2.trans_decl x (SMTLib2.empty ()) |> Sexp.to_string |> print_endline; + fst @@ SMTLib2.trans_decl y (SMTLib2.empty ()) |> Sexp.to_string |> print_endline; [%expect {| (declare-datatype Opaque ()) diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index cca82a06..1655e372 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -248,7 +248,7 @@ end = struct match local_id_gen with | Some g -> g | None -> - let g = ID.make_gen () in + let g = ID.make_gen ~scope_name:(ID.name id) () in (* Oh no: we could have used a _different_ generator to build the in-params *) StringMap.iter (fun k v -> ignore @@ g.decl_exn k) formal_in_params; StringMap.iter (fun k v -> ignore @@ g.decl_exn k) formal_out_params; diff --git a/lib/lang/program.ml b/lib/lang/program.ml index 295e24db..e5858c86 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -62,7 +62,7 @@ let decl_id = function | Function { binding } -> Var.id binding | Procedure { definition } -> Procedure.id definition -let decl_var = function +let decl_bound_var = function | Variable { binding } -> Some binding | Function { binding } -> Some binding | _ -> None @@ -204,11 +204,11 @@ let declare_name name prog = prog.global_names.decl_or_get name let get_id_by_name name prog = prog.global_names.get_id name let remove_decl p decl = - let d = p.global_names.decl_or_get (decl_binding decl) in + let d = (decl_id decl) in { p with declarations = IDMap.remove d p.declarations } let update_decl ?(attrib = StringMap.empty) p decl = - let id = p.global_names.decl_or_get (decl_binding decl) in + let id = decl_id decl in { p with declarations = IDMap.add id decl p.declarations } let add_proc p prog = @@ -287,8 +287,7 @@ let flat_map_decls f p = (fun prog (i, decl) -> let ex = ref false in let update_decl prog decl = - get_decl_by_name_id (decl_binding decl) prog - |> Option.iter (fun (id, _) -> if ID.equal id i then ex := true); + (decl_id decl |> fun id -> if ID.equal id i then ex := true); update_decl prog decl in let next = f i decl in @@ -304,25 +303,15 @@ let pretty_to_chan chan (p : t) = Containers_pp.Pretty.to_format ~width:80 fmt p; Format.flush fmt () -(* - -Variable { binding = v; attrib; classification } - - *) - let add_decl p decl = + decl_bound_var decl |> Option.iter (fun v -> assert (Var.is_global v)); { p with declarations = IDMap.add (decl_id decl) decl p.declarations } -let decl_global p name f = - let id : ID.t = p.global_names.decl_exn name in - let decl = f id in - add_decl p decl - (** add var decl for with id exising in generator *) let add_var_decl p ?(attrib = Attrib.empty) ?classification v = - assert (Var.is_global v) ; + assert (Var.is_global v); let id = Var.id v in - (try p.global_names.get_name (ID.index id) |> ignore + (try assert (ID.equal id (p.global_names.get_name (ID.index id))) with Not_found -> failwith "Id not created with programs' generator"); { p with @@ -342,10 +331,10 @@ let decl_global_var p ?(attrib = StringMap.empty) ?(classification = None) name let global_ids p = p.global_names let decl_or_get_var p name scope typ = - let id : ID.t = p.global_names.decl_or_get name in - IDMap.find_opt id p.declarations |> function + let vr = (var_generator p).with_name name ~access:scope typ in + IDMap.find_opt (Var.id vr) p.declarations |> function | Some (Variable { binding }) -> (p, binding) - | _ -> decl_global_var p name scope typ + | _ -> (add_var_decl p vr, vr) let decl_typ ?(attrib = StringMap.empty) p t = match t with diff --git a/lib/lang/program.mli b/lib/lang/program.mli index 4bda72bb..c9cf56e8 100644 --- a/lib/lang/program.mli +++ b/lib/lang/program.mli @@ -95,7 +95,6 @@ val map_decls : (ID.t -> declaration -> declaration) -> t -> t val filter_map_decls : (ID.t -> declaration -> declaration option) -> t -> t val flat_map_decls : (ID.t -> declaration -> declaration Iter.t) -> t -> t val pretty_to_chan : out_channel -> t -> unit -val decl_global : t -> string -> (ID.t -> declaration) -> t val add_decl : t -> declaration -> t val var_generator : t -> Var.generator @@ -111,6 +110,8 @@ val decl_global_var : Types.t -> t * Var.t +val decl_bound_var : declaration -> Var.t option + val decl_or_get_var : t -> string -> Var.access_tag -> Types.t -> t * Var.t val global_ids : t -> ID.generator val decl_typ : ?attrib:'a Types.StringMap.t -> t -> Types.t -> t diff --git a/lib/loadir.ml b/lib/loadir.ml index 3c6a5b40..185bafbe 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -294,7 +294,7 @@ module BasilASTLoader = struct attrib, spec, definition ) -> - let ids = ID.make_gen () in + let ids = ID.make_gen ~scope_name:id () in let vg = Var.mk_gen ~id_generator:ids ~scope:`Local () in let proc_id = Program.declare_name id prog.prog in let formal_in_params_order = List.map (param_to_formal vg) in_params in @@ -1893,7 +1893,6 @@ proc @c() -> () |} in print_endline "globals: "; - print_endline (Program.global_vars prog.prog |> Iter.to_string Var.show); let res = analyse prog.prog in Iter.iter (fun (pid, proc) -> @@ -1902,10 +1901,6 @@ proc @c() -> () [%expect {| globals: - { Var.name = ("R0", 0); scope = (Var.Global ""); typ = bv64; tags = Var.None - }, { Var.name = ("R1", 1); scope = (Var.Global ""); typ = bv64; tags = Var.None - }, { Var.name = ("mem", 2); scope = (Var.Global ""); typ = (bv64->bv8); - tags = Var.Shared } @entry: read: $R0:bv64,$R1:bv64,$mem:(bv64->bv8) written: $R0:bv64,$mem:(bv64->bv8) diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index 99489cf6..f46f5244 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -401,7 +401,7 @@ module Instructions = struct unique_stores_loads prog |> Iter.filter_map (store_load_decl - (Var.mk_gen ~id_generator:(Program.global_ids prog) ())) + (Program.var_generator prog)) |> Iter.fold Program.add_decl prog end @@ -563,7 +563,8 @@ module Normalise = struct end let transform (p : Program.t) = - p |> Normalise.replace_functions |> Normalise.replace_exprs + p |> Normalise.replace_functions + |> Normalise.replace_exprs |> Instructions.transform_add_store_load_decls |> Normalise.replace_stmts |> Builtins.transform_add_builtin_decls |> Builtins.transform_builtin_decls diff --git a/lib/transforms/cf_tx.ml b/lib/transforms/cf_tx.ml index 3934b77c..282c7161 100644 --- a/lib/transforms/cf_tx.ml +++ b/lib/transforms/cf_tx.ml @@ -65,7 +65,7 @@ let simplify_prog_exprs rewriter ?visit (p : Program.t) = let to_smt (r : Expr.BasilExpr.rwinfo) = let open Lang.Expr_smt in let cexpr = Expr.BasilExpr.binexp ~op:`NEQ r.from r.into in - let smt = snd @@ SMTLib2.assert_bexpr cexpr SMTLib2.empty in + let smt = snd @@ SMTLib2.assert_bexpr cexpr (SMTLib2.empty ()) in smt |> SMTLib2.to_sexp ~set_logic:false let online_check visit (solver : Bincaml_util.Smt.Solver.t) diff --git a/lib/transforms/function_summaries.ml b/lib/transforms/function_summaries.ml index a7d5dd81..d37ef72a 100644 --- a/lib/transforms/function_summaries.ml +++ b/lib/transforms/function_summaries.ml @@ -54,7 +54,7 @@ let redundant proc (solver : Bincaml_util.Smt.Solver.t) p ps = in let open Expr_smt in let s = - SMTLib2.assert_bexpr q SMTLib2.empty + SMTLib2.assert_bexpr q (SMTLib2.empty ()) |> snd |> SMTLib2.to_sexp ~set_logic:false in @@ -143,18 +143,31 @@ let add_summary summary (proc : Program.proc) = Procedure.set_specification proc spec let add_decls solver prog = - Program.declarations prog |> Iter.from_iter |> Iter.map snd - |> Iter.filter - Program.( - function - | Type { binding } -> true - | Variable { binding } -> Var.is_const binding - | Function { binding } -> Var.is_const binding - | Procedure { definition } -> false) - |> Iter.map (fun d -> Expr_smt.SMTLib2.trans_decl d Expr_smt.SMTLib2.empty) - |> Iter.map fst - |> fun i -> - Iter.for_each i (fun s -> Bincaml_util.Smt.Solver.add_command solver s) + let decls = + Program.declarations prog |> Iter.from_iter |> Iter.map snd + |> Iter.filter + Program.( + function + | Type { binding } -> true + | Variable { binding } -> Var.is_const binding + | Function { binding } -> Var.is_const binding + | Procedure { definition } -> false) + |> Iter.persistent + in + + let add_decls ds = + ds + |> Iter.map (fun d -> Expr_smt.SMTLib2.trans_decl d (Expr_smt.SMTLib2.empty ())) + |> Iter.map fst + |> fun i -> + Iter.for_each i (fun s -> Bincaml_util.Smt.Solver.add_command solver s) + in + (decls + |> Iter.filter Program.(function Type _ -> true | _ -> false) + |> add_decls); + decls + |> Iter.filter Program.(function Type _ -> false | _ -> true) + |> add_decls let intraproc_transform_proc (prog : Program.t) (proc : Program.proc) = let solver = @@ -280,6 +293,12 @@ let solve_component (solver : Bincaml_util.Smt.Solver.t) g (prog : Program.t) IDMap.add pid (append_summary (IDMap.find pid res) (sol pid)) res) component res +let progs_decls_global p = + assert ( + Program.declarations p + |> Iter.for_all (fun (k, v) -> + Program.decl_bound_var v |> Option.for_all Var.is_global)) + let interproc_transform (prog : Program.t) = let call_graph = Program.CallGraph.make_call_graph prog in let sccs = Program.CallGraph.Scc.scc_list call_graph in @@ -290,6 +309,7 @@ let interproc_transform (prog : Program.t) = log = Bincaml_util.Smt.Config.quiet_log; } in + progs_decls_global prog; add_decls solver prog; let summaries = Program.procs prog diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index aa7b0d05..b1b118d4 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -8,12 +8,17 @@ let dead = Bitvec.of_int 2 ~size:2 type function_body = Var.generator * Expr.BasilExpr.t -module Globals = struct +module GlobalsF (N : sig + val global_ids : Var.generator +end) = +struct open Var let mem_encoding_typ_name = "memory_encoding" let mem_encoding_typ = Types.Variable mem_encoding_typ_name - let mem_encoding v = v.with_name "mem_encoding" ~access:None mem_encoding_typ + + let mem_encoding = + N.global_ids.with_name "mem_encoding" ~access:None mem_encoding_typ end module Calls (N : sig @@ -23,14 +28,17 @@ struct open Var open BasilExpr - let v = N.global_ids + (* instantiating this first should put the ids in the right order *) + module Globals = GlobalsF (N) (** [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 (v.with_name "me_addr_is_heap" ~access:Var.Const Types.Boolean)) + (rvar + (N.global_ids.with_name "me_addr_is_heap" ~access:Var.Const + Types.Boolean)) args (** [alloc_base args] returns the base address of a supplied allocation id. @@ -39,7 +47,8 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "me_alloc_base" ~access:Var.Const (Types.Bitvector 64))) + (N.global_ids.with_name "me_alloc_base" ~access:Var.Const + (Types.Bitvector 64))) args (** [alloc_live args] returns the liveness of an allocation. Returns value is @@ -49,7 +58,8 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "me_alloc_live" ~access:Var.Const (Types.Bitvector 2))) + (N.global_ids.with_name "me_alloc_live" ~access:Var.Const + (Types.Bitvector 2))) args (** [alloc_size args] returns the size of an allocation. args(0) is the memory @@ -58,7 +68,8 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "me_alloc_size" ~access:Var.Const (Types.Bitvector 64))) + (N.global_ids.with_name "me_alloc_size" ~access:Var.Const + (Types.Bitvector 64))) args (** [addr_alloc args] returns the allocation id of an address. args(0) is the @@ -67,7 +78,8 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "me_addr_alloc" ~access:Var.Const (Types.Bitvector 64))) + (N.global_ids.with_name "me_addr_alloc" ~access:Var.Const + (Types.Bitvector 64))) args (** [addr_offset args] returns the offset an address is into its allocation. @@ -76,7 +88,8 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "me_addr_offset" ~access:Var.Const (Types.Bitvector 64))) + (N.global_ids.with_name "me_addr_offset" ~access:Var.Const + (Types.Bitvector 64))) args (** [alloc_size_update args] returns a new memory encoding with the size of an @@ -86,7 +99,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "me_alloc_size_update" ~access:Var.Const + (N.global_ids.with_name "me_alloc_size_update" ~access:Var.Const Globals.mem_encoding_typ)) args @@ -97,7 +110,7 @@ struct apply_fun ?attrib ~func: (rvar - (v.with_name "me_alloc_live_update" ~access:Var.Const + (N.global_ids.with_name "me_alloc_live_update" ~access:Var.Const Globals.mem_encoding_typ)) args @@ -106,7 +119,9 @@ struct allocated at. args(3) is the size of the allocation. *) let allocate ?attrib args = apply_fun ?attrib - ~func:(rvar (v.with_name "me_allocate" ~access:Var.Const Types.Boolean)) + ~func: + (rvar + (N.global_ids.with_name "me_allocate" ~access:Var.Const Types.Boolean)) args (** [can_alloc args] Returns whether an alloc, performed by [allocate], is @@ -115,7 +130,9 @@ struct let can_alloc ?attrib args = apply_fun ?attrib ~func: - (rvar (v.with_name "me_can_allocate" ~access:Var.Const Types.Boolean)) + (rvar + (N.global_ids.with_name "me_can_allocate" ~access:Var.Const + Types.Boolean)) args (** [init_encoding args] Returns if a memory encoding is initialized. args(0) @@ -123,7 +140,9 @@ struct let init_encoding ?attrib args = apply_fun ?attrib ~func: - (rvar (v.with_name "me_init_encoding" ~access:Var.Const Types.Boolean)) + (rvar + (N.global_ids.with_name "me_init_encoding" ~access:Var.Const + Types.Boolean)) args (** [valid_access args] Checks if an access is valid. args(0) is the memory @@ -132,13 +151,21 @@ struct let valid_access ?attrib args = apply_fun ?attrib ~func: - (rvar (v.with_name "me_valid_access" ~access:Var.Const Types.Boolean)) + (rvar + (N.global_ids.with_name "me_valid_access" ~access:Var.Const + Types.Boolean)) args end module type MemoryEncoding = sig val global_ids : Var.generator + module Globals : sig + val mem_encoding_typ_name : string + val mem_encoding_typ : Types.t + val mem_encoding : Var.t + end + module Locals : sig val mem_encoding : Var.generator -> Var.t val mem_encoding_out : Var.generator -> Var.t @@ -164,15 +191,16 @@ module type MemoryEncoding = sig end module MemoryEncoder (Encoding : MemoryEncoding) = struct + module Globals = Encoding.Globals + let decl_global ?(attrib = Attrib.empty) (p : Program.t) (name : string) (bindings : (Var.generator -> Var.t) list) (body : function_body) = - let name = "$" ^ name in - let var_gen, body = body in - let bindings = List.map (fun f -> f var_gen) bindings in + let local_var_gen, body = body in + let bindings = List.map (fun f -> f local_var_gen) bindings in let decl = Lang.Program.Function { - var_gen; + var_gen = local_var_gen; binding = (Program.var_generator p).with_name name ~access:Const (Types.curry (List.map Var.typ bindings) @@ -198,7 +226,7 @@ module MemoryEncoder (Encoding : MemoryEncoding) = struct Lang.Program.add_decl p (Lang.Program.Variable { - binding = Globals.mem_encoding (Program.var_generator p); + binding = Globals.mem_encoding; attrib = Attrib.empty; classification = None; }) @@ -327,9 +355,9 @@ end module FlatMemory (M : IDAllocs) : MemoryEncoding = struct open BasilExpr module Calls = Calls (M) + module Globals = Calls.Globals - let v = M.global_ids - let global_ids = v + let global_ids = (M.global_ids) let mem_encoding_type : Types.t = Types.Sort @@ -635,6 +663,7 @@ end module SplitMemory (M : IDAllocs) : MemoryEncoding = struct open BasilExpr module Calls = Calls (M) + module Globals = Calls.Globals let v = M.global_ids let global_ids = v @@ -876,4 +905,4 @@ let flat_transform (p : Program.t) = end in let module E = MemoryEncoder (FlatMemory (I)) in - E.transform p |> fun prog -> Spec_modifies.set_modsets prog + E.transform p |> fun prog -> Spec_modifies.set_modsets prog diff --git a/lib/transforms/memory_specification.ml b/lib/transforms/memory_specification.ml index 94b3862a..3bb69288 100644 --- a/lib/transforms/memory_specification.ml +++ b/lib/transforms/memory_specification.ml @@ -8,6 +8,7 @@ module T (I : sig end) = struct module Calls = Calls (I) + module Globals = Calls.Globals let make_msg_attrib msg = StringMap.of_list @@ -30,7 +31,7 @@ struct let transform_main (p : Program.proc) = (* TODO: Specify Gammas Oneday *) - let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding I.global_ids in + let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding in let spec = Procedure.specification p in let i = Procedure.fresh_var p ~name:"i" ~pure:true (Types.Bitvector 64) in Procedure.set_specification p @@ -58,15 +59,15 @@ struct (BasilExpr.bvconst live)); ]; modifies_globs = - spec.modifies_globs @ [ Globals.mem_encoding I.global_ids ]; + spec.modifies_globs @ [ Globals.mem_encoding ]; captures_globs = - spec.captures_globs @ [ Globals.mem_encoding I.global_ids ]; + spec.captures_globs @ [ Globals.mem_encoding ]; } let transform_malloc p = (* TODO: Specify Gammas Oneday *) let spec = Procedure.specification p in - let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding I.global_ids in + let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding in let pid = Var.mk_gen ~id_generator:(Procedure.local_ids p) () in let r_in = r_in pid in let r_out = r_out pid in @@ -93,16 +94,16 @@ struct [ old @@ mem_encoding; mem_encoding; r_out 0; r_in 0 ]; ]; modifies_globs = - spec.modifies_globs @ [ Globals.mem_encoding I.global_ids ]; + spec.modifies_globs @ [ Globals.mem_encoding ]; captures_globs = - spec.captures_globs @ [ Globals.mem_encoding I.global_ids ]; + spec.captures_globs @ [ Globals.mem_encoding ]; } let transform_free p = (* TODO: Specify Gammas Oneday *) let spec = Procedure.specification p in let open BasilExpr in - let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding I.global_ids in + let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding in let pid = Var.mk_gen ~id_generator:(Procedure.local_ids p) () in let r_in = r_in pid in Procedure.set_specification p @@ -148,9 +149,9 @@ struct ]); ]; modifies_globs = - spec.modifies_globs @ [ Globals.mem_encoding I.global_ids ]; + spec.modifies_globs @ [ Globals.mem_encoding ]; captures_globs = - spec.captures_globs @ [ Globals.mem_encoding I.global_ids ]; + spec.captures_globs @ [ Globals.mem_encoding ]; } let transform_stmt (s : Program.stmt) = @@ -167,7 +168,7 @@ struct BasilExpr.( Calls.valid_access [ - rvar (Globals.mem_encoding I.global_ids); + rvar (Globals.mem_encoding ); addr; bv_of_int ~size:64 (size / 8); ]); diff --git a/lib/util/var.ml b/lib/util/var.ml index c8e70739..e9e322d4 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -25,6 +25,11 @@ let typ (e : t) = e.typ let is_local (v : t) = match v.scope with Local _ -> true | Global _ -> false let is_global (v : t) = match v.scope with Global _ -> true | Local _ -> false let name (e : t) = if is_global e then "$" ^ ID.name e.name else ID.name e.name + +let name_scoped (e : t) = + let sn = e.scope |> function Local n -> n | Global n -> n in + name e ^ sn + let to_string v = name v ^ ":" ^ Types.to_string @@ typ v let pp fmt v = Format.pp_print_string fmt (to_string v) let pretty v = Containers_pp.text (to_string v) @@ -51,6 +56,7 @@ type generator = { fresh : ?name:string -> ?access:access_tag -> Types.t -> t; (** generate a fresh unique name optional string prefix hint *) with_name : string -> ?access:access_tag -> Types.t -> t; + of_var: t -> t; (** Create or return variable with name*) create_exn : string -> ?access:access_tag -> Types.t -> t; (** Create variable or throw exception if it was previously declared *) @@ -69,7 +75,8 @@ open struct let create name id_gen ?(access = None) typ = (* disallow creating local const as its too hard to have declaration order *) - { name; scope = id_gen; typ; tags = access } + let tags = match (id_gen, access) with Local _, _ -> None | _, o -> o in + { name; scope = id_gen; typ; tags } let fresh gt (gen : ID.generator) sgl name ?access typ = let name = force_sigil sgl name in @@ -81,6 +88,9 @@ open struct let name = id_gen.decl_or_get name in create name gt ?access typ + let of_var gt (id_gen : ID.generator) sgl v = + with_name gt (id_gen) sgl (name v) ~access:(access v) (typ v) + let create_exn gt (id_gen : ID.generator) sgl name ?access typ = let name = force_sigil sgl name in let name = id_gen.decl_exn name in @@ -90,7 +100,11 @@ end let mk_gen ?id_generator ?(req_sigil = Option.None) ?(scope = `Local) ?(default_name = "v") () = let id_gen = Option.get_or ~default:(ID.make_gen ()) id_generator in - let gt = match scope with `Local -> Local "" | `Global -> Global "" in + let gt = + match scope with + | `Local -> Local id_gen.gen_id + | `Global -> Global id_gen.gen_id + in let sgl = match (req_sigil, scope) with | Some s, _ -> s @@ -108,5 +122,6 @@ let mk_gen ?id_generator ?(req_sigil = Option.None) ?(scope = `Local) fresh; with_name = with_name gt id_gen sgl; create_exn = create_exn gt id_gen sgl; + of_var = of_var gt id_gen sgl; generator = id_gen; } diff --git a/test/cram/expr_smt.t b/test/cram/expr_smt.t index 155be2bb..dd7506ef 100644 --- a/test/cram/expr_smt.t +++ b/test/cram/expr_smt.t @@ -90,9 +90,4 @@ Check concat rewrites work < bvshl(var2_4206400_bv64:bv64, 0x0:bv64)); --- > $R0:bv64 := bvor(var1_4206400_bv64:bv64, var2_4206400_bv64:bv64); - 95a31,34 - > var $R28:bv64; - > var $R0:bv64; - > var $R30:bv64; - > var $__BranchTaken:bv1; [1] diff --git a/test/cram/malloc_free.t b/test/cram/malloc_free.t index c72b9bda..6dbccaad 100644 --- a/test/cram/malloc_free.t +++ b/test/cram/malloc_free.t @@ -1,17 +1,24 @@ - $ bincaml script malloc_free.sexp + $ bincaml script malloc_free.sexp -v (load-il ../../examples/memory/malloc_free.il) (run-transforms ssa split-memory-encoding) + bincaml: [DEBUG] Starting ssa + bincaml: [DEBUG] Starting split-memory-encoding (run-transforms memory-specification flatten-phis) + bincaml: [DEBUG] Starting memory-specification + bincaml: [DEBUG] Starting flatten-phis (dump-boogie good.bpl) (load-il ../../examples/memory/malloc_free_oob.il) (run-transforms ssa split-memory-encoding) + bincaml: [DEBUG] Starting ssa + bincaml: [DEBUG] Starting split-memory-encoding (run-transforms memory-specification flatten-phis) + bincaml: [DEBUG] Starting memory-specification + bincaml: [DEBUG] Starting flatten-phis (dump-boogie bad.bpl) $ cat ./good.bpl var $mem: [bv64]bv8; var $stack: [bv64]bv8; - datatype memory_encoding {MemEncoding(alloc_live: [bv64]bv2, alloc_size: [bv64]bv64, addr_is_heap: [bv64]bool)} var $mem_encoding: memory_encoding; function {:extern } {:inline } $me_addr_alloc(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { addr @@ -37,6 +44,7 @@ function {:extern } {:inline } $me_addr_offset(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { $bvand_bv64(addr, 4294967295bv64) } + datatype memory_encoding {MemEncoding(alloc_live: [bv64]bv2, alloc_size: [bv64]bv64, addr_is_heap: [bv64]bool)} function {:extern } {:inline } $me_can_allocate(mem_encoding: memory_encoding, addr: bv64, size: bv64) returns (bool) { (((($me_addr_is_heap(mem_encoding, addr) && @@ -128,10 +136,6 @@ function {:bvbuiltin "bvand"} {:extern } $bvand_bv64(bv64, bv64) returns (bv64); function {:bvbuiltin "bvule"} {:extern } $bvule_bv64_bv64_bool(bv64, bv64) returns (bool); function {:bvbuiltin "bvult"} {:extern } $bvult_bv64_bv64_bool(bv64, bv64) returns (bool); - function {:bvbuiltin "bvadd"} {:extern } $bvadd_bv64(bv64, bv64) returns (bv64); - function {:bvbuiltin "bvand"} {:extern } $bvand_bv64(bv64, bv64) returns (bv64); - function {:bvbuiltin "bvule"} {:extern } $bvule_bv64_bv64_bool(bv64, bv64) returns (bool); - function {:bvbuiltin "bvult"} {:extern } $bvult_bv64_bv64_bool(bv64, bv64) returns (bool); procedure p$main_2276(R0_in: bv64, R16_in: bv64, R17_in: bv64, R1_in: bv64, R29_in: bv64, R30_in: bv64, R31_in: bv64, _PC_in: bv64) returns (R0_out: bv64, @@ -253,7 +257,6 @@ $ cat ./bad.bpl var $mem: [bv64]bv8; var $stack: [bv64]bv8; - datatype memory_encoding {MemEncoding(alloc_live: [bv64]bv2, alloc_size: [bv64]bv64, addr_is_heap: [bv64]bool)} var $mem_encoding: memory_encoding; function {:extern } {:inline } $me_addr_alloc(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { addr @@ -279,6 +282,7 @@ function {:extern } {:inline } $me_addr_offset(mem_encoding: memory_encoding, addr: bv64) returns (bv64) { $bvand_bv64(addr, 4294967295bv64) } + datatype memory_encoding {MemEncoding(alloc_live: [bv64]bv2, alloc_size: [bv64]bv64, addr_is_heap: [bv64]bool)} function {:extern } {:inline } $me_can_allocate(mem_encoding: memory_encoding, addr: bv64, size: bv64) returns (bool) { (((($me_addr_is_heap(mem_encoding, addr) && @@ -370,10 +374,6 @@ function {:bvbuiltin "bvand"} {:extern } $bvand_bv64(bv64, bv64) returns (bv64); function {:bvbuiltin "bvule"} {:extern } $bvule_bv64_bv64_bool(bv64, bv64) returns (bool); function {:bvbuiltin "bvult"} {:extern } $bvult_bv64_bv64_bool(bv64, bv64) returns (bool); - function {:bvbuiltin "bvadd"} {:extern } $bvadd_bv64(bv64, bv64) returns (bv64); - function {:bvbuiltin "bvand"} {:extern } $bvand_bv64(bv64, bv64) returns (bv64); - function {:bvbuiltin "bvule"} {:extern } $bvule_bv64_bv64_bool(bv64, bv64) returns (bool); - function {:bvbuiltin "bvult"} {:extern } $bvult_bv64_bv64_bool(bv64, bv64) returns (bool); procedure p$main_2276(R0_in: bv64, R16_in: bv64, R17_in: bv64, R1_in: bv64, R29_in: bv64, R30_in: bv64, R31_in: bv64, _PC_in: bv64) returns (R0_out: bv64, @@ -490,7 +490,7 @@ $ boogie ./bad.bpl Memory Error: Invalid Access Execution trace: - ./bad.bpl(148,3): b#main_entry + ./bad.bpl(144,3): b#main_entry Boogie program verifier finished with 0 verified, 1 error diff --git a/test/cram/memory_safety.t b/test/cram/memory_safety.t index 46cc7b76..4462128e 100644 --- a/test/cram/memory_safety.t +++ b/test/cram/memory_safety.t @@ -23,19 +23,19 @@ $ boogie out.bpl Memory Error: Invalid Free (object not live) Execution trace: - out.bpl(194,3): b#inputs + out.bpl(190,3): b#inputs Memory Error: Invalid Free (not base address) Execution trace: - out.bpl(239,3): b#inputs + out.bpl(235,3): b#inputs Memory Error: Invalid Access Execution trace: - out.bpl(274,3): b#inputs + out.bpl(270,3): b#inputs Memory Error: Invalid Access Execution trace: - out.bpl(323,3): b#inputs + out.bpl(319,3): b#inputs Memory Error: Memory Leak Execution trace: - out.bpl(371,3): b#inputs + out.bpl(367,3): b#inputs Boogie program verifier finished with 1 verified, 5 errors @@ -65,25 +65,25 @@ $ boogie out.bpl Memory Error: Invalid Free (object not live) Execution trace: - out.bpl(230,3): b#inputs + out.bpl(226,3): b#inputs Memory Error: Invalid Free (not base address) Execution trace: - out.bpl(275,3): b#inputs + out.bpl(271,3): b#inputs Memory Error: Invalid Free (object not live) Execution trace: - out.bpl(275,3): b#inputs - out.bpl(281,5): Error: a precondition for this call could not be proved - out.bpl(150,3): Related location: this is the precondition that could not be proved + out.bpl(271,3): b#inputs + out.bpl(277,5): Error: a precondition for this call could not be proved + out.bpl(146,3): Related location: this is the precondition that could not be proved Execution trace: - out.bpl(275,3): b#inputs + out.bpl(271,3): b#inputs Memory Error: Invalid Access Execution trace: - out.bpl(310,3): b#inputs + out.bpl(306,3): b#inputs Memory Error: Invalid Access Execution trace: - out.bpl(359,3): b#inputs + out.bpl(355,3): b#inputs Memory Error: Memory Leak Execution trace: - out.bpl(407,3): b#inputs + out.bpl(403,3): b#inputs Boogie program verifier finished with 1 verified, 7 errors diff --git a/test/cram/roundtrip.t b/test/cram/roundtrip.t index 45ec3210..97da1c57 100644 --- a/test/cram/roundtrip.t +++ b/test/cram/roundtrip.t @@ -55,8 +55,8 @@ Memassign repr return; ] ]; - let $a : uninterpSort = UninterpSort; - let $b : record = (Record)(0x1:bv64, 0x2:bv64, 0x3:bv64); + let $a : uninterpSort = $UninterpSort; + let $b : record = ($Record)(0x1:bv64, 0x2:bv64, 0x3:bv64); let $three : bv64 = let func (a:bv64) : bv64 = (bvadd(a:bv64, 0x1:bv64)) in ((func:(bv64->bv64))(($mul_2)(0x2:bv64, 0x1:bv64))); prog entry @main_4196164; diff --git a/test/cram/sva.t b/test/cram/sva.t index 03ea72b9..390bcbfc 100644 --- a/test/cram/sva.t +++ b/test/cram/sva.t @@ -2,5 +2,7 @@ (load-il ../../examples/irreducible_loop_1.il) (run-transforms sva) bincaml: [WARNING] Invariants not satisfied during 'sva'. Needs [SSA] but only have []. - (R31_in->(Stack(@puts_1584)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@puts_1584_{ Var.V.name = "R30_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⟧, _->⊥), _->⊥) - (R31_in->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@main_1876_{ Var.V.name = "R30_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⟧, _->⊥), $CF->(Loaded->⊤, _->⊥), $NF->(Loaded->⊤, _->⊥), $R0->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $R1->(Loaded->⊤, _->⊥), $R29->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $R30->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $VF->(Loaded->⊤, _->⊥), $ZF->(Loaded->⊤, _->⊥), load18->(Loaded->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), #5->(Loaded->⊤, _->⊥), load19->(Loaded->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), load21->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), load22->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), load20->(Loaded->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), #6->(Loaded->⊤, _->⊥), _->⊥) + (R31_in->(Stack(@puts_1584)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@puts_1584_{ Var.name = ("R30_in", 1); scope = (Var.Local "@puts_1584"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_in->(Par(@puts_1584_{ Var.name = ("R29_in", 2); scope = (Var.Local "@puts_1584"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), _->⊥) + (#4->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), load18->(Loaded->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), #5->(Loaded->⊤, _->⊥), $NF->(Loaded->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), $R0->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $R1->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $R29->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $R30->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_in->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Loaded->⊤, _->⊥), R29_in->(Loaded->⊤, _->⊥), _->⊥) diff --git a/test/lang/test_expr_eval_qcheck.ml b/test/lang/test_expr_eval_qcheck.ml index df87dcf6..59be4b59 100644 --- a/test/lang/test_expr_eval_qcheck.ml +++ b/test/lang/test_expr_eval_qcheck.ml @@ -159,7 +159,7 @@ let check_smt = let query = "(set-logic QF_BV)\n(set-option :print-success true)\n" ^ Sexp.to_string - (Expr_smt.SMTLib2.add_assert check_p Expr_smt.SMTLib2.empty |> fst) + (Expr_smt.SMTLib2.add_assert check_p (Expr_smt.SMTLib2.empty () ) |> fst) ^ "\n(exit)" in check_success_smt query diff --git a/test/lang/test_interp.ml b/test/lang/test_interp.ml index 7db229b7..535857cc 100644 --- a/test/lang/test_interp.ml +++ b/test/lang/test_interp.ml @@ -22,7 +22,6 @@ let%expect_test "fold_block" = (); [%expect {| - Warn: global undeclared $mem assuming mutable unshared PC= test::Return Stack diff --git a/test/lang/test_stmt.ml b/test/lang/test_stmt.ml index e181ad46..0b724e14 100644 --- a/test/lang/test_stmt.ml +++ b/test/lang/test_stmt.ml @@ -55,8 +55,6 @@ let%expect_test "fold_block" = (); [%expect {| - Warn: global undeclared $stack assuming mutable unshared - Warn: global undeclared $mem assuming mutable unshared $stack:(bv64->bv8) := store le $stack:(bv64->bv8) bvadd(R31_in:bv64, 0xfffffffffffffffc:bv64) extract(32,0, R0_in:bv64) 32 var load45_1:bv32 := load le $stack:(bv64->bv8) bvadd(R31_in:bv64, From 312498c0f81faddcad4627171b37a84b047036aa Mon Sep 17 00:00:00 2001 From: agle Date: Tue, 30 Jun 2026 18:02:41 +1000 Subject: [PATCH 15/22] rm redundant file --- lib/lang/check.ml | 3 +- lib/lang/dune | 1 - lib/lang/expr_smt.ml | 6 ++- lib/lang/program.ml | 2 +- lib/lang/program.mli | 1 - lib/lang/rewrite.ml | 74 -------------------------- lib/transforms/boogie_prepass.ml | 2 +- lib/transforms/cf_tx.ml | 5 ++ lib/transforms/function_summaries.ml | 7 +-- lib/transforms/memory_encoding.ml | 2 +- lib/transforms/memory_specification.ml | 22 +++----- lib/util/var.ml | 5 +- 12 files changed, 27 insertions(+), 103 deletions(-) delete mode 100644 lib/lang/rewrite.ml diff --git a/lib/lang/check.ml b/lib/lang/check.ml index 90a803d4..f0847da0 100644 --- a/lib/lang/check.ml +++ b/lib/lang/check.ml @@ -109,9 +109,8 @@ let variables_wf p = Procedure.iter_blocks p (fun (_, b) -> Block.assigned_vars_iter b |> Iter.iter check_lvar) - let wf_checks p = try formal_params p; - variables_wf p; + variables_wf p with IRWellformed e -> Logs.err (fun m -> m "%s" e) diff --git a/lib/lang/dune b/lib/lang/dune index 063af74f..e2cd189a 100644 --- a/lib/lang/dune +++ b/lib/lang/dune @@ -2,7 +2,6 @@ (public_name bincaml.ast) (name lang) (modules - rewrite abstract_expr attrib spec_modifies diff --git a/lib/lang/expr_smt.ml b/lib/lang/expr_smt.ml index 3a7c6494..d9df7fac 100644 --- a/lib/lang/expr_smt.ml +++ b/lib/lang/expr_smt.ml @@ -569,8 +569,10 @@ let%expect_test "datatypes" = } in - fst @@ SMTLib2.trans_decl x (SMTLib2.empty ()) |> Sexp.to_string |> print_endline; - fst @@ SMTLib2.trans_decl y (SMTLib2.empty ()) |> Sexp.to_string |> print_endline; + fst @@ SMTLib2.trans_decl x (SMTLib2.empty ()) + |> Sexp.to_string |> print_endline; + fst @@ SMTLib2.trans_decl y (SMTLib2.empty ()) + |> Sexp.to_string |> print_endline; [%expect {| (declare-datatype Opaque ()) diff --git a/lib/lang/program.ml b/lib/lang/program.ml index e5858c86..ddb53336 100644 --- a/lib/lang/program.ml +++ b/lib/lang/program.ml @@ -204,7 +204,7 @@ let declare_name name prog = prog.global_names.decl_or_get name let get_id_by_name name prog = prog.global_names.get_id name let remove_decl p decl = - let d = (decl_id decl) in + let d = decl_id decl in { p with declarations = IDMap.remove d p.declarations } let update_decl ?(attrib = StringMap.empty) p decl = diff --git a/lib/lang/program.mli b/lib/lang/program.mli index c9cf56e8..5273806d 100644 --- a/lib/lang/program.mli +++ b/lib/lang/program.mli @@ -111,7 +111,6 @@ val decl_global_var : t * Var.t val decl_bound_var : declaration -> Var.t option - val decl_or_get_var : t -> string -> Var.access_tag -> Types.t -> t * Var.t val global_ids : t -> ID.generator val decl_typ : ?attrib:'a Types.StringMap.t -> t -> Types.t -> t diff --git a/lib/lang/rewrite.ml b/lib/lang/rewrite.ml deleted file mode 100644 index 1a85c325..00000000 --- a/lib/lang/rewrite.ml +++ /dev/null @@ -1,74 +0,0 @@ -open Common - -let rewrite_proc_exprs ?visit - (rewriter : ?visit:'a -> Expr.BasilExpr.t -> Expr.BasilExpr.t) - (p : (Var.t, Expr.BasilExpr.t) Procedure.t) = - let open Procedure in - let simplify_proc_exprs p = - p - |> map_blocks_nondet (fun (i, b) -> - let b = - Block.map ~phi:Fun.id - (Stmt.map ~f_lvar:Fun.id ~f_rvar:Fun.id ~f_expr:(rewriter ?visit)) - b - in - b) - in - - let simplify_proc_spec_exprs p = - let s = specification p in - let s = - { - s with - requires = List.map (rewriter ?visit) s.requires; - ensures = List.map (rewriter ?visit) s.ensures; - rely = List.map (rewriter ?visit) s.rely; - guarantee = List.map (rewriter ?visit) s.guarantee; - } - in - set_specification p s - in - p |> simplify_proc_exprs |> simplify_proc_spec_exprs - -let rewrite_prog_exprs rewriter ?visit (p : Program.t) = - let open Program in - let simplify_prog_spec_exprs (p : t) = - map_procedures - (fun _ proc -> - (fun ?visit rewriter p -> - let s = Procedure.specification p in - let s = - { - s with - requires = List.map (rewriter ?visit) s.requires; - ensures = List.map (rewriter ?visit) s.ensures; - rely = List.map (rewriter ?visit) s.rely; - guarantee = List.map (rewriter ?visit) s.guarantee; - } - in - Procedure.set_specification p s) - rewriter ?visit proc) - p - in - - let simplify_decls p = - map_decls - (fun id -> - (function - | Function { binding; attrib; definition; var_gen } -> - let definition = - match definition with - | Axiom b -> - let rw = rewriter ?visit b in - Axiom rw - | Function b -> Function (rewriter ?visit b) - | Uninterpreted -> Uninterpreted - in - Function { binding; attrib; definition; var_gen } - | o -> o)) - p - in - p - |> Program.map_procedures (fun _ proc -> - rewrite_proc_exprs rewriter ?visit proc) - |> simplify_decls |> simplify_prog_spec_exprs diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index f46f5244..68aa4734 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -222,7 +222,7 @@ module Builtins = struct | _ -> None in let rw_expr ?visit (e: Expr.BasilExpr.t) = Expr.BasilExpr.rewrite_typed bvop_alg e in - Lang.Rewrite.rewrite_prog_exprs rw_expr p + Cf_tx.simplify_all rw_expr p let transform_add_builtin_decls (p : Program.t) : Program.t = diff --git a/lib/transforms/cf_tx.ml b/lib/transforms/cf_tx.ml index 282c7161..7827bf67 100644 --- a/lib/transforms/cf_tx.ml +++ b/lib/transforms/cf_tx.ml @@ -62,6 +62,11 @@ let simplify_prog_exprs rewriter ?visit (p : Program.t) = | o -> o)) p +let simplify_all ?visit rewriter prog = + prog + |> simplify_prog_exprs ?visit rewriter + |> simplify_prog_spec_exprs ?visit rewriter + let to_smt (r : Expr.BasilExpr.rwinfo) = let open Lang.Expr_smt in let cexpr = Expr.BasilExpr.binexp ~op:`NEQ r.from r.into in diff --git a/lib/transforms/function_summaries.ml b/lib/transforms/function_summaries.ml index d37ef72a..2141af47 100644 --- a/lib/transforms/function_summaries.ml +++ b/lib/transforms/function_summaries.ml @@ -157,14 +157,15 @@ let add_decls solver prog = let add_decls ds = ds - |> Iter.map (fun d -> Expr_smt.SMTLib2.trans_decl d (Expr_smt.SMTLib2.empty ())) + |> Iter.map (fun d -> + Expr_smt.SMTLib2.trans_decl d (Expr_smt.SMTLib2.empty ())) |> Iter.map fst |> fun i -> Iter.for_each i (fun s -> Bincaml_util.Smt.Solver.add_command solver s) in - (decls + decls |> Iter.filter Program.(function Type _ -> true | _ -> false) - |> add_decls); + |> add_decls; decls |> Iter.filter Program.(function Type _ -> false | _ -> true) |> add_decls diff --git a/lib/transforms/memory_encoding.ml b/lib/transforms/memory_encoding.ml index b1b118d4..518f41e6 100644 --- a/lib/transforms/memory_encoding.ml +++ b/lib/transforms/memory_encoding.ml @@ -357,7 +357,7 @@ module FlatMemory (M : IDAllocs) : MemoryEncoding = struct module Calls = Calls (M) module Globals = Calls.Globals - let global_ids = (M.global_ids) + let global_ids = M.global_ids let mem_encoding_type : Types.t = Types.Sort diff --git a/lib/transforms/memory_specification.ml b/lib/transforms/memory_specification.ml index 3bb69288..aef2c7a4 100644 --- a/lib/transforms/memory_specification.ml +++ b/lib/transforms/memory_specification.ml @@ -58,10 +58,8 @@ struct ]) (BasilExpr.bvconst live)); ]; - modifies_globs = - spec.modifies_globs @ [ Globals.mem_encoding ]; - captures_globs = - spec.captures_globs @ [ Globals.mem_encoding ]; + modifies_globs = spec.modifies_globs @ [ Globals.mem_encoding ]; + captures_globs = spec.captures_globs @ [ Globals.mem_encoding ]; } let transform_malloc p = @@ -93,17 +91,15 @@ struct Calls.allocate [ old @@ mem_encoding; mem_encoding; r_out 0; r_in 0 ]; ]; - modifies_globs = - spec.modifies_globs @ [ Globals.mem_encoding ]; - captures_globs = - spec.captures_globs @ [ Globals.mem_encoding ]; + modifies_globs = spec.modifies_globs @ [ Globals.mem_encoding ]; + captures_globs = spec.captures_globs @ [ Globals.mem_encoding ]; } let transform_free p = (* TODO: Specify Gammas Oneday *) let spec = Procedure.specification p in let open BasilExpr in - let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding in + let mem_encoding = BasilExpr.rvar @@ Globals.mem_encoding in let pid = Var.mk_gen ~id_generator:(Procedure.local_ids p) () in let r_in = r_in pid in Procedure.set_specification p @@ -148,10 +144,8 @@ struct BasilExpr.bvconst dead; ]); ]; - modifies_globs = - spec.modifies_globs @ [ Globals.mem_encoding ]; - captures_globs = - spec.captures_globs @ [ Globals.mem_encoding ]; + modifies_globs = spec.modifies_globs @ [ Globals.mem_encoding ]; + captures_globs = spec.captures_globs @ [ Globals.mem_encoding ]; } let transform_stmt (s : Program.stmt) = @@ -168,7 +162,7 @@ struct BasilExpr.( Calls.valid_access [ - rvar (Globals.mem_encoding ); + rvar Globals.mem_encoding; addr; bv_of_int ~size:64 (size / 8); ]); diff --git a/lib/util/var.ml b/lib/util/var.ml index e9e322d4..a42cfb34 100644 --- a/lib/util/var.ml +++ b/lib/util/var.ml @@ -56,8 +56,7 @@ type generator = { fresh : ?name:string -> ?access:access_tag -> Types.t -> t; (** generate a fresh unique name optional string prefix hint *) with_name : string -> ?access:access_tag -> Types.t -> t; - of_var: t -> t; - (** Create or return variable with name*) + of_var : t -> t; (** Create or return variable with name*) create_exn : string -> ?access:access_tag -> Types.t -> t; (** Create variable or throw exception if it was previously declared *) generator : ID.generator; (** The internal ID generator this closes over *) @@ -89,7 +88,7 @@ open struct create name gt ?access typ let of_var gt (id_gen : ID.generator) sgl v = - with_name gt (id_gen) sgl (name v) ~access:(access v) (typ v) + with_name gt id_gen sgl (name v) ~access:(access v) (typ v) let create_exn gt (id_gen : ID.generator) sgl name ?access typ = let name = force_sigil sgl name in From d0fe39027dd3a5f0f262421015d2fdb772e1aaf7 Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 9 Jul 2026 13:34:13 +1000 Subject: [PATCH 16/22] fixup --- examples | 2 +- lib/transforms/aslp/aslp.ml | 15 +++-- lib/transforms/aslp/aslp_lexpr.ml | 71 +++++++++++++-------- lib/transforms/aslp/aslp_state.ml | 50 ++++----------- lib/transforms/aslp/bincaml_ibi.ml | 7 ++- lib/transforms/aslp/bincaml_ibi_make.ml | 29 ++++++--- test/cram/sva.t | 82 +++++++++++++++++++++---- test/transforms/test_aslp.ml | 60 +++++++++--------- test/transforms/test_aslp_ibi.ml | 14 ++--- 9 files changed, 201 insertions(+), 129 deletions(-) diff --git a/examples b/examples index 51d12f65..339b7c48 160000 --- a/examples +++ b/examples @@ -1 +1 @@ -Subproject commit 51d12f6565ee284ea50a86e823c5d65177275941 +Subproject commit 339b7c483383d3c73af612dc5e612a4d4252b599 diff --git a/lib/transforms/aslp/aslp.ml b/lib/transforms/aslp/aslp.ml index bea9f319..92e506d6 100644 --- a/lib/transforms/aslp/aslp.ml +++ b/lib/transforms/aslp/aslp.ml @@ -88,7 +88,7 @@ let next_aarch64_stmt stmts = (** Returns the Bincaml global variable representing heap memory. *) let aarch64_mem_of_prog prog = - Program.get_decl_by_name "$mem" prog |> function + Program.get_decl_by_name "mem" prog |> function | Some (Variable { binding }) -> binding | _ -> failwith "aarch64_mem_of_prog: no $mem found" @@ -175,9 +175,9 @@ let rec transform_block (module I : Bincaml_ibi.IBI) ~proc bid = (** Transforms the {!Lang.Stmt.Intrinsic.Aarch64Eval} intrinsics of all blocks within the given procedure. *) -let transform_procedure ~memory proc = +let transform_procedure prog ~memory proc = let memory = Fun.const memory in - let module I = (val Bincaml_ibi.from_bincaml_procedure ~memory proc) in + let module I = (val Bincaml_ibi.from_bincaml_procedure prog ~memory proc) in Procedure.iter_blocks proc |> Iter.fold (fun proc (bid, _) -> transform_block (module I) ~proc bid) proc @@ -192,7 +192,12 @@ let add_aarch64_global_declarations ?(add_all = false) prog = |> Iter.to_set (module VarSet)) in - Lazy.force Aslp_lexpr.global_vars + let gen = + Aslp_lexpr.aslp_ids_from_generators ~local_var:(Var.mk_gen ()) + ~global_var:(Program.var_generator prog) + in + + (Aslp_lexpr.global_vars gen) |> List.to_iter |> Iter.filter include_var |> Iter.fold (fun prog var -> @@ -210,7 +215,7 @@ let transform_program prog = let memory = aarch64_mem_of_prog prog in prog - |> Program.map_procedures (fun _ -> transform_procedure ~memory) + |> Program.map_procedures (fun _ -> transform_procedure prog ~memory) |> add_aarch64_global_declarations (** {1 Supplementary transformation} *) diff --git a/lib/transforms/aslp/aslp_lexpr.ml b/lib/transforms/aslp/aslp_lexpr.ml index ceaeff31..d9c4270e 100644 --- a/lib/transforms/aslp/aslp_lexpr.ml +++ b/lib/transforms/aslp/aslp_lexpr.ml @@ -38,6 +38,18 @@ type t = | ExclusiveLocal [@@deriving show { with_path = false }] +let predefined = + ([ PC; SP_EL0 ] + @ List.init 31 (fun i -> R (Some i)) + @ List.init 31 (fun i -> Z (Some i)) + @ [ FPSR; FPCR; PSTATE_N; PSTATE_Z; PSTATE_C; PSTATE_V ] + @ [ PSTATE_A; PSTATE_D; PSTATE_DIT; PSTATE_F; PSTATE_I ] + @ [ + PSTATE_PAN; PSTATE_SP; PSTATE_SSBS; PSTATE_TCO; PSTATE_UAO; PSTATE_BTYPE; + ] + @ [ BTypeCompatible; BranchTaken; BTypeNext; ExclusiveLocal ]) + + let typ (x : t) = let bv = Types.bv in match x with @@ -58,38 +70,47 @@ let typ (x : t) = | ExclusiveLocal -> Types.Boolean | R None | Z None -> failwith "typeof_lexpr: array lexpr has no bincaml type" -let name = function +let name : _ -> string = function | Local (v, _) -> v - | SP_EL0 -> "SP" | R (Some n) -> Printf.sprintf "R%d" n | Z (Some n) -> Printf.sprintf "Z%d" n | R None | Z None -> failwith "name_of_lexpr: array lexpr has no bincaml name" | v -> show v -let scope = function - | Local _ -> Var.LocalVar - | BranchTaken | BTypeCompatible | BTypeNext -> LocalVar - | _ -> GlobalVar +type aslp_ids = { local_var : Var.generator; global_var : Var.generator } +(** Generators for unique IDs used by the offline lifter. The {!aslp_ids} is + stateful and the same {!aslp_ids} should be used by all opcodes within the + same procedure, to ensure that IDs are unique.*) -let to_var x = - let ty = typ x and name = name x and scope = scope x in - let name = match scope with GlobalVar -> "$" ^ name | _ -> name in - Var.create ~scope name ty +(** Construct a new {!aslp_ids} with no pre-existing IDs. -let pc_var = to_var PC -let branchtaken_var = to_var BranchTaken + Be careful! You should use {!aslp_ids_from_generators} if you will use the + lifted statements within an existing Bincaml IR. *) +let empty_aslp_ids () = + let local_var = Var.mk_gen () in + let global_var = Var.mk_gen ~scope:`Global () in + { local_var; global_var } -let predefined = - lazy - ([ PC; SP_EL0 ] - @ List.init 31 (fun i -> R (Some i)) - @ List.init 31 (fun i -> Z (Some i)) - @ [ FPSR; FPCR; PSTATE_N; PSTATE_Z; PSTATE_C; PSTATE_V ] - @ [ PSTATE_A; PSTATE_D; PSTATE_DIT; PSTATE_F; PSTATE_I ] - @ [ - PSTATE_PAN; PSTATE_SP; PSTATE_SSBS; PSTATE_TCO; PSTATE_UAO; PSTATE_BTYPE; - ] - @ [ BTypeCompatible; BranchTaken; BTypeNext; ExclusiveLocal ]) +(** {2 ID-generating functions} *) + +(** Construct a {!aslp_ids} with the given {!Bincaml_util.ID.generator}s as + underlying generators. + + This will ensure that ASLp's local variable and block names do not clash + with existing names. *) +let aslp_ids_from_generators ~local_var ~global_var = { local_var; global_var } + +let scope st = function + | Local _ -> st.local_var + | BranchTaken | BTypeCompatible | BTypeNext -> st.local_var + | _ -> st.global_var + +let to_var st x = + let ty = typ x and name = name x and scope = scope st x in + scope.with_name name ty + +let global_vars gen = + predefined |> (List.map (to_var gen) %> List.filter Var.is_global) -let global_vars = - predefined |> Lazy.map (List.map to_var %> List.filter Var.is_global) +let pc_var st = to_var st PC +let branchtaken_var st = to_var st BranchTaken diff --git a/lib/transforms/aslp/aslp_state.ml b/lib/transforms/aslp/aslp_state.ml index 7701255c..a252ff6f 100644 --- a/lib/transforms/aslp/aslp_state.ml +++ b/lib/transforms/aslp/aslp_state.ml @@ -37,19 +37,13 @@ type aslp_diamond = aslp_block Diamond.diamond [@@deriving show] it is not the representation which is used {i during} lifting. For the "in-progress" representation, see {!diamond}. *) -type aslp_ids = { local_id : unit -> string } -(** Generators for unique IDs used by the offline lifter. - - The {!aslp_ids} is stateful and the same {!aslp_ids} should be used by all - opcodes within the same procedure, to ensure that IDs are unique.*) - type lifter_state = { address : Bitvec.t option; (** Byte address of the instruction currently being lifted. *) diamond : aslp_block Diamond_zipper.zipper; (** Lifter state representing a control flow diamond while it is being built. *) - generator : aslp_ids; [@opaque] (** Generators for ID names. *) + generator : Aslp_lexpr.aslp_ids; [@opaque] (** Generators for ID names. *) names : (string, string) Hashtbl.t; (** Map of ASLp local variable names to the "ID-ified" names produced for Bincaml. @@ -86,24 +80,6 @@ let empty_lifter_state ~generator () = generator; } -(** Construct a new {!aslp_ids} with no pre-existing IDs. - - Be careful! You should use {!aslp_ids_from_generators} if you will use the - lifted statements within an existing Bincaml IR. *) -let empty_aslp_ids () = - let local_id = Fix.Gensym.make () %> Printf.sprintf "var_%d" in - { local_id } - -(** {2 ID-generating functions} *) - -(** Construct a {!aslp_ids} with the given {!Bincaml_util.ID.generator}s as - underlying generators. - - This will ensure that ASLp's local variable and block names do not clash - with existing names. *) -let aslp_ids_from_generators ~local_ids = - let local_id = ID.fresh ~name:"var" local_ids %> ID.name in - { local_id } (** {1 State manipulation functions} *) @@ -113,11 +89,11 @@ let aslp_ids_from_generators ~local_ids = is assumed that [PC] is assigned at most once on any straight-line path. Raises an exception if the statement is an assignment to [PC] and {!pc_assign} is already set. *) -let add_stmt_to_block ?(allow_double_pc = false) ~stmt blk = +let add_stmt_to_block gen ?(allow_double_pc = false) ~stmt blk = let pc_assign = match stmt with | Stmt.Instr_Assign { al = assigns; _ } -> - assigns |> List.Assoc.get ~eq:Var.equal Aslp_lexpr.pc_var + assigns |> List.Assoc.get ~eq:Var.equal (Aslp_lexpr.pc_var gen) | _ -> None in match (pc_assign, blk.pc_assign) with @@ -131,24 +107,24 @@ let add_stmt_to_block ?(allow_double_pc = false) ~stmt blk = let add_stmt_to_active stmt (lifter_state : lifter_state) = let diamond = lifter_state.diamond in - let diamond = diamond |> Diamond_zipper.modify (add_stmt_to_block ~stmt) in + let diamond = diamond |> Diamond_zipper.modify (add_stmt_to_block lifter_state.generator ~stmt) in { lifter_state with diamond } (** {1 Program counter and guard functions} *) (** Ensures that the focused block has a PC assignment. If it already has {!pc_assign}, no changes are made. *) -let ensure_pc_assigned ~address = +let ensure_pc_assigned gen ~address = Diamond_zipper.modify (function | { pc_assign = None } as block -> let incremented = Expr.BasilExpr.bvconst Bitvec.(add address (of_int ~size:64 4)) and ff = Expr.BasilExpr.boolconst false in - let bt = Aslp_lexpr.branchtaken_var and pc = Aslp_lexpr.pc_var in + let bt = Aslp_lexpr.branchtaken_var gen and pc = Aslp_lexpr.pc_var gen in let al = [ (bt, ff); (pc, incremented) ] in block - |> add_stmt_to_block + |> add_stmt_to_block gen ~stmt:(Stmt.Instr_Assign { attrib = Attrib.empty; al }) | block -> block) @@ -170,15 +146,15 @@ let ensure_pc_assigned ~address = This is used to maintain the invariant that at every control flow point, the [PC] variable is either assigned on all paths or assigned on no paths (from the beginning of the instruction). *) -let ensure_pc_consistency ~address state = +let ensure_pc_consistency gen ~address state = let left = state |> Diamond_zipper.move_in_to `L |> Result.get_ok and right = state |> Diamond_zipper.move_in_to `R |> Result.get_ok in (* Make PCs of left and right agree. Resulting state is at left or right. *) let state = match Diamond_zipper.((focus left).pc_assign, (focus right).pc_assign) with - | Some _, None -> right |> ensure_pc_assigned ~address - | None, Some _ -> left |> ensure_pc_assigned ~address + | Some _, None -> right |> ensure_pc_assigned gen ~address + | None, Some _ -> left |> ensure_pc_assigned gen ~address | None, None | Some _, Some _ -> left (* arbitrary *) in @@ -204,7 +180,7 @@ let ensure_pc_consistency ~address state = If the PC was assigned earlier, inserts a new assignment in the last block. This is semantically redundant, but is meant to simplify guard cleanup. *) -let ensure_forwarded_pc state = +let ensure_forwarded_pc gen state = match Diamond_zipper.(move_in_to `L state, move_in_to `R state) with | Error _, _ | _, Error _ -> state (* focus is not a branch *) | Ok l, Ok r -> ( @@ -215,11 +191,11 @@ let ensure_forwarded_pc state = Option.get_exn_or "invariant violation: pc should be propagated" (Diamond_zipper.focus state).pc_assign in - let al = [ (Aslp_lexpr.pc_var, pc_assign) ] in + let al = [ (Aslp_lexpr.pc_var gen, pc_assign) ] in let stmt = Stmt.Instr_Assign { attrib = Attrib.empty; al } in state |> Diamond_zipper.modify - (add_stmt_to_block ~stmt ~allow_double_pc:true) + (add_stmt_to_block (gen) ~stmt ~allow_double_pc:true) | Some _, None | None, Some _ -> failwith "pcs should already agree") (** Returns an {!Lang.Stmt.Instr_Assume} statement for the given block's guard, diff --git a/lib/transforms/aslp/bincaml_ibi.ml b/lib/transforms/aslp/bincaml_ibi.ml index d18180ab..e8807306 100644 --- a/lib/transforms/aslp/bincaml_ibi.ml +++ b/lib/transforms/aslp/bincaml_ibi.ml @@ -30,6 +30,7 @@ let from_generator ?(memory = fun () -> failwith "bincaml_memory_var undefined") (** Builds a new {!IBI} where the ID generators are derived from the given procedure. *) -let from_bincaml_procedure ?memory proc : (module IBI) = - let local_ids = Procedure.local_ids proc in - from_generator ?memory (Aslp_state.aslp_ids_from_generators ~local_ids) +let from_bincaml_procedure prog ?memory proc : (module IBI) = + let local_var = Procedure.var_generator proc in + let global_var = Program.var_generator prog in + from_generator ?memory (Aslp_lexpr.aslp_ids_from_generators ~local_var ~global_var) diff --git a/lib/transforms/aslp/bincaml_ibi_make.ml b/lib/transforms/aslp/bincaml_ibi_make.ml index 5291cafc..763d3c32 100644 --- a/lib/transforms/aslp/bincaml_ibi_make.ml +++ b/lib/transforms/aslp/bincaml_ibi_make.ml @@ -37,7 +37,10 @@ struct let id_name = match Hashtbl.find_opt !bincaml_lifter_state.names name with | None -> - let id_name = !bincaml_lifter_state.generator.local_id () in + let id_name = + ID.name @@ Var.id + @@ !bincaml_lifter_state.generator.local_var.fresh ty + in Hashtbl.replace !bincaml_lifter_state.names name id_name; id_name | Some x -> x @@ -77,7 +80,11 @@ struct | `M -> let address = bincaml_get_address () and diamond = !bincaml_lifter_state.diamond in - let diamond = diamond |> Aslp_state.ensure_pc_consistency ~address in + let diamond = + diamond + |> Aslp_state.ensure_pc_consistency !bincaml_lifter_state.generator + ~address + in bincaml_lifter_state := { !bincaml_lifter_state with diamond } (** {2 IR extraction} *) @@ -94,8 +101,10 @@ struct failwith "invariant violation: context switches did not return to merge" | [] -> diamond - |> Aslp_state.ensure_pc_assigned ~address - |> Aslp_state.ensure_forwarded_pc |> Diamond_zipper.to_diamond + |> Aslp_state.ensure_pc_assigned !bincaml_lifter_state.generator + ~address + |> Aslp_state.ensure_forwarded_pc !bincaml_lifter_state.generator + |> Diamond_zipper.to_diamond (** {2 Instruction building interface implementation} *) @@ -254,12 +263,12 @@ struct let f_gen_bool_lit : bool -> expr = Expr.BasilExpr.boolconst let f_gen_int_lit : bigint -> expr = Expr.BasilExpr.intconst + let to_var v = Aslp_lexpr.to_var !bincaml_lifter_state.generator v let f_gen_store : lexpr -> expr -> unit = fun lhs rhs -> bincaml_internal_emit - (Stmt.Instr_Assign - { attrib = Attrib.empty; al = [ (Aslp_lexpr.to_var lhs, rhs) ] }) + (Stmt.Instr_Assign { attrib = Attrib.empty; al = [ (to_var lhs, rhs) ] }) let f_decl_bv : string -> bigint -> lexpr = fun name size -> @@ -273,8 +282,7 @@ struct f_gen_store v (f_gen_bool_lit false); v - let f_gen_load : lexpr -> expr = - fun lhs -> Expr.BasilExpr.rvar (Aslp_lexpr.to_var lhs) + let f_gen_load : lexpr -> expr = fun lhs -> Expr.BasilExpr.rvar (to_var lhs) let f_gen_array_load : lexpr -> bigint -> expr = fun array idx -> @@ -311,8 +319,9 @@ struct fun size addr _ _acctype -> let addr = Stmt.Addr { addr; size = Z.to_int size; endian = `Little } and mem = S.bincaml_memory_var () in - let name = !bincaml_lifter_state.generator.local_id () in - let rhs = Var.create name (Types.bv (Z.to_int size)) in + let rhs = + !bincaml_lifter_state.generator.local_var.fresh (Types.bv (Z.to_int size)) + in bincaml_internal_emit (Stmt.Instr_Load { attrib = Attrib.empty; lhs = mem; rhs; addr }); Expr.BasilExpr.rvar rhs diff --git a/test/cram/sva.t b/test/cram/sva.t index 6b40735d..a1f1830b 100644 --- a/test/cram/sva.t +++ b/test/cram/sva.t @@ -1,14 +1,74 @@ $ bincaml script ./sva.sexp (load-il ../../examples/irreducible_loop_1.il) -<<<<<<< HEAD - (run-transforms sva) - bincaml: [WARNING] Invariants not satisfied during 'sva'. Needs [SSA] but only have []. - (R31_in->(Stack(@puts_1584)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@puts_1584_{ Var.name = ("R30_in", 1); scope = (Var.Local "@puts_1584"); typ = bv64; - tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_in->(Par(@puts_1584_{ Var.name = ("R29_in", 2); scope = (Var.Local "@puts_1584"); typ = bv64; - tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), _->⊥) - (#4->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), load18->(Loaded->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), #5->(Loaded->⊤, _->⊥), $NF->(Loaded->⟦0x0:bv32, 0x0:bv32⟧, _->⊥), $R0->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $R1->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $R29->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), $R30->(Loaded->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_in->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Loaded->⊤, _->⊥), R29_in->(Loaded->⊤, _->⊥), _->⊥) -======= (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->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, Ret(@puts_1584_{ Var.V.name = "R29_6"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0: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->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, Ret(@puts_1584_{ Var.V.name = "R29_4"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_4->(Par(@main_1876_{ Var.V.name = "R1_in"; typ = bv64; scope = Var.LocalVar })->⟦0x0:bv64, 0x0:bv64⟧, Ret(@puts_1584_{ Var.V.name = "R1_3"; 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⟧, _->⊥), _->⊥) ->>>>>>> 72aca687a10a60dc59bad6a66ff8ae5a202d354d + (CF_in->(Par(@puts_1584_{ Var.name = ("CF_in", 0); scope = (Var.Local "@puts_1584"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_in->(Par(@puts_1584_{ Var.name = ("NF_in", 1); scope = (Var.Local "@puts_1584"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_in->(Par(@puts_1584_{ Var.name = ("R0_in", 2); scope = (Var.Local "@puts_1584"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_in->(Par(@puts_1584_{ Var.name = ("R1_in", 3); scope = (Var.Local "@puts_1584"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_in->(Par(@puts_1584_{ Var.name = ("R29_in", 4); scope = (Var.Local "@puts_1584"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@puts_1584_{ Var.name = ("R30_in", 5); scope = (Var.Local "@puts_1584"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_in->(Stack(@puts_1584)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_in->(Par(@puts_1584_{ Var.name = ("VF_in", 7); scope = (Var.Local "@puts_1584"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_in->(Par(@puts_1584_{ Var.name = ("ZF_in", 8); scope = (Var.Local "@puts_1584"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), _->⊥) + (CF_in->(Par(@main_1876_{ Var.name = ("CF_in", 8); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_in->(Par(@main_1876_{ Var.name = ("NF_in", 9); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_in->(Par(@main_1876_{ Var.name = ("R0_in", 10); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_in->(Par(@main_1876_{ Var.name = ("R1_in", 11); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_in->(Par(@main_1876_{ Var.name = ("R29_in", 12); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_in->(Par(@main_1876_{ Var.name = ("R30_in", 13); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_in->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_in->(Par(@main_1876_{ Var.name = ("VF_in", 15); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_in->(Par(@main_1876_{ Var.name = ("ZF_in", 16); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), CF_out->(Ret(@puts_1584_{ Var.name = ("CF_8", 120); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_out->(Ret(@puts_1584_{ Var.name = ("NF_8", 121); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_out->(Constant->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_out->(Ret(@puts_1584_{ Var.name = ("R1_7", 123); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦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.name = ("R31_7", 126); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x20:bv64, 0x20:bv64⟧, _->⊥), VF_out->(Ret(@puts_1584_{ Var.name = ("VF_8", 127); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_out->(Ret(@puts_1584_{ Var.name = ("ZF_12", 128); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), CF_1->(Par(@main_1876_{ Var.name = ("CF_in", 8); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_1->(Par(@main_1876_{ Var.name = ("NF_in", 9); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_1->(Par(@main_1876_{ Var.name = ("R0_in", 10); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_1->(Par(@main_1876_{ Var.name = ("R1_in", 11); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_1->(Par(@main_1876_{ Var.name = ("R29_in", 12); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_1->(Par(@main_1876_{ Var.name = ("R30_in", 13); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_1->(Stack(@main_1876)->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_1->(Par(@main_1876_{ Var.name = ("VF_in", 15); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_1->(Par(@main_1876_{ Var.name = ("ZF_in", 16); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦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.name = ("ZF_10", 108); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), VF_3->(Loaded(load18_1)->⊤, Ret(@puts_1584_{ Var.name = ("VF_7", 107); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R31_3->(Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, Ret(@puts_1584_{ Var.name = ("R31_6", 106); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_3->(Ret(@puts_1584_{ Var.name = ("R29_6", 104); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R1_2->(Loaded(load19_1)->⊤, Par(@main_1876_{ Var.name = ("R1_in", 11); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), NF_3->(Ret(@puts_1584_{ Var.name = ("NF_7", 101); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, Loaded(load18_1)->⊤, _->⊥), CF_3->(Loaded(load18_1)->⊤, Ret(@puts_1584_{ Var.name = ("CF_7", 100); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), 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.name = ("CF_4", 71); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_4->(Ret(@puts_1584_{ Var.name = ("NF_4", 72); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_10->(Ret(@puts_1584_{ Var.name = ("R0_10", 73); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_3->(Ret(@puts_1584_{ Var.name = ("R1_3", 74); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_4->(Ret(@puts_1584_{ Var.name = ("R29_4", 75); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_3->(Ret(@puts_1584_{ Var.name = ("R30_3", 76); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_4->(Ret(@puts_1584_{ Var.name = ("R31_4", 77); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_4->(Ret(@puts_1584_{ Var.name = ("VF_4", 78); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_6->(Ret(@puts_1584_{ Var.name = ("ZF_6", 79); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦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.name = ("R31_4", 77); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_5->(Ret(@puts_1584_{ Var.name = ("R29_4", 75); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, Stack(@main_1876)->⟦0xffffffffffffffe0:bv64, 0xffffffffffffffe0:bv64⟧, _->⊥), R1_4->(Ret(@puts_1584_{ Var.name = ("R1_3", 74); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, Par(@main_1876_{ Var.name = ("R1_in", 11); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦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.name = ("CF_7", 100); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_7->(Ret(@puts_1584_{ Var.name = ("NF_7", 101); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_16->(Ret(@puts_1584_{ Var.name = ("R0_16", 102); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_5->(Ret(@puts_1584_{ Var.name = ("R1_5", 103); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_6->(Ret(@puts_1584_{ Var.name = ("R29_6", 104); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_5->(Ret(@puts_1584_{ Var.name = ("R30_5", 105); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_6->(Ret(@puts_1584_{ Var.name = ("R31_6", 106); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_7->(Ret(@puts_1584_{ Var.name = ("VF_7", 107); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_10->(Ret(@puts_1584_{ Var.name = ("ZF_10", 108); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦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.name = ("CF_8", 120); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), NF_8->(Ret(@puts_1584_{ Var.name = ("NF_8", 121); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), R0_24->(Ret(@puts_1584_{ Var.name = ("R0_24", 122); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R1_7->(Ret(@puts_1584_{ Var.name = ("R1_7", 123); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R29_7->(Ret(@puts_1584_{ Var.name = ("R29_7", 124); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R30_7->(Ret(@puts_1584_{ Var.name = ("R30_7", 125); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), R31_7->(Ret(@puts_1584_{ Var.name = ("R31_7", 126); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x0:bv64, 0x0:bv64⟧, _->⊥), VF_8->(Ret(@puts_1584_{ Var.name = ("VF_8", 127); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦0x0:bv1, 0x0:bv1⟧, _->⊥), ZF_12->(Ret(@puts_1584_{ Var.name = ("ZF_12", 128); scope = (Var.Local "@main_1876"); typ = bv1; + tags = Var.None })->⟦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.name = ("R31_7", 126); scope = (Var.Local "@main_1876"); typ = bv64; + tags = Var.None })->⟦0x20:bv64, 0x20:bv64⟧, _->⊥), _->⊥) diff --git a/test/transforms/test_aslp.ml b/test/transforms/test_aslp.ml index 2d288a32..cfebf889 100644 --- a/test/transforms/test_aslp.ml +++ b/test/transforms/test_aslp.ml @@ -3,7 +3,7 @@ open Common open Transforms.Aslp let%expect_test "lift empty" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_code_block (module I) ~address:(Bitvec.of_int ~size:64 0x2000) [] @@ -12,7 +12,7 @@ let%expect_test "lift empty" = [%expect {| |}] let%expect_test "lift: add x1, x2, x3, lsl #4" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_opcode @@ -26,15 +26,15 @@ let%expect_test "lift: add x1, x2, x3, lsl #4" = (Leaf { Aslp_state.assume = true; stmts = - [var var_0:bv64 := 0x0:bv64; var var_0:bv64 := $R2; - var var_1:bv64 := 0x0:bv64; var var_1:bv64 := $R3; - $R1:bv64 := bvadd(var_0:bv64, bvshl(var_1:bv64, 0x4:bv12)); + [var v:bv64 := 0x0:bv64; var v:bv64 := $R2; var v_1:bv64 := 0x0:bv64; + var v_1:bv64 := $R3; + $R1:bv64 := bvadd(v:bv64, bvshl(v_1:bv64, 0x4:bv12)); (var BranchTaken:bool := false, $PC:bv64 := 0x2004:bv64)]; pc_assign = (Some 0x2004:bv64) }) |}] let%expect_test "lift 2x: mov x1, #0xabcd" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_code_block @@ -60,7 +60,7 @@ let%expect_test "lift 2x: mov x1, #0xabcd" = |}] let%expect_test "lift: b.eq #1024" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_opcode @@ -92,7 +92,7 @@ let%expect_test "lift: b.eq #1024" = |}] let%expect_test "lift: b #16" = - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in let x = lift_opcode @@ -106,9 +106,9 @@ let%expect_test "lift: b #16" = (Leaf { Aslp_state.assume = true; stmts = - [var var_0:bv64 := 0x0:bv64; var var_0:bv64 := $R2; - var var_1:bv64 := 0x0:bv64; var var_1:bv64 := $R3; - $R1:bv64 := bvadd(var_0:bv64, bvshl(var_1:bv64, 0x4:bv12)); + [var v:bv64 := 0x0:bv64; var v:bv64 := $R2; var v_1:bv64 := 0x0:bv64; + var v_1:bv64 := $R3; + $R1:bv64 := bvadd(v:bv64, bvshl(v_1:bv64, 0x4:bv12)); (var BranchTaken:bool := false, $PC:bv64 := 0x2004:bv64)]; pc_assign = (Some 0x2004:bv64) }) |}] @@ -165,37 +165,37 @@ proc @main() -> () { } goto (%block); ]; block %block { .asm = "stp x29, x30, [sp, #-0x20]!" } [ - var var:bv64 := 0x0:bv64; - var var:bv64 := $SP; - $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP, + var v:bv64 := 0x0:bv64; + var v:bv64 := $SP_EL0; + $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP_EL0, 0xffffffffffffffe0:bv64) $R29 8; - $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd(bvadd($SP, + $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd(bvadd($SP_EL0, 0xffffffffffffffe0:bv64), 0x8:bv64) $R30 8; - $SP:bv64 := bvadd(var:bv64, 0xffffffffffffffe0:bv64); + $SP_EL0:bv64 := bvadd(v:bv64, 0xffffffffffffffe0:bv64); (var BranchTaken:bool := false, $PC:bv64 := 0x40080c:bv64); goto (%block_1); ]; block %block_1 { .asm = "mov x29, sp" } [ - var var_1:bv64 := 0x0:bv64; - $R29:bv64 := bvadd($SP, 0x0:bv64); + var v_1:bv64 := 0x0:bv64; + $R29:bv64 := bvadd($SP_EL0, 0x0:bv64); (var BranchTaken:bool := false, $PC:bv64 := 0x400810:bv64); goto (%block_2); ]; block %block_2 { .asm = "str w0, [sp, #0x1c]" } [ - $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP, 0x1c:bv64) extract(-32,0, $R0) 4; + $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP_EL0, 0x1c:bv64) extract(-32,0, $R0) 4; (var BranchTaken:bool := false, $PC:bv64 := 0x400814:bv64); goto (%block_3); ]; block %block_3 { .asm = "str x1, [sp, #0x10]" } [ - $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP, 0x10:bv64) $R1 8; + $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP_EL0, 0x10:bv64) $R1 8; (var BranchTaken:bool := false, $PC:bv64 := 0x400818:bv64); goto (%block_4); ]; block %block_4 { .asm = "ldrsw x0, [sp, #0x1c]" } [ - var var_2:bv32 := 0x0:bv32; - $mem:(bv64->bv8) := load le var_3:bv4 bvadd($SP, 0x1c:bv64) 4; - var var_2:bv32 := var_3:bv4; - $R0:bv64 := zero_extend(0, sign_extend(32, var_2:bv32)); + var v_2:bv32 := 0x0:bv32; + $mem:(bv64->bv8) := load le v_3:bv4 bvadd($SP_EL0, 0x1c:bv64) 4; + var v_2:bv32 := v_3:bv4; + $R0:bv64 := zero_extend(0, sign_extend(32, v_2:bv32)); (var BranchTaken:bool := false, $PC:bv64 := 0x40081c:bv64); goto (%block_5); ]; @@ -208,11 +208,11 @@ proc @main() -> () { } ]; block %ret_1 [ return; ] ]; - var $SP:bv64; - var $R0:bv64; - var $R1:bv64; + var $SP_EL0:bv64; var $R29:bv64; var $R30:bv64; + var $R0:bv64; + var $R1:bv64; prog entry @main; |}] @@ -285,8 +285,8 @@ proc @Sqrt() -> () { } block %Sqrt_code_3 [ assume eq(0x4007fc:bv64, $PC); goto (%ret); ]; block %ret [ return; ] ]; - var $PSTATE_N:bv1; var $PSTATE_V:bv1; + var $PSTATE_N:bv1; prog entry @Sqrt; |}] @@ -339,8 +339,8 @@ proc @main() -> () { } goto (%block); ]; block %block { .asm = "mov xzr, xzr" } [ - var var:bv64 := 0x0:bv64; - var var_1:bv64 := 0x0:bv64; + var v:bv64 := 0x0:bv64; + var v_1:bv64 := 0x0:bv64; (var BranchTaken:bool := false, $PC:bv64 := 0x400810:bv64); goto (%ret_1); ]; diff --git a/test/transforms/test_aslp_ibi.ml b/test/transforms/test_aslp_ibi.ml index 0ef01457..985bb434 100644 --- a/test/transforms/test_aslp_ibi.ml +++ b/test/transforms/test_aslp_ibi.ml @@ -78,7 +78,7 @@ let%expect_test "diamond bfs" = let%expect_test "nested diamonds" = let make_call = make_call () in - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in I.bincaml_set_address (Bitvec.of_int ~size:64 0xfaf); let branch1 = I.f_gen_branch (I.f_gen_bool_lit true) in @@ -157,7 +157,7 @@ let%expect_test "nested diamonds" = let%expect_test "sequential diamonds" = let make_call = make_call () in - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in ( guard @@ fun () -> I.bincaml_set_address (Bitvec.of_int ~size:64 0xfaf); @@ -208,7 +208,7 @@ let%expect_test "sequential diamonds" = let%expect_test "pc before branch" = let make_call = make_call () in - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in guard (fun () -> I.bincaml_set_address (Bitvec.of_int ~size:64 0xbadbad); @@ -254,7 +254,7 @@ let%expect_test "pc before branch" = let%expect_test "skipped merge context when going to outer merge" = let make_call = make_call () in - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in I.bincaml_set_address (Bitvec.of_int ~size:64 0xfaf); let outer = I.f_gen_branch (I.f_gen_bool_lit true) in @@ -309,7 +309,7 @@ let%expect_test "skipped merge context when going to outer merge" = let%expect_test "skipped merge context when going to outer branch" = let make_call = make_call () in - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in I.bincaml_set_address (Bitvec.of_int ~size:64 0xfaf); let outer = I.f_gen_branch (I.f_gen_bool_lit true) in @@ -371,7 +371,7 @@ let%expect_test "skipped merge context when going to outer branch" = let%expect_test "pathological: referencing old branch with intervening gen_branch" = let make_call = make_call () in - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in guard (fun () -> I.bincaml_set_address (Bitvec.of_int ~size:64 0xfaf); @@ -401,7 +401,7 @@ let%expect_test let%expect_test "pathological: sequential diamonds, then going back into the first one" = let make_call = make_call () in - let module I = (val Bincaml_ibi.from_generator (Aslp_state.empty_aslp_ids ())) + let module I = (val Bincaml_ibi.from_generator (Aslp_lexpr.empty_aslp_ids ())) in ( guard @@ fun () -> begin From 8f81c8f4532f48b68be6515f39a9360de0953f01 Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 9 Jul 2026 13:34:24 +1000 Subject: [PATCH 17/22] format --- lib/gtirb/gfir_to_bincaml.ml | 3 ++- lib/transforms/aslp/aslp.ml | 3 +-- lib/transforms/aslp/aslp_lexpr.ml | 19 ++++++++----------- lib/transforms/aslp/aslp_state.ml | 11 +++++++---- lib/transforms/aslp/bincaml_ibi.ml | 3 ++- 5 files changed, 20 insertions(+), 19 deletions(-) diff --git a/lib/gtirb/gfir_to_bincaml.ml b/lib/gtirb/gfir_to_bincaml.ml index 040d39a3..968aefc2 100644 --- a/lib/gtirb/gfir_to_bincaml.ml +++ b/lib/gtirb/gfir_to_bincaml.ml @@ -142,7 +142,8 @@ let add_new_code_block (pc_var : Var.t) (all_blocks : block UUIDMap.t) temp_proc add_new_simple_block pc_var ~name_suffix:"_code" ~attrib succ_addr (proc, blockmap) (Gtirb.uuid b, Some address, instrs) - | Proxy uuid -> add_proxy_block pc_var ~attrib succ_addr (proc, blockmap) uuid) + | Proxy uuid -> + add_proxy_block pc_var ~attrib succ_addr (proc, blockmap) uuid) | Data _ | Proxy _ -> (proc, blockmap) (** For each successor set containing a fallthrough edge, remove fallthrough diff --git a/lib/transforms/aslp/aslp.ml b/lib/transforms/aslp/aslp.ml index 92e506d6..a8aafd23 100644 --- a/lib/transforms/aslp/aslp.ml +++ b/lib/transforms/aslp/aslp.ml @@ -197,8 +197,7 @@ let add_aarch64_global_declarations ?(add_all = false) prog = ~global_var:(Program.var_generator prog) in - (Aslp_lexpr.global_vars gen) - |> List.to_iter |> Iter.filter include_var + Aslp_lexpr.global_vars gen |> List.to_iter |> Iter.filter include_var |> Iter.fold (fun prog var -> let attrib = Attrib.empty and classification = None in diff --git a/lib/transforms/aslp/aslp_lexpr.ml b/lib/transforms/aslp/aslp_lexpr.ml index d9c4270e..480efc96 100644 --- a/lib/transforms/aslp/aslp_lexpr.ml +++ b/lib/transforms/aslp/aslp_lexpr.ml @@ -39,16 +39,13 @@ type t = [@@deriving show { with_path = false }] let predefined = - ([ PC; SP_EL0 ] - @ List.init 31 (fun i -> R (Some i)) - @ List.init 31 (fun i -> Z (Some i)) - @ [ FPSR; FPCR; PSTATE_N; PSTATE_Z; PSTATE_C; PSTATE_V ] - @ [ PSTATE_A; PSTATE_D; PSTATE_DIT; PSTATE_F; PSTATE_I ] - @ [ - PSTATE_PAN; PSTATE_SP; PSTATE_SSBS; PSTATE_TCO; PSTATE_UAO; PSTATE_BTYPE; - ] - @ [ BTypeCompatible; BranchTaken; BTypeNext; ExclusiveLocal ]) - + [ PC; SP_EL0 ] + @ List.init 31 (fun i -> R (Some i)) + @ List.init 31 (fun i -> Z (Some i)) + @ [ FPSR; FPCR; PSTATE_N; PSTATE_Z; PSTATE_C; PSTATE_V ] + @ [ PSTATE_A; PSTATE_D; PSTATE_DIT; PSTATE_F; PSTATE_I ] + @ [ PSTATE_PAN; PSTATE_SP; PSTATE_SSBS; PSTATE_TCO; PSTATE_UAO; PSTATE_BTYPE ] + @ [ BTypeCompatible; BranchTaken; BTypeNext; ExclusiveLocal ] let typ (x : t) = let bv = Types.bv in @@ -110,7 +107,7 @@ let to_var st x = scope.with_name name ty let global_vars gen = - predefined |> (List.map (to_var gen) %> List.filter Var.is_global) + predefined |> List.map (to_var gen) %> List.filter Var.is_global let pc_var st = to_var st PC let branchtaken_var st = to_var st BranchTaken diff --git a/lib/transforms/aslp/aslp_state.ml b/lib/transforms/aslp/aslp_state.ml index a252ff6f..f420d602 100644 --- a/lib/transforms/aslp/aslp_state.ml +++ b/lib/transforms/aslp/aslp_state.ml @@ -80,7 +80,6 @@ let empty_lifter_state ~generator () = generator; } - (** {1 State manipulation functions} *) (** Appends the given statement to the given block. @@ -107,7 +106,10 @@ let add_stmt_to_block gen ?(allow_double_pc = false) ~stmt blk = let add_stmt_to_active stmt (lifter_state : lifter_state) = let diamond = lifter_state.diamond in - let diamond = diamond |> Diamond_zipper.modify (add_stmt_to_block lifter_state.generator ~stmt) in + let diamond = + diamond + |> Diamond_zipper.modify (add_stmt_to_block lifter_state.generator ~stmt) + in { lifter_state with diamond } (** {1 Program counter and guard functions} *) @@ -121,7 +123,8 @@ let ensure_pc_assigned gen ~address = Expr.BasilExpr.bvconst Bitvec.(add address (of_int ~size:64 4)) and ff = Expr.BasilExpr.boolconst false in - let bt = Aslp_lexpr.branchtaken_var gen and pc = Aslp_lexpr.pc_var gen in + let bt = Aslp_lexpr.branchtaken_var gen + and pc = Aslp_lexpr.pc_var gen in let al = [ (bt, ff); (pc, incremented) ] in block |> add_stmt_to_block gen @@ -195,7 +198,7 @@ let ensure_forwarded_pc gen state = let stmt = Stmt.Instr_Assign { attrib = Attrib.empty; al } in state |> Diamond_zipper.modify - (add_stmt_to_block (gen) ~stmt ~allow_double_pc:true) + (add_stmt_to_block gen ~stmt ~allow_double_pc:true) | Some _, None | None, Some _ -> failwith "pcs should already agree") (** Returns an {!Lang.Stmt.Instr_Assume} statement for the given block's guard, diff --git a/lib/transforms/aslp/bincaml_ibi.ml b/lib/transforms/aslp/bincaml_ibi.ml index e8807306..f70b802a 100644 --- a/lib/transforms/aslp/bincaml_ibi.ml +++ b/lib/transforms/aslp/bincaml_ibi.ml @@ -33,4 +33,5 @@ let from_generator ?(memory = fun () -> failwith "bincaml_memory_var undefined") let from_bincaml_procedure prog ?memory proc : (module IBI) = let local_var = Procedure.var_generator proc in let global_var = Program.var_generator prog in - from_generator ?memory (Aslp_lexpr.aslp_ids_from_generators ~local_var ~global_var) + from_generator ?memory + (Aslp_lexpr.aslp_ids_from_generators ~local_var ~global_var) From 764ef25b741808d6ea543c97736b0f8096404b66 Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 9 Jul 2026 13:53:06 +1000 Subject: [PATCH 18/22] fix --- lib/transforms/boogie_prepass.ml | 115 ++++++++++++++++--------------- 1 file changed, 58 insertions(+), 57 deletions(-) diff --git a/lib/transforms/boogie_prepass.ml b/lib/transforms/boogie_prepass.ml index 68aa4734..d89e3735 100644 --- a/lib/transforms/boogie_prepass.ml +++ b/lib/transforms/boogie_prepass.ml @@ -153,12 +153,11 @@ module Builtins = struct let function_for_op (pid : Var.generator) op args ret = let name = - (match name op (args @ [ ret ]) with + match name op (args @ [ ret ]) with | Function s -> s - | _ -> failwith "unexpected") - in - pid.with_name name ~access:Var.Const - (Types.curry args ret) + | _ -> failwith "unexpected" + in + pid.with_name name ~access:Var.Const (Types.curry args ret) let transform_op_to_decl pid op args ret = let boogie_attribs = @@ -182,15 +181,13 @@ module Builtins = struct let used_ops (p : Program.t) = Iter.from_iter (fun f -> iprog f p) |> Iter.sort_uniq - let expr_ops vargen (e : Types.t Expr.BasilExpr.abstract_expr) = let open Expr.AbstractExpr in let open Ops.AllOps in - let get_ty (op : [ unary | binary | intrin ]) o = + let get_ty (op : [ unary | binary | intrin ]) o = match o with - | Fun { ret; args } -> - try Some (function_for_op vargen op args ret) with - | Failure _ -> None + | Fun { ret; args } -> ( + try Some (function_for_op vargen op args ret) with Failure _ -> None) | _ -> None in match e with @@ -204,27 +201,35 @@ module Builtins = struct let transform_builtin_decls (p : Program.t) : Program.t = let v = Program.var_generator p in - let bvop_alg : (Program.e * Types.t) Expr.BasilExpr.abstract_expr -> - Program.e option -= fun e -> + let bvop_alg : + (Program.e * Types.t) Expr.BasilExpr.abstract_expr -> Program.e option = + fun e -> let open Expr.AbstractExpr in let types = map snd e in let ex = map fst e in match ex with - | ApplyIntrin {op=`BVConcat | `AND | `OR | `Cases | `MapUpdate } -> None - | BinaryExpr {op ;arg1; arg2} -> - (match expr_ops v types with - | Some (func) -> Some (Expr.BasilExpr.apply_fun ~func:(Expr.BasilExpr.rvar func) ([arg1; arg2])) - | None -> None) - | ApplyIntrin {op; args} -> (match expr_ops v types with - | Some (func) -> Some (Expr.BasilExpr.apply_fun ~func:(Expr.BasilExpr.rvar func) (args)) - | None -> None) + | ApplyIntrin { op = `BVConcat | `AND | `OR | `Cases | `MapUpdate } -> + None + | BinaryExpr { op; arg1; arg2 } -> ( + match expr_ops v types with + | Some func -> + Some + (Expr.BasilExpr.apply_fun ~func:(Expr.BasilExpr.rvar func) + [ arg1; arg2 ]) + | None -> None) + | ApplyIntrin { op; args } -> ( + match expr_ops v types with + | Some func -> + Some + (Expr.BasilExpr.apply_fun ~func:(Expr.BasilExpr.rvar func) args) + | None -> None) | _ -> None in - let rw_expr ?visit (e: Expr.BasilExpr.t) = Expr.BasilExpr.rewrite_typed bvop_alg e in + let rw_expr ?visit (e : Expr.BasilExpr.t) = + Expr.BasilExpr.rewrite_typed bvop_alg e + in Cf_tx.simplify_all rw_expr p - let transform_add_builtin_decls (p : Program.t) : Program.t = used_ops p |> Iter.filter_map (function op, args, ret -> @@ -276,14 +281,9 @@ module Instructions = struct let store_body ?(be = false) mem_typ val_size addr_size = let v = Var.mk_gen ~scope:`Local () in - (** FIXME: function-local variables *) let memory = v.with_name "#memory" mem_typ in - let value = - v.with_name "#value" (Types.Bitvector val_size) - in - let index = - v.with_name "#index" (Types.Bitvector addr_size) - in + let value = v.with_name "#value" (Types.Bitvector val_size) in + let index = v.with_name "#index" (Types.Bitvector addr_size) in (* TODO: maybe generalize to non 8 bit stores, based on mem typ value? *) let steps = val_size / 8 in let body = @@ -306,14 +306,12 @@ module Instructions = struct ]) (Expr.BasilExpr.rvar memory) in - v, Expr.BasilExpr.lambda ~bound:[ memory; index; value ] body + (v, Expr.BasilExpr.lambda ~bound:[ memory; index; value ] body) let load_body ?(be = false) mem_typ val_size addr_size = let v = Var.mk_gen ~scope:`Local () in let memory = v.with_name "#memory" mem_typ in - let index = - v.with_name "#index" (Types.Bitvector addr_size) - in + let index = v.with_name "#index" (Types.Bitvector addr_size) in let steps = val_size / 8 in let body = (if be then List.range 0 (steps - 1) else List.range (steps - 1) 0) @@ -337,7 +335,7 @@ module Instructions = struct (Bitvec.of_int ~size:addr_size (if be then 0 else steps - 1))))) in - v, Expr.BasilExpr.lambda ~bound:[ memory; index ] body + (v, Expr.BasilExpr.lambda ~bound:[ memory; index ] body) let store_load_decl (global_vargen : Var.generator) (s : Program.stmt) = match s with @@ -347,7 +345,7 @@ module Instructions = struct StringMap.of_list [ (".extern", `List []); (".define", `List []) ] in let attribs = StringMap.singleton ".boogie" (`Assoc boogie_attribs) in - let var_gen,body = + let var_gen, body = store_body (Var.typ rhs) (match Expr.BasilExpr.type_of value with | Types.Bitvector s -> s @@ -360,7 +358,7 @@ module Instructions = struct (Function { attrib = attribs; - var_gen ; + var_gen; binding = global_vargen.with_name ~access:Var.Const (Printf.sprintf "$store%d_%s" size @@ -399,9 +397,7 @@ module Instructions = struct let transform_add_store_load_decls (prog : Program.t) = unique_stores_loads prog - |> Iter.filter_map - (store_load_decl - (Program.var_generator prog)) + |> Iter.filter_map (store_load_decl (Program.var_generator prog)) |> Iter.fold Program.add_decl prog end @@ -433,8 +429,7 @@ module Normalise = struct | RVar { attrib; id } when Var.is_global id -> replace [%here] (BasilExpr.apply_fun ~attrib - ~func: - (BasilExpr.rvar ~attrib id) + ~func:(BasilExpr.rvar ~attrib id) args) | _ -> replace [%here] (apply_fun_to_map func args)) | ApplyIntrin { op = `AND; args } -> @@ -457,7 +452,7 @@ module Normalise = struct open Stmt - let replace_stmt ~(global_vars: Var.generator) (s : Program.stmt) = + let replace_stmt ~(global_vars : Var.generator) (s : Program.stmt) = match s with | Instr_IndirectCall { attrib } -> Instr_Assert @@ -480,7 +475,8 @@ module Normalise = struct ( lhs, Expr.BasilExpr.fapply (Expr.BasilExpr.rvar - (global_vars.with_name ~access:Var.Const fn_name (Var.typ lhs))) + (global_vars.with_name ~access:Var.Const fn_name + (Var.typ lhs))) [ Expr.BasilExpr.rvar rhs; addr ] ); ]; attrib; @@ -497,7 +493,8 @@ module Normalise = struct ( lhs, Expr.BasilExpr.fapply (Expr.BasilExpr.rvar - (global_vars.with_name ~access:Var.Const fn_name (Var.typ lhs))) + (global_vars.with_name ~access:Var.Const fn_name + (Var.typ lhs))) [ Expr.BasilExpr.rvar rhs; addr; value ] ); ]; attrib; @@ -519,25 +516,30 @@ module Normalise = struct let prog = Program.flat_map_decls (fun k -> function - | Function { binding; attrib; definition ; var_gen} -> ( + | Function { binding; attrib; definition; var_gen } -> ( let keep = - Iter.singleton (Function { binding; attrib; definition ; var_gen}) + Iter.singleton + (Function { binding; attrib; definition; var_gen }) in match definition with | Function b -> ( match BasilExpr.unfix b with | Lambda { bound_vars; in_body } -> keep | body -> - let axiom_name = - (ID.name k ^ "_funvalue") - in + let axiom_name = ID.name k ^ "_funvalue" in Iter.doubleton (Function - { binding; definition = Uninterpreted; attrib ; var_gen }) + { + binding; + definition = Uninterpreted; + attrib; + var_gen; + }) (Function { binding = - vg.with_name (axiom_name) ~access:(Var.access binding) (Var.typ binding); + vg.with_name axiom_name + ~access:(Var.access binding) (Var.typ binding); var_gen; definition = Axiom @@ -557,14 +559,13 @@ module Normalise = struct Program.map_procedures (fun _ p -> Procedure.map_blocks_nondet - (fun (id, b) -> Block.map ~phi:Fun.id (replace_stmt ~global_vars:gids) b) + (fun (id, b) -> + Block.map ~phi:Fun.id (replace_stmt ~global_vars:gids) b) p) p end let transform (p : Program.t) = - p |> Normalise.replace_functions - |> Normalise.replace_exprs + p |> Normalise.replace_functions |> Normalise.replace_exprs |> Instructions.transform_add_store_load_decls |> Normalise.replace_stmts - |> Builtins.transform_add_builtin_decls - |> Builtins.transform_builtin_decls + |> Builtins.transform_add_builtin_decls |> Builtins.transform_builtin_decls From 2facc2895c36a31d367ff4c7ac22790762f91bf9 Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 9 Jul 2026 14:33:09 +1000 Subject: [PATCH 19/22] revert malloc_free.t verbose --- test/cram/malloc_free.t | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/test/cram/malloc_free.t b/test/cram/malloc_free.t index 6dbccaad..b6851167 100644 --- a/test/cram/malloc_free.t +++ b/test/cram/malloc_free.t @@ -1,19 +1,11 @@ - $ bincaml script malloc_free.sexp -v + $ bincaml script malloc_free.sexp (load-il ../../examples/memory/malloc_free.il) (run-transforms ssa split-memory-encoding) - bincaml: [DEBUG] Starting ssa - bincaml: [DEBUG] Starting split-memory-encoding (run-transforms memory-specification flatten-phis) - bincaml: [DEBUG] Starting memory-specification - bincaml: [DEBUG] Starting flatten-phis (dump-boogie good.bpl) (load-il ../../examples/memory/malloc_free_oob.il) (run-transforms ssa split-memory-encoding) - bincaml: [DEBUG] Starting ssa - bincaml: [DEBUG] Starting split-memory-encoding (run-transforms memory-specification flatten-phis) - bincaml: [DEBUG] Starting memory-specification - bincaml: [DEBUG] Starting flatten-phis (dump-boogie bad.bpl) $ cat ./good.bpl From 39072e61c68ebf10d736a8aca626730e74efdedf Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 9 Jul 2026 14:39:49 +1000 Subject: [PATCH 20/22] aslp fix --- lib/transforms/aslp/aslp_lexpr.ml | 1 + test/transforms/test_aslp.ml | 18 +++++++++--------- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/lib/transforms/aslp/aslp_lexpr.ml b/lib/transforms/aslp/aslp_lexpr.ml index 480efc96..2d041f2c 100644 --- a/lib/transforms/aslp/aslp_lexpr.ml +++ b/lib/transforms/aslp/aslp_lexpr.ml @@ -69,6 +69,7 @@ let typ (x : t) = let name : _ -> string = function | Local (v, _) -> v + | SP_EL0 -> "SP" | R (Some n) -> Printf.sprintf "R%d" n | Z (Some n) -> Printf.sprintf "Z%d" n | R None | Z None -> failwith "name_of_lexpr: array lexpr has no bincaml name" diff --git a/test/transforms/test_aslp.ml b/test/transforms/test_aslp.ml index cfebf889..fc026b78 100644 --- a/test/transforms/test_aslp.ml +++ b/test/transforms/test_aslp.ml @@ -166,34 +166,34 @@ proc @main() -> () { } ]; block %block { .asm = "stp x29, x30, [sp, #-0x20]!" } [ var v:bv64 := 0x0:bv64; - var v:bv64 := $SP_EL0; - $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP_EL0, + var v:bv64 := $SP; + $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP, 0xffffffffffffffe0:bv64) $R29 8; - $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd(bvadd($SP_EL0, + $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd(bvadd($SP, 0xffffffffffffffe0:bv64), 0x8:bv64) $R30 8; - $SP_EL0:bv64 := bvadd(v:bv64, 0xffffffffffffffe0:bv64); + $SP:bv64 := bvadd(v:bv64, 0xffffffffffffffe0:bv64); (var BranchTaken:bool := false, $PC:bv64 := 0x40080c:bv64); goto (%block_1); ]; block %block_1 { .asm = "mov x29, sp" } [ var v_1:bv64 := 0x0:bv64; - $R29:bv64 := bvadd($SP_EL0, 0x0:bv64); + $R29:bv64 := bvadd($SP, 0x0:bv64); (var BranchTaken:bool := false, $PC:bv64 := 0x400810:bv64); goto (%block_2); ]; block %block_2 { .asm = "str w0, [sp, #0x1c]" } [ - $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP_EL0, 0x1c:bv64) extract(-32,0, $R0) 4; + $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP, 0x1c:bv64) extract(-32,0, $R0) 4; (var BranchTaken:bool := false, $PC:bv64 := 0x400814:bv64); goto (%block_3); ]; block %block_3 { .asm = "str x1, [sp, #0x10]" } [ - $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP_EL0, 0x10:bv64) $R1 8; + $mem:(bv64->bv8) := store le $mem:(bv64->bv8) bvadd($SP, 0x10:bv64) $R1 8; (var BranchTaken:bool := false, $PC:bv64 := 0x400818:bv64); goto (%block_4); ]; block %block_4 { .asm = "ldrsw x0, [sp, #0x1c]" } [ var v_2:bv32 := 0x0:bv32; - $mem:(bv64->bv8) := load le v_3:bv4 bvadd($SP_EL0, 0x1c:bv64) 4; + $mem:(bv64->bv8) := load le v_3:bv4 bvadd($SP, 0x1c:bv64) 4; var v_2:bv32 := v_3:bv4; $R0:bv64 := zero_extend(0, sign_extend(32, v_2:bv32)); (var BranchTaken:bool := false, $PC:bv64 := 0x40081c:bv64); @@ -208,7 +208,7 @@ proc @main() -> () { } ]; block %ret_1 [ return; ] ]; - var $SP_EL0:bv64; + var $SP:bv64; var $R29:bv64; var $R30:bv64; var $R0:bv64; From d53b6125ae17103f99a8f6daeb8d9cce82d6dd04 Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 9 Jul 2026 15:11:52 +1000 Subject: [PATCH 21/22] simpler create_proc --- lib/lang/procedure.ml | 78 +++++++++++++++++++++++++++++++++++++++++++ lib/loadir.ml | 31 ++++++++++------- 2 files changed, 97 insertions(+), 12 deletions(-) diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index 8b9fba9d..6ffbdf07 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -127,6 +127,21 @@ module PG : sig unit -> ('a, 'b) t + val create_p : + IDSet.elt -> + ?is_stub:bool -> + ?formal_in_params:(string * Types.t) list -> + ?formal_out_params:(string * Types.t) list -> + ?captures_globs:(string * Types.t) list -> + ?modifies_globs:(string * Types.t) list -> + ?requires:BasilExpr.t list -> + ?ensures:BasilExpr.t list -> + ?rely:BasilExpr.t list -> + ?guarantee:BasilExpr.t list -> + ?attrib:Attrib.attrib_map -> + unit -> + (Var.t, 'a) t + val attrib : ('a, 'b) t -> Attrib.attrib_map val set_attrib : ('a, 'b) t -> Attrib.t -> string -> ('a, 'b) t val set_attribs : ('a, 'b) t -> Attrib.attrib_map -> ('a, 'b) t @@ -288,6 +303,69 @@ end = struct Return); } + let create_p id ?(is_stub = false) ?(formal_in_params = []) + ?(formal_out_params = []) ?(captures_globs = []) ?(modifies_globs = []) + ?(requires = []) ?(ensures = []) ?(rely = []) ?(guarantee = []) + ?(attrib = Attrib.empty) () = + let local_ids = ID.make_gen ~scope_name:(ID.name id) () in + let vg = Var.mk_gen ~id_generator:local_ids () in + let vars_of_list = + List.map (fun (name, ty) -> + let v = vg.with_name name ty in + (Var.name v, v)) + in + let formal_in_params = + formal_in_params |> vars_of_list |> StringMap.of_list + in + let specification = + { + captures_globs = + (List.map (uncurry @@ vg.with_name ~access:None)) captures_globs; + modifies_globs = + (List.map (uncurry @@ vg.with_name ~access:None)) modifies_globs; + requires; + ensures; + rely; + guarantee; + } + in + let formal_out_params = + formal_out_params |> vars_of_list |> StringMap.of_list + in + let block_ids = ID.make_gen () in + let locals = + Hashtbl.create + (StringMap.cardinal formal_in_params + + StringMap.cardinal formal_out_params) + in + Hashtbl.add_iter locals + (Iter.append + (StringMap.to_iter formal_in_params) + (StringMap.to_iter formal_out_params)); + + let graph = if is_stub then None else Some empty_graph in + { + id; + attrib; + formal_in_params; + formal_out_params; + graph; + locals; + local_ids; + block_ids; + specification; + topo_fwd = + lazy + (WTO.recursive_scc + (Option.get_exn_or "no graph to iterate" graph) + Entry); + topo_rev = + lazy + (RevWTO.recursive_scc + (Option.get_exn_or "no graph to iterate" graph) + Return); + } + let make_stub p = { p with diff --git a/lib/loadir.ml b/lib/loadir.ml index 4608e055..78b23abd 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -294,23 +294,27 @@ module BasilASTLoader = struct attrib, spec, definition ) -> - let ids = ID.make_gen ~scope_name:id () in - let vg = Var.mk_gen ~id_generator:ids ~scope:`Local () in let proc_id = Program.declare_name id prog.prog in - let formal_in_params_order = List.map (param_to_formal vg) in_params in - let formal_in_params = formal_in_params_order |> StringMap.of_list in + let formal_in_params = List.map param_names in_params in + let formal_out_params = List.map param_names out_params in + let _, attrib = trans_attrib_set prog ~binds:StringMap.empty attrib in + let is_stub = Stdlib.(definition = ProcDef_Empty) in + let p = + Procedure.create_p proc_id ~attrib ~is_stub ~formal_in_params + ~formal_out_params () + in + let formal_in_params_order = + formal_in_params + |> List.map (fun (n, _) -> + (n, StringMap.find n (Procedure.formal_in_params p))) + in let formal_out_params_order = - List.map (param_to_formal vg) out_params + formal_out_params + |> List.map (fun (n, _) -> + (n, StringMap.find n (Procedure.formal_out_params p))) in - let formal_out_params = StringMap.of_list formal_out_params_order in - let _, attrib = trans_attrib_set prog ~binds:formal_in_params attrib in Hashtbl.add prog.params_order id (formal_in_params_order, formal_out_params_order); - let is_stub = Stdlib.(definition = ProcDef_Empty) in - let p = - Procedure.create proc_id ~local_id_gen:ids ~attrib ~is_stub - ~formal_in_params ~formal_out_params () - in let prog = map_prog (Program.add_proc p) prog in prog @@ -1076,6 +1080,9 @@ module BasilASTLoader = struct | Params1 (LocalIdent (pos, id), t) -> (id, p.with_name id ~access:None (trans_type t)) + and param_names (pp : params) : string * Types.t = + match pp with Params1 (LocalIdent (pos, id), t) -> (id, trans_type t) + and trans_funspec prog bound_post (spec : (Var.t, BasilExpr.t) Procedure.proc_spec) (s : funSpec) : (Var.t, BasilExpr.t) Procedure.proc_spec = From c45a5d1f1af0779663a71ac17c18c60fb487bb54 Mon Sep 17 00:00:00 2001 From: agle Date: Thu, 9 Jul 2026 15:17:53 +1000 Subject: [PATCH 22/22] cleanup --- lib/lang/procedure.ml | 12 ++++++++++++ lib/loadir.ml | 9 +++------ 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/lib/lang/procedure.ml b/lib/lang/procedure.ml index 6ffbdf07..377987d5 100644 --- a/lib/lang/procedure.ml +++ b/lib/lang/procedure.ml @@ -251,6 +251,7 @@ end = struct let graph = G.add_vertex graph Return in graph + (** Create a generic procedure *) let create id ?local_id_gen ?(is_stub = false) ?(formal_in_params = StringMap.empty) ?(formal_out_params = StringMap.empty) ?(captures_globs = []) @@ -303,6 +304,7 @@ end = struct Return); } + (** Create a (Var.t, Expr.BasilExpr.t) procedure *) let create_p id ?(is_stub = false) ?(formal_in_params = []) ?(formal_out_params = []) ?(captures_globs = []) ?(modifies_globs = []) ?(requires = []) ?(ensures = []) ?(rely = []) ?(guarantee = []) @@ -685,6 +687,16 @@ let fold_blocks_topo_rev_headers let fold_blocks_topo_rev (f : 'a -> ID.t -> Edge.block -> 'a) init p = fold_blocks_topo_rev_headers (fun acc i -> f acc) init p +(** get map for formal params assuming in and out are disjointly named (they + should be) *) +let get_formal_params p = + StringMap.merge_safe + ~f:(fun _ -> function + | `Both _ -> failwith "present in both" + | `Left l -> Some l + | `Right r -> Some r) + (formal_in_params p) (formal_out_params p) + let map_blocks_nondet f p = iter_blocks p |> Iter.fold diff --git a/lib/loadir.ml b/lib/loadir.ml index 78b23abd..4a36ae7e 100644 --- a/lib/loadir.ml +++ b/lib/loadir.ml @@ -303,15 +303,12 @@ module BasilASTLoader = struct Procedure.create_p proc_id ~attrib ~is_stub ~formal_in_params ~formal_out_params () in + let param n = StringMap.find n @@ Procedure.get_formal_params p in let formal_in_params_order = - formal_in_params - |> List.map (fun (n, _) -> - (n, StringMap.find n (Procedure.formal_in_params p))) + formal_in_params |> List.map (fun (n, _) -> (n, param n)) in let formal_out_params_order = - formal_out_params - |> List.map (fun (n, _) -> - (n, StringMap.find n (Procedure.formal_out_params p))) + formal_out_params |> List.map (fun (n, _) -> (n, param n)) in Hashtbl.add prog.params_order id (formal_in_params_order, formal_out_params_order);