From fc5b5e3980ad3c7e71b7f778ce6b57d996857e3c Mon Sep 17 00:00:00 2001 From: Angs12 Date: Mon, 25 May 2026 16:22:37 +0300 Subject: [PATCH 01/44] x86: resolve RIP-relative addresses --- plugins/x86/semantics/x86-64.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/x86/semantics/x86-64.lisp b/plugins/x86/semantics/x86-64.lisp index d2551ccda..131df6625 100644 --- a/plugins/x86/semantics/x86-64.lisp +++ b/plugins/x86/semantics/x86-64.lisp @@ -478,4 +478,4 @@ (set rd (opo (opi rn rm)))) (defmacro bitwise-rrm (set opo opi rd rn ptr off) - (set rd (opo (opi rn (load-bits (word-width (unquote rn)) (+ ptr off)))))) + (set rd (opo (opi rn (load-bits (word-width (unquote rn)) (+ (reg# ptr) off)))))) From 36db150c1bd4bb58f2ecee4867c8f3994a954fe2 Mon Sep 17 00:00:00 2001 From: Angs12 Date: Mon, 25 May 2026 17:05:44 +0300 Subject: [PATCH 02/44] x86: add instruction length and fix PC resolution --- .../primus_lisp/primus_lisp_semantic_primitives.ml | 11 +++++++++++ plugins/primus_lisp/site-lisp/llvm-x86-64-floats.lisp | 2 +- plugins/x86/semantics/x86-64.lisp | 2 +- 3 files changed, 13 insertions(+), 2 deletions(-) diff --git a/plugins/primus_lisp/primus_lisp_semantic_primitives.ml b/plugins/primus_lisp/primus_lisp_semantic_primitives.ml index ee4b2e9bc..4fddc684d 100644 --- a/plugins/primus_lisp/primus_lisp_semantic_primitives.ml +++ b/plugins/primus_lisp/primus_lisp_semantic_primitives.ml @@ -256,6 +256,10 @@ let export = Primus.Lisp.Type.Spec.[ "get-current-program-counter", unit @-> int, "(get-current-program-counter) is an alias to (get-program-counter)"; + "get-instruction-length", unit @-> int, + "(get-instruction-length) returns the length of the current instruction \ + in bytes."; + "set-symbol-value", tuple [any; a] @-> a, "(set-symbol-value S X) sets the value of the symbol S to X. Returns X"; @@ -839,6 +843,12 @@ module Primitives(CT : Theory.Core)(T : Target) = struct | None -> !!(empty s) | Some addr -> forget@@const_int s addr + let get_instruction_length s lbl = + let open Bap.Std in + KB.collect Memory.slot lbl >>= function + | None -> !!(empty s) + | Some mem -> forget@@int s (Memory.length mem) + let require_symbol v k = match symbol v with | Some name -> k name @@ -1479,6 +1489,7 @@ module Primitives(CT : Theory.Core)(T : Target) = struct | "store-word",_-> data@@store_word t args | "get-program-counter",[] | "get-current-program-counter",[] -> pure@@get_pc s lbl + | "get-instruction-length",[] -> pure@@get_instruction_length s lbl | "set-symbol-value",[sym;x] -> data@@set_symbol t sym x | "symbol-concat",syms -> pure@@symbol_concat s syms | "symbol",[x] -> pure@@mksymbol s x diff --git a/plugins/primus_lisp/site-lisp/llvm-x86-64-floats.lisp b/plugins/primus_lisp/site-lisp/llvm-x86-64-floats.lisp index e8980b26d..a75b833c5 100644 --- a/plugins/primus_lisp/site-lisp/llvm-x86-64-floats.lisp +++ b/plugins/primus_lisp/site-lisp/llvm-x86-64-floats.lisp @@ -24,7 +24,7 @@ (defun reg-val (reg) (case (reg-name reg) - 'RIP (+ (get-current-program-counter) 8) + 'RIP (+ (get-current-program-counter) (get-instruction-length)) 'RSP RSP 'RBP RBP (error "unknown register"))) diff --git a/plugins/x86/semantics/x86-64.lisp b/plugins/x86/semantics/x86-64.lisp index 131df6625..045c5fc5b 100644 --- a/plugins/x86/semantics/x86-64.lisp +++ b/plugins/x86/semantics/x86-64.lisp @@ -24,7 +24,7 @@ (defun reg# (reg) (if (is-rip reg) - (+ (get-program-counter) 8) + (+ (get-program-counter) (get-instruction-length)) reg)) (defun load-mem (reg off) From 20922e0d71fbbbf35892b2c4615bb274eead3e0b Mon Sep 17 00:00:00 2001 From: Angs12 Date: Wed, 24 Jun 2026 14:33:56 +0300 Subject: [PATCH 03/44] x86: add symbolic immediates to the lifter --- plugins/optimization/optimization_main.ml | 277 +- plugins/x86/x86_lifter.ml | 2966 +++++++++++---------- plugins/x86/x86_main.ml | 150 +- plugins/x86/x86_sym_imm_lifter.ml | 1967 ++++++++++++++ plugins/x86/x86_sym_imm_lifter.mli | 12 + plugins/x86/x86_sym_imm_targets.ml | 22 + plugins/x86/x86_sym_imm_targets.mli | 14 + 7 files changed, 3843 insertions(+), 1565 deletions(-) create mode 100644 plugins/x86/x86_sym_imm_lifter.ml create mode 100644 plugins/x86/x86_sym_imm_lifter.mli create mode 100644 plugins/x86/x86_sym_imm_targets.ml create mode 100644 plugins/x86/x86_sym_imm_targets.mli diff --git a/plugins/optimization/optimization_main.ml b/plugins/optimization/optimization_main.ml index 314534750..4b3f89c1d 100644 --- a/plugins/optimization/optimization_main.ml +++ b/plugins/optimization/optimization_main.ml @@ -1,20 +1,16 @@ -open Core_kernel[@@warning "-D"] +open Core_kernel [@@warning "-D"] open Bap.Std open Regular.Std open Format -include Self() - +include Self () module Digest = Data.Cache.Digest module O = Optimization_data type level = int - type cls = Phys | Virt | Flag let classify is_flag var = - if is_flag var then Flag - else if Var.is_physical var then Phys - else Virt + if is_flag var then Flag else if Var.is_physical var then Phys else Virt let is_optimization_allowed is_flag level var = match classify is_flag var with @@ -22,56 +18,58 @@ let is_optimization_allowed is_flag level var = | Flag -> level > 1 | Phys -> level > 2 -let def_use_collector = object - inherit [Var.Set.t * Var.Set.t] Term.visitor +let def_use_collector = + object + inherit [Var.Set.t * Var.Set.t] Term.visitor - method! enter_def t (defs,uses) = - Set.add defs (Def.lhs t), Set.union uses (Def.free_vars t) + method! enter_def t (defs, uses) = + (Set.add defs (Def.lhs t), Set.union uses (Def.free_vars t)) - method! enter_phi t (defs,uses) = - Set.add defs (Phi.lhs t), Set.union uses (Phi.free_vars t) + method! enter_phi t (defs, uses) = + (Set.add defs (Phi.lhs t), Set.union uses (Phi.free_vars t)) - method! enter_jmp t (defs,uses) = - defs, Set.union uses (Jmp.free_vars t) -end + method! enter_jmp t (defs, uses) = (defs, Set.union uses (Jmp.free_vars t)) + end let computed_def_use sub = - def_use_collector#visit_sub sub (Var.Set.empty,Var.Set.empty) + def_use_collector#visit_sub sub (Var.Set.empty, Var.Set.empty) let compute_dead can_touch protected sub = - let defs,uses = computed_def_use sub in + let defs, uses = computed_def_use sub in let dead = Set.diff defs uses in let live v = not (Set.mem dead v) in - Term.enum blk_t sub |> - Seq.fold ~init:Tid.Set.empty ~f:(fun dead blk -> - Term.enum ~rev:true def_t blk |> - Seq.fold ~init:(protected,dead) ~f:(fun (protected,dead) def -> + Term.enum blk_t sub + |> Seq.fold ~init:Tid.Set.empty ~f:(fun dead blk -> + Term.enum ~rev:true def_t blk + |> Seq.fold ~init:(protected, dead) ~f:(fun (protected, dead) def -> let v = Def.lhs def in - if not (can_touch v) || live v - then (protected,dead) - else if Set.mem protected (Var.base v) - then Set.remove protected (Var.base v), dead - else protected, Set.add dead (Term.tid def)) |> - snd) + if (not (can_touch v)) || live v then (protected, dead) + else if Set.mem protected (Var.base v) then + (Set.remove protected (Var.base v), dead) + else (protected, Set.add dead (Term.tid def))) + |> snd) let is_alive dead t = not (Set.mem dead (Term.tid t)) let live_phi dead blk = Term.filter phi_t ~f:(is_alive dead) blk let live_def can_touch dead blk = Term.filter def_t blk ~f:(fun d -> - not (can_touch (Def.lhs d)) || is_alive dead d) + (not (can_touch (Def.lhs d))) || is_alive dead d) let rec substitute vars exp = - let substituter = object - inherit Exp.mapper as super - method! map_let var ~exp ~body = - let exp = super#map_exp exp in - let body = substitute (Map.remove vars var) body in - Bil.let_ var exp body - method! map_var v = match Map.find vars v with - | None -> Bil.var v - | Some e -> e - end in + let substituter = + object + inherit Exp.mapper as super + + method! map_let var ~exp ~body = + let exp = super#map_exp exp in + let body = substitute (Map.remove vars var) body in + Bil.let_ var exp body + + method! map_var v = + match Map.find vars v with None -> Bil.var v | Some e -> e + end + in substituter#map_exp exp |> Exp.fold_consts let equal_kinds j j' = compare_jmp_kind (Jmp.kind j) (Jmp.kind j') = 0 @@ -79,48 +77,47 @@ let equal_kinds j j' = compare_jmp_kind (Jmp.kind j) (Jmp.kind j') = 0 let substitute sub vars = let def d = let rhs = substitute vars (Def.rhs d) in - if Exp.(Def.rhs d <> rhs) then - O.mark_updated (Def.with_rhs d rhs) - else d in + if Exp.(Def.rhs d <> rhs) then O.mark_updated (Def.with_rhs d rhs) else d + in let jmp j = let j' = Jmp.map_exp j ~f:(substitute vars) in - if Exp.(Jmp.cond j <> Jmp.cond j') || not (equal_kinds j j') - then O.mark_updated j' - else j in + if Exp.(Jmp.cond j <> Jmp.cond j') || not (equal_kinds j j') then + O.mark_updated j' + else j + in Term.map blk_t sub ~f:(Blk.map_elts ~def ~jmp) (* A simple constant propagation. Note, the input is required to be in SSA. *) let propagate_consts can_touch sub = - Seq.fold (Term.enum blk_t sub) ~init:Var.Map.empty - ~f:(fun vars b -> - Seq.fold (Term.enum def_t b) ~init:vars - ~f:(fun vars d -> - let v = Def.lhs d in - if can_touch v then - match Def.rhs d with - | Bil.Unknown _ | Bil.Int _ as exp -> - Map.set vars ~key:v ~data:exp - | _ -> vars - else vars)) |> - substitute sub + Seq.fold (Term.enum blk_t sub) ~init:Var.Map.empty ~f:(fun vars b -> + Seq.fold (Term.enum def_t b) ~init:vars ~f:(fun vars d -> + let v = Def.lhs d in + if can_touch v then + match Def.rhs d with + | (Bil.Unknown _ | Bil.Int _) as exp -> + Map.set vars ~key:v ~data:exp + | _ -> vars + else vars)) + |> substitute sub let clean can_touch dead sub = Term.map blk_t sub ~f:(fun b -> live_def can_touch dead b |> live_phi dead) let is_flag arch = - let module T = (val (target_of_arch arch)) in + let module T = (val target_of_arch arch) in T.CPU.is_flag let free_vars prog = report_progress ~note:"free-vars" (); - let (++) = Set.union in + let ( ++ ) = Set.union in let collect cls t ~f = - Seq.fold (Term.enum cls t) ~init:Var.Set.empty - ~f:(fun acc x -> acc ++ f x) in + Seq.fold (Term.enum cls t) ~init:Var.Set.empty ~f:(fun acc x -> acc ++ f x) + in let sub_free sub = Sub.free_vars sub |> Set.filter ~f:Var.is_physical in let sub_args sub = collect arg_t sub ~f:(fun arg -> - Set.add (Exp.free_vars (Arg.rhs arg)) (Arg.lhs arg)) in + Set.add (Exp.free_vars (Arg.rhs arg)) (Arg.lhs arg)) + in collect sub_t prog ~f:(fun sub -> sub_args sub ++ sub_free sub) let process_sub free can_touch sub = @@ -128,27 +125,32 @@ let process_sub free can_touch sub = let s = propagate_consts can_touch s in let dead' = compute_dead can_touch free s in let dead = Set.union dead dead' in - if Set.is_empty dead' then s, dead - else loop dead (clean can_touch dead' s) in + if Set.is_empty dead' then (s, dead) + else loop dead (clean can_touch dead' s) + in let sub', dead = loop Tid.Set.empty (Sub.ssa sub) in O.create dead sub' let digest_of_sub sub level = - let add addrs t = match Term.get_attr t address with + let add addrs t = + match Term.get_attr t address with | None -> addrs - | Some a -> Set.add addrs a in + | Some a -> Set.add addrs a + in let addrs = - Term.to_sequence blk_t sub |> - Seq.fold ~init:(Set.empty (module Addr)) - ~f:(fun addrs b -> - Seq.fold (Blk.elts b) ~init:(add addrs b) - ~f:(fun addrs -> function - | `Def d -> add addrs d - | `Jmp j -> add addrs j - | `Phi p -> add addrs p)) in + Term.to_sequence blk_t sub + |> Seq.fold + ~init:(Set.empty (module Addr)) + ~f:(fun addrs b -> + Seq.fold (Blk.elts b) ~init:(add addrs b) ~f:(fun addrs -> function + | `Def d -> add addrs d + | `Jmp j -> add addrs j + | `Phi p -> add addrs p)) + in let digest = Digest.create ~namespace:"optimization" in - let digest = Set.fold addrs ~init:digest ~f:(fun d a -> - Digest.add d "%a" Addr.pp a) in + let digest = + Set.fold addrs ~init:digest ~f:(fun d a -> Digest.add d "%a" Addr.pp a) + in let digest = Digest.add digest "%s" (Sub.name sub) in Digest.add digest "%d" level @@ -158,73 +160,64 @@ let run level proj = Project.map_program proj ~f:(fun prog -> let free = free_vars prog in Term.map sub_t prog ~f:(fun sub -> - let digest = digest_of_sub sub level in - match O.Cache.load digest with - | Some data -> O.apply sub data - | None -> - let data = process_sub free can_touch sub in - let sub = O.update sub data in - let data = O.find_unreachable sub data in - O.Cache.save digest data; - O.remove_dead_code sub data)) + let data = process_sub free can_touch sub in + let sub = O.update sub data in + let data = O.find_unreachable sub data in + O.remove_dead_code sub data)) let () = - Config.manpage [ - `S "SYNOPSIS"; - `Pre " - $(b,--)$(mname) -"; - `S "DESCRIPTION"; - - `P "An autorun pass that conservatively removes dead code. The - removed dead code is usually produced by a lifter, though it might - be possible that a binary indeed contains a dead code. The algorithm - doesn't remove variables that are stored in memory, only registers - are considered"; - - `S "ALGORITHM"; - - `P "Applies constant folding, dead code elimination, and constant - propagation in a loop until the fixed point is reached. The - algorithm is interprocedural, however it is not call graph - sensitive, as instead of considering the call graph we use an over - approximation that any function can call any other, thus any - variables that occurs free in any function is considered to be - non-constant. The algorithm is, however, flow sensitive on the - control flow graph level and uses the SSA form to encode data - facts. Since, it is not always safe to rely on the control flow - integrity and CFG precision, by default we optimize only flags and - virtual variables under a presumption that those two kind of data - points rarely used non-locally. - - See the $(b,--optimization-level) parameter for the list of - available optimization levels and their consequences."; - - `S "DEPENDENCIES"; - `P "$(b,bap-plugin-api)(1)"; - - `S "SEE ALSO"; - `P "$(b,bap-plugin-api)(1), $(b,bap-plugin-ssa)(1)"; - ]; + Config.manpage + [ + `S "SYNOPSIS"; + `Pre "\n $(b,--)$(mname)\n"; + `S "DESCRIPTION"; + `P + "An autorun pass that conservatively removes dead code. The\n\ + \ removed dead code is usually produced by a lifter, though it might\n\ + \ be possible that a binary indeed contains a dead code. The algorithm\n\ + \ doesn't remove variables that are stored in memory, only registers\n\ + \ are considered"; + `S "ALGORITHM"; + `P + "Applies constant folding, dead code elimination, and constant\n\ + \ propagation in a loop until the fixed point is reached. The\n\ + \ algorithm is interprocedural, however it is not call graph\n\ + \ sensitive, as instead of considering the call graph we use an over\n\ + \ approximation that any function can call any other, thus any\n\ + \ variables that occurs free in any function is considered to be\n\ + \ non-constant. The algorithm is, however, flow sensitive on the\n\ + \ control flow graph level and uses the SSA form to encode data\n\ + \ facts. Since, it is not always safe to rely on the control flow\n\ + \ integrity and CFG precision, by default we optimize only flags and\n\ + \ virtual variables under a presumption that those two kind of data\n\ + \ points rarely used non-locally.\n\n\ + \ See the $(b,--optimization-level) parameter for the list of\n\ + \ available optimization levels and their consequences."; + `S "DEPENDENCIES"; + `P "$(b,bap-plugin-api)(1)"; + `S "SEE ALSO"; + `P "$(b,bap-plugin-api)(1), $(b,bap-plugin-ssa)(1)"; + ]; let level = let doc = - "Specifies the optimization level. The higher the value the more - aggressive (and less safe) optimizations are applied. On level - 0 we touch nothing, only some constant folding may occur. On - level 1 we optimize only the synthetic code that was generated - by the lifter. Since such code can't leave a scope of instruction - it is not affected by the imprecision of a control flow graph. - On level 2, we also move and optimize processor flags. This - removes a significant amount of code and simplifies the program - and is a fair compromise between safety and performance. - (Since flags are rarely used non-locally). - Finally, on level 3 we extend our analysis to all variables." in - - Config.(param int ~default:0 ~doc "level") in - - Config.declare_extension - ~doc:"removes dead code and propagates constants" - ~provides:["pass"; "optimization"; "analysis"; "simplification"] - (fun {Config.get=(!)} -> - if !level > 0 - then Project.register_pass ~deps:["api"] ~autorun:true (run !level)) + "Specifies the optimization level. The higher the value the more\n\ + \ aggressive (and less safe) optimizations are applied. On level\n\ + \ 0 we touch nothing, only some constant folding may occur. On\n\ + \ level 1 we optimize only the synthetic code that was generated\n\ + \ by the lifter. Since such code can't leave a scope of instruction\n\ + \ it is not affected by the imprecision of a control flow graph.\n\ + \ On level 2, we also move and optimize processor flags. This\n\ + \ removes a significant amount of code and simplifies the program\n\ + \ and is a fair compromise between safety and performance.\n\ + \ (Since flags are rarely used non-locally).\n\ + \ Finally, on level 3 we extend our analysis to all variables." + in + + Config.(param int ~default:0 ~doc "level") + in + + Config.declare_extension ~doc:"removes dead code and propagates constants" + ~provides:[ "pass"; "optimization"; "analysis"; "simplification" ] + (fun { Config.get = ( ! ) } -> + if !level > 0 then + Project.register_pass ~deps:[ "api" ] ~autorun:true (run !level)) diff --git a/plugins/x86/x86_lifter.ml b/plugins/x86/x86_lifter.ml index 5db51f02d..b4b6459ac 100644 --- a/plugins/x86/x86_lifter.ml +++ b/plugins/x86/x86_lifter.ml @@ -1,16 +1,15 @@ (** Native lifter of x86 instructions to the BAP IL *) -open Core_kernel[@@warning "-D"] +open Core_kernel [@@warning "-D"] open Bap.Std open Format open Bil.Types open X86_types open X86_utils open X86_env -include Self() +include Self () module ToIR = struct - let cf_e = Bil.var cf let pf_e = Bil.var pf let af_e = Bil.var af @@ -19,44 +18,40 @@ module ToIR = struct let of_e = Bil.var oF let df_e = Bil.var df - let size_of_typ s = Size.of_int_exn !!s (** doubts here *) - + (** doubts here *) + let size_of_typ s = Size.of_int_exn !!s let undefine = List.map ~f:(fun r -> Bil.(r := unknown "#undefined" (Var.typ r))) - (* stmt helpers *) let store_s mode s t a e = - let mem = match mode with - | X86 -> R32.mem - | X8664 -> R64.mem in + let mem = match mode with X86 -> R32.mem | X8664 -> R64.mem in let sz = size_of_typ t in match s with | None -> Bil.Move (mem, Bil.(Store (Var mem, a, e, LittleEndian, sz))) - | Some v -> Bil.Move (mem, Bil.(Store (Var mem, Var v + a, e, - LittleEndian, sz))) + | Some v -> + Bil.Move (mem, Bil.(Store (Var mem, Var v + a, e, LittleEndian, sz))) (* copypasted from op2e_s below, but keeps the opcode width *) let op2e_s_keep_width mode ss has_rex t operand = - let (=) = Type.equal in + let ( = ) = Type.equal in match operand with | Ovec r when t = reg256_t -> (bits2ymme mode r, t) | Ovec r when t = reg128_t -> (bits2ymm128e mode r, t) | Ovec r when t = reg64_t -> (bits2ymm64e mode r, t) | Ovec r when t = reg32_t -> (bits2ymm32e mode r, t) | Ovec _ -> - let i = match t with - | Type.Imm n -> ": "^(string_of_int n) - | _ -> "" in - disfailwith mode ("invalid SIMD register size for op2e"^i) + let i = match t with Type.Imm n -> ": " ^ string_of_int n | _ -> "" in + disfailwith mode ("invalid SIMD register size for op2e" ^ i) | Oreg r when t = reg64_t -> (bits2reg64e mode r, t) | Oreg r when t = reg32_t -> (bits2reg32e mode r, t) | Oreg r when t = reg16_t -> (bits2reg16e mode r, t) | Oreg r when t = reg8_t -> (bits2reg8e mode ~has_rex r, t) | Oreg _ -> unimplemented mode "unknown register" - | Oseg r when t = reg64_t -> Bil.(Cast (UNSIGNED, !!reg64_t, bits2segrege r), t) + | Oseg r when t = reg64_t -> + Bil.(Cast (UNSIGNED, !!reg64_t, bits2segrege r), t) (* There is no 32-bit extension of segment selectors; this is not a bug *) | Oseg r when t = reg16_t -> (bits2segrege r, t) | Oseg _ -> (disfailwith mode "Segment register when t is not r16", t) @@ -64,23 +59,22 @@ module ToIR = struct | Oimm i -> Bil.(Int (resize_word i !!t), t) let op2e_s mode ss has_rex t operand = - let (=) = Type.equal in + let ( = ) = Type.equal in match operand with | Ovec r when t = reg256_t -> bits2ymme mode r | Ovec r when t = reg128_t -> bits2ymm128e mode r | Ovec r when t = reg64_t -> bits2ymm64e mode r | Ovec r when t = reg32_t -> bits2ymm32e mode r | Ovec _ -> - let i = match t with - | Type.Imm n -> ": "^(string_of_int n) - | _ -> "" in - disfailwith mode ("invalid SIMD register size for op2e"^i) + let i = match t with Type.Imm n -> ": " ^ string_of_int n | _ -> "" in + disfailwith mode ("invalid SIMD register size for op2e" ^ i) | Oreg r when t = reg64_t -> bits2reg64e mode r | Oreg r when t = reg32_t -> bits2reg32e mode r | Oreg r when t = reg16_t -> bits2reg16e mode r | Oreg r when t = reg8_t -> bits2reg8e mode ~has_rex r | Oreg _ -> unimplemented mode "unknown register" - | Oseg r when t = reg64_t -> Bil.(Cast (UNSIGNED, !!reg64_t, bits2segrege r)) + | Oseg r when t = reg64_t -> + Bil.(Cast (UNSIGNED, !!reg64_t, bits2segrege r)) (* There is no 32-bit extension of segment selectors; this is not a bug *) | Oseg r when t = reg16_t -> bits2segrege r | Oseg _ -> disfailwith mode "Segment register when t is not r16" @@ -89,66 +83,71 @@ module ToIR = struct let assn_s mode s has_rex has_vex t v e = (* Assign to some bits of v, starting at bit off, while preserving the other bits *) - let sub_assn ?(off=0) t v e = + let sub_assn ?(off = 0) t v e = let concat_exps = ref [] in let bits = !!(Var.typ v) in let assnbits = !!t in (* Add the upper preserved bits, if any *) - let ubh = (bits-1) and ubl = (assnbits+off) in - if ubh > ubl then concat_exps := (Bil.(Extract (ubh, ubl, Var v)))::!concat_exps; + let ubh = bits - 1 and ubl = assnbits + off in + if ubh > ubl then + concat_exps := Bil.(Extract (ubh, ubl, Var v)) :: !concat_exps; (* Add e *) - concat_exps := e::!concat_exps; + concat_exps := e :: !concat_exps; (* Add the lower preserved bits, if any *) - let lbh = (off-1) and lbl = 0 in + let lbh = off - 1 and lbl = 0 in if lbh > lbl then - concat_exps := (Bil.(Extract (lbh, lbl, Var v)))::!concat_exps; + concat_exps := Bil.(Extract (lbh, lbl, Var v)) :: !concat_exps; - let final_e = List.reduce_exn ~f:(fun big_e e -> Bil.Concat (e, big_e)) !concat_exps in + let final_e = + List.reduce_exn ~f:(fun big_e e -> Bil.Concat (e, big_e)) !concat_exps + in Bil.Move (v, final_e) in let is8664 = [%compare.equal: mode] mode X8664 in - match v, t with + match (v, t) with (* Zero-extend 128-bit assignments to 256-bit ymms. *) - | Ovec r, Type.Imm (128|64|32) when has_vex -> - let v = bits2ymm mode r in - sub_assn reg256_t v Bil.(Cast (UNSIGNED, !!reg256_t, e)) - | Ovec r, Type.Imm (256|128|64|32) -> - let v = bits2ymm mode r in - sub_assn t v e + | Ovec r, Type.Imm (128 | 64 | 32) when has_vex -> + let v = bits2ymm mode r in + sub_assn reg256_t v Bil.(Cast (UNSIGNED, !!reg256_t, e)) + | Ovec r, Type.Imm (256 | 128 | 64 | 32) -> + let v = bits2ymm mode r in + sub_assn t v e | Ovec _, _ -> disfailwith mode "invalid SIMD register size for assignment" (* Zero-extend 32-bit assignments to 64-bit registers. *) | Oreg r, Type.Imm 32 when is8664 -> - let v = bits2genreg mode r in - sub_assn reg64_t v Bil.(Cast (UNSIGNED, !!reg64_t, e)) - | Oreg r, Type.Imm (64|32|16) -> - let v = bits2genreg mode r in - sub_assn t v e - | Oreg r, Type.Imm 8 when r < 4 || ([%compare.equal: mode] mode X8664 && has_rex) -> - let v = bits2genreg mode r in - sub_assn t v e + let v = bits2genreg mode r in + sub_assn reg64_t v Bil.(Cast (UNSIGNED, !!reg64_t, e)) + | Oreg r, Type.Imm (64 | 32 | 16) -> + let v = bits2genreg mode r in + sub_assn t v e + | Oreg r, Type.Imm 8 + when r < 4 || ([%compare.equal: mode] mode X8664 && has_rex) -> + let v = bits2genreg mode r in + sub_assn t v e | Oreg r, Type.Imm 8 -> - let v = bits2genreg mode (r land 3) in - sub_assn ~off:8 t v e + let v = bits2genreg mode (r land 3) in + sub_assn ~off:8 t v e | Oreg _, _ -> unimplemented mode "assignment to sub registers" | Oseg r, _ when Type.equal t reg16_t -> - let v = bits2segreg r in - Bil.Move (v, e) - | Oseg _, _ -> disfailwith mode "Can't assign to non 16 bit segment register" + let v = bits2segreg r in + Bil.Move (v, e) + | Oseg _, _ -> + disfailwith mode "Can't assign to non 16 bit segment register" | Oaddr a, _ -> store_s mode s t a e - | Oimm _, _ -> disfailwith mode "disasm x86: Can't assign to an immediate value" - + | Oimm _, _ -> + disfailwith mode "disasm x86: Can't assign to an immediate value" (* Double width operands, as used by multiplication and division *) let op_dbl t = let open Type in match t with - | Imm 8 -> [reg16_t, o_rax] - | Imm 16 -> [reg16_t, o_rdx; reg16_t, o_rax] - | Imm 32 -> [reg32_t, o_rdx; reg32_t, o_rax] - | Imm 64 -> [reg64_t, o_rdx; reg64_t, o_rax] + | Imm 8 -> [ (reg16_t, o_rax) ] + | Imm 16 -> [ (reg16_t, o_rdx); (reg16_t, o_rax) ] + | Imm 32 -> [ (reg32_t, o_rdx); (reg32_t, o_rax) ] + | Imm 64 -> [ (reg64_t, o_rdx); (reg64_t, o_rax) ] | _ -> disfailwith X86 "op_dbl only defined for Reg 8, 16, 32, and 64" (* Return an expression for a double-width operand, as used by the div @@ -156,30 +155,36 @@ module ToIR = struct let op2e_dbl_s mode ss has_rex t = let cf (ct, o) = op2e_s mode ss has_rex ct o in let ol = List.map ~f:cf (op_dbl t) in - List.reduce_exn - ~f:(fun bige little -> Bil.(bige ^ little)) - ol + List.reduce_exn ~f:(fun bige little -> Bil.(bige ^ little)) ol (* Double width assignments, as used by multiplication *) let assn_dbl_s mode s has_rex has_vex t e = match op_dbl t with - | (t,o) :: [] -> [assn_s mode s has_rex has_vex t o e], op2e_s mode s has_rex t o + | (t, o) :: [] -> + ([ assn_s mode s has_rex has_vex t o e ], op2e_s mode s has_rex t o) | l -> - let tmp = tmp (Type.Imm (!!t * 2)) in - let f (stmts, off) (ct, o) = - let newoff = off + !!ct in - assn_s mode s has_rex has_vex ct o (Bil.Extract (newoff-1, off, Bil.Var tmp))::stmts, newoff - in - List.rev (fst (List.fold_left ~f:f ~init:([Bil.Move (tmp, e)], 0) (List.rev l))), Bil.Var tmp + let tmp = tmp (Type.Imm (!!t * 2)) in + let f (stmts, off) (ct, o) = + let newoff = off + !!ct in + ( assn_s mode s has_rex has_vex ct o + (Bil.Extract (newoff - 1, off, Bil.Var tmp)) + :: stmts, + newoff ) + in + ( List.rev + (fst + (List.fold_left ~f ~init:([ Bil.Move (tmp, e) ], 0) (List.rev l))), + Bil.Var tmp ) (* A function for computing the target of jumps. *) let compute_jump_target mode s has_rex = let t = type_of_mode mode in function | Jabs o -> op2e_s mode s has_rex t o - | Jrel (na,offset) -> - (*let i,t = Arithmetic.binop PLUS (na,t) (offset,t) in*) - Bil.((Int na) + (Int offset)) + | Jrel (na, offset) -> + (*let i,t = Arithmetic.binop PLUS (na,t) (offset,t) in*) + Bil.(Int na + Int offset) + let jump_target = compute_jump_target let string_incr mode t v = @@ -192,25 +197,26 @@ module ToIR = struct let rep_wrap ?check_zf ~mode ~addr:_ ~next:_ stmts = let extend = big_int_of_mode mode in let zero = extend Word.b0 and one = extend Word.b1 in - let rcx = match mode with - | X86 -> R32.rcx - | X8664 -> R64.rcx in + let rcx = match mode with X86 -> R32.rcx | X8664 -> R64.rcx in let flag = tmp bool_t in let cond = Bil.((var rcx <> int zero) land var flag) in let head = Bil.(flag := int Word.b1) in let tail = - Bil.(rcx := var rcx - int one) :: match check_zf with + Bil.(rcx := var rcx - int one) + :: + (match check_zf with | None -> [] - | Some x when x = repz -> Bil.[flag := zf_e] - | Some x when x = repnz -> Bil.[flag := lnot zf_e] - | _ -> failwith "invalid value for ?check_zf" in - Bil.[head; while_ cond (stmts @ tail)] + | Some x when x = repz -> Bil.[ flag := zf_e ] + | Some x when x = repnz -> Bil.[ flag := lnot zf_e ] + | _ -> failwith "invalid value for ?check_zf") + in + Bil.[ head; while_ cond (stmts @ tail) ] let compute_sf result = Bil.(Cast (HIGH, !!bool_t, result)) let compute_zf t result = let bi0 = BV.of_int ~width:t 0 in - Bil.((Int bi0) = result) + Bil.(Int bi0 = result) let compute_pf t r = let acc = tmp t in @@ -219,8 +225,17 @@ module ToIR = struct (* extra parens do not change semantics but do make it pretty print nicer *) let open Bil in - exp_not (Cast (LOW, !!bool_t, - ((Let(acc, (r lsr (int_exp 4 t')) lxor r, Let(acc, (var_acc lsr (int_exp 2 t')) lxor var_acc, (var_acc lsr (int_exp 1 t')) lxor var_acc)))))) + exp_not + (Cast + ( LOW, + !!bool_t, + Let + ( acc, + (r lsr int_exp 4 t') lxor r, + Let + ( acc, + (var_acc lsr int_exp 2 t') lxor var_acc, + (var_acc lsr int_exp 1 t') lxor var_acc ) ) )) let set_sf r = Bil.Move (sf, compute_sf r) let set_zf t r = Bil.Move (zf, compute_zf t r) @@ -228,9 +243,7 @@ module ToIR = struct let set_pszf t r = let t' = !!t in - [set_pf t r; - set_sf r; - set_zf t' r] + [ set_pf t r; set_sf r; set_zf t' r ] (* Adjust flag @@ -246,39 +259,38 @@ module ToIR = struct let set_apszf t s1 s2 r = let bit4 = int_exp (1 lsl 4) t in let t = Type.Imm t in - Bil.Move (af, Bil.(bit4 = (bit4 land ((r lxor s1) lxor s2)))) - ::set_pszf t r + Bil.Move (af, Bil.(bit4 = bit4 land (r lxor s1 lxor s2))) :: set_pszf t r (* Helper functions to set flags for adding *) let set_aopszf_add t s1 s2 r = (* Move (oF, Bop.(Cast (CAST_HIGH, r1, (s1 = s2) land (s1 lxor r)))) *) let s1_high = Bil.(Cast (HIGH, !!bool_t, s1)) in let s2_high = Bil.(Cast (HIGH, !!bool_t, s2)) in - let r_high = Bil.(Cast (HIGH, !!bool_t, r)) in + let r_high = Bil.(Cast (HIGH, !!bool_t, r)) in Bil.Move (oF, Bil.((s1_high = s2_high) land (s1_high lxor r_high))) - ::set_apszf t s1 s2 r + :: set_apszf t s1 s2 r let set_flags_add t s1 s2 r = - Bil.Move (cf, Bil.(r < s1)) - ::set_aopszf_add t s1 s2 r + Bil.Move (cf, Bil.(r < s1)) :: set_aopszf_add t s1 s2 r (* Helper functions to set flags for subtracting *) let set_apszf_sub t s1 s2 r = set_apszf t s1 s2 r let set_aopszf_sub t s1 s2 r = - Bil.Move (oF, Bil.(Cast (HIGH, !!bool_t, (s1 lxor s2) land (s1 lxor r)))) - ::set_apszf_sub t s1 s2 r + Bil.Move (oF, Bil.(Cast (HIGH, !!bool_t, s1 lxor s2 land (s1 lxor r)))) + :: set_apszf_sub t s1 s2 r let set_flags_sub t s1 s2 r = - Bil.Move (cf, Bil.(s2 > s1)) - ::set_aopszf_sub t s1 s2 r + Bil.Move (cf, Bil.(s2 > s1)) :: set_aopszf_sub t s1 s2 r - let popcount x ~one ~two ~four ~sh ~m1 ~m2 ~m4 ~h01 = Bil.[ - x := var x - ((var x lsr int one) land int m1); - x := (var x land int m2) + ((var x lsr int two) land int m2); - x := (var x + (var x lsr int four)) land int m4; - x := (var x * int h01) lsr int sh; - ] + let popcount x ~one ~two ~four ~sh ~m1 ~m2 ~m4 ~h01 = + Bil. + [ + x := var x - ((var x lsr int one) land int m1); + x := (var x land int m2) + ((var x lsr int two) land int m2); + x := (var x + (var x lsr int four)) land int m4; + x := (var x * int h01) lsr int sh; + ] let popcnt16 x = let one = Word.one 16 in @@ -313,59 +325,68 @@ module ToIR = struct let h01 = Word.of_int64 ~width:64 0x0101010101010101L in popcount x ~one ~two ~four ~sh ~m1 ~m2 ~m4 ~h01 - let clz16 x = Bil.[ - x := var x lor (var x lsr int Word.(one 16)); - x := var x lor (var x lsr int Word.(of_int 2 ~width:16)); - x := var x lor (var x lsr int Word.(of_int 4 ~width:16)); - x := var x lor (var x lsr int Word.(of_int 8 ~width:16)); - x := lnot (var x); - ] @ popcnt16 x - - let clz32 x = Bil.[ - x := var x lor (var x lsr int Word.(one 32)); - x := var x lor (var x lsr int Word.(of_int 2 ~width:32)); - x := var x lor (var x lsr int Word.(of_int 4 ~width:32)); - x := var x lor (var x lsr int Word.(of_int 8 ~width:32)); - x := var x lor (var x lsr int Word.(of_int 16 ~width:32)); - x := lnot (var x); - ] @ popcnt32 x - - let clz64 x = Bil.[ - x := var x lor (var x lsr int Word.(one 64)); - x := var x lor (var x lsr int Word.(of_int 2 ~width:64)); - x := var x lor (var x lsr int Word.(of_int 4 ~width:64)); - x := var x lor (var x lsr int Word.(of_int 8 ~width:64)); - x := var x lor (var x lsr int Word.(of_int 16 ~width:64)); - x := var x lor (var x lsr int Word.(of_int 32 ~width:64)); - x := lnot (var x); - ] @ popcnt64 x - - let ctz16 x = Bil.( - x := (var x land unop NEG (var x)) - int Word.(one 16) - ) :: popcnt16 x - - let ctz32 x = Bil.( - x := (var x land unop NEG (var x)) - int Word.(one 32) - ) :: popcnt32 x - - let ctz64 x = Bil.( - x := (var x land unop NEG (var x)) - int Word.(one 64) - ) :: popcnt64 x + let clz16 x = + Bil. + [ + x := var x lor (var x lsr int Word.(one 16)); + x := var x lor (var x lsr int Word.(of_int 2 ~width:16)); + x := var x lor (var x lsr int Word.(of_int 4 ~width:16)); + x := var x lor (var x lsr int Word.(of_int 8 ~width:16)); + x := lnot (var x); + ] + @ popcnt16 x + + let clz32 x = + Bil. + [ + x := var x lor (var x lsr int Word.(one 32)); + x := var x lor (var x lsr int Word.(of_int 2 ~width:32)); + x := var x lor (var x lsr int Word.(of_int 4 ~width:32)); + x := var x lor (var x lsr int Word.(of_int 8 ~width:32)); + x := var x lor (var x lsr int Word.(of_int 16 ~width:32)); + x := lnot (var x); + ] + @ popcnt32 x + + let clz64 x = + Bil. + [ + x := var x lor (var x lsr int Word.(one 64)); + x := var x lor (var x lsr int Word.(of_int 2 ~width:64)); + x := var x lor (var x lsr int Word.(of_int 4 ~width:64)); + x := var x lor (var x lsr int Word.(of_int 8 ~width:64)); + x := var x lor (var x lsr int Word.(of_int 16 ~width:64)); + x := var x lor (var x lsr int Word.(of_int 32 ~width:64)); + x := lnot (var x); + ] + @ popcnt64 x + + let ctz16 x = + Bil.(x := (var x land unop NEG (var x)) - int Word.(one 16)) :: popcnt16 x + + let ctz32 x = + Bil.(x := (var x land unop NEG (var x)) - int Word.(one 32)) :: popcnt32 x + + let ctz64 x = + Bil.(x := (var x land unop NEG (var x)) - int Word.(one 64)) :: popcnt64 x let bitscan_flags is_zero_count = - let l = Bil.[ - oF := unknown "bits" bool_t; - sf := unknown "bits" bool_t; - af := unknown "bits" bool_t; - pf := unknown "bits" bool_t; - ] in - if is_zero_count then l - else Bil.(cf := unknown "bits" bool_t) :: l + let l = + Bil. + [ + oF := unknown "bits" bool_t; + sf := unknown "bits" bool_t; + af := unknown "bits" bool_t; + pf := unknown "bits" bool_t; + ] + in + if is_zero_count then l else Bil.(cf := unknown "bits" bool_t) :: l let rec to_ir mode addr next ss pref has_rex has_vex = - let module R = (val (vars_of_mode mode)) in + let module R = (val vars_of_mode mode) in let open R in - let load = load_s mode ss in (* Need to change this if we want seg_ds <> None *) + let load = load_s mode ss in + (* Need to change this if we want seg_ds <> None *) let op2e = op2e_s mode ss has_rex in let op2e_keep_width = op2e_s_keep_width mode ss has_rex in let op2e_dbl = op2e_dbl_s mode ss has_rex in @@ -383,911 +404,1097 @@ module ToIR = struct let ah_e = ah_e mode in let disfailwith = disfailwith mode in let unimplemented = unimplemented mode in - let is_small_imm op t = match op with + let is_small_imm op t = + match op with | Oimm imm -> Word.bitwidth imm < bitwidth_of_type t - | _ -> false in + | _ -> false + in let sign_extend_imm op t = - let op_typ = match op with + let op_typ = + match op with | Oimm imm -> Type.imm (Word.bitwidth imm) - | _ -> disfailwith "imm operand expected" in - Bil.(cast signed (bitwidth_of_type t) (op2e op_typ op)) in - let is_repz = function - | [x] -> x = repz - | _ -> false in - let is_repnz = function - | [x] -> x = repnz - | _ -> false in + | _ -> disfailwith "imm operand expected" + in + Bil.(cast signed (bitwidth_of_type t) (op2e op_typ op)) + in + let is_repz = function [ x ] -> x = repz | _ -> false in + let is_repnz = function [ x ] -> x = repnz | _ -> false in function | Nop -> [] - | Bswap(t, op) -> - let e = match t with - | Type.Imm 32 | Type.Imm 64 -> let (op', t') = op2e_keep_width t op in - reverse_bytes op' t' - | _ -> disfailwith "bswap: Expected 32 or 64 bit type" - in - [assn t op e] - | Retn (op, far_ret) when List.is_empty pref || is_repz pref || is_repnz pref -> - let temp = tmp mt in - let load_stmt = if far_ret - then (* TODO Mess with segment selectors here *) - unimplemented "long retn not supported" - else Bil.Move (temp, load_s mode seg_ss (size_of_typ mt) rsp_e) - in - let rsp_stmts = - Bil.Move (rsp, Bil.(rsp_e + (Int (mi (bytes_of_width mt))))):: - (match op with - | None -> [] - | Some(t, src) -> - [Bil.Move (rsp, Bil.(rsp_e + (op2e t src)))] - ) in - load_stmt:: - rsp_stmts@ - [Bil.Jmp (Bil.Var temp)] - | Mov(t, dst, src, condition) -> - let c_src = (match condition with + | Bswap (t, op) -> + let e = + match t with + | Type.Imm 32 | Type.Imm 64 -> + let op', t' = op2e_keep_width t op in + reverse_bytes op' t' + | _ -> disfailwith "bswap: Expected 32 or 64 bit type" + in + [ assn t op e ] + | Retn (op, far_ret) + when List.is_empty pref || is_repz pref || is_repnz pref -> + let temp = tmp mt in + let load_stmt = + if far_ret then (* TODO Mess with segment selectors here *) + unimplemented "long retn not supported" + else Bil.Move (temp, load_s mode seg_ss (size_of_typ mt) rsp_e) + in + let rsp_stmts = + Bil.Move (rsp, Bil.(rsp_e + Int (mi (bytes_of_width mt)))) + :: + (match op with + | None -> [] + | Some (t, src) -> [ Bil.Move (rsp, Bil.(rsp_e + op2e t src)) ]) + in + (load_stmt :: rsp_stmts) @ [ Bil.Jmp (Bil.Var temp) ] + | Mov (t, dst, src, condition) -> + let c_src = + match condition with | None -> op2e t src - | Some c -> Bil.Ite (c, op2e t src, op2e t dst)) - in - (* Find base by looking at LDT or GDT *) - let base_e e = - (* 0 = GDT, 1 = LDT *) - let ti = Bil.Extract (3, 3, e) in - let base = Bil.Ite (ti, Bil.var ldt, Bil.var gdt) in - (* Extract index into table *) - let entry_size, entry_shift = match mode with - | X86 -> reg64_t, 6 (* "1<<6 = 64" *) - | X8664 -> reg128_t, 7 (* "1<<7 = 128" *) - in - let index = Bil.(Cast (UNSIGNED, !!mt, (Extract (15, 4, e)) lsl (Int (mi entry_shift)))) in - (* Load the table entry *) - let table_entry = load_s mode None (size_of_typ entry_size) (Bil.(base + index)) in - (* Extract the base *) - concat_explist - ((match mode with - | X86 -> [] - | X8664 -> (Bil.Extract (95, 64, table_entry)) :: []) - @ (Bil.Extract (63, 56, table_entry)) - :: (Bil.Extract (39, 32, table_entry)) - :: (Bil.Extract (31, 16, table_entry)) - :: []) - in - let bs = - let dst_e = op2e t dst in - if [%compare.equal: operand] dst o_fs && !compute_segment_bases - then [Bil.Move (fs_base, base_e dst_e)] - else if [%compare.equal: operand] dst o_gs && !compute_segment_bases - then [Bil.Move (gs_base, base_e dst_e)] - else [] - in - assn t dst c_src :: bs - | Movs(Type.Imm _bits as t) -> - let stmts = - store_s mode seg_es t rdi_e (load_s mode seg_es (size_of_typ t) rsi_e) - :: string_incr mode t rsi - :: string_incr mode t rdi - :: [] - in - if List.is_empty pref then - stmts - else if ints_mem pref repz || ints_mem pref repnz then - (* movs has only rep instruction others just considered to be rep *) - rep_wrap ~mode ~addr ~next stmts - else - unimplemented "unsupported prefix for movs" - | Movzx(t, dst, ts, src) -> - [assn t dst Bil.(Cast (UNSIGNED, !!t, op2e ts src))] - | Movsx(t, dst, ts, src) -> - [assn t dst Bil.(Cast (SIGNED, !!t, op2e ts src))] - | Movdq(ts, s, td, d, align) -> - let (s, al) = match s with - | Ovec _ | Oreg _-> op2e ts s, [] - | Oaddr a -> op2e ts s, [a] - | Oimm _ | Oseg _ -> disfailwith "invalid source operand for movdq" - in - let (d, al) = match d with - (* Behavior is to clear the xmm bits *) - | Ovec _ -> assn td d Bil.(Cast (UNSIGNED, !!td, s)), al - | Oreg _ -> assn td d s, al - | Oaddr a -> assn td d s, a::al - | Oimm _ | Oseg _ -> disfailwith "invalid dest operand for movdq" - in - (* sources tell me that movdqa raises a general protection exception - * if its operands aren't aligned on a 16-byte boundary *) - let im i = Bil.Int (int_of_mode mode i) in - let al = - if align then - List.map ~f:(fun a -> Bil.If (Bil.((a land im 15) = im 0), [], [Cpu_exceptions.general_protection])) al - else [] - in - d::al - | Movoffset((tdst, dst), offsets) -> - (* If a vex prefix is present, then extra space is filled with 0. + | Some c -> Bil.Ite (c, op2e t src, op2e t dst) + in + (* Find base by looking at LDT or GDT *) + let base_e e = + (* 0 = GDT, 1 = LDT *) + let ti = Bil.Extract (3, 3, e) in + let base = Bil.Ite (ti, Bil.var ldt, Bil.var gdt) in + (* Extract index into table *) + let entry_size, entry_shift = + match mode with + | X86 -> (reg64_t, 6 (* "1<<6 = 64" *)) + | X8664 -> (reg128_t, 7 (* "1<<7 = 128" *)) + in + let index = + Bil.( + Cast (UNSIGNED, !!mt, Extract (15, 4, e) lsl Int (mi entry_shift))) + in + (* Load the table entry *) + let table_entry = + load_s mode None (size_of_typ entry_size) Bil.(base + index) + in + (* Extract the base *) + concat_explist + ((match mode with + | X86 -> [] + | X8664 -> Bil.Extract (95, 64, table_entry) :: []) + @ [ + Bil.Extract (63, 56, table_entry); + Bil.Extract (39, 32, table_entry); + Bil.Extract (31, 16, table_entry); + ]) + in + let bs = + let dst_e = op2e t dst in + if [%compare.equal: operand] dst o_fs && !compute_segment_bases then + [ Bil.Move (fs_base, base_e dst_e) ] + else if [%compare.equal: operand] dst o_gs && !compute_segment_bases + then [ Bil.Move (gs_base, base_e dst_e) ] + else [] + in + assn t dst c_src :: bs + | Movs (Type.Imm _bits as t) -> + let stmts = + [ + store_s mode seg_es t rdi_e + (load_s mode seg_es (size_of_typ t) rsi_e); + string_incr mode t rsi; + string_incr mode t rdi; + ] + in + if List.is_empty pref then stmts + else if ints_mem pref repz || ints_mem pref repnz then + (* movs has only rep instruction others just considered to be rep *) + rep_wrap ~mode ~addr ~next stmts + else unimplemented "unsupported prefix for movs" + | Movzx (t, dst, ts, src) -> + [ assn t dst Bil.(Cast (UNSIGNED, !!t, op2e ts src)) ] + | Movsx (t, dst, ts, src) -> + [ assn t dst Bil.(Cast (SIGNED, !!t, op2e ts src)) ] + | Movdq (ts, s, td, d, align) -> + let s, al = + match s with + | Ovec _ | Oreg _ -> (op2e ts s, []) + | Oaddr a -> (op2e ts s, [ a ]) + | Oimm _ | Oseg _ -> disfailwith "invalid source operand for movdq" + in + let d, al = + match d with + (* Behavior is to clear the xmm bits *) + | Ovec _ -> (assn td d Bil.(Cast (UNSIGNED, !!td, s)), al) + | Oreg _ -> (assn td d s, al) + | Oaddr a -> (assn td d s, a :: al) + | Oimm _ | Oseg _ -> disfailwith "invalid dest operand for movdq" + in + (* sources tell me that movdqa raises a general protection exception + * if its operands aren't aligned on a 16-byte boundary *) + let im i = Bil.Int (int_of_mode mode i) in + let al = + if align then + List.map + ~f:(fun a -> + Bil.If + ( Bil.(a land im 15 = im 0), + [], + [ Cpu_exceptions.general_protection ] )) + al + else [] + in + d :: al + | Movoffset ((tdst, dst), offsets) -> + (* If a vex prefix is present, then extra space is filled with 0. Otherwise, the bits are preserved. *) - let padding hi lo = - if hi < lo then [] - else if has_vex then [int_exp 0 (hi - lo + 1)] - else [Bil.Extract (hi, lo, op2e tdst dst)] - in - let offsets = List.sort ~compare:(fun {offdstoffset=o1; _} {offdstoffset=o2; _} -> Int.compare o1 o2) offsets in - let add_exp (elist,nextbit) {offlen; offtyp; offop; offsrcoffset; offdstoffset} = - Bil.Extract ((!!offlen + offsrcoffset - 1), offsrcoffset, (op2e offtyp offop)) - :: padding (offdstoffset - 1) nextbit - @ elist, offdstoffset + !!offlen - in - let elist, nextbit = List.fold_left ~f:add_exp ~init:([],0) offsets in - let elist = padding (!!tdst - 1) nextbit @ elist in - [assn tdst dst (concat_explist elist)] - | Punpck(t, et, o, d, s, vs) -> - let nelem = match t, et with - | Type.Imm n, Type.Imm n' -> n / n' - | _ -> disfailwith "invalid" - in - assert (nelem mod 2 = 0); - let nelem_per_src = nelem / 2 in - let halft = Type.Imm (!!t / 2) in - let castf = match o with - | High -> fun e -> Bil.(Cast (HIGH, !!halft, e)) - | Low -> fun e -> Bil.(Cast (LOW, !!halft, e)) - in - let se, de = castf (op2e t s), castf (op2e t d) in - let st, dt = tmp halft, tmp halft in - let et' = !!et in - let mape i = - [extract_element et' (Bil.Var st) i; extract_element et' (Bil.Var dt) i] - in - let e = concat_explist (List.concat (List.map ~f:mape (List.range ~stride:(-1) ~stop:`inclusive (nelem_per_src-1) 0))) in - let dest = match vs with - | None -> d - | Some vdst -> vdst - in - [Bil.Move (st, se); - Bil.Move (dt, de); - assn t dest e] - | Ppackedbinop(t, et, fbop, _, d, s, vs) -> - let t_width = bitwidth_of_type t in - let e_width = bitwidth_of_type et in - let nops = t_width / e_width in - let byte = 8 in - let tmp_dst = tmp t in - let vdst = Option.value ~default:d vs in - let iv = tmp (Type.imm byte) in - let elt = tmp et in - let zero = Word.zero t_width in - let bits = Word.of_int ~width:byte e_width in - - let foreach_size f = List.concat @@ List.init nops ~f in - let getelement o i = - (* assumption: immediate operands are repeated for all vector + let padding hi lo = + if hi < lo then [] + else if has_vex then [ int_exp 0 (hi - lo + 1) ] + else [ Bil.Extract (hi, lo, op2e tdst dst) ] + in + let offsets = + List.sort + ~compare:(fun { offdstoffset = o1; _ } { offdstoffset = o2; _ } -> + Int.compare o1 o2) + offsets + in + let add_exp (elist, nextbit) + { offlen; offtyp; offop; offsrcoffset; offdstoffset } = + ( Bil.Extract + (!!offlen + offsrcoffset - 1, offsrcoffset, op2e offtyp offop) + :: padding (offdstoffset - 1) nextbit + @ elist, + offdstoffset + !!offlen ) + in + let elist, nextbit = List.fold_left ~f:add_exp ~init:([], 0) offsets in + let elist = padding (!!tdst - 1) nextbit @ elist in + [ assn tdst dst (concat_explist elist) ] + | Punpck (t, et, o, d, s, vs) -> + let nelem = + match (t, et) with + | Type.Imm n, Type.Imm n' -> n / n' + | _ -> disfailwith "invalid" + in + assert (nelem mod 2 = 0); + let nelem_per_src = nelem / 2 in + let halft = Type.Imm (!!t / 2) in + let castf = + match o with + | High -> fun e -> Bil.(Cast (HIGH, !!halft, e)) + | Low -> fun e -> Bil.(Cast (LOW, !!halft, e)) + in + let se, de = (castf (op2e t s), castf (op2e t d)) in + let st, dt = (tmp halft, tmp halft) in + let et' = !!et in + let mape i = + [ + extract_element et' (Bil.Var st) i; + extract_element et' (Bil.Var dt) i; + ] + in + let e = + concat_explist + (List.concat + (List.map ~f:mape + (List.range ~stride:(-1) ~stop:`inclusive (nelem_per_src - 1) + 0))) + in + let dest = match vs with None -> d | Some vdst -> vdst in + [ Bil.Move (st, se); Bil.Move (dt, de); assn t dest e ] + | Ppackedbinop (t, et, fbop, _, d, s, vs) -> + let t_width = bitwidth_of_type t in + let e_width = bitwidth_of_type et in + let nops = t_width / e_width in + let byte = 8 in + let tmp_dst = tmp t in + let vdst = Option.value ~default:d vs in + let iv = tmp (Type.imm byte) in + let elt = tmp et in + let zero = Word.zero t_width in + let bits = Word.of_int ~width:byte e_width in + + let foreach_size f = List.concat @@ List.init nops ~f in + let getelement o i = + (* assumption: immediate operands are repeated for all vector elements *) - match o with - | Oimm _ -> op2e et o - | _ -> extract_element !!et (op2e t o) i in - - List.concat Bil.[ - [tmp_dst := int zero]; - foreach_size (fun i -> [ - elt := fbop (getelement d i) (getelement s i); - iv := int @@ Word.of_int ~width:byte i; - tmp_dst := - var tmp_dst lor - ((cast unsigned t_width (var elt)) lsl (var iv * int bits)) - ] - ); - [assn t vdst (var tmp_dst)] - ] - | Pbinop(t, fbop, _s, o1, o2, vop) -> - (match vop with - | None -> [assn t o1 (fbop (op2e t o1) (op2e t o2))] - | Some vop -> [assn t o1 (fbop (op2e t vop) (op2e t o2))]) - | Pcmp (t,elet,bop,_,dst,src,vsrc) -> - let elebits = bitwidth_of_type elet in - let t_width = bitwidth_of_type t in - let ncmps = t_width / elebits in - let src = match src with - | Ovec _ -> op2e t src - | Oaddr a -> load (size_of_typ t) a - | Oreg _ | Oimm _ | Oseg _ -> disfailwith "invalid" in - let vsrc = Option.value ~default:dst vsrc in - let byte = 8 in - let tmp_dst = tmp t in - let iv = tmp (Type.imm byte) in - let elt = tmp elet in - let elt_1 = tmp elet in - let elt_2 = tmp elet in - let _one = Word.of_int ~width:elebits (-1) in - let zero = Word.zero elebits in - let bits = Word.of_int ~width:byte elebits in - let zero_long = Word.zero t_width in - let foreach_size f = - let sizes = List.init ncmps ~f:(fun i -> - let left_bit = i * elebits in - let right_bit = (i + 1) * elebits - 1 in - let i = Word.of_int ~width:byte i in - i, left_bit, right_bit) in - List.concat @@ List.map sizes ~f in - - List.concat Bil.[ - [tmp_dst := int zero_long]; - foreach_size (fun (i, left_bit, right_bit) -> [ - elt_1 := extract right_bit left_bit src; - elt_2 := extract right_bit left_bit (op2e t vsrc); - iv := int i; - if_ (binop bop (var elt_1) (var elt_2)) [ - elt := int _one; - ] [ - elt := int zero; - ]; - tmp_dst := - var tmp_dst lor - ((cast unsigned t_width (var elt)) lsl (var iv * int bits)) - ]); - [assn t dst (var tmp_dst)] ] + match o with + | Oimm _ -> op2e et o + | _ -> extract_element !!et (op2e t o) i + in + + List.concat + Bil. + [ + [ tmp_dst := int zero ]; + foreach_size (fun i -> + [ + elt := fbop (getelement d i) (getelement s i); + iv := int @@ Word.of_int ~width:byte i; + tmp_dst := + var tmp_dst + lor cast unsigned t_width (var elt) + lsl (var iv * int bits); + ]); + [ assn t vdst (var tmp_dst) ]; + ] + | Pbinop (t, fbop, _s, o1, o2, vop) -> ( + match vop with + | None -> [ assn t o1 (fbop (op2e t o1) (op2e t o2)) ] + | Some vop -> [ assn t o1 (fbop (op2e t vop) (op2e t o2)) ]) + | Pcmp (t, elet, bop, _, dst, src, vsrc) -> + let elebits = bitwidth_of_type elet in + let t_width = bitwidth_of_type t in + let ncmps = t_width / elebits in + let src = + match src with + | Ovec _ -> op2e t src + | Oaddr a -> load (size_of_typ t) a + | Oreg _ | Oimm _ | Oseg _ -> disfailwith "invalid" + in + let vsrc = Option.value ~default:dst vsrc in + let byte = 8 in + let tmp_dst = tmp t in + let iv = tmp (Type.imm byte) in + let elt = tmp elet in + let elt_1 = tmp elet in + let elt_2 = tmp elet in + let _one = Word.of_int ~width:elebits (-1) in + let zero = Word.zero elebits in + let bits = Word.of_int ~width:byte elebits in + let zero_long = Word.zero t_width in + let foreach_size f = + let sizes = + List.init ncmps ~f:(fun i -> + let left_bit = i * elebits in + let right_bit = ((i + 1) * elebits) - 1 in + let i = Word.of_int ~width:byte i in + (i, left_bit, right_bit)) + in + List.concat @@ List.map sizes ~f + in + + List.concat + Bil. + [ + [ tmp_dst := int zero_long ]; + foreach_size (fun (i, left_bit, right_bit) -> + [ + elt_1 := extract right_bit left_bit src; + elt_2 := extract right_bit left_bit (op2e t vsrc); + iv := int i; + if_ + (binop bop (var elt_1) (var elt_2)) + [ elt := int _one ] + [ elt := int zero ]; + tmp_dst := + var tmp_dst + lor cast unsigned t_width (var elt) + lsl (var iv * int bits); + ]); + [ assn t dst (var tmp_dst) ]; + ] | Pmov (t, dstet, srcet, dst, src, ext, _) -> - let nelem = match t, dstet with - | Type.Imm n, Type.Imm n' -> n / n' - | _ -> disfailwith "invalid" - in - let getelt op i = extract_element !!srcet (op2e t op) i in - let extcast = - let open Exp in - match ext with - | UNSIGNED | SIGNED -> fun e -> Bil.Cast (ext, !!dstet, e) - | _ -> disfailwith "invalid" - in - let extend i = extcast (getelt src i) in - let e = concat_explist (List.map ~f:extend (List.range ~stride:(-1) ~stop:`inclusive (nelem-1) 0)) in - [assn t dst e] - | Pmovmskb (t,dst,src) -> - let nbytes = bytes_of_width t in - let src = match src with - | Ovec _ -> op2e t src - | _ -> disfailwith "invalid operand" - in - let get_bit i = Bil.Extract(i*8-1, i*8-1, src) in - let byte_indices = List.init ~f:(fun i -> i + 1) nbytes in (* list 1-nbytes *) - let all_bits = List.rev (List.map ~f:get_bit byte_indices) in - (* could also be done with shifts *) - let padt = Type.Imm(32 - nbytes) in - let or_together_bits = List.fold_left ~f:(fun acc i -> Bil.Concat(acc,i)) ~init:(int_exp 0 (!!padt)) all_bits in - [assn reg32_t dst or_together_bits] - | Palignr (t,dst,src,vsrc,imm) -> - let (dst_e, t_concat) = op2e_keep_width t dst in - let (src_e, t_concat') = op2e_keep_width t src in - (* previously, this code called Typecheck.infer_ast. - * We're now just preserving the widths, so here we assert - * that our 2 "preserved widths" are the same. *) - assert (!!t_concat = !!t_concat'); - let imm = op2e t imm in - let conct = Bil.(dst_e ^ src_e) in - let shift = Bil.(conct lsr (Cast (UNSIGNED, !!t_concat, imm lsl (int_exp 3 !!t)))) in - let high, low = match t with - | Type.Imm 256 -> 255, 0 - | Type.Imm 128 -> 127, 0 - | Type.Imm 64 -> 63, 0 - | _ -> disfailwith "impossible: used non 64/128/256-bit operand in palignr" - in - let result = Bil.Extract (high, low, shift) in - let im i = Bil.Int (int_of_mode mode i) in - let addresses = List.fold - ~f:(fun acc -> function Oaddr a -> a::acc | _ -> acc) ~init:[] [src;dst] in - (* Palignr seems to cause a CPU general protection exception if this fails. - * previously this code used the ast.ml Assert statement, which is gone, - * so it's been replaced with Bil's CpuExn *) - List.map ~f:(fun addr -> Bil.If (Bil.((addr land im 15) = im 0), - [], [Cpu_exceptions.general_protection])) addresses - @ (match vsrc with - | None -> [assn t dst result] - | Some vdst -> [assn t vdst result]) - | Pcmpstr(t,xmm1,xmm2m128,_imm,imm8cb,pcmpinfo) -> - let open Pcmpstr in - let concat elt_width exps = match exps with - | [] -> disfailwith "trying concat on empty list" - | first :: exps' -> - let len = List.length exps * elt_width in - let exp = List.fold exps' ~init:first ~f:(fun e e' -> Bil.(e ^ e')) in - let tmp = tmp (Type.imm len) in - tmp, Bil.[tmp := exp] in - - (* All bytes and bits are numbered with zero being the least + let nelem = + match (t, dstet) with + | Type.Imm n, Type.Imm n' -> n / n' + | _ -> disfailwith "invalid" + in + let getelt op i = extract_element !!srcet (op2e t op) i in + let extcast = + let open Exp in + match ext with + | UNSIGNED | SIGNED -> fun e -> Bil.Cast (ext, !!dstet, e) + | _ -> disfailwith "invalid" + in + let extend i = extcast (getelt src i) in + let e = + concat_explist + (List.map ~f:extend + (List.range ~stride:(-1) ~stop:`inclusive (nelem - 1) 0)) + in + [ assn t dst e ] + | Pmovmskb (t, dst, src) -> + let nbytes = bytes_of_width t in + let src = + match src with + | Ovec _ -> op2e t src + | _ -> disfailwith "invalid operand" + in + let get_bit i = Bil.Extract ((i * 8) - 1, (i * 8) - 1, src) in + let byte_indices = List.init ~f:(fun i -> i + 1) nbytes in + (* list 1-nbytes *) + let all_bits = List.rev (List.map ~f:get_bit byte_indices) in + (* could also be done with shifts *) + let padt = Type.Imm (32 - nbytes) in + let or_together_bits = + List.fold_left + ~f:(fun acc i -> Bil.Concat (acc, i)) + ~init:(int_exp 0 !!padt) all_bits + in + [ assn reg32_t dst or_together_bits ] + | Palignr (t, dst, src, vsrc, imm) -> ( + let dst_e, t_concat = op2e_keep_width t dst in + let src_e, t_concat' = op2e_keep_width t src in + (* previously, this code called Typecheck.infer_ast. + * We're now just preserving the widths, so here we assert + * that our 2 "preserved widths" are the same. *) + assert (!!t_concat = !!t_concat'); + let imm = op2e t imm in + let conct = Bil.(dst_e ^ src_e) in + let shift = + Bil.(conct lsr Cast (UNSIGNED, !!t_concat, imm lsl int_exp 3 !!t)) + in + let high, low = + match t with + | Type.Imm 256 -> (255, 0) + | Type.Imm 128 -> (127, 0) + | Type.Imm 64 -> (63, 0) + | _ -> + disfailwith + "impossible: used non 64/128/256-bit operand in palignr" + in + let result = Bil.Extract (high, low, shift) in + let im i = Bil.Int (int_of_mode mode i) in + let addresses = + List.fold + ~f:(fun acc -> function Oaddr a -> a :: acc | _ -> acc) + ~init:[] [ src; dst ] + in + (* Palignr seems to cause a CPU general protection exception if this fails. + * previously this code used the ast.ml Assert statement, which is gone, + * so it's been replaced with Bil's CpuExn *) + List.map + ~f:(fun addr -> + Bil.If + ( Bil.(addr land im 15 = im 0), + [], + [ Cpu_exceptions.general_protection ] )) + addresses + @ + match vsrc with + | None -> [ assn t dst result ] + | Some vdst -> [ assn t vdst result ]) + | Pcmpstr (t, xmm1, xmm2m128, _imm, imm8cb, pcmpinfo) -> + let open Pcmpstr in + let concat elt_width exps = + match exps with + | [] -> disfailwith "trying concat on empty list" + | first :: exps' -> + let len = List.length exps * elt_width in + let exp = + List.fold exps' ~init:first ~f:(fun e e' -> Bil.(e ^ e')) + in + let tmp = tmp (Type.imm len) in + (tmp, Bil.[ tmp := exp ]) + in + + (* All bytes and bits are numbered with zero being the least significant. This includes strings! *) - (* NOTE: Strings are backwards, at least when they are in + (* NOTE: Strings are backwards, at least when they are in registers. This doesn't seem to be documented in the Intel manual. This means that the NULL byte comes before the string. *) - let xmm1_e = op2e t xmm1 in - let xmm2m128_e = op2e t xmm2m128 in - let regm = type_of_mode mode in - - let nelem, _nbits, elemt = match imm8cb.ssize with - | Bytes -> 16, 8, Type.imm 8 - | Words -> 8, 16, Type.imm 16 in + let xmm1_e = op2e t xmm1 in + let xmm2m128_e = op2e t xmm2m128 in + let regm = type_of_mode mode in + + let nelem, _nbits, elemt = + match imm8cb.ssize with + | Bytes -> (16, 8, Type.imm 8) + | Words -> (8, 16, Type.imm 16) + in - (* Get element index in e *) - let get_elem = extract_element !!elemt in - let get_xmm1 = get_elem xmm1_e in - let get_xmm2 = get_elem xmm2m128_e in + (* Get element index in e *) + let get_elem = extract_element !!elemt in + let get_xmm1 = get_elem xmm1_e in + let get_xmm2 = get_elem xmm2m128_e in - let nelem_range = - List.range ~stride:(-1) ~stop:`inclusive (nelem-1) 0 in + let nelem_range = + List.range ~stride:(-1) ~stop:`inclusive (nelem - 1) 0 + in - (* Build expressions that assigns the correct values to the + (* Build expressions that assigns the correct values to the is_valid variables using implicit (NULL-based) string length. *) - let implicit_check is_valid_xmm_i get_xmm_i = - let f acc i = - let previous_valid = - if i = 0 then exp_true - else Bil.var (is_valid_xmm_i (i - 1)) in - let current_valid = - Bil.(get_xmm_i i <> (int_exp 0 !!elemt)) in - let x = is_valid_xmm_i i in - Bil.(x := previous_valid land current_valid) :: acc in - List.fold ~f:f ~init:[] nelem_range in - - (* Build expressions that assigns the correct values to the + let implicit_check is_valid_xmm_i get_xmm_i = + let f acc i = + let previous_valid = + if i = 0 then exp_true else Bil.var (is_valid_xmm_i (i - 1)) + in + let current_valid = Bil.(get_xmm_i i <> int_exp 0 !!elemt) in + let x = is_valid_xmm_i i in + Bil.(x := previous_valid land current_valid) :: acc + in + List.fold ~f ~init:[] nelem_range + in + + (* Build expressions that assigns the correct values to the is_valid variables using explicit string length. *) - let explicit_check is_valid_xmm_i sizee = - (* Max size is nelem *) - let nelem_e = Word.of_int ~width:(bitwidth_of_type regm) nelem in - let sizev = tmp ~name:"sz" regm in - let init = Bil.[ - if_ (int nelem_e < sizee) [ - sizev := int nelem_e; - ] [ - sizev := sizee; - ] - ] in - let f acc i = - (* Current element is valid *) - let current_valid = Bil.(int_exp i !!regm < var sizev) in - let x = is_valid_xmm_i i in - Bil.(x := current_valid) :: acc in - List.fold_left ~f ~init nelem_range in - - (* Get var name indicating whether index in xmm num is a valid - byte (before NULL byte). *) - (* XXX more hashtable code *) - let is_valid = - let vh = Hashtbl.Poly.create () ~size:(2*nelem) in - (fun xmmnum index -> match Hashtbl.find vh (xmmnum,index) with - | Some v -> v - | None -> - let name = sprintf "is_valid_xmm%d_ele%d" xmmnum index in - let v = tmp ~name bool_t in - Hashtbl.add_exn vh ~key:(xmmnum,index) ~data:v; - v) in - - let is_valid_xmm1 index = is_valid 1 index in - let is_valid_xmm2 index = is_valid 2 index in - let is_valid_xmm1_e index = Bil.Var(is_valid_xmm1 index) in - let is_valid_xmm2_e index = Bil.Var(is_valid_xmm2 index) in - - let xmm1_checks, xmm2_checks = - match pcmpinfo.len with - | Implicit -> - implicit_check is_valid_xmm1 get_xmm1, - implicit_check is_valid_xmm2 get_xmm2 - | Explicit -> - explicit_check is_valid_xmm1 rax_e, - explicit_check is_valid_xmm2 rdx_e in - - let get_bit index = - match imm8cb.agg with - | EqualAny -> - (* Is xmm2[index] at xmm1[j]? *) - let check_char acc j = - let is_eql = Bil.(get_xmm2 index = get_xmm1 j) in - let is_valid = is_valid_xmm1_e j in - Bil.((is_eql land is_valid) lor acc) + let explicit_check is_valid_xmm_i sizee = + (* Max size is nelem *) + let nelem_e = Word.of_int ~width:(bitwidth_of_type regm) nelem in + let sizev = tmp ~name:"sz" regm in + let init = + Bil. + [ + if_ + (int nelem_e < sizee) + [ sizev := int nelem_e ] + [ sizev := sizee ]; + ] in - (* Is xmm2[index] included in xmm1[j] for any j? *) - Bil.(is_valid_xmm2_e index land - (List.fold ~f:check_char ~init:exp_false nelem_range)) - | Ranges -> - (* Is there an even j such that xmm1[j] <= xmm2[index] <= + let f acc i = + (* Current element is valid *) + let current_valid = Bil.(int_exp i !!regm < var sizev) in + let x = is_valid_xmm_i i in + Bil.(x := current_valid) :: acc + in + List.fold_left ~f ~init nelem_range + in + + (* Get var name indicating whether index in xmm num is a valid + byte (before NULL byte). *) + (* XXX more hashtable code *) + let is_valid = + let vh = Hashtbl.Poly.create () ~size:(2 * nelem) in + fun xmmnum index -> + match Hashtbl.find vh (xmmnum, index) with + | Some v -> v + | None -> + let name = sprintf "is_valid_xmm%d_ele%d" xmmnum index in + let v = tmp ~name bool_t in + Hashtbl.add_exn vh ~key:(xmmnum, index) ~data:v; + v + in + + let is_valid_xmm1 index = is_valid 1 index in + let is_valid_xmm2 index = is_valid 2 index in + let is_valid_xmm1_e index = Bil.Var (is_valid_xmm1 index) in + let is_valid_xmm2_e index = Bil.Var (is_valid_xmm2 index) in + + let xmm1_checks, xmm2_checks = + match pcmpinfo.len with + | Implicit -> + ( implicit_check is_valid_xmm1 get_xmm1, + implicit_check is_valid_xmm2 get_xmm2 ) + | Explicit -> + ( explicit_check is_valid_xmm1 rax_e, + explicit_check is_valid_xmm2 rdx_e ) + in + + let get_bit index = + match imm8cb.agg with + | EqualAny -> + (* Is xmm2[index] at xmm1[j]? *) + let check_char acc j = + let is_eql = Bil.(get_xmm2 index = get_xmm1 j) in + let is_valid = is_valid_xmm1_e j in + Bil.(is_eql land is_valid lor acc) + in + (* Is xmm2[index] included in xmm1[j] for any j? *) + Bil.( + is_valid_xmm2_e index + land List.fold ~f:check_char ~init:exp_false nelem_range) + | Ranges -> + (* Is there an even j such that xmm1[j] <= xmm2[index] <= xmm1[j+1]? *) - let check_char acc j = - (* XXX: Should this be AND? *) - let ind0 = 2 * j in - let ind1 = ind0 + 1 in - let rangevalid = Bil.(is_valid_xmm1_e ind0 land is_valid_xmm1_e ind1) in - let (<=) = match imm8cb.ssign with - | Unsigned -> Bil.(<=) - | Signed -> Bil.(<=$) in - let (land) = Bil.(land) in - let inrange = - (get_xmm1 ind0 <= get_xmm2 index) land (get_xmm2 index <= get_xmm1 ind1) in - Bil.(rangevalid land (inrange lor acc)) in - Bil.(is_valid_xmm2_e index land - List.fold_left ~f:check_char ~init:exp_false (List.range ~stride:(-1) ~stop:`inclusive Stdlib.(nelem/2-1) 0)) - | EqualEach -> - (* Does xmm1[index] = xmm2[index]? *) - let xmm1_invalid = Bil.(UnOp (NOT, (is_valid_xmm1_e index))) in - let xmm2_invalid = Bil.(UnOp (NOT, (is_valid_xmm2_e index))) in - let bothinvalid = Bil.(xmm1_invalid land xmm2_invalid) in - let eitherinvalid = Bil.(xmm1_invalid lor xmm2_invalid) in - let equal = Bil.(get_xmm1 index = get_xmm2 index) in - (* both invalid -> true + let check_char acc j = + (* XXX: Should this be AND? *) + let ind0 = 2 * j in + let ind1 = ind0 + 1 in + let rangevalid = + Bil.(is_valid_xmm1_e ind0 land is_valid_xmm1_e ind1) + in + let ( <= ) = + match imm8cb.ssign with + | Unsigned -> Bil.( <= ) + | Signed -> Bil.( <=$ ) + in + let ( land ) = Bil.( land ) in + let inrange = + (get_xmm1 ind0 <= get_xmm2 index) + land (get_xmm2 index <= get_xmm1 ind1) + in + Bil.(rangevalid land (inrange lor acc)) + in + Bil.( + is_valid_xmm2_e index + land List.fold_left ~f:check_char ~init:exp_false + (List.range ~stride:(-1) ~stop:`inclusive + Stdlib.((nelem / 2) - 1) + 0)) + | EqualEach -> + (* Does xmm1[index] = xmm2[index]? *) + let xmm1_invalid = Bil.(UnOp (NOT, is_valid_xmm1_e index)) in + let xmm2_invalid = Bil.(UnOp (NOT, is_valid_xmm2_e index)) in + let bothinvalid = Bil.(xmm1_invalid land xmm2_invalid) in + let eitherinvalid = Bil.(xmm1_invalid lor xmm2_invalid) in + let equal = Bil.(get_xmm1 index = get_xmm2 index) in + (* both invalid -> true one invalid -> false both valid -> check same byte *) - Bil.(bothinvalid lor (UnOp (NOT, eitherinvalid) land equal)) - | EqualOrdered -> - (* Does the substring xmm1 occur at xmm2[index]? *) - let check_char acc j = - let equal = Bil.(get_xmm1 j = get_xmm2 Stdlib.(index+j)) in - let substrended = Bil.(UnOp (NOT, (is_valid_xmm1_e j))) in - let bigstrended = Bil.UnOp (NOT, (is_valid_xmm2_e (index+j))) in - (* substrended => true + Bil.(bothinvalid lor (UnOp (NOT, eitherinvalid) land equal)) + | EqualOrdered -> + (* Does the substring xmm1 occur at xmm2[index]? *) + let check_char acc j = + let equal = Bil.(get_xmm1 j = get_xmm2 Stdlib.(index + j)) in + let substrended = Bil.(UnOp (NOT, is_valid_xmm1_e j)) in + let bigstrended = Bil.UnOp (NOT, is_valid_xmm2_e (index + j)) in + (* substrended => true bigstrended => false byte diff => false byte same => keep going *) - Bil.(substrended lor - (UnOp (NOT,bigstrended) land (equal land acc))) in - (* Is xmm1[j] equal to xmm2[index+j]? *) - List.fold_left ~f:check_char ~init:exp_true (List.range - ~stride:(-1) ~stop:`inclusive (nelem-index-1) 0) - in - let bits = List.map ~f:get_bit nelem_range in - let res, res_bil = concat 1 bits in - let int_res_1 = tmp ~name:"IntRes1" reg16_t in - let int_res_2 = tmp ~name:"IntRes2" reg16_t in - - let contains_null e = - let elts = List.init nelem ~f:(fun i -> Bil.(get_elem e i = int_exp 0 !!elemt)) in - List.fold elts ~init:exp_false ~f:(fun acc elt -> Bil.(acc lor elt)) in - - (* For pcmpistri/pcmpestri *) - let sb exp = - List.fold_left ~f:(fun acc i -> - Bil.Ite (Bil.(exp_true = Extract (i, i, exp)), - (int_exp i !!regm), acc)) - ~init:(int_exp nelem !!regm) - (match imm8cb.outselectsig with - | LSB -> List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive nelem 0 - | MSB -> List.init ~f:(fun x -> x) nelem) - in + Bil.( + substrended lor (UnOp (NOT, bigstrended) land (equal land acc))) + in + (* Is xmm1[j] equal to xmm2[index+j]? *) + List.fold_left ~f:check_char ~init:exp_true + (List.range ~stride:(-1) ~stop:`inclusive (nelem - index - 1) 0) + in + let bits = List.map ~f:get_bit nelem_range in + let res, res_bil = concat 1 bits in + let int_res_1 = tmp ~name:"IntRes1" reg16_t in + let int_res_2 = tmp ~name:"IntRes2" reg16_t in + + let contains_null e = + let elts = + List.init nelem ~f:(fun i -> Bil.(get_elem e i = int_exp 0 !!elemt)) + in + List.fold elts ~init:exp_false ~f:(fun acc elt -> Bil.(acc lor elt)) + in + + (* For pcmpistri/pcmpestri *) + let sb exp = + List.fold_left + ~f:(fun acc i -> + Bil.Ite + (Bil.(exp_true = Extract (i, i, exp)), int_exp i !!regm, acc)) + ~init:(int_exp nelem !!regm) + (match imm8cb.outselectsig with + | LSB -> + List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive nelem + 0 + | MSB -> List.init ~f:(fun x -> x) nelem) + in - (* For pcmpistrm/pcmpestrm *) - let mask e = - match imm8cb.outselectmask with - | Bitmask -> Bil.(cast unsigned 128 e) - | Bytemask -> - let get_element i = - Bil.(cast unsigned !!elemt (extract i i e)) in - let range = List.range ~stride:(-1) - ~start:`exclusive ~stop:`inclusive nelem 0 in - concat_explist (List.map ~f:get_element range) in - - let res_of_cb = match imm8cb with - | {negintres1=false; _} -> Bil.(int_res_2 := var int_res_1) - | {negintres1=true; maskintres1=false; _} -> (* int_res_1 is bitwise-notted *) - Bil.(int_res_2 := unop not (var int_res_1)) - | {negintres1=true; maskintres1=true; _} -> - (* only the valid elements in xmm2 are bitwise-notted *) - (* XXX: Right now we duplicate the valid element computations + (* For pcmpistrm/pcmpestrm *) + let mask e = + match imm8cb.outselectmask with + | Bitmask -> Bil.(cast unsigned 128 e) + | Bytemask -> + let get_element i = Bil.(cast unsigned !!elemt (extract i i e)) in + let range = + List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive nelem + 0 + in + concat_explist (List.map ~f:get_element range) + in + + let res_of_cb = + match imm8cb with + | { negintres1 = false; _ } -> Bil.(int_res_2 := var int_res_1) + | { negintres1 = true; maskintres1 = false; _ } -> + (* int_res_1 is bitwise-notted *) + Bil.(int_res_2 := unop not (var int_res_1)) + | { negintres1 = true; maskintres1 = true; _ } -> + (* only the valid elements in xmm2 are bitwise-notted *) + (* XXX: Right now we duplicate the valid element computations when negating the valid elements. They are also used by the aggregation functions. A better way to implement this might be to write the valid element information out as a temporary bitvector. The aggregation functions and this code would then extract the relevant bit to see if an element is valid. *) - let validvector = - let range = List.range ~stride:(-1) - ~start:`exclusive ~stop:`inclusive nelem 0 in - let bits = List.map ~f:is_valid_xmm2_e range in - Bil.(cast unsigned 16 (concat_explist bits)) in - Bil.(int_res_2 := validvector lxor var int_res_1) in - - let res_of_pcmpinfo = match pcmpinfo.out with - | Index -> Bil.(rcx := sb (var int_res_2)) - (* FIXME: ymms should be used instead of xmms here *) - | Mask -> Bil.(ymms.(0) := mask (var int_res_2)) in - - List.concat [ - xmm1_checks; - xmm2_checks; - res_bil; - Bil.[ - int_res_1 := cast unsigned 16 (var res); - res_of_cb; - res_of_pcmpinfo; - cf := var int_res_2 <> int_exp 0 16; - zf := contains_null xmm2m128_e; - sf := contains_null xmm1_e; - oF := extract 0 0 (var int_res_2); - af := int_exp 0 1; - pf := int_exp 0 1; - ] - ] + let validvector = + let range = + List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive + nelem 0 + in + let bits = List.map ~f:is_valid_xmm2_e range in + Bil.(cast unsigned 16 (concat_explist bits)) + in + Bil.(int_res_2 := validvector lxor var int_res_1) + in + + let res_of_pcmpinfo = + match pcmpinfo.out with + | Index -> Bil.(rcx := sb (var int_res_2)) + (* FIXME: ymms should be used instead of xmms here *) + | Mask -> Bil.(ymms.(0) := mask (var int_res_2)) + in - | Pshufd (t, dst, src, vsrc, imm) -> - let src_e = op2e t src in - let imm_e = op2e t imm in - (* XXX: This would be more straight-forward if implemented using + List.concat + [ + xmm1_checks; + xmm2_checks; + res_bil; + Bil. + [ + int_res_1 := cast unsigned 16 (var res); + res_of_cb; + res_of_pcmpinfo; + cf := var int_res_2 <> int_exp 0 16; + zf := contains_null xmm2m128_e; + sf := contains_null xmm1_e; + oF := extract 0 0 (var int_res_2); + af := int_exp 0 1; + pf := int_exp 0 1; + ]; + ] + | Pshufd (t, dst, src, vsrc, imm) -> ( + let src_e = op2e t src in + let imm_e = op2e t imm in + (* XXX: This would be more straight-forward if implemented using map, instead of fold *) - let get_dword ndword = - let high_b = 2 * (ndword mod 4) + 1 in - let low_b = 2 * (ndword mod 4) in - let index = Bil.(Cast (UNSIGNED, !!t, Extract (high_b, low_b, imm_e))) in - let t' = !!t in - (* Use the same pattern for the top half of a ymm register *) - (* had to stop using extract_element_symbolic, since that calls + let get_dword ndword = + let high_b = (2 * (ndword mod 4)) + 1 in + let low_b = 2 * (ndword mod 4) in + let index = + Bil.(Cast (UNSIGNED, !!t, Extract (high_b, low_b, imm_e))) + in + let t' = !!t in + (* Use the same pattern for the top half of a ymm register *) + (* had to stop using extract_element_symbolic, since that calls * Typecheck.infer_ast. I believe this captures the same * "width logic", but this is a good place to check if things start * going wrong later. *) - let (index, index_width) = if t' = 256 && ndword > 3 then - (Bil.(index + (Int (BV.of_int ~width:(!!t) 4))), 256) - else (index, t') in - extract_element_symbolic_with_width (Type.imm 32) src_e index index_width - in - let topdword = match t with Type.Imm 128 -> 3 | _ -> 7 in - let dwords = concat_explist (List.map ~f:get_dword (List.range ~stride:(-1) ~stop:`inclusive topdword 0)) in - (match vsrc with - | None -> [assn t dst dwords] - | Some vdst -> [assn t vdst dwords]) + let index, index_width = + if t' = 256 && ndword > 3 then + (Bil.(index + Int (BV.of_int ~width:!!t 4)), 256) + else (index, t') + in + extract_element_symbolic_with_width (Type.imm 32) src_e index + index_width + in + let topdword = match t with Type.Imm 128 -> 3 | _ -> 7 in + let dwords = + concat_explist + (List.map ~f:get_dword + (List.range ~stride:(-1) ~stop:`inclusive topdword 0)) + in + match vsrc with + | None -> [ assn t dst dwords ] + | Some vdst -> [ assn t vdst dwords ]) | Pshufb (exp_type, dst_op, src_op, vsrc) -> - let op_size = bitwidth_of_type exp_type in - let index_bits = match op_size with - | 64 -> 3 - | 128 | 256 -> 4 - | _ -> disfailwith "invalid size for pshufb" in - let foreach_byte f = List.concat @@ List.init (op_size / 8) ~f in - - let src = op2e exp_type src_op in - let dst = op2e exp_type dst_op in - let dst_op = Option.value ~default:dst_op vsrc in - let zero = Bil.int (Word.zero op_size) in - let msb_one = Bil.int (Word.of_int ~width:8 0x80) in - - let byte_t = Type.imm 8 in - let byte = int_exp 8 8 in - let iv = tmp ~name:"i" byte_t in - let mask_byte_i = tmp byte_t in - let tmp_byte = tmp exp_type in - let tmp_dst = tmp exp_type in - let ind = tmp byte_t in - - let check_mem_alignment = match src_op with - | Oaddr addr when (op_size = 128) -> - let word_size = width_of_mode mode in - let zero = Bil.int (Word.zero word_size) in - let oxf = Bil.int (Word.of_int ~width:word_size 0xf) in - [ Bil.(if_ (oxf land addr <> zero) [cpuexn 13] []) ] - | _ -> [] in - - List.concat [ - check_mem_alignment; - [Bil.move tmp_dst zero]; - foreach_byte (fun i -> - Bil.[ - iv := int (Word.of_int ~width:8 i); - mask_byte_i := extract 7 0 (src lsr (var iv * byte)); - if_ (msb_one land var mask_byte_i = msb_one) [ - tmp_byte := zero; - ] (* else *) [ - ind := cast unsigned 8 (extract index_bits 0 (var mask_byte_i)); - tmp_byte := - cast unsigned op_size (extract 7 0 (dst lsr (var ind * byte))) - ]; - tmp_dst := Bil.(var tmp_dst lor (var tmp_byte lsl (var iv * byte))); - ]); - [assn exp_type dst_op (Bil.var tmp_dst)] - ] + let op_size = bitwidth_of_type exp_type in + let index_bits = + match op_size with + | 64 -> 3 + | 128 | 256 -> 4 + | _ -> disfailwith "invalid size for pshufb" + in + let foreach_byte f = List.concat @@ List.init (op_size / 8) ~f in + + let src = op2e exp_type src_op in + let dst = op2e exp_type dst_op in + let dst_op = Option.value ~default:dst_op vsrc in + let zero = Bil.int (Word.zero op_size) in + let msb_one = Bil.int (Word.of_int ~width:8 0x80) in + + let byte_t = Type.imm 8 in + let byte = int_exp 8 8 in + let iv = tmp ~name:"i" byte_t in + let mask_byte_i = tmp byte_t in + let tmp_byte = tmp exp_type in + let tmp_dst = tmp exp_type in + let ind = tmp byte_t in + + let check_mem_alignment = + match src_op with + | Oaddr addr when op_size = 128 -> + let word_size = width_of_mode mode in + let zero = Bil.int (Word.zero word_size) in + let oxf = Bil.int (Word.of_int ~width:word_size 0xf) in + [ Bil.(if_ (oxf land addr <> zero) [ cpuexn 13 ] []) ] + | _ -> [] + in - | Lea(t, r, a) when List.is_empty pref -> - (* See Table 3-64 *) - (* previously, it checked whether addrbits > opbits before the cast_low. + List.concat + [ + check_mem_alignment; + [ Bil.move tmp_dst zero ]; + foreach_byte (fun i -> + Bil. + [ + iv := int (Word.of_int ~width:8 i); + mask_byte_i := extract 7 0 (src lsr (var iv * byte)); + if_ + (msb_one land var mask_byte_i = msb_one) + [ tmp_byte := zero ] + (* else *) + [ + ind := + cast unsigned 8 + (extract index_bits 0 (var mask_byte_i)); + tmp_byte := + cast unsigned op_size + (extract 7 0 (dst lsr (var ind * byte))); + ]; + (tmp_dst := + Bil.(var tmp_dst lor (var tmp_byte lsl (var iv * byte)))); + ]); + [ assn exp_type dst_op (Bil.var tmp_dst) ]; + ] + | Lea (t, r, a) when List.is_empty pref -> + (* See Table 3-64 *) + (* previously, it checked whether addrbits > opbits before the cast_low. * The conclusion we came to was that - if they were equal, the cast is basically a nop - if it was the other way round, you want to extend it anyway. * (I may be remembering things wrongly) *) - [assn t r Bil.(Cast (LOW, !!t, a))] - | Call(o1, ra) -> - (* If o1 is an immediate, we should syntactically have Jump(imm) + [ assn t r Bil.(Cast (LOW, !!t, a)) ] + | Call (o1, ra) -> ( + (* If o1 is an immediate, we should syntactically have Jump(imm) so that the CFG algorithm knows where the jump goes. Otherwise it will point to BB_Indirect. Otherwise, we should evaluate the operand before decrementing esp. (This really only matters when esp is the base register of a memory lookup. *) - let target = op2e mt o1 in - (match o1 with - | Oimm _ -> - [Bil.Move (rsp, Bil.(rsp_e - (Int (mi (bytes_of_width mt))))); - store_s mode None mt rsp_e (Bil.Int ra); - Bil.Jmp target] - | _ -> - let t = tmp mt in - [Bil.Move (t, target); - Bil.Move (rsp, Bil.(rsp_e - (Int (mi (bytes_of_width mt))))); - store_s mode None mt rsp_e (Bil.Int ra); - Bil.Jmp (Bil.Var t)]) - | Jump(o) -> - [Bil.Jmp (jump_target mode ss has_rex o)] - | Jcc(o, c) -> - [Bil.If (c, [Bil.Jmp (jump_target mode ss has_rex o)], [])] - | Setcc(t, o1, c) -> - [assn t o1 Bil.(Cast (UNSIGNED, !!t, c))] - | Shift(st, s, dst, shift) -> - let old = tmp ~name:"tmp" s in - let s' = !!s in - let size = int_exp s' s' in - let s_f = Bil.(match st with - | LSHIFT -> (lsl) - | RSHIFT -> (lsr) - | ARSHIFT -> (asr) - | _ -> disfailwith "invalid shift type") in - let dste = op2e s dst in - let count_mask = Bil.(size - int_exp 1 s') in - let count = Bil.(op2e s shift land count_mask) in - let new_of = match st with - | LSHIFT -> Bil.((Cast (HIGH, !!bool_t, dste)) lxor cf_e) - | RSHIFT -> Bil.(Cast (HIGH, !!bool_t, var old)) - | ARSHIFT -> exp_false - | _ -> disfailwith "impossible" - in - let new_cf = - (* undefined for SHL and SHR instructions where the count is greater than + let target = op2e mt o1 in + match o1 with + | Oimm _ -> + [ + Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width mt)))); + store_s mode None mt rsp_e (Bil.Int ra); + Bil.Jmp target; + ] + | _ -> + let t = tmp mt in + [ + Bil.Move (t, target); + Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width mt)))); + store_s mode None mt rsp_e (Bil.Int ra); + Bil.Jmp (Bil.Var t); + ]) + | Jump o -> [ Bil.Jmp (jump_target mode ss has_rex o) ] + | Jcc (o, c) -> + [ Bil.If (c, [ Bil.Jmp (jump_target mode ss has_rex o) ], []) ] + | Setcc (t, o1, c) -> [ assn t o1 Bil.(Cast (UNSIGNED, !!t, c)) ] + | Shift (st, s, dst, shift) -> + let old = tmp ~name:"tmp" s in + let s' = !!s in + let size = int_exp s' s' in + let s_f = + Bil.( + match st with + | LSHIFT -> ( lsl ) + | RSHIFT -> ( lsr ) + | ARSHIFT -> ( asr ) + | _ -> disfailwith "invalid shift type") + in + let dste = op2e s dst in + let count_mask = Bil.(size - int_exp 1 s') in + let count = Bil.(op2e s shift land count_mask) in + let new_of = + match st with + | LSHIFT -> Bil.(Cast (HIGH, !!bool_t, dste) lxor cf_e) + | RSHIFT -> Bil.(Cast (HIGH, !!bool_t, var old)) + | ARSHIFT -> exp_false + | _ -> disfailwith "impossible" + in + let new_cf = + (* undefined for SHL and SHR instructions where the count is greater than or equal to the size (in bits) of the destination operand *) - match st with - | LSHIFT -> Bil.(Cast (LOW, !!bool_t, var old lsr (size - count))) - | RSHIFT | ARSHIFT -> - Bil.(Cast (HIGH, !!bool_t, var old lsl (size - count))) - | _ -> failwith "impossible" - in - Bil.[ - old := dste; - assn s dst (s_f dste count); - if_ (count <> int_exp 0 s') [ - cf := new_cf; - sf := compute_sf dste; - zf := compute_zf s' dste; - pf := compute_pf s dste; - af := unknown "after-shift" bool_t; - if_ (count = int_exp 1 s') [ - oF := new_of; - ] [ - oF := unknown "after-shift" bool_t; + match st with + | LSHIFT -> Bil.(Cast (LOW, !!bool_t, var old lsr (size - count))) + | RSHIFT | ARSHIFT -> + Bil.(Cast (HIGH, !!bool_t, var old lsl (size - count))) + | _ -> failwith "impossible" + in + Bil. + [ + old := dste; + assn s dst (s_f dste count); + if_ + (count <> int_exp 0 s') + [ + cf := new_cf; + sf := compute_sf dste; + zf := compute_zf s' dste; + pf := compute_pf s dste; + af := unknown "after-shift" bool_t; + if_ + (count = int_exp 1 s') + [ oF := new_of ] + [ oF := unknown "after-shift" bool_t ]; + ] + []; ] - ] []; - ] - | Shiftd(st, s, dst, fill, count) -> - let was = tmp ~name:"tmp" s in - let e_dst = op2e s dst in - let e_fill = op2e s fill in - let s' = !!s in - (* Check for 64-bit operand *) - let size = int_exp s' s' in - let count_mask = Bil.(size - int_exp 1 s') in - let e_count = Bil.(op2e s count land count_mask) in - let new_cf = match st with - | LSHIFT -> Bil.(Cast (LOW, !!bool_t, var was lsr (size - e_count))) - | RSHIFT -> Bil.(Cast (HIGH, !!bool_t, var was lsl (size - e_count))) - | _ -> disfailwith "impossible" in - let new_of = Bil.(Cast (HIGH, !!bool_t, (var was lxor e_dst))) in - let unk_of = - Bil.Unknown ("OF undefined after shiftd of more then 1 bit", bool_t) in - let ret1 = match st with - | LSHIFT -> Bil.(e_fill lsr (size - e_count)) - | RSHIFT -> Bil.(e_fill lsl (size - e_count)) - | _ -> disfailwith "impossible" in - let ret2 = match st with - | LSHIFT -> Bil.(e_dst lsl e_count) - | RSHIFT -> Bil.(e_dst lsr e_count) - | _ -> disfailwith "impossible" in - let result = Bil.(ret1 lor ret2) in - (* SWXXX If shift is greater than the operand size, dst and + | Shiftd (st, s, dst, fill, count) -> + let was = tmp ~name:"tmp" s in + let e_dst = op2e s dst in + let e_fill = op2e s fill in + let s' = !!s in + (* Check for 64-bit operand *) + let size = int_exp s' s' in + let count_mask = Bil.(size - int_exp 1 s') in + let e_count = Bil.(op2e s count land count_mask) in + let new_cf = + match st with + | LSHIFT -> Bil.(Cast (LOW, !!bool_t, var was lsr (size - e_count))) + | RSHIFT -> Bil.(Cast (HIGH, !!bool_t, var was lsl (size - e_count))) + | _ -> disfailwith "impossible" + in + let new_of = Bil.(Cast (HIGH, !!bool_t, var was lxor e_dst)) in + let unk_of = + Bil.Unknown ("OF undefined after shiftd of more then 1 bit", bool_t) + in + let ret1 = + match st with + | LSHIFT -> Bil.(e_fill lsr (size - e_count)) + | RSHIFT -> Bil.(e_fill lsl (size - e_count)) + | _ -> disfailwith "impossible" + in + let ret2 = + match st with + | LSHIFT -> Bil.(e_dst lsl e_count) + | RSHIFT -> Bil.(e_dst lsr e_count) + | _ -> disfailwith "impossible" + in + let result = Bil.(ret1 lor ret2) in + (* SWXXX If shift is greater than the operand size, dst and flags are undefined *) - Bil.[ - was := e_dst; - assn s dst result; - if_ (e_count <> int_exp 0 s') [ - cf := new_cf; - sf := compute_sf e_dst; - zf := compute_zf s' e_dst; - pf := compute_pf s e_dst; - (* For a 1-bit shift, the OF flag is set if a sign change occurred; + Bil. + [ + was := e_dst; + assn s dst result; + if_ + (e_count <> int_exp 0 s') + [ + cf := new_cf; + sf := compute_sf e_dst; + zf := compute_zf s' e_dst; + pf := compute_pf s e_dst; + (* For a 1-bit shift, the OF flag is set if a sign change occurred; otherwise, it is cleared. For shifts greater than 1 bit, the OF flag is undefined. *) - if_ (e_count = int_exp 1 s') [ - oF := new_of; - ] [ - oF := unk_of; + if_ (e_count = int_exp 1 s') [ oF := new_of ] [ oF := unk_of ]; + ] + []; ] - ] [] - ] - | Rotate(shift_type, exp_type, dst_op, shift_op, use_cf) -> - if use_cf then unimplemented "rotate use_vf"; - let word_size = bitwidth_of_type exp_type in - let mask_size = word_size - 1 in - let count_var = tmp exp_type in - let count = Bil.var count_var in - let zero = int_exp 0 word_size in - let one = int_exp 1 word_size in - let dst = op2e exp_type dst_op in - let shift_mask = int_exp mask_size word_size in - let size = int_exp word_size word_size in - let shift = op2e exp_type shift_op in - - if [%compare.equal: binop] shift_type LSHIFT then - Bil.[ - count_var := (shift land shift_mask) mod size; - assn exp_type dst_op ((dst lsl count) lor (dst lsr (size - count))); - if_ (count = zero) [ - cf := cast low 1 dst; - ] (* else *) [ - if_ (count = one) [ - oF := cf_e lxor (cast high 1 dst); - ] (* else *) [ - oF := unknown "OF undefined after rotate of more then 1 bit" bool_t; + | Rotate (shift_type, exp_type, dst_op, shift_op, use_cf) -> + if use_cf then unimplemented "rotate use_vf"; + let word_size = bitwidth_of_type exp_type in + let mask_size = word_size - 1 in + let count_var = tmp exp_type in + let count = Bil.var count_var in + let zero = int_exp 0 word_size in + let one = int_exp 1 word_size in + let dst = op2e exp_type dst_op in + let shift_mask = int_exp mask_size word_size in + let size = int_exp word_size word_size in + let shift = op2e exp_type shift_op in + + if [%compare.equal: binop] shift_type LSHIFT then + Bil. + [ + count_var := shift land shift_mask mod size; + assn exp_type dst_op ((dst lsl count) lor (dst lsr (size - count))); + if_ (count = zero) + [ cf := cast low 1 dst ] + (* else *) + [ + if_ (count = one) + [ oF := cf_e lxor cast high 1 dst ] + (* else *) + [ + oF := + unknown "OF undefined after rotate of more then 1 bit" + bool_t; + ]; + ]; ] - ] - ] - else - Bil.[ - count_var := (shift land shift_mask) mod size; - assn exp_type dst_op ((dst lsr count) lor (dst lsl (size - count))); - if_ (count = zero) [ - cf := cast high 1 dst; - ] (* else *) [ - if_ (count = one) [ - oF := cast high 1 dst lxor (cast high 1 (dst lsl int_exp 1 word_size)); - ] (* else *) [ - oF := unknown "OF undefined after rotate of more then 1 bit" bool_t; + else + Bil. + [ + count_var := shift land shift_mask mod size; + assn exp_type dst_op ((dst lsr count) lor (dst lsl (size - count))); + if_ (count = zero) + [ cf := cast high 1 dst ] + (* else *) + [ + if_ (count = one) + [ + oF := + cast high 1 dst + lxor cast high 1 (dst lsl int_exp 1 word_size); + ] + (* else *) + [ + oF := + unknown "OF undefined after rotate of more then 1 bit" + bool_t; + ]; + ]; ] - ] + | Bt (t, bitoffset, bitbase) -> + let t' = !!t in + let offset = op2e t bitoffset in + let value, shift = + match bitbase with + | Oreg _ -> + let reg = op2e t bitbase in + let shift = Bil.(offset land int_exp Stdlib.(t' - 1) t') in + (reg, shift) + | Oaddr a -> + let offset = Bil.(cast unsigned (width_of_mode mode) offset) in + let byte = + load (size_of_typ reg8_t) Bil.(a + (offset lsr int_exp 3 t')) + in + let shift = Bil.(Cast (LOW, !!reg8_t, offset) land int_exp 7 8) in + (byte, shift) + | Ovec _ | Oseg _ | Oimm _ -> disfailwith "Invalid bt operand" + in + [ + Bil.Move (cf, Bil.(Cast (LOW, !!bool_t, value lsr shift))); + Bil.Move (oF, Bil.Unknown ("OF undefined after bt", bool_t)); + Bil.Move (sf, Bil.Unknown ("SF undefined after bt", bool_t)); + Bil.Move (af, Bil.Unknown ("AF undefined after bt", bool_t)); + Bil.Move (pf, Bil.Unknown ("PF undefined after bt", bool_t)); ] - | Bt(t, bitoffset, bitbase) -> - let t' = !!t in - let offset = op2e t bitoffset in - let value, shift = match bitbase with - | Oreg _ -> - let reg = op2e t bitbase in - let shift = Bil.(offset land int_exp Stdlib.(t' - 1) t') in - reg, shift - | Oaddr a -> - let offset = Bil.(cast unsigned (width_of_mode mode) offset) in - let byte = load (size_of_typ reg8_t) Bil.(a + offset lsr int_exp 3 t') in - let shift = Bil.(Cast (LOW, !!reg8_t, offset) land int_exp 7 8) in - byte, shift - | Ovec _ | Oseg _ | Oimm _ -> disfailwith "Invalid bt operand" - in - [ - Bil.Move (cf, Bil.(Cast (LOW, !!bool_t, value lsr shift))); - Bil.Move (oF, Bil.Unknown ("OF undefined after bt", bool_t)); - Bil.Move (sf, Bil.Unknown ("SF undefined after bt", bool_t)); - Bil.Move (af, Bil.Unknown ("AF undefined after bt", bool_t)); - Bil.Move (pf, Bil.Unknown ("PF undefined after bt", bool_t)) - ] - | Bs(t, dst, src, dir) -> - let is_zero_count = List.rev pref |> List.exists ~f:Int.((=) 0xf3) in - let width = !!t in - let src_e = op2e t src in - let is_fwd = match dir with - | Backward -> false - | Forward -> true in - let res = tmp t in - let assn_res = Bil.(res := src_e) in - let scan_bil = - if is_fwd then match width with - | 16 -> ctz16 res - | 32 -> ctz32 res - | 64 -> ctz64 res - | _ -> disfailwith "Invalid bitscan width" - else match width with - | 16 -> clz16 res - | 32 -> clz32 res - | 64 -> clz64 res - | _ -> disfailwith "Invalid bitscan width" in - let assn_result = - let n1 = width - 1 in - assn t dst @@ if is_zero_count || is_fwd then Bil.var res - else Bil.(var res lxor int Word.(of_int n1 ~width)) in - let bil = assn_res :: scan_bil in - let bil = - if is_zero_count then bil @ Bil.[ - assn_result; - cf := var res = int Word.(of_int ~width width); - zf := var res = int Word.(zero width); - ] - else Bil.[ - if_ (src_e = int (Word.zero width)) [ - zf := int Word.b1; - assn t dst @@ unknown "bits" t; - ] (bil @ Bil.[assn_result; zf := int Word.b0]); - ] in - bil @ bitscan_flags is_zero_count + | Bs (t, dst, src, dir) -> + let is_zero_count = List.rev pref |> List.exists ~f:Int.(( = ) 0xf3) in + let width = !!t in + let src_e = op2e t src in + let is_fwd = match dir with Backward -> false | Forward -> true in + let res = tmp t in + let assn_res = Bil.(res := src_e) in + let scan_bil = + if is_fwd then + match width with + | 16 -> ctz16 res + | 32 -> ctz32 res + | 64 -> ctz64 res + | _ -> disfailwith "Invalid bitscan width" + else + match width with + | 16 -> clz16 res + | 32 -> clz32 res + | 64 -> clz64 res + | _ -> disfailwith "Invalid bitscan width" + in + let assn_result = + let n1 = width - 1 in + assn t dst + @@ + if is_zero_count || is_fwd then Bil.var res + else Bil.(var res lxor int Word.(of_int n1 ~width)) + in + let bil = assn_res :: scan_bil in + let bil = + if is_zero_count then + bil + @ Bil. + [ + assn_result; + cf := var res = int Word.(of_int ~width width); + zf := var res = int Word.(zero width); + ] + else + Bil. + [ + if_ + (src_e = int (Word.zero width)) + [ zf := int Word.b1; assn t dst @@ unknown "bits" t ] + (bil @ Bil.[ assn_result; zf := int Word.b0 ]); + ] + in + bil @ bitscan_flags is_zero_count | Hlt -> [] (* x86 Hlt is essentially a NOP *) | Rdtsc -> - let undef reg = assn reg32_t reg (Bil.Unknown ("rdtsc", reg32_t)) in - List.map ~f:undef [o_rax; o_rdx] + let undef reg = assn reg32_t reg (Bil.Unknown ("rdtsc", reg32_t)) in + List.map ~f:undef [ o_rax; o_rdx ] | Cpuid -> - let undef reg = assn reg32_t reg (Bil.Unknown ("cpuid", reg32_t)) in - List.map ~f:undef [o_rax; o_rbx; o_rcx; o_rdx] + let undef reg = assn reg32_t reg (Bil.Unknown ("cpuid", reg32_t)) in + List.map ~f:undef [ o_rax; o_rbx; o_rcx; o_rdx ] | Xgetbv -> - let undef reg = assn reg32_t reg (Bil.Unknown ("xgetbv", reg32_t)) in - List.map ~f:undef [o_rax; o_rdx] - | Stmxcsr (dst) -> - let dst = match dst with - | Oaddr addr -> addr - | _ -> disfailwith "stmxcsr argument cannot be non-memory" - in - [store reg32_t dst (Bil.Var mxcsr);(*(Unknown ("stmxcsr", reg32_t));*) ] - | Ldmxcsr (src) -> - let src = match src with - | Oaddr addr -> addr - | _ -> disfailwith "ldmxcsr argument cannot be non-memory" - in - [ Bil.Move (mxcsr, load (size_of_typ reg32_t) src); ] - | Fnstcw (dst) -> - let dst = match dst with - | Oaddr addr -> addr - | _ -> disfailwith "fnstcw argument cannot be non-memory" - in - [store reg16_t dst (Bil.Var fpu_ctrl); ] - | Fldcw (src) -> - let src = match src with - | Oaddr addr -> addr - | _ -> disfailwith "fldcw argument cannot be non-memory" - in - [ Bil.Move (fpu_ctrl, load (size_of_typ reg16_t) src); ] - | Fld _src -> - unimplemented "unsupported FPU register stack" - | Fst (_dst,_pop) -> - unimplemented "unsupported FPU flags" - | Cmps(Type.Imm _bits as t) -> - let t' = !!t in - let src1 = tmp t in - let src2 = tmp t in - let tmpres = tmp t in - let stmts = - Bil.Move (src1, op2e t (Oaddr rsi_e)) - :: Bil.Move (src2, op2e_s mode seg_es has_rex t (Oaddr rdi_e)) - :: Bil.Move (tmpres, Bil.(Var src1 - Var src2)) - :: string_incr mode t rsi - :: string_incr mode t rdi - :: set_flags_sub t' (Bil.Var src1) (Bil.Var src2) (Bil.Var tmpres) - in - begin match pref with + let undef reg = assn reg32_t reg (Bil.Unknown ("xgetbv", reg32_t)) in + List.map ~f:undef [ o_rax; o_rdx ] + | Stmxcsr dst -> + let dst = + match dst with + | Oaddr addr -> addr + | _ -> disfailwith "stmxcsr argument cannot be non-memory" + in + [ + store reg32_t dst (Bil.Var mxcsr); (*(Unknown ("stmxcsr", reg32_t));*) + ] + | Ldmxcsr src -> + let src = + match src with + | Oaddr addr -> addr + | _ -> disfailwith "ldmxcsr argument cannot be non-memory" + in + [ Bil.Move (mxcsr, load (size_of_typ reg32_t) src) ] + | Fnstcw dst -> + let dst = + match dst with + | Oaddr addr -> addr + | _ -> disfailwith "fnstcw argument cannot be non-memory" + in + [ store reg16_t dst (Bil.Var fpu_ctrl) ] + | Fldcw src -> + let src = + match src with + | Oaddr addr -> addr + | _ -> disfailwith "fldcw argument cannot be non-memory" + in + [ Bil.Move (fpu_ctrl, load (size_of_typ reg16_t) src) ] + | Fld _src -> unimplemented "unsupported FPU register stack" + | Fst (_dst, _pop) -> unimplemented "unsupported FPU flags" + | Cmps (Type.Imm _bits as t) -> + let t' = !!t in + let src1 = tmp t in + let src2 = tmp t in + let tmpres = tmp t in + let stmts = + Bil.Move (src1, op2e t (Oaddr rsi_e)) + :: Bil.Move (src2, op2e_s mode seg_es has_rex t (Oaddr rdi_e)) + :: Bil.Move (tmpres, Bil.(Var src1 - Var src2)) + :: string_incr mode t rsi :: string_incr mode t rdi + :: set_flags_sub t' (Bil.Var src1) (Bil.Var src2) (Bil.Var tmpres) + in + begin match pref with | [] -> stmts - | [single] when single = repz || single = repnz -> - rep_wrap ~mode ~check_zf:single ~addr ~next stmts - | _ -> unimplemented "unsupported flags in cmps" end - | Scas(Type.Imm _bits as t) -> - let t' = !!t in - let src1 = tmp t in - let src2 = tmp t in - let tmpres = tmp t in - let stmts = - let open Stmt in - Move (src1, Bil.(Cast (LOW, !!t, Var rax))) - :: Move (src2, op2e_s mode seg_es has_rex t (Oaddr rdi_e)) - :: Move (tmpres, Bil.(Var src1 - Var src2)) - :: string_incr mode t rdi - :: set_flags_sub t' (Bil.Var src1) (Bil.Var src2) (Bil.Var tmpres) - in - begin match pref with + | [ single ] when single = repz || single = repnz -> + rep_wrap ~mode ~check_zf:single ~addr ~next stmts + | _ -> unimplemented "unsupported flags in cmps" + end + | Scas (Type.Imm _bits as t) -> + let t' = !!t in + let src1 = tmp t in + let src2 = tmp t in + let tmpres = tmp t in + let stmts = + let open Stmt in + Move (src1, Bil.(Cast (LOW, !!t, Var rax))) + :: Move (src2, op2e_s mode seg_es has_rex t (Oaddr rdi_e)) + :: Move (tmpres, Bil.(Var src1 - Var src2)) + :: string_incr mode t rdi + :: set_flags_sub t' (Bil.Var src1) (Bil.Var src2) (Bil.Var tmpres) + in + begin match pref with | [] -> stmts - | [single] when single = repz || single = repnz -> - rep_wrap ~mode ~check_zf:single ~addr ~next stmts - | _ -> unimplemented "unsupported flags in scas" end - | Stos(Type.Imm _bits as t) -> - let stmts = [store_s mode seg_es t rdi_e (op2e t o_rax); - string_incr mode t rdi] - in - begin match pref with + | [ single ] when single = repz || single = repnz -> + rep_wrap ~mode ~check_zf:single ~addr ~next stmts + | _ -> unimplemented "unsupported flags in scas" + end + | Stos (Type.Imm _bits as t) -> + let stmts = + [ store_s mode seg_es t rdi_e (op2e t o_rax); string_incr mode t rdi ] + in + begin match pref with | [] -> stmts - | [single] when single = repz -> rep_wrap ~mode ~addr ~next stmts - | _ -> unimplemented "unsupported prefix for stos" end - | Push(t, o) -> - let o = if is_small_imm o t then sign_extend_imm o t - else op2e t o in - let tmp = tmp t in (* only really needed when o involves esp *) - Bil.Move (tmp, o) - :: Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width t)))) - :: store_s mode seg_ss t rsp_e (Bil.var tmp) (* FIXME: can ss be overridden? *) - :: [] - | Pop(t, o) -> - (* From the manual: + | [ single ] when single = repz -> rep_wrap ~mode ~addr ~next stmts + | _ -> unimplemented "unsupported prefix for stos" + end + | Push (t, o) -> + let o = if is_small_imm o t then sign_extend_imm o t else op2e t o in + let tmp = tmp t in + (* only really needed when o involves esp *) + [ + Bil.Move (tmp, o); + Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width t)))); + store_s mode seg_ss t rsp_e (Bil.var tmp) + (* FIXME: can ss be overridden? *); + ] + | Pop (t, o) -> + (* From the manual: "The POP ESP instruction increments the stack pointer (ESP) before data at the old top of stack is written into the @@ -1295,131 +1502,145 @@ module ToIR = struct So, effectively there is no incrementation. *) - assn t o (load_s mode seg_ss (size_of_typ t) rsp_e) - :: if [%compare.equal: operand] o o_rsp then [] - else [Bil.Move (rsp, Bil.(rsp_e + Int (mi (bytes_of_width t))))] - | Pushf(t) -> - (* Note that we currently treat these fields as unknowns, but the + assn t o (load_s mode seg_ss (size_of_typ t) rsp_e) + :: + (if [%compare.equal: operand] o o_rsp then [] + else [ Bil.Move (rsp, Bil.(rsp_e + Int (mi (bytes_of_width t)))) ]) + | Pushf t -> + (* Note that we currently treat these fields as unknowns, but the manual says: When copying the entire EFLAGS register to the stack, the VM and RF flags (bits 16 and 17) are not copied; instead, the values for these flags are cleared in the EFLAGS image stored on the stack. *) - let flags_e = match t with - | Type.Imm 16 -> flags_e - | Type.Imm 32 -> eflags_e - | Type.Imm 64 -> rflags_e - | _ -> failwith "impossible" - in - Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width t)))) - :: store_s mode seg_ss t rsp_e flags_e - :: [] + let flags_e = + match t with + | Type.Imm 16 -> flags_e + | Type.Imm 32 -> eflags_e + | Type.Imm 64 -> rflags_e + | _ -> failwith "impossible" + in + [ + Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width t)))); + store_s mode seg_ss t rsp_e flags_e; + ] | Popf t -> - let assnsf = match t with - | Type.Imm 16 -> assns_flags_to_bap - | Type.Imm 32 -> assns_eflags_to_bap - | Type.Imm 64 -> assns_rflags_to_bap - | _ -> failwith "impossible" - in - let tmp = tmp t in - let extractlist = - List.map - ~f:(fun i -> - Bil.(Extract (i, i, Var tmp))) - (List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive !!t 0) - in - Bil.Move (tmp, load_s mode seg_ss (size_of_typ t) rsp_e) - :: Bil.Move (rsp, Bil.(rsp_e + Int (mi (bytes_of_width t)))) - :: List.concat (List.map2_exn ~f:(fun f e -> f e) assnsf - extractlist) - | Popcnt(t, s, d) -> - let width = !!t in - let bits = op2e t s in - let res = tmp t in - let assn_src = Bil.(res := bits) in - let cnt = match width with - | 16 -> popcnt16 res - | 32 -> popcnt32 res - | 64 -> popcnt64 res - | _ -> disfailwith "Invalid popcnt width" in - let bil = (assn_src :: cnt) @ Bil.[assn t d (var res)] in - let flags = List.map ~f:(fun r -> - Bil.Move (r, int_exp 0 1)) [cf; oF; sf; af; pf] in - set_zf width bits :: (bil @ flags) + let assnsf = + match t with + | Type.Imm 16 -> assns_flags_to_bap + | Type.Imm 32 -> assns_eflags_to_bap + | Type.Imm 64 -> assns_rflags_to_bap + | _ -> failwith "impossible" + in + let tmp = tmp t in + let extractlist = + List.map + ~f:(fun i -> Bil.(Extract (i, i, Var tmp))) + (List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive !!t 0) + in + Bil.Move (tmp, load_s mode seg_ss (size_of_typ t) rsp_e) + :: Bil.Move (rsp, Bil.(rsp_e + Int (mi (bytes_of_width t)))) + :: List.concat (List.map2_exn ~f:(fun f e -> f e) assnsf extractlist) + | Popcnt (t, s, d) -> + let width = !!t in + let bits = op2e t s in + let res = tmp t in + let assn_src = Bil.(res := bits) in + let cnt = + match width with + | 16 -> popcnt16 res + | 32 -> popcnt32 res + | 64 -> popcnt64 res + | _ -> disfailwith "Invalid popcnt width" + in + let bil = (assn_src :: cnt) @ Bil.[ assn t d (var res) ] in + let flags = + List.map + ~f:(fun r -> Bil.Move (r, int_exp 0 1)) + [ cf; oF; sf; af; pf ] + in + set_zf width bits :: (bil @ flags) | Sahf -> - let assnsf = assns_lflags_to_bap in - let tah = tmp ~name:"AH" reg8_t in - let extractlist = - List.map - ~f:(fun i -> - Bil.(Extract (i, i, Var tah))) - (List.range ~stride:(-1) ~stop:`inclusive 7 0) - in - Bil.Move (tah, ah_e) - :: List.concat (List.map2_exn ~f:(fun f e -> f e) assnsf extractlist) + let assnsf = assns_lflags_to_bap in + let tah = tmp ~name:"AH" reg8_t in + let extractlist = + List.map + ~f:(fun i -> Bil.(Extract (i, i, Var tah))) + (List.range ~stride:(-1) ~stop:`inclusive 7 0) + in + Bil.Move (tah, ah_e) + :: List.concat (List.map2_exn ~f:(fun f e -> f e) assnsf extractlist) | Lahf -> - let o_ah = Oreg 4 in - [assn reg8_t o_ah lflags_e] - | Add(t, o1, o2) -> - let tmp = tmp t and tmp2 = tmp t in - Bil.Move (tmp, op2e t o1) - :: Bil.Move (tmp2, op2e t o2) - :: assn t o1 Bil.(op2e t o1 + Var tmp2) - :: let s1 = Bil.Var tmp in let s2 = Bil.Var tmp2 in let r = op2e t o1 in - set_flags_add !!t s1 s2 r - | Adc(t, o1, o2) -> - let orig1 = tmp t in - let orig2 = tmp t in - let bits = !!t in - let t' = Type.Imm (bits + 1) in - let c e = Bil.(Cast (UNSIGNED, !!t', e)) in - (* Literally compute the addition with an extra bit and see + let o_ah = Oreg 4 in + [ assn reg8_t o_ah lflags_e ] + | Add (t, o1, o2) -> + let tmp = tmp t and tmp2 = tmp t in + Bil.Move (tmp, op2e t o1) + :: Bil.Move (tmp2, op2e t o2) + :: assn t o1 Bil.(op2e t o1 + Var tmp2) + :: + (let s1 = Bil.Var tmp in + let s2 = Bil.Var tmp2 in + let r = op2e t o1 in + set_flags_add !!t s1 s2 r) + | Adc (t, o1, o2) -> + let orig1 = tmp t in + let orig2 = tmp t in + let bits = !!t in + let t' = Type.Imm (bits + 1) in + let c e = Bil.(Cast (UNSIGNED, !!t', e)) in + (* Literally compute the addition with an extra bit and see what the value is for CF *) - let s1 = Bil.Var orig1 in let s2 = Bil.Var orig2 in let r = op2e t o1 in - let bige = Bil.(c s1 + c s2 + c (Cast (UNSIGNED, !!t, cf_e))) in - Bil.Move (orig1, op2e t o1) - :: Bil.Move (orig2, op2e t o2) - :: assn t o1 Bil.(s1 + s2 + Cast (UNSIGNED, !!t, cf_e)) - :: Bil.Move (cf, Bil.Extract (bits, bits, bige)) - :: set_aopszf_add !!t s1 s2 r - | Inc(t, o) (* o = o + 1 *) -> - let t' = !!t in - let tmp = tmp t in - Bil.Move (tmp, op2e t o) - :: assn t o Bil.(op2e t o + int_exp 1 t') - :: set_aopszf_add t' (Bil.Var tmp) (int_exp 1 t') (op2e t o) - | Dec(t, o) (* o = o - 1 *) -> - let t' = !!t in - let tmp = tmp t in - Bil.Move (tmp, op2e t o) - :: assn t o Bil.(op2e t o - int_exp 1 t') - :: set_aopszf_sub t' (Bil.Var tmp) (int_exp 1 t') (op2e t o) (* CF is maintained *) - | Sub(t, o1, o2) (* o1 = o1 - o2 *) -> - let oldo1 = tmp t in - let oldo2 = tmp t in - let op1 = op2e t o1 in - let op2 = - if is_small_imm o2 t then sign_extend_imm o2 t - else op2e t o2 in - Bil.([ - oldo1 := op1; - oldo2 := op2; - assn t o1 (op1 - op2); - ] @ set_flags_sub (bitwidth_of_type t) (var oldo1) (var oldo2) op1) - | Sbb(t, o1, o2) -> - let tmp_s = tmp t in - let tmp_d = tmp t in - let orig_s = Bil.Var tmp_s in - let orig_d = Bil.Var tmp_d in - let sube = Bil.(orig_s + Cast (UNSIGNED, !!t, cf_e)) in - let d = op2e t o1 in - let s1 = - if is_small_imm o2 t then sign_extend_imm o2 t - else op2e t o2 in - Bil.Move (tmp_s, s1) - :: Bil.Move (tmp_d, d) - :: assn t o1 Bil.(orig_d - sube) - :: Bil.Move (oF, Bil.(Cast (HIGH, !!bool_t, (orig_s lxor orig_d) land (orig_d lxor d)))) - (* When src = 0xffffffff and cf=1, the processor sets CF=1. + let s1 = Bil.Var orig1 in + let s2 = Bil.Var orig2 in + let r = op2e t o1 in + let bige = Bil.(c s1 + c s2 + c (Cast (UNSIGNED, !!t, cf_e))) in + Bil.Move (orig1, op2e t o1) + :: Bil.Move (orig2, op2e t o2) + :: assn t o1 Bil.(s1 + s2 + Cast (UNSIGNED, !!t, cf_e)) + :: Bil.Move (cf, Bil.Extract (bits, bits, bige)) + :: set_aopszf_add !!t s1 s2 r + | Inc (t, o) (* o = o + 1 *) -> + let t' = !!t in + let tmp = tmp t in + Bil.Move (tmp, op2e t o) + :: assn t o Bil.(op2e t o + int_exp 1 t') + :: set_aopszf_add t' (Bil.Var tmp) (int_exp 1 t') (op2e t o) + | Dec (t, o) (* o = o - 1 *) -> + let t' = !!t in + let tmp = tmp t in + Bil.Move (tmp, op2e t o) + :: assn t o Bil.(op2e t o - int_exp 1 t') + :: set_aopszf_sub t' (Bil.Var tmp) (int_exp 1 t') (op2e t o) + (* CF is maintained *) + | Sub (t, o1, o2) (* o1 = o1 - o2 *) -> + let oldo1 = tmp t in + let oldo2 = tmp t in + let op1 = op2e t o1 in + let op2 = + if is_small_imm o2 t then sign_extend_imm o2 t else op2e t o2 + in + Bil.( + [ oldo1 := op1; oldo2 := op2; assn t o1 (op1 - op2) ] + @ set_flags_sub (bitwidth_of_type t) (var oldo1) (var oldo2) op1) + | Sbb (t, o1, o2) -> + let tmp_s = tmp t in + let tmp_d = tmp t in + let orig_s = Bil.Var tmp_s in + let orig_d = Bil.Var tmp_d in + let sube = Bil.(orig_s + Cast (UNSIGNED, !!t, cf_e)) in + let d = op2e t o1 in + let s1 = + if is_small_imm o2 t then sign_extend_imm o2 t else op2e t o2 + in + Bil.Move (tmp_s, s1) + :: Bil.Move (tmp_d, d) + :: assn t o1 Bil.(orig_d - sube) + :: Bil.Move + ( oF, + Bil.( + Cast (HIGH, !!bool_t, orig_s lxor orig_d land (orig_d lxor d))) + ) + (* When src = 0xffffffff and cf=1, the processor sets CF=1. Note that we compute dest = dest - (0xffffffff + 1) = 0, so the subtraction does not overflow. @@ -1430,262 +1651,288 @@ module ToIR = struct Maybe we should implement this by doing the actual computation, like we do for adc. *) - (* sub overflow | add overflow *) - :: Bil.Move (cf, Bil.((sube > orig_d) lor (sube < orig_s))) - :: set_apszf !!t orig_s orig_d d - | Cmp(t, o1, o2) -> - let tmp = tmp t in - Bil.Move (tmp, Bil.(op2e t o1 - op2e t o2)) - :: set_flags_sub !!t (op2e t o1) (op2e t o2) (Bil.Var tmp) - | Cmpxchg(t, src, dst) -> - let t' = !!t in - let eax_e = op2e t o_rax in - let dst_e = op2e t dst in - let src_e = op2e t src in - let tmp = tmp t in - Bil.Move (tmp, Bil.(eax_e - dst_e)) - :: set_flags_sub t' eax_e dst_e (Bil.Var tmp) - @ assn t dst (Bil.Ite (zf_e, src_e, dst_e)) - :: assn t o_rax (Bil.Ite (zf_e, eax_e, dst_e)) - :: [] - | Cmpxchg8b o -> (* only 32bit case *) - let accumulator = Bil.Concat((op2e reg32_t o_rdx),(op2e reg32_t o_rax)) in - let dst_e = op2e reg64_t o in - let src_e = Bil.Concat((op2e reg32_t o_rcx),(op2e reg32_t o_rbx)) in - let dst_low_e = Bil.Extract(63, 32, dst_e) in - let dst_hi_e = Bil.Extract(31, 0, dst_e) in - let eax_e = op2e reg32_t o_rax in - let edx_e = op2e reg32_t o_rdx in - let equal = tmp bool_t in - let equal_v = Bil.Var equal in - [ - Bil.Move (equal, Bil.(accumulator = dst_e)); - Bil.Move (zf, equal_v); - assn reg64_t o (Bil.Ite (equal_v, src_e, dst_e)); - assn reg32_t o_rax (Bil.Ite (equal_v, eax_e, dst_low_e)); - assn reg32_t o_rdx (Bil.Ite (equal_v, edx_e, dst_hi_e)) - ] - | Xadd(t, dst_op, src_op) -> - let tmp_res = tmp t in - let tmp_dst = tmp t in - let tmp_src = tmp t in - let dst = op2e t dst_op in - let src = op2e t src_op in - Bil.[ - tmp_src := src; - tmp_dst := dst; - tmp_res := src + dst; - assn t src_op dst; - assn t dst_op (var tmp_res); - ] @ set_flags_add !!t (Bil.var tmp_dst) (Bil.var tmp_src) dst; - | Xchg(t, src, dst) -> - let tmp = tmp t in - [ Bil.Move (tmp, op2e t src); - assn t src (op2e t dst); - assn t dst (Bil.Var tmp); ] - | And(t, o1, o2) -> - assn t o1 Bil.(op2e t o1 land op2e t o2) - :: Bil.Move (oF, exp_false) - :: Bil.Move (cf, exp_false) - :: Bil.Move (af, Bil.Unknown ("AF is undefined after and", bool_t)) - :: set_pszf t (op2e t o1) - | Or(t, o1, o2) -> - let o2 = - if is_small_imm o2 t then sign_extend_imm o2 t - else op2e t o2 in - assn t o1 Bil.(op2e t o1 lor o2) - :: Bil.Move (oF, exp_false) - :: Bil.Move (cf, exp_false) - :: Bil.Move (af, Bil.Unknown ("AF is undefined after or", bool_t)) - :: set_pszf t (op2e t o1) - | Xor(t, o1, o2) when [%compare.equal: operand] o1 o2 -> - assn t o1 Bil.(Int (BV.of_int ~width:(!!t) 0)) - :: Bil.Move (af, Bil.Unknown ("AF is undefined after xor", bool_t)) - :: List.map ~f:(fun v -> Bil.Move (v, exp_true)) [zf; pf] - @ List.map ~f:(fun v -> Bil.Move (v, exp_false)) [oF; cf; sf] - | Xor(t, o1, o2) -> - assn t o1 Bil.(op2e t o1 lxor op2e t o2) - :: Bil.Move (oF, exp_false) - :: Bil.Move (cf, exp_false) - :: Bil.Move (af, Bil.Unknown ("AF is undefined after xor", bool_t)) - :: set_pszf t (op2e t o1) - | Test(t, o1, o2) -> - let o2 = - if is_small_imm o2 t then sign_extend_imm o2 t - else op2e t o2 in - let tmp = tmp t in - Bil.Move (tmp, Bil.(op2e t o1 land o2)) - :: Bil.Move (oF, exp_false) - :: Bil.Move (cf, exp_false) - :: Bil.Move (af, Bil.Unknown ("AF is undefined after and", bool_t)) - :: set_pszf t (Bil.Var tmp) - | Ptest(t, o1, o2) -> - let open Stmt in - let t' = !!t in - let tmp1 = tmp t and tmp2 = tmp t in - Move (tmp1, Bil.(op2e t o2 land op2e t o1)) - :: Move (tmp2, Bil.(op2e t o2 land (exp_not (op2e t o1)))) - :: Move (af, exp_false) - :: Move (oF, exp_false) - :: Move (pf, exp_false) - :: Move (sf, exp_false) - :: Move (zf, Bil.(Var tmp1 = Int (BV.of_int ~width:t' 0))) - :: [Move (cf, Bil.(Var tmp2 = Int (BV.of_int ~width:t' 0)))] - | Not(t, o) -> - [assn t o (exp_not (op2e t o))] - | Neg(t, o) -> - let t' = !!t in - let tmp = tmp t in - let min_int = - Bil.BinOp (LSHIFT, int_exp 1 t', int_exp (t'-1) t') - in - Bil.Move (tmp, op2e t o) - ::assn t o Bil.(int_exp 0 t' - op2e t o) - ::Bil.Move (cf, Bil.(Ite (Var tmp = int_exp 0 t', int_exp 0 1, int_exp 1 1))) - ::Bil.Move (oF, Bil.(Ite (Var tmp = min_int, int_exp 1 1, int_exp 0 1))) - ::set_apszf_sub t' (Bil.Var tmp) (int_exp 0 t') (op2e t o) + (* sub overflow | add overflow *) + :: Bil.Move (cf, Bil.((sube > orig_d) lor (sube < orig_s))) + :: set_apszf !!t orig_s orig_d d + | Cmp (t, o1, o2) -> + let tmp = tmp t in + Bil.Move (tmp, Bil.(op2e t o1 - op2e t o2)) + :: set_flags_sub !!t (op2e t o1) (op2e t o2) (Bil.Var tmp) + | Cmpxchg (t, src, dst) -> + let t' = !!t in + let eax_e = op2e t o_rax in + let dst_e = op2e t dst in + let src_e = op2e t src in + let tmp = tmp t in + Bil.Move (tmp, Bil.(eax_e - dst_e)) + :: set_flags_sub t' eax_e dst_e (Bil.Var tmp) + @ [ + assn t dst (Bil.Ite (zf_e, src_e, dst_e)); + assn t o_rax (Bil.Ite (zf_e, eax_e, dst_e)); + ] + | Cmpxchg8b o -> + (* only 32bit case *) + let accumulator = Bil.Concat (op2e reg32_t o_rdx, op2e reg32_t o_rax) in + let dst_e = op2e reg64_t o in + let src_e = Bil.Concat (op2e reg32_t o_rcx, op2e reg32_t o_rbx) in + let dst_low_e = Bil.Extract (63, 32, dst_e) in + let dst_hi_e = Bil.Extract (31, 0, dst_e) in + let eax_e = op2e reg32_t o_rax in + let edx_e = op2e reg32_t o_rdx in + let equal = tmp bool_t in + let equal_v = Bil.Var equal in + [ + Bil.Move (equal, Bil.(accumulator = dst_e)); + Bil.Move (zf, equal_v); + assn reg64_t o (Bil.Ite (equal_v, src_e, dst_e)); + assn reg32_t o_rax (Bil.Ite (equal_v, eax_e, dst_low_e)); + assn reg32_t o_rdx (Bil.Ite (equal_v, edx_e, dst_hi_e)); + ] + | Xadd (t, dst_op, src_op) -> + let tmp_res = tmp t in + let tmp_dst = tmp t in + let tmp_src = tmp t in + let dst = op2e t dst_op in + let src = op2e t src_op in + Bil. + [ + tmp_src := src; + tmp_dst := dst; + tmp_res := src + dst; + assn t src_op dst; + assn t dst_op (var tmp_res); + ] + @ set_flags_add !!t (Bil.var tmp_dst) (Bil.var tmp_src) dst + | Xchg (t, src, dst) -> + let tmp = tmp t in + [ + Bil.Move (tmp, op2e t src); + assn t src (op2e t dst); + assn t dst (Bil.Var tmp); + ] + | And (t, o1, o2) -> + assn t o1 Bil.(op2e t o1 land op2e t o2) + :: Bil.Move (oF, exp_false) + :: Bil.Move (cf, exp_false) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after and", bool_t)) + :: set_pszf t (op2e t o1) + | Or (t, o1, o2) -> + let o2 = + if is_small_imm o2 t then sign_extend_imm o2 t else op2e t o2 + in + assn t o1 Bil.(op2e t o1 lor o2) + :: Bil.Move (oF, exp_false) + :: Bil.Move (cf, exp_false) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after or", bool_t)) + :: set_pszf t (op2e t o1) + | Xor (t, o1, o2) when [%compare.equal: operand] o1 o2 -> + assn t o1 Bil.(Int (BV.of_int ~width:!!t 0)) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after xor", bool_t)) + :: List.map ~f:(fun v -> Bil.Move (v, exp_true)) [ zf; pf ] + @ List.map ~f:(fun v -> Bil.Move (v, exp_false)) [ oF; cf; sf ] + | Xor (t, o1, o2) -> + assn t o1 Bil.(op2e t o1 lxor op2e t o2) + :: Bil.Move (oF, exp_false) + :: Bil.Move (cf, exp_false) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after xor", bool_t)) + :: set_pszf t (op2e t o1) + | Test (t, o1, o2) -> + let o2 = + if is_small_imm o2 t then sign_extend_imm o2 t else op2e t o2 + in + let tmp = tmp t in + Bil.Move (tmp, Bil.(op2e t o1 land o2)) + :: Bil.Move (oF, exp_false) + :: Bil.Move (cf, exp_false) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after and", bool_t)) + :: set_pszf t (Bil.Var tmp) + | Ptest (t, o1, o2) -> + let open Stmt in + let t' = !!t in + let tmp1 = tmp t and tmp2 = tmp t in + Move (tmp1, Bil.(op2e t o2 land op2e t o1)) + :: Move (tmp2, Bil.(op2e t o2 land exp_not (op2e t o1))) + :: Move (af, exp_false) + :: Move (oF, exp_false) + :: Move (pf, exp_false) + :: Move (sf, exp_false) + :: Move (zf, Bil.(Var tmp1 = Int (BV.of_int ~width:t' 0))) + :: [ Move (cf, Bil.(Var tmp2 = Int (BV.of_int ~width:t' 0))) ] + | Not (t, o) -> [ assn t o (exp_not (op2e t o)) ] + | Neg (t, o) -> + let t' = !!t in + let tmp = tmp t in + let min_int = Bil.BinOp (LSHIFT, int_exp 1 t', int_exp (t' - 1) t') in + Bil.Move (tmp, op2e t o) + :: assn t o Bil.(int_exp 0 t' - op2e t o) + :: Bil.Move + (cf, Bil.(Ite (Var tmp = int_exp 0 t', int_exp 0 1, int_exp 1 1))) + :: Bil.Move (oF, Bil.(Ite (Var tmp = min_int, int_exp 1 1, int_exp 0 1))) + :: set_apszf_sub t' (Bil.Var tmp) (int_exp 0 t') (op2e t o) | Mul (t, src) -> - (* Mul always multiplies EAX by src and stores the result in EDX:EAX + (* Mul always multiplies EAX by src and stores the result in EDX:EAX starting from the "right hand side" based on the type t of src *) - (* The OF and CF flags are set to 0 if the upper half of the result is 0; + (* The OF and CF flags are set to 0 if the upper half of the result is 0; otherwise, they are set to 1 *) - let new_t = Type.Imm (!!t * 2) in - let assnstmts, assne = Bil.(assn_dbl t ((Cast (UNSIGNED, !!new_t, op2e t o_rax)) * (Cast (UNSIGNED, !!new_t, op2e t src)))) - in - let flag = - let highbit = !!new_t - 1 in - let lowbit = !!new_t / 2 in - Bil.((Extract (highbit, lowbit, assne)) <> int_exp 0 !!t) - in - assnstmts - @ - [ - Bil.Move (oF, flag); - Bil.Move (cf, flag); - Bil.Move (sf, Bil.Unknown ("SF is undefined after Mul", bool_t)); - Bil.Move (zf, Bil.Unknown ("ZF is undefined after Mul", bool_t)); - Bil.Move (af, Bil.Unknown ("AF is undefined after Mul", bool_t)); - Bil.Move (pf, Bil.Unknown ("PF is undefined after Mul", bool_t)) - ] + let new_t = Type.Imm (!!t * 2) in + let assnstmts, assne = + Bil.( + assn_dbl t + (Cast (UNSIGNED, !!new_t, op2e t o_rax) + * Cast (UNSIGNED, !!new_t, op2e t src))) + in + let flag = + let highbit = !!new_t - 1 in + let lowbit = !!new_t / 2 in + Bil.(Extract (highbit, lowbit, assne) <> int_exp 0 !!t) + in + assnstmts + @ [ + Bil.Move (oF, flag); + Bil.Move (cf, flag); + Bil.Move (sf, Bil.Unknown ("SF is undefined after Mul", bool_t)); + Bil.Move (zf, Bil.Unknown ("ZF is undefined after Mul", bool_t)); + Bil.Move (af, Bil.Unknown ("AF is undefined after Mul", bool_t)); + Bil.Move (pf, Bil.Unknown ("PF is undefined after Mul", bool_t)); + ] | Imul (t, (oneopform, dst), src1, src2) -> - let new_t = Type.Imm (!!t * 2) in - let mul_stmts = - (match oneopform with - | true -> - (* For one operand form, use assn_double *) - let assnstmts, assne = - assn_dbl t Bil.((Cast (SIGNED, !!new_t, op2e t src1)) * (Cast (SIGNED, !!new_t, op2e t src2))) in - let flag = - (* Intel checks if EAX == EDX:EAX. Instead of doing this, we are just + let new_t = Type.Imm (!!t * 2) in + let mul_stmts = + match oneopform with + | true -> + (* For one operand form, use assn_double *) + let assnstmts, assne = + assn_dbl t + Bil.( + Cast (SIGNED, !!new_t, op2e t src1) + * Cast (SIGNED, !!new_t, op2e t src2)) + in + let flag = + (* Intel checks if EAX == EDX:EAX. Instead of doing this, we are just going to check if the upper bits are != 0 *) - let highbit = !!new_t - 1 in - let lowbit = !!new_t / 2 in - Bil.((Extract (highbit, lowbit, assne)) <> int_exp 0 !!t) - in - assnstmts @ - [Bil.Move (oF, flag); - Bil.Move (cf, flag)] - | false -> - (* Two and three operand forms *) - let tmp = tmp new_t in - (* Flag is set when the result is truncated *) - let flag = Bil.(Var tmp <> Cast (SIGNED, !!new_t, op2e t dst)) in - [(Bil.Move (tmp, Bil.((Cast (SIGNED, !!new_t, op2e t src1)) * (Cast (SIGNED, !!new_t, op2e t src2))))); - (assn t dst Bil.(Cast (LOW, !!t, Var tmp))); - Bil.Move (oF, flag); - Bil.Move (cf, flag)] ) - in - mul_stmts@[ - Bil.Move (pf, Bil.Unknown ("PF is undefined after imul", bool_t)); - Bil.Move (sf, Bil.Unknown ("SF is undefined after imul", bool_t)); - Bil.Move (zf, Bil.Unknown ("ZF is undefined after imul", bool_t)); - Bil.Move (af, Bil.Unknown ("AF is undefined after imul", bool_t));] - | Div(t, src) -> - let dt' = !!t * 2 in - let dt = Type.Imm dt' in - let zero = int_exp 0 dt' in - let dividend = tmp ~name:"dividend" dt in - let divisor = tmp ~name:"divisor" dt in - let tdiv = tmp ~name:"div" dt in - let trem = tmp ~name:"rem" dt in - let result = Bil.(cast low!!t (var trem) ^ cast low !!t (var tdiv)) in - let apply_result = fst (assn_dbl t result) in - Bil.[ - divisor := cast unsigned !!dt (op2e t src); - dividend := op2e_dbl t; - if_ (var divisor = zero) [ - Cpu_exceptions.divide_by_zero - ](* else *) [ - tdiv := var dividend / var divisor; - trem := var dividend mod var divisor; - if_ (cast high !!t (var tdiv) = int_exp 0 !!t) - apply_result (* else *) - [Cpu_exceptions.divide_by_zero] + let highbit = !!new_t - 1 in + let lowbit = !!new_t / 2 in + Bil.(Extract (highbit, lowbit, assne) <> int_exp 0 !!t) + in + assnstmts @ [ Bil.Move (oF, flag); Bil.Move (cf, flag) ] + | false -> + (* Two and three operand forms *) + let tmp = tmp new_t in + (* Flag is set when the result is truncated *) + let flag = Bil.(Var tmp <> Cast (SIGNED, !!new_t, op2e t dst)) in + [ + Bil.Move + ( tmp, + Bil.( + Cast (SIGNED, !!new_t, op2e t src1) + * Cast (SIGNED, !!new_t, op2e t src2)) ); + assn t dst Bil.(Cast (LOW, !!t, Var tmp)); + Bil.Move (oF, flag); + Bil.Move (cf, flag); + ] + in + mul_stmts + @ [ + Bil.Move (pf, Bil.Unknown ("PF is undefined after imul", bool_t)); + Bil.Move (sf, Bil.Unknown ("SF is undefined after imul", bool_t)); + Bil.Move (zf, Bil.Unknown ("ZF is undefined after imul", bool_t)); + Bil.Move (af, Bil.Unknown ("AF is undefined after imul", bool_t)); + ] + | Div (t, src) -> + let dt' = !!t * 2 in + let dt = Type.Imm dt' in + let zero = int_exp 0 dt' in + let dividend = tmp ~name:"dividend" dt in + let divisor = tmp ~name:"divisor" dt in + let tdiv = tmp ~name:"div" dt in + let trem = tmp ~name:"rem" dt in + let result = Bil.(cast low !!t (var trem) ^ cast low !!t (var tdiv)) in + let apply_result = fst (assn_dbl t result) in + Bil. + [ + divisor := cast unsigned !!dt (op2e t src); + dividend := op2e_dbl t; + if_ + (var divisor = zero) + [ Cpu_exceptions.divide_by_zero ] + (* else *) + [ + tdiv := var dividend / var divisor; + trem := var dividend mod var divisor; + if_ + (cast high !!t (var tdiv) = int_exp 0 !!t) + apply_result (* else *) + [ Cpu_exceptions.divide_by_zero ]; + ]; + ] + @ undefine [ cf; oF; sf; zf; af; pf ] + | Idiv (t, src) -> + let dt' = !!t * 2 in + let dt = Type.Imm dt' in + let zero = int_exp 0 dt' in + let dividend = tmp ~name:"dividend" dt in + let divisor = tmp ~name:"divisor" dt in + let tdiv = tmp ~name:"div" dt in + let trem = tmp ~name:"rem" dt in + let result = Bil.(cast low !!t (var trem) ^ cast low !!t (var tdiv)) in + let apply_result = fst @@ assn_dbl t result in + let lbound = + let dtm1 = dt' - 1 in + Word.(one dt' lsl of_int ~width:dt' dtm1) + in + let ubound = Word.(lbound - one dt') in + Bil. + [ + divisor := cast signed !!dt (op2e t src); + dividend := op2e_dbl t; + if_ + (var divisor = zero) + [ Cpu_exceptions.divide_by_zero ] + (* else *) + [ + tdiv := var dividend /$ var divisor; + trem := var dividend %$ var divisor; + if_ + ((var tdiv >$ int ubound) lor (var tdiv <$ int lbound)) + [ Cpu_exceptions.divide_by_zero ] (* else *) + apply_result; + ]; + ] + @ undefine [ cf; oF; sf; zf; af; pf ] + | Cld -> [ Bil.Move (df, exp_false) ] + | Leave t when List.is_empty pref -> + (* #UD if Lock prefix is used *) + Bil.Move (rsp, rbp_e) + :: to_ir mode addr next ss pref has_rex has_vex (Pop (t, o_rbp)) + | Interrupt3 -> [ Bil.CpuExn 3 ] + | Interrupt (Oimm i) -> + [ + (match Addr.to_int i with + | Ok i -> Bil.cpuexn i + | Error _ -> + let dst = asprintf "interrupt@%s" (Addr.string_of_value i) in + Bil.(encode call dst)); ] - ] @ undefine [cf; oF; sf; zf; af; pf] - | Idiv(t, src) -> - let dt' = !!t * 2 in - let dt = Type.Imm dt' in - let zero = int_exp 0 dt' in - let dividend = tmp ~name:"dividend" dt in - let divisor = tmp ~name:"divisor" dt in - let tdiv = tmp ~name:"div" dt in - let trem = tmp ~name:"rem" dt in - let result = Bil.(cast low !!t (var trem) ^ cast low !!t (var tdiv)) in - let apply_result = fst @@ assn_dbl t result in - let lbound = - let dtm1 = dt' - 1 in - Word.(one dt' lsl of_int ~width:dt' dtm1) in - let ubound = Word.(lbound - one dt') in - Bil.[ - divisor := cast signed !!dt (op2e t src); - dividend := op2e_dbl t; - if_ (var divisor = zero) [ - Cpu_exceptions.divide_by_zero - ] (* else *) [ - tdiv := var dividend /$ var divisor; - trem := var dividend %$ var divisor; - if_ ((var tdiv >$ int ubound) lor (var tdiv <$ int lbound)) [ - Cpu_exceptions.divide_by_zero; - ] (* else *) - apply_result; - ]; - ] @ undefine [cf; oF; sf; zf; af; pf] - | Cld -> - [Bil.Move (df, exp_false)] - | Leave t when List.is_empty pref -> (* #UD if Lock prefix is used *) - Bil.Move (rsp, rbp_e) - ::to_ir mode addr next ss pref has_rex has_vex (Pop(t, o_rbp)) - | Interrupt3 -> [Bil.CpuExn 3] - | Interrupt(Oimm i) -> [ - match Addr.to_int i with - | Ok i -> Bil.cpuexn i - | Error _ -> - let dst = asprintf "interrupt@%s" (Addr.string_of_value i) in - Bil.(encode call dst) - ] - | Sysenter | Syscall -> [ - Bil.(encode call "syscall") - ] + | Sysenter | Syscall -> [ Bil.(encode call "syscall") ] (* Match everything exhaustively *) - | Leave _ -> unimplemented "to_ir: Leave" - | Lea _ -> unimplemented "to_ir: Lea" - | Movs _ -> unimplemented "to_ir: Movs" - | Cmps _ -> unimplemented "to_ir: Cmps" - | Scas _ -> unimplemented "to_ir: Scas" - | Stos _ -> unimplemented "to_ir: Stos" - | Retn _ -> unimplemented "to_ir: Retn" - | Interrupt _ -> unimplemented "to_ir: Interrupt" - -end (* ToIR *) + | Leave _ -> unimplemented "to_ir: Leave" + | Lea _ -> unimplemented "to_ir: Lea" + | Movs _ -> unimplemented "to_ir: Movs" + | Cmps _ -> unimplemented "to_ir: Cmps" + | Scas _ -> unimplemented "to_ir: Scas" + | Stos _ -> unimplemented "to_ir: Stos" + | Retn _ -> unimplemented "to_ir: Retn" + | Interrupt _ -> unimplemented "to_ir: Interrupt" +end +(* ToIR *) let disasm_instr mode mem addr = let module D = X86_disasm in - let (pref, prefix, op, na) = D.parse_instr mode mem addr in + let pref, prefix, op, na = D.parse_instr mode mem addr in let has_rex = Option.is_some prefix.rex in let has_vex = Option.is_some prefix.vex in - let (ss, pref) = D.parse_prefixes mode pref op in + let ss, pref = D.parse_prefixes mode pref op in ToIR.to_ir mode addr na ss pref has_rex has_vex op let insn arch mem insn = @@ -1693,25 +1940,28 @@ let insn arch mem insn = let addr = Memory.min_addr mem in match disasm_instr mode mem addr with | exception No_semantics -> Ok [] - | exception Arch_exception (_,msg) -> - Or_error.errorf "invalid instruction: %s" msg + | exception Arch_exception (_, msg) -> + Or_error.errorf "invalid instruction: %s" msg | exception exn -> - Or_error.errorf "internal error in the legacy lifter: %s@\n%s@\n" - (Exn.to_string exn) - (Printexc.get_backtrace ()) - | bil -> match Type.check bil with - | Ok () -> Ok bil - | Error err -> - warning "BIL is not well-typed in the legacy lifter at %a - %a" - pp_insn (mem,insn) Type.Error.pp err; - Error (Error.of_string "type error") + Or_error.errorf "internal error in the legacy lifter: %s@\n%s@\n" + (Exn.to_string exn) + (Printexc.get_backtrace ()) + | bil -> ( + match Type.check bil with + | Ok () -> Ok bil + | Error err -> + warning "BIL is not well-typed in the legacy lifter at %a - %a" + pp_insn (mem, insn) Type.Error.pp err; + Error (Error.of_string "type error")) module AMD64 = struct module CPU = X86_cpu.AMD64 + let lift mem i = insn `x86_64 mem i end module IA32 = struct module CPU = X86_cpu.IA32 + let lift mem i = insn `x86 mem i end diff --git a/plugins/x86/x86_main.ml b/plugins/x86/x86_main.ml index 28cbc76ff..08c190398 100644 --- a/plugins/x86/x86_main.ml +++ b/plugins/x86/x86_main.ml @@ -1,95 +1,115 @@ -open Core_kernel[@@warning "-D"] +open Core_kernel [@@warning "-D"] open Bap_core_theory open Poly open Bap.Std open X86_targets -include Self() +open X86_sym_imm_targets +include Self () -type kind = Legacy | Modern | Merge [@@deriving equal] +type kind = Legacy | Modern | Merge | SymImm [@@deriving equal] let main backend kind abi = let abi = Option.map ~f:(Theory.Abi.read ~package:"bap") abi in X86_target.load ?abi ?backend (); let kind = if backend = Some "ghidra" then Modern else kind in - let ia32, amd64 = match kind with - | Legacy -> (module IA32L : Target), (module AMD64L : Target) - | Modern -> (module IA32 : Target), (module AMD64 : Target) - | Merge -> (module IA32M : Target), (module AMD64M : Target) in + let ia32, amd64 = + match kind with + | Legacy -> ((module IA32L : Target), (module AMD64L : Target)) + | Modern -> ((module IA32 : Target), (module AMD64 : Target)) + | Merge -> ((module IA32M : Target), (module AMD64M : Target)) + | SymImm -> ((module IA32SI_M : Target), (module AMD64SI_M : Target)) + in register_target `x86 ia32; register_target `x86_64 amd64 let () = - let () = Config.manpage [ - `S "SYNOPSIS"; - `P "$(b,bap) FILE [--x86-abi=ABI]"; - `P "$(b,bap) FILE [--x86-64-abi=ABI]"; - `S "DESCRIPTION"; - `P "Provides lifter and implements a set of ABI for x86 and - x86-64 architectures. No parameters are usually required. Once the - plugin is installed it will automatically provide it - services. However it is possible to override default abi, e.g., - when working with an executable compiled for MS Windows - platform. For a full set of supported ABI use corresponding list - option."; - `S "EXAMPLE"; - `P "To choose a correct ABI for a binary compiled for MS Windows - x64 target, use the following:"; - `P "$(b,bap) FILE --x86-64=ms"; - `S "SEE ALSO"; - `P "$(b,bap-x86-cpu)(3), $(b,bap-plugin-abi)(1), $(b,bap-plugin-arm)(1)" - ] in + let () = + Config.manpage + [ + `S "SYNOPSIS"; + `P "$(b,bap) FILE [--x86-abi=ABI]"; + `P "$(b,bap) FILE [--x86-64-abi=ABI]"; + `S "DESCRIPTION"; + `P + "Provides lifter and implements a set of ABI for x86 and\n\ + \ x86-64 architectures. No parameters are usually required. Once \ + the\n\ + \ plugin is installed it will automatically provide it\n\ + \ services. However it is possible to override default abi, e.g.,\n\ + \ when working with an executable compiled for MS Windows\n\ + \ platform. For a full set of supported ABI use corresponding list\n\ + \ option."; + `S "EXAMPLE"; + `P + "To choose a correct ABI for a binary compiled for MS Windows\n\ + \ x64 target, use the following:"; + `P "$(b,bap) FILE --x86-64=ms"; + `S "SEE ALSO"; + `P "$(b,bap-x86-cpu)(3), $(b,bap-plugin-abi)(1), $(b,bap-plugin-arm)(1)"; + ] + in let abi = let doc = "Override the ABI detection and use the selected ABI." in - Config.(param (some string) "abi" ~synonyms:["64-abi"] ~doc) in - let fp_lifter = Config.flag "with-floating-points" - ~doc:"DEPRECATED" in - let legacy_lifter = Config.flag "with-legacy-floating-points" - ~doc:"Enables the legacy floating-point lifter and \ - disables the intrinsic semantics of floating-point \ - operations" in + Config.(param (some string) "abi" ~synonyms:[ "64-abi" ] ~doc) + in + let fp_lifter = Config.flag "with-floating-points" ~doc:"DEPRECATED" in + let legacy_lifter = + Config.flag "with-legacy-floating-points" + ~doc: + "Enables the legacy floating-point lifter and disables the intrinsic \ + semantics of floating-point operations" + in let disable_intrinsics = Config.flag "disable-floating-point-intrinsics" - ~doc:"Disables translation of floating-point instructions \ - into calls to intrinsic functions." in - let backend = Config.param Config.(some string) "backend" - ~synonyms:["64-backend"] in + ~doc: + "Disables translation of floating-point instructions into calls to \ + intrinsic functions." + in + let backend = + Config.param Config.(some string) "backend" ~synonyms:[ "64-backend" ] + in let kind = - let kinds = ["legacy", Legacy; - "modern", Modern; - "merge", Merge] in + let kinds = + [ + ("legacy", Legacy); + ("modern", Modern); + ("merge", Merge); + ("sym-imm", SymImm); + ] + in let default = Merge in let doc = - sprintf "Debug purpose only. The $(docv) must be %s. Default: $(docv) = %s." + sprintf + "Debug purpose only. The $(docv) must be %s. Default: $(docv) = %s." (Config.doc_enum kinds) - (List.find_map_exn kinds - ~f:(fun (name, kind) -> - Option.some_if (equal_kind kind default) name)) in - Config.(param (enum kinds) "lifter" ~doc ~default) in - Config.declare_extension - ~doc:"provides x86/x86-64 semantics" - ~provides:["disassembler"; "lifter"; "semantics"; "x86"; "abi"] - @@ fun {Config.get=(!!)} -> + (List.find_map_exn kinds ~f:(fun (name, kind) -> + Option.some_if (equal_kind kind default) name)) + in + Config.(param (enum kinds) "lifter" ~doc ~default) + in + Config.declare_extension ~doc:"provides x86/x86-64 semantics" + ~provides:[ "disassembler"; "lifter"; "semantics"; "x86"; "abi" ] + @@ fun { Config.get = ( !! ) } -> let open Bap_core_theory in let open Bap_primus.Std in - main !!backend !!kind !!abi; if !!fp_lifter || !!legacy_lifter then begin let open Bap_core_theory in let open Bap_primus.Std in - if !!fp_lifter then Format.eprintf - "The --with-floating-points flag is deprecated \ - and will be removed in the following versions of bap. \ - This flag enables the legacy lifter that is incomplete \ - and disables the new version that translates \ - floating-point operations into the intrinsic calls. \ - If you still need the legacy lifter use the \ - --x86-with-legacy-floating-points option instead.@\n%!"; + if !!fp_lifter then + Format.eprintf + "The --with-floating-points flag is deprecated and will be removed in \ + the following versions of bap. This flag enables the legacy lifter \ + that is incomplete and disables the new version that translates \ + floating-point operations into the intrinsic calls. If you still need \ + the legacy lifter use the --x86-with-legacy-floating-points option \ + instead.@\n\ + %!"; X86_legacy_bil_lifter.init (); - X86_legacy_bil_semantics.init (); - end else if not !!disable_intrinsics - then + X86_legacy_bil_semantics.init () + end + else if not !!disable_intrinsics then KB.promise Primus.Lisp.Semantics.context @@ fun _ -> - KB.return @@ - Primus.Lisp.Context.create [ - "x86-floating-points", ["intrinsic-semantics"] - ] + KB.return + @@ Primus.Lisp.Context.create + [ ("x86-floating-points", [ "intrinsic-semantics" ]) ] diff --git a/plugins/x86/x86_sym_imm_lifter.ml b/plugins/x86/x86_sym_imm_lifter.ml new file mode 100644 index 000000000..695a480c3 --- /dev/null +++ b/plugins/x86/x86_sym_imm_lifter.ml @@ -0,0 +1,1967 @@ +(** Native lifter of x86 instructions to the BAP IL *) + +open Core_kernel [@@warning "-D"] +open Bap.Std +open Format +open Bil.Types +open X86_types +open X86_utils +open X86_env +include Self () + +module ToIR = struct + let cf_e = Bil.var cf + let pf_e = Bil.var pf + let af_e = Bil.var af + let zf_e = Bil.var zf + let sf_e = Bil.var sf + let of_e = Bil.var oF + let df_e = Bil.var df + + (** doubts here *) + let size_of_typ s = Size.of_int_exn !!s + + let undefine = + List.map ~f:(fun r -> Bil.(r := unknown "#undefined" (Var.typ r))) + + (* stmt helpers *) + + let store_s mode s t a e = + let mem = match mode with X86 -> R32.mem | X8664 -> R64.mem in + let sz = size_of_typ t in + match s with + | None -> Bil.Move (mem, Bil.(Store (Var mem, a, e, LittleEndian, sz))) + | Some v -> + Bil.Move (mem, Bil.(Store (Var mem, Var v + a, e, LittleEndian, sz))) + + (* copypasted from op2e_s below, but keeps the opcode width *) + let op2e_s_keep_width mode ss has_rex t operand = + let ( = ) = Type.equal in + match operand with + | Ovec r when t = reg256_t -> (bits2ymme mode r, t) + | Ovec r when t = reg128_t -> (bits2ymm128e mode r, t) + | Ovec r when t = reg64_t -> (bits2ymm64e mode r, t) + | Ovec r when t = reg32_t -> (bits2ymm32e mode r, t) + | Ovec _ -> + let i = match t with Type.Imm n -> ": " ^ string_of_int n | _ -> "" in + disfailwith mode ("invalid SIMD register size for op2e" ^ i) + | Oreg r when t = reg64_t -> (bits2reg64e mode r, t) + | Oreg r when t = reg32_t -> (bits2reg32e mode r, t) + | Oreg r when t = reg16_t -> (bits2reg16e mode r, t) + | Oreg r when t = reg8_t -> (bits2reg8e mode ~has_rex r, t) + | Oreg _ -> unimplemented mode "unknown register" + | Oseg r when t = reg64_t -> + Bil.(Cast (UNSIGNED, !!reg64_t, bits2segrege r), t) + (* There is no 32-bit extension of segment selectors; this is not a bug *) + | Oseg r when t = reg16_t -> (bits2segrege r, t) + | Oseg _ -> (disfailwith mode "Segment register when t is not r16", t) + | Oaddr e -> (load_s mode ss (size_of_typ t) e, t) + | Oimm i -> Bil.(Var (Var.create ~is_virtual:true "IMM" t), t) + + let op2e_s mode ss has_rex t operand = + let ( = ) = Type.equal in + match operand with + | Ovec r when t = reg256_t -> bits2ymme mode r + | Ovec r when t = reg128_t -> bits2ymm128e mode r + | Ovec r when t = reg64_t -> bits2ymm64e mode r + | Ovec r when t = reg32_t -> bits2ymm32e mode r + | Ovec _ -> + let i = match t with Type.Imm n -> ": " ^ string_of_int n | _ -> "" in + disfailwith mode ("invalid SIMD register size for op2e" ^ i) + | Oreg r when t = reg64_t -> bits2reg64e mode r + | Oreg r when t = reg32_t -> bits2reg32e mode r + | Oreg r when t = reg16_t -> bits2reg16e mode r + | Oreg r when t = reg8_t -> bits2reg8e mode ~has_rex r + | Oreg _ -> unimplemented mode "unknown register" + | Oseg r when t = reg64_t -> + Bil.(Cast (UNSIGNED, !!reg64_t, bits2segrege r)) + (* There is no 32-bit extension of segment selectors; this is not a bug *) + | Oseg r when t = reg16_t -> bits2segrege r + | Oseg _ -> disfailwith mode "Segment register when t is not r16" + | Oaddr e -> load_s mode ss (size_of_typ t) e + | Oimm i -> Bil.(Var (Var.create ~is_virtual:true "IMM" t)) + + let assn_s mode s has_rex has_vex t v e = + (* Assign to some bits of v, starting at bit off, while preserving the other bits *) + let sub_assn ?(off = 0) t v e = + let concat_exps = ref [] in + let bits = !!(Var.typ v) in + let assnbits = !!t in + + (* Add the upper preserved bits, if any *) + let ubh = bits - 1 and ubl = assnbits + off in + if ubh > ubl then + concat_exps := Bil.(Extract (ubh, ubl, Var v)) :: !concat_exps; + + (* Add e *) + concat_exps := e :: !concat_exps; + + (* Add the lower preserved bits, if any *) + let lbh = off - 1 and lbl = 0 in + if lbh > lbl then + concat_exps := Bil.(Extract (lbh, lbl, Var v)) :: !concat_exps; + + let final_e = + List.reduce_exn ~f:(fun big_e e -> Bil.Concat (e, big_e)) !concat_exps + in + Bil.Move (v, final_e) + in + let is8664 = [%compare.equal: mode] mode X8664 in + match (v, t) with + (* Zero-extend 128-bit assignments to 256-bit ymms. *) + | Ovec r, Type.Imm (128 | 64 | 32) when has_vex -> + let v = bits2ymm mode r in + sub_assn reg256_t v Bil.(Cast (UNSIGNED, !!reg256_t, e)) + | Ovec r, Type.Imm (256 | 128 | 64 | 32) -> + let v = bits2ymm mode r in + sub_assn t v e + | Ovec _, _ -> disfailwith mode "invalid SIMD register size for assignment" + (* Zero-extend 32-bit assignments to 64-bit registers. *) + | Oreg r, Type.Imm 32 when is8664 -> + let v = bits2genreg mode r in + sub_assn reg64_t v Bil.(Cast (UNSIGNED, !!reg64_t, e)) + | Oreg r, Type.Imm (64 | 32 | 16) -> + let v = bits2genreg mode r in + sub_assn t v e + | Oreg r, Type.Imm 8 + when r < 4 || ([%compare.equal: mode] mode X8664 && has_rex) -> + let v = bits2genreg mode r in + sub_assn t v e + | Oreg r, Type.Imm 8 -> + let v = bits2genreg mode (r land 3) in + sub_assn ~off:8 t v e + | Oreg _, _ -> unimplemented mode "assignment to sub registers" + | Oseg r, _ when Type.equal t reg16_t -> + let v = bits2segreg r in + Bil.Move (v, e) + | Oseg _, _ -> + disfailwith mode "Can't assign to non 16 bit segment register" + | Oaddr a, _ -> store_s mode s t a e + | Oimm _, _ -> + disfailwith mode "disasm x86: Can't assign to an immediate value" + + (* Double width operands, as used by multiplication and division *) + let op_dbl t = + let open Type in + match t with + | Imm 8 -> [ (reg16_t, o_rax) ] + | Imm 16 -> [ (reg16_t, o_rdx); (reg16_t, o_rax) ] + | Imm 32 -> [ (reg32_t, o_rdx); (reg32_t, o_rax) ] + | Imm 64 -> [ (reg64_t, o_rdx); (reg64_t, o_rax) ] + | _ -> disfailwith X86 "op_dbl only defined for Reg 8, 16, 32, and 64" + + (* Return an expression for a double-width operand, as used by the div + instruction. *) + let op2e_dbl_s mode ss has_rex t = + let cf (ct, o) = op2e_s mode ss has_rex ct o in + let ol = List.map ~f:cf (op_dbl t) in + List.reduce_exn ~f:(fun bige little -> Bil.(bige ^ little)) ol + + (* Double width assignments, as used by multiplication *) + let assn_dbl_s mode s has_rex has_vex t e = + match op_dbl t with + | (t, o) :: [] -> + ([ assn_s mode s has_rex has_vex t o e ], op2e_s mode s has_rex t o) + | l -> + let tmp = tmp (Type.Imm (!!t * 2)) in + let f (stmts, off) (ct, o) = + let newoff = off + !!ct in + ( assn_s mode s has_rex has_vex ct o + (Bil.Extract (newoff - 1, off, Bil.Var tmp)) + :: stmts, + newoff ) + in + ( List.rev + (fst + (List.fold_left ~f ~init:([ Bil.Move (tmp, e) ], 0) (List.rev l))), + Bil.Var tmp ) + + (* A function for computing the target of jumps. *) + let compute_jump_target mode s has_rex = + let t = type_of_mode mode in + function + | Jabs o -> op2e_s mode s has_rex t o + | Jrel (na, offset) -> + (*let i,t = Arithmetic.binop PLUS (na,t) (offset,t) in*) + Bil.(Int na + Int offset) + + let jump_target = compute_jump_target + + let string_incr mode t v = + let i n = Bil.Int (int_of_mode mode n) in + if Type.equal t reg8_t then + Bil.Move (v, Bil.(Var v + df_to_offset mode df_e)) + else + Bil.Move (v, Bil.(Var v + (df_to_offset mode df_e * i (bytes_of_width t)))) + + let rep_wrap ?check_zf ~mode ~addr:_ ~next:_ stmts = + let extend = big_int_of_mode mode in + let zero = extend Word.b0 and one = extend Word.b1 in + let rcx = match mode with X86 -> R32.rcx | X8664 -> R64.rcx in + let flag = tmp bool_t in + let cond = Bil.((var rcx <> int zero) land var flag) in + let head = Bil.(flag := int Word.b1) in + let tail = + Bil.(rcx := var rcx - int one) + :: + (match check_zf with + | None -> [] + | Some x when x = repz -> Bil.[ flag := zf_e ] + | Some x when x = repnz -> Bil.[ flag := lnot zf_e ] + | _ -> failwith "invalid value for ?check_zf") + in + Bil.[ head; while_ cond (stmts @ tail) ] + + let compute_sf result = Bil.(Cast (HIGH, !!bool_t, result)) + + let compute_zf t result = + let bi0 = BV.of_int ~width:t 0 in + Bil.(Int bi0 = result) + + let compute_pf t r = + let acc = tmp t in + let var_acc = Bil.Var acc in + let t' = !!t in + (* extra parens do not change semantics but do make it pretty + print nicer *) + let open Bil in + exp_not + (Cast + ( LOW, + !!bool_t, + Let + ( acc, + (r lsr int_exp 4 t') lxor r, + Let + ( acc, + (var_acc lsr int_exp 2 t') lxor var_acc, + (var_acc lsr int_exp 1 t') lxor var_acc ) ) )) + + let set_sf r = Bil.Move (sf, compute_sf r) + let set_zf t r = Bil.Move (zf, compute_zf t r) + let set_pf t r = Bil.Move (pf, compute_pf t r) + + let set_pszf t r = + let t' = !!t in + [ set_pf t r; set_sf r; set_zf t' r ] + + (* Adjust flag + + AF is set when there is a carry to or borrow from bit 4 (starting + at 0), when considering unsigned operands. Let X_i denote bit i of + value X. Note that in addition, r_4 = c + [(op1_4 + op2_4) mod 2], + where c is the carry bit from the lower four bits. Since AF = c, + and we want to know the value of AF, we can rewrite as AF = c = r_4 + - [(op1_4 + op2_4) mod 2]. Noting that addition and subtraction mod + 2 is just xor, we can simplify to AF = r_4 xor op1_4 xor op2_4. + *) + + let set_apszf t s1 s2 r = + let bit4 = int_exp (1 lsl 4) t in + let t = Type.Imm t in + Bil.Move (af, Bil.(bit4 = bit4 land (r lxor s1 lxor s2))) :: set_pszf t r + + (* Helper functions to set flags for adding *) + let set_aopszf_add t s1 s2 r = + (* Move (oF, Bop.(Cast (CAST_HIGH, r1, (s1 = s2) land (s1 lxor r)))) *) + let s1_high = Bil.(Cast (HIGH, !!bool_t, s1)) in + let s2_high = Bil.(Cast (HIGH, !!bool_t, s2)) in + let r_high = Bil.(Cast (HIGH, !!bool_t, r)) in + Bil.Move (oF, Bil.((s1_high = s2_high) land (s1_high lxor r_high))) + :: set_apszf t s1 s2 r + + let set_flags_add t s1 s2 r = + Bil.Move (cf, Bil.(r < s1)) :: set_aopszf_add t s1 s2 r + + (* Helper functions to set flags for subtracting *) + let set_apszf_sub t s1 s2 r = set_apszf t s1 s2 r + + let set_aopszf_sub t s1 s2 r = + Bil.Move (oF, Bil.(Cast (HIGH, !!bool_t, s1 lxor s2 land (s1 lxor r)))) + :: set_apszf_sub t s1 s2 r + + let set_flags_sub t s1 s2 r = + Bil.Move (cf, Bil.(s2 > s1)) :: set_aopszf_sub t s1 s2 r + + let popcount x ~one ~two ~four ~sh ~m1 ~m2 ~m4 ~h01 = + Bil. + [ + x := var x - ((var x lsr int one) land int m1); + x := (var x land int m2) + ((var x lsr int two) land int m2); + x := (var x + (var x lsr int four)) land int m4; + x := (var x * int h01) lsr int sh; + ] + + let popcnt16 x = + let one = Word.one 16 in + let two = Word.succ one in + let four = Word.of_int ~width:16 4 in + let sh = Word.of_int ~width:16 8 in + let m1 = Word.of_int ~width:16 0x5555 in + let m2 = Word.of_int ~width:16 0x3333 in + let m4 = Word.of_int ~width:16 0x0f0f in + let h01 = Word.of_int ~width:16 0x0101 in + popcount x ~one ~two ~four ~sh ~m1 ~m2 ~m4 ~h01 + + let popcnt32 x = + let one = Word.one 32 in + let two = Word.succ one in + let four = Word.of_int ~width:32 4 in + let sh = Word.of_int ~width:32 24 in + let m1 = Word.of_int ~width:32 0x55555555 in + let m2 = Word.of_int ~width:32 0x33333333 in + let m4 = Word.of_int ~width:32 0x0f0f0f0f in + let h01 = Word.of_int ~width:32 0x01010101 in + popcount x ~one ~two ~four ~sh ~m1 ~m2 ~m4 ~h01 + + let popcnt64 x = + let one = Word.one 64 in + let two = Word.succ one in + let four = Word.of_int ~width:64 4 in + let sh = Word.of_int ~width:64 56 in + let m1 = Word.of_int64 ~width:64 0x5555555555555555L in + let m2 = Word.of_int64 ~width:64 0x3333333333333333L in + let m4 = Word.of_int64 ~width:64 0x0f0f0f0f0f0f0f0fL in + let h01 = Word.of_int64 ~width:64 0x0101010101010101L in + popcount x ~one ~two ~four ~sh ~m1 ~m2 ~m4 ~h01 + + let clz16 x = + Bil. + [ + x := var x lor (var x lsr int Word.(one 16)); + x := var x lor (var x lsr int Word.(of_int 2 ~width:16)); + x := var x lor (var x lsr int Word.(of_int 4 ~width:16)); + x := var x lor (var x lsr int Word.(of_int 8 ~width:16)); + x := lnot (var x); + ] + @ popcnt16 x + + let clz32 x = + Bil. + [ + x := var x lor (var x lsr int Word.(one 32)); + x := var x lor (var x lsr int Word.(of_int 2 ~width:32)); + x := var x lor (var x lsr int Word.(of_int 4 ~width:32)); + x := var x lor (var x lsr int Word.(of_int 8 ~width:32)); + x := var x lor (var x lsr int Word.(of_int 16 ~width:32)); + x := lnot (var x); + ] + @ popcnt32 x + + let clz64 x = + Bil. + [ + x := var x lor (var x lsr int Word.(one 64)); + x := var x lor (var x lsr int Word.(of_int 2 ~width:64)); + x := var x lor (var x lsr int Word.(of_int 4 ~width:64)); + x := var x lor (var x lsr int Word.(of_int 8 ~width:64)); + x := var x lor (var x lsr int Word.(of_int 16 ~width:64)); + x := var x lor (var x lsr int Word.(of_int 32 ~width:64)); + x := lnot (var x); + ] + @ popcnt64 x + + let ctz16 x = + Bil.(x := (var x land unop NEG (var x)) - int Word.(one 16)) :: popcnt16 x + + let ctz32 x = + Bil.(x := (var x land unop NEG (var x)) - int Word.(one 32)) :: popcnt32 x + + let ctz64 x = + Bil.(x := (var x land unop NEG (var x)) - int Word.(one 64)) :: popcnt64 x + + let bitscan_flags is_zero_count = + let l = + Bil. + [ + oF := unknown "bits" bool_t; + sf := unknown "bits" bool_t; + af := unknown "bits" bool_t; + pf := unknown "bits" bool_t; + ] + in + if is_zero_count then l else Bil.(cf := unknown "bits" bool_t) :: l + + let rec to_ir mode addr next ss pref has_rex has_vex = + let module R = (val vars_of_mode mode) in + let open R in + let load = load_s mode ss in + (* Need to change this if we want seg_ds <> None *) + let op2e = op2e_s mode ss has_rex in + let op2e_keep_width = op2e_s_keep_width mode ss has_rex in + let op2e_dbl = op2e_dbl_s mode ss has_rex in + let store = store_s mode ss in + let assn = assn_s mode ss has_rex has_vex in + let assn_dbl = assn_dbl_s mode ss has_rex has_vex in + let mi = int_of_mode mode in + let mt = type_of_mode mode in + let rbp_e = Bil.var rbp in + let rsp_e = Bil.var rsp in + let rsi_e = Bil.var rsi in + let rdi_e = Bil.var rdi in + let rax_e = Bil.var rax in + let rdx_e = Bil.var rdx in + let ah_e = ah_e mode in + let disfailwith = disfailwith mode in + let unimplemented = unimplemented mode in + let is_small_imm op t = + match op with + | Oimm imm -> Word.bitwidth imm < bitwidth_of_type t + | _ -> false + in + let sign_extend_imm op t = + let op_typ = + match op with + | Oimm imm -> Type.imm (Word.bitwidth imm) + | _ -> disfailwith "imm operand expected" + in + Bil.(cast signed (bitwidth_of_type t) (op2e op_typ op)) + in + let is_repz = function [ x ] -> x = repz | _ -> false in + let is_repnz = function [ x ] -> x = repnz | _ -> false in + function + | Nop -> [] + | Bswap (t, op) -> + let e = + match t with + | Type.Imm 32 | Type.Imm 64 -> + let op', t' = op2e_keep_width t op in + reverse_bytes op' t' + | _ -> disfailwith "bswap: Expected 32 or 64 bit type" + in + [ assn t op e ] + | Retn (op, far_ret) + when List.is_empty pref || is_repz pref || is_repnz pref -> + let temp = tmp mt in + let load_stmt = + if far_ret then (* TODO Mess with segment selectors here *) + unimplemented "long retn not supported" + else Bil.Move (temp, load_s mode seg_ss (size_of_typ mt) rsp_e) + in + let rsp_stmts = + Bil.Move (rsp, Bil.(rsp_e + Int (mi (bytes_of_width mt)))) + :: + (match op with + | None -> [] + | Some (t, src) -> [ Bil.Move (rsp, Bil.(rsp_e + op2e t src)) ]) + in + (load_stmt :: rsp_stmts) @ [ Bil.Jmp (Bil.Var temp) ] + | Mov (t, dst, src, condition) -> + let c_src = + match condition with + | None -> op2e t src + | Some c -> Bil.Ite (c, op2e t src, op2e t dst) + in + (* Find base by looking at LDT or GDT *) + let base_e e = + (* 0 = GDT, 1 = LDT *) + let ti = Bil.Extract (3, 3, e) in + let base = Bil.Ite (ti, Bil.var ldt, Bil.var gdt) in + (* Extract index into table *) + let entry_size, entry_shift = + match mode with + | X86 -> (reg64_t, 6 (* "1<<6 = 64" *)) + | X8664 -> (reg128_t, 7 (* "1<<7 = 128" *)) + in + let index = + Bil.( + Cast (UNSIGNED, !!mt, Extract (15, 4, e) lsl Int (mi entry_shift))) + in + (* Load the table entry *) + let table_entry = + load_s mode None (size_of_typ entry_size) Bil.(base + index) + in + (* Extract the base *) + concat_explist + ((match mode with + | X86 -> [] + | X8664 -> Bil.Extract (95, 64, table_entry) :: []) + @ [ + Bil.Extract (63, 56, table_entry); + Bil.Extract (39, 32, table_entry); + Bil.Extract (31, 16, table_entry); + ]) + in + let bs = + let dst_e = op2e t dst in + if [%compare.equal: operand] dst o_fs && !compute_segment_bases then + [ Bil.Move (fs_base, base_e dst_e) ] + else if [%compare.equal: operand] dst o_gs && !compute_segment_bases + then [ Bil.Move (gs_base, base_e dst_e) ] + else [] + in + assn t dst c_src :: bs + | Movs (Type.Imm _bits as t) -> + let stmts = + [ + store_s mode seg_es t rdi_e + (load_s mode seg_es (size_of_typ t) rsi_e); + string_incr mode t rsi; + string_incr mode t rdi; + ] + in + if List.is_empty pref then stmts + else if ints_mem pref repz || ints_mem pref repnz then + (* movs has only rep instruction others just considered to be rep *) + rep_wrap ~mode ~addr ~next stmts + else unimplemented "unsupported prefix for movs" + | Movzx (t, dst, ts, src) -> + [ assn t dst Bil.(Cast (UNSIGNED, !!t, op2e ts src)) ] + | Movsx (t, dst, ts, src) -> + [ assn t dst Bil.(Cast (SIGNED, !!t, op2e ts src)) ] + | Movdq (ts, s, td, d, align) -> + let s, al = + match s with + | Ovec _ | Oreg _ -> (op2e ts s, []) + | Oaddr a -> (op2e ts s, [ a ]) + | Oimm _ | Oseg _ -> disfailwith "invalid source operand for movdq" + in + let d, al = + match d with + (* Behavior is to clear the xmm bits *) + | Ovec _ -> (assn td d Bil.(Cast (UNSIGNED, !!td, s)), al) + | Oreg _ -> (assn td d s, al) + | Oaddr a -> (assn td d s, a :: al) + | Oimm _ | Oseg _ -> disfailwith "invalid dest operand for movdq" + in + (* sources tell me that movdqa raises a general protection exception + * if its operands aren't aligned on a 16-byte boundary *) + let im i = Bil.Int (int_of_mode mode i) in + let al = + if align then + List.map + ~f:(fun a -> + Bil.If + ( Bil.(a land im 15 = im 0), + [], + [ Cpu_exceptions.general_protection ] )) + al + else [] + in + d :: al + | Movoffset ((tdst, dst), offsets) -> + (* If a vex prefix is present, then extra space is filled with 0. + Otherwise, the bits are preserved. *) + let padding hi lo = + if hi < lo then [] + else if has_vex then [ int_exp 0 (hi - lo + 1) ] + else [ Bil.Extract (hi, lo, op2e tdst dst) ] + in + let offsets = + List.sort + ~compare:(fun { offdstoffset = o1; _ } { offdstoffset = o2; _ } -> + Int.compare o1 o2) + offsets + in + let add_exp (elist, nextbit) + { offlen; offtyp; offop; offsrcoffset; offdstoffset } = + ( Bil.Extract + (!!offlen + offsrcoffset - 1, offsrcoffset, op2e offtyp offop) + :: padding (offdstoffset - 1) nextbit + @ elist, + offdstoffset + !!offlen ) + in + let elist, nextbit = List.fold_left ~f:add_exp ~init:([], 0) offsets in + let elist = padding (!!tdst - 1) nextbit @ elist in + [ assn tdst dst (concat_explist elist) ] + | Punpck (t, et, o, d, s, vs) -> + let nelem = + match (t, et) with + | Type.Imm n, Type.Imm n' -> n / n' + | _ -> disfailwith "invalid" + in + assert (nelem mod 2 = 0); + let nelem_per_src = nelem / 2 in + let halft = Type.Imm (!!t / 2) in + let castf = + match o with + | High -> fun e -> Bil.(Cast (HIGH, !!halft, e)) + | Low -> fun e -> Bil.(Cast (LOW, !!halft, e)) + in + let se, de = (castf (op2e t s), castf (op2e t d)) in + let st, dt = (tmp halft, tmp halft) in + let et' = !!et in + let mape i = + [ + extract_element et' (Bil.Var st) i; + extract_element et' (Bil.Var dt) i; + ] + in + let e = + concat_explist + (List.concat + (List.map ~f:mape + (List.range ~stride:(-1) ~stop:`inclusive (nelem_per_src - 1) + 0))) + in + let dest = match vs with None -> d | Some vdst -> vdst in + [ Bil.Move (st, se); Bil.Move (dt, de); assn t dest e ] + | Ppackedbinop (t, et, fbop, _, d, s, vs) -> + let t_width = bitwidth_of_type t in + let e_width = bitwidth_of_type et in + let nops = t_width / e_width in + let byte = 8 in + let tmp_dst = tmp t in + let vdst = Option.value ~default:d vs in + let iv = tmp (Type.imm byte) in + let elt = tmp et in + let zero = Word.zero t_width in + let bits = Word.of_int ~width:byte e_width in + + let foreach_size f = List.concat @@ List.init nops ~f in + let getelement o i = + (* assumption: immediate operands are repeated for all vector + elements *) + match o with + | Oimm _ -> op2e et o + | _ -> extract_element !!et (op2e t o) i + in + + List.concat + Bil. + [ + [ tmp_dst := int zero ]; + foreach_size (fun i -> + [ + elt := fbop (getelement d i) (getelement s i); + iv := int @@ Word.of_int ~width:byte i; + tmp_dst := + var tmp_dst + lor cast unsigned t_width (var elt) + lsl (var iv * int bits); + ]); + [ assn t vdst (var tmp_dst) ]; + ] + | Pbinop (t, fbop, _s, o1, o2, vop) -> ( + match vop with + | None -> [ assn t o1 (fbop (op2e t o1) (op2e t o2)) ] + | Some vop -> [ assn t o1 (fbop (op2e t vop) (op2e t o2)) ]) + | Pcmp (t, elet, bop, _, dst, src, vsrc) -> + let elebits = bitwidth_of_type elet in + let t_width = bitwidth_of_type t in + let ncmps = t_width / elebits in + let src = + match src with + | Ovec _ -> op2e t src + | Oaddr a -> load (size_of_typ t) a + | Oreg _ | Oimm _ | Oseg _ -> disfailwith "invalid" + in + let vsrc = Option.value ~default:dst vsrc in + let byte = 8 in + let tmp_dst = tmp t in + let iv = tmp (Type.imm byte) in + let elt = tmp elet in + let elt_1 = tmp elet in + let elt_2 = tmp elet in + let _one = Word.of_int ~width:elebits (-1) in + let zero = Word.zero elebits in + let bits = Word.of_int ~width:byte elebits in + let zero_long = Word.zero t_width in + let foreach_size f = + let sizes = + List.init ncmps ~f:(fun i -> + let left_bit = i * elebits in + let right_bit = ((i + 1) * elebits) - 1 in + let i = Word.of_int ~width:byte i in + (i, left_bit, right_bit)) + in + List.concat @@ List.map sizes ~f + in + + List.concat + Bil. + [ + [ tmp_dst := int zero_long ]; + foreach_size (fun (i, left_bit, right_bit) -> + [ + elt_1 := extract right_bit left_bit src; + elt_2 := extract right_bit left_bit (op2e t vsrc); + iv := int i; + if_ + (binop bop (var elt_1) (var elt_2)) + [ elt := int _one ] + [ elt := int zero ]; + tmp_dst := + var tmp_dst + lor cast unsigned t_width (var elt) + lsl (var iv * int bits); + ]); + [ assn t dst (var tmp_dst) ]; + ] + | Pmov (t, dstet, srcet, dst, src, ext, _) -> + let nelem = + match (t, dstet) with + | Type.Imm n, Type.Imm n' -> n / n' + | _ -> disfailwith "invalid" + in + let getelt op i = extract_element !!srcet (op2e t op) i in + let extcast = + let open Exp in + match ext with + | UNSIGNED | SIGNED -> fun e -> Bil.Cast (ext, !!dstet, e) + | _ -> disfailwith "invalid" + in + let extend i = extcast (getelt src i) in + let e = + concat_explist + (List.map ~f:extend + (List.range ~stride:(-1) ~stop:`inclusive (nelem - 1) 0)) + in + [ assn t dst e ] + | Pmovmskb (t, dst, src) -> + let nbytes = bytes_of_width t in + let src = + match src with + | Ovec _ -> op2e t src + | _ -> disfailwith "invalid operand" + in + let get_bit i = Bil.Extract ((i * 8) - 1, (i * 8) - 1, src) in + let byte_indices = List.init ~f:(fun i -> i + 1) nbytes in + (* list 1-nbytes *) + let all_bits = List.rev (List.map ~f:get_bit byte_indices) in + (* could also be done with shifts *) + let padt = Type.Imm (32 - nbytes) in + let or_together_bits = + List.fold_left + ~f:(fun acc i -> Bil.Concat (acc, i)) + ~init:(int_exp 0 !!padt) all_bits + in + [ assn reg32_t dst or_together_bits ] + | Palignr (t, dst, src, vsrc, imm) -> ( + let dst_e, t_concat = op2e_keep_width t dst in + let src_e, t_concat' = op2e_keep_width t src in + (* previously, this code called Typecheck.infer_ast. + * We're now just preserving the widths, so here we assert + * that our 2 "preserved widths" are the same. *) + assert (!!t_concat = !!t_concat'); + let imm = op2e t imm in + let conct = Bil.(dst_e ^ src_e) in + let shift = + Bil.(conct lsr Cast (UNSIGNED, !!t_concat, imm lsl int_exp 3 !!t)) + in + let high, low = + match t with + | Type.Imm 256 -> (255, 0) + | Type.Imm 128 -> (127, 0) + | Type.Imm 64 -> (63, 0) + | _ -> + disfailwith + "impossible: used non 64/128/256-bit operand in palignr" + in + let result = Bil.Extract (high, low, shift) in + let im i = Bil.Int (int_of_mode mode i) in + let addresses = + List.fold + ~f:(fun acc -> function Oaddr a -> a :: acc | _ -> acc) + ~init:[] [ src; dst ] + in + (* Palignr seems to cause a CPU general protection exception if this fails. + * previously this code used the ast.ml Assert statement, which is gone, + * so it's been replaced with Bil's CpuExn *) + List.map + ~f:(fun addr -> + Bil.If + ( Bil.(addr land im 15 = im 0), + [], + [ Cpu_exceptions.general_protection ] )) + addresses + @ + match vsrc with + | None -> [ assn t dst result ] + | Some vdst -> [ assn t vdst result ]) + | Pcmpstr (t, xmm1, xmm2m128, _imm, imm8cb, pcmpinfo) -> + let open Pcmpstr in + let concat elt_width exps = + match exps with + | [] -> disfailwith "trying concat on empty list" + | first :: exps' -> + let len = List.length exps * elt_width in + let exp = + List.fold exps' ~init:first ~f:(fun e e' -> Bil.(e ^ e')) + in + let tmp = tmp (Type.imm len) in + (tmp, Bil.[ tmp := exp ]) + in + + (* All bytes and bits are numbered with zero being the least + significant. This includes strings! *) + (* NOTE: Strings are backwards, at least when they are in + registers. This doesn't seem to be documented in the Intel + manual. This means that the NULL byte comes before the + string. *) + let xmm1_e = op2e t xmm1 in + let xmm2m128_e = op2e t xmm2m128 in + let regm = type_of_mode mode in + + let nelem, _nbits, elemt = + match imm8cb.ssize with + | Bytes -> (16, 8, Type.imm 8) + | Words -> (8, 16, Type.imm 16) + in + + (* Get element index in e *) + let get_elem = extract_element !!elemt in + let get_xmm1 = get_elem xmm1_e in + let get_xmm2 = get_elem xmm2m128_e in + + let nelem_range = + List.range ~stride:(-1) ~stop:`inclusive (nelem - 1) 0 + in + + (* Build expressions that assigns the correct values to the + is_valid variables using implicit (NULL-based) string length. *) + let implicit_check is_valid_xmm_i get_xmm_i = + let f acc i = + let previous_valid = + if i = 0 then exp_true else Bil.var (is_valid_xmm_i (i - 1)) + in + let current_valid = Bil.(get_xmm_i i <> int_exp 0 !!elemt) in + let x = is_valid_xmm_i i in + Bil.(x := previous_valid land current_valid) :: acc + in + List.fold ~f ~init:[] nelem_range + in + + (* Build expressions that assigns the correct values to the + is_valid variables using explicit string length. *) + let explicit_check is_valid_xmm_i sizee = + (* Max size is nelem *) + let nelem_e = Word.of_int ~width:(bitwidth_of_type regm) nelem in + let sizev = tmp ~name:"sz" regm in + let init = + Bil. + [ + if_ + (int nelem_e < sizee) + [ sizev := int nelem_e ] + [ sizev := sizee ]; + ] + in + let f acc i = + (* Current element is valid *) + let current_valid = Bil.(int_exp i !!regm < var sizev) in + let x = is_valid_xmm_i i in + Bil.(x := current_valid) :: acc + in + List.fold_left ~f ~init nelem_range + in + + (* Get var name indicating whether index in xmm num is a valid + byte (before NULL byte). *) + (* XXX more hashtable code *) + let is_valid = + let vh = Hashtbl.Poly.create () ~size:(2 * nelem) in + fun xmmnum index -> + match Hashtbl.find vh (xmmnum, index) with + | Some v -> v + | None -> + let name = sprintf "is_valid_xmm%d_ele%d" xmmnum index in + let v = tmp ~name bool_t in + Hashtbl.add_exn vh ~key:(xmmnum, index) ~data:v; + v + in + + let is_valid_xmm1 index = is_valid 1 index in + let is_valid_xmm2 index = is_valid 2 index in + let is_valid_xmm1_e index = Bil.Var (is_valid_xmm1 index) in + let is_valid_xmm2_e index = Bil.Var (is_valid_xmm2 index) in + + let xmm1_checks, xmm2_checks = + match pcmpinfo.len with + | Implicit -> + ( implicit_check is_valid_xmm1 get_xmm1, + implicit_check is_valid_xmm2 get_xmm2 ) + | Explicit -> + ( explicit_check is_valid_xmm1 rax_e, + explicit_check is_valid_xmm2 rdx_e ) + in + + let get_bit index = + match imm8cb.agg with + | EqualAny -> + (* Is xmm2[index] at xmm1[j]? *) + let check_char acc j = + let is_eql = Bil.(get_xmm2 index = get_xmm1 j) in + let is_valid = is_valid_xmm1_e j in + Bil.(is_eql land is_valid lor acc) + in + (* Is xmm2[index] included in xmm1[j] for any j? *) + Bil.( + is_valid_xmm2_e index + land List.fold ~f:check_char ~init:exp_false nelem_range) + | Ranges -> + (* Is there an even j such that xmm1[j] <= xmm2[index] <= + xmm1[j+1]? *) + let check_char acc j = + (* XXX: Should this be AND? *) + let ind0 = 2 * j in + let ind1 = ind0 + 1 in + let rangevalid = + Bil.(is_valid_xmm1_e ind0 land is_valid_xmm1_e ind1) + in + let ( <= ) = + match imm8cb.ssign with + | Unsigned -> Bil.( <= ) + | Signed -> Bil.( <=$ ) + in + let ( land ) = Bil.( land ) in + let inrange = + (get_xmm1 ind0 <= get_xmm2 index) + land (get_xmm2 index <= get_xmm1 ind1) + in + Bil.(rangevalid land (inrange lor acc)) + in + Bil.( + is_valid_xmm2_e index + land List.fold_left ~f:check_char ~init:exp_false + (List.range ~stride:(-1) ~stop:`inclusive + Stdlib.((nelem / 2) - 1) + 0)) + | EqualEach -> + (* Does xmm1[index] = xmm2[index]? *) + let xmm1_invalid = Bil.(UnOp (NOT, is_valid_xmm1_e index)) in + let xmm2_invalid = Bil.(UnOp (NOT, is_valid_xmm2_e index)) in + let bothinvalid = Bil.(xmm1_invalid land xmm2_invalid) in + let eitherinvalid = Bil.(xmm1_invalid lor xmm2_invalid) in + let equal = Bil.(get_xmm1 index = get_xmm2 index) in + (* both invalid -> true + one invalid -> false + both valid -> check same byte *) + Bil.(bothinvalid lor (UnOp (NOT, eitherinvalid) land equal)) + | EqualOrdered -> + (* Does the substring xmm1 occur at xmm2[index]? *) + let check_char acc j = + let equal = Bil.(get_xmm1 j = get_xmm2 Stdlib.(index + j)) in + let substrended = Bil.(UnOp (NOT, is_valid_xmm1_e j)) in + let bigstrended = Bil.UnOp (NOT, is_valid_xmm2_e (index + j)) in + (* substrended => true + bigstrended => false + byte diff => false + byte same => keep going *) + Bil.( + substrended lor (UnOp (NOT, bigstrended) land (equal land acc))) + in + (* Is xmm1[j] equal to xmm2[index+j]? *) + List.fold_left ~f:check_char ~init:exp_true + (List.range ~stride:(-1) ~stop:`inclusive (nelem - index - 1) 0) + in + let bits = List.map ~f:get_bit nelem_range in + let res, res_bil = concat 1 bits in + let int_res_1 = tmp ~name:"IntRes1" reg16_t in + let int_res_2 = tmp ~name:"IntRes2" reg16_t in + + let contains_null e = + let elts = + List.init nelem ~f:(fun i -> Bil.(get_elem e i = int_exp 0 !!elemt)) + in + List.fold elts ~init:exp_false ~f:(fun acc elt -> Bil.(acc lor elt)) + in + + (* For pcmpistri/pcmpestri *) + let sb exp = + List.fold_left + ~f:(fun acc i -> + Bil.Ite + (Bil.(exp_true = Extract (i, i, exp)), int_exp i !!regm, acc)) + ~init:(int_exp nelem !!regm) + (match imm8cb.outselectsig with + | LSB -> + List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive nelem + 0 + | MSB -> List.init ~f:(fun x -> x) nelem) + in + + (* For pcmpistrm/pcmpestrm *) + let mask e = + match imm8cb.outselectmask with + | Bitmask -> Bil.(cast unsigned 128 e) + | Bytemask -> + let get_element i = Bil.(cast unsigned !!elemt (extract i i e)) in + let range = + List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive nelem + 0 + in + concat_explist (List.map ~f:get_element range) + in + + let res_of_cb = + match imm8cb with + | { negintres1 = false; _ } -> Bil.(int_res_2 := var int_res_1) + | { negintres1 = true; maskintres1 = false; _ } -> + (* int_res_1 is bitwise-notted *) + Bil.(int_res_2 := unop not (var int_res_1)) + | { negintres1 = true; maskintres1 = true; _ } -> + (* only the valid elements in xmm2 are bitwise-notted *) + (* XXX: Right now we duplicate the valid element computations + when negating the valid elements. They are also used by the + aggregation functions. A better way to implement this might + be to write the valid element information out as a temporary + bitvector. The aggregation functions and this code would + then extract the relevant bit to see if an element is + valid. *) + let validvector = + let range = + List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive + nelem 0 + in + let bits = List.map ~f:is_valid_xmm2_e range in + Bil.(cast unsigned 16 (concat_explist bits)) + in + Bil.(int_res_2 := validvector lxor var int_res_1) + in + + let res_of_pcmpinfo = + match pcmpinfo.out with + | Index -> Bil.(rcx := sb (var int_res_2)) + (* FIXME: ymms should be used instead of xmms here *) + | Mask -> Bil.(ymms.(0) := mask (var int_res_2)) + in + + List.concat + [ + xmm1_checks; + xmm2_checks; + res_bil; + Bil. + [ + int_res_1 := cast unsigned 16 (var res); + res_of_cb; + res_of_pcmpinfo; + cf := var int_res_2 <> int_exp 0 16; + zf := contains_null xmm2m128_e; + sf := contains_null xmm1_e; + oF := extract 0 0 (var int_res_2); + af := int_exp 0 1; + pf := int_exp 0 1; + ]; + ] + | Pshufd (t, dst, src, vsrc, imm) -> ( + let src_e = op2e t src in + let imm_e = op2e t imm in + (* XXX: This would be more straight-forward if implemented using + map, instead of fold *) + let get_dword ndword = + let high_b = (2 * (ndword mod 4)) + 1 in + let low_b = 2 * (ndword mod 4) in + let index = + Bil.(Cast (UNSIGNED, !!t, Extract (high_b, low_b, imm_e))) + in + let t' = !!t in + (* Use the same pattern for the top half of a ymm register *) + (* had to stop using extract_element_symbolic, since that calls + * Typecheck.infer_ast. I believe this captures the same + * "width logic", but this is a good place to check if things start + * going wrong later. *) + let index, index_width = + if t' = 256 && ndword > 3 then + (Bil.(index + Int (BV.of_int ~width:!!t 4)), 256) + else (index, t') + in + extract_element_symbolic_with_width (Type.imm 32) src_e index + index_width + in + let topdword = match t with Type.Imm 128 -> 3 | _ -> 7 in + let dwords = + concat_explist + (List.map ~f:get_dword + (List.range ~stride:(-1) ~stop:`inclusive topdword 0)) + in + match vsrc with + | None -> [ assn t dst dwords ] + | Some vdst -> [ assn t vdst dwords ]) + | Pshufb (exp_type, dst_op, src_op, vsrc) -> + let op_size = bitwidth_of_type exp_type in + let index_bits = + match op_size with + | 64 -> 3 + | 128 | 256 -> 4 + | _ -> disfailwith "invalid size for pshufb" + in + let foreach_byte f = List.concat @@ List.init (op_size / 8) ~f in + + let src = op2e exp_type src_op in + let dst = op2e exp_type dst_op in + let dst_op = Option.value ~default:dst_op vsrc in + let zero = Bil.int (Word.zero op_size) in + let msb_one = Bil.int (Word.of_int ~width:8 0x80) in + + let byte_t = Type.imm 8 in + let byte = int_exp 8 8 in + let iv = tmp ~name:"i" byte_t in + let mask_byte_i = tmp byte_t in + let tmp_byte = tmp exp_type in + let tmp_dst = tmp exp_type in + let ind = tmp byte_t in + + let check_mem_alignment = + match src_op with + | Oaddr addr when op_size = 128 -> + let word_size = width_of_mode mode in + let zero = Bil.int (Word.zero word_size) in + let oxf = Bil.int (Word.of_int ~width:word_size 0xf) in + [ Bil.(if_ (oxf land addr <> zero) [ cpuexn 13 ] []) ] + | _ -> [] + in + + List.concat + [ + check_mem_alignment; + [ Bil.move tmp_dst zero ]; + foreach_byte (fun i -> + Bil. + [ + iv := int (Word.of_int ~width:8 i); + mask_byte_i := extract 7 0 (src lsr (var iv * byte)); + if_ + (msb_one land var mask_byte_i = msb_one) + [ tmp_byte := zero ] + (* else *) + [ + ind := + cast unsigned 8 + (extract index_bits 0 (var mask_byte_i)); + tmp_byte := + cast unsigned op_size + (extract 7 0 (dst lsr (var ind * byte))); + ]; + (tmp_dst := + Bil.(var tmp_dst lor (var tmp_byte lsl (var iv * byte)))); + ]); + [ assn exp_type dst_op (Bil.var tmp_dst) ]; + ] + | Lea (t, r, a) when List.is_empty pref -> + (* See Table 3-64 *) + (* previously, it checked whether addrbits > opbits before the cast_low. + * The conclusion we came to was that + - if they were equal, the cast is basically a nop + - if it was the other way round, you want to extend it anyway. + * (I may be remembering things wrongly) *) + [ assn t r Bil.(Cast (LOW, !!t, a)) ] + | Call (o1, ra) -> ( + (* If o1 is an immediate, we should syntactically have Jump(imm) + so that the CFG algorithm knows where the jump goes. Otherwise + it will point to BB_Indirect. + + Otherwise, we should evaluate the operand before decrementing esp. + (This really only matters when esp is the base register of a memory + lookup. *) + let target = op2e mt o1 in + match o1 with + | Oimm _ -> + [ + Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width mt)))); + store_s mode None mt rsp_e (Bil.Int ra); + Bil.Jmp target; + ] + | _ -> + let t = tmp mt in + [ + Bil.Move (t, target); + Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width mt)))); + store_s mode None mt rsp_e (Bil.Int ra); + Bil.Jmp (Bil.Var t); + ]) + | Jump o -> [ Bil.Jmp (jump_target mode ss has_rex o) ] + | Jcc (o, c) -> + [ Bil.If (c, [ Bil.Jmp (jump_target mode ss has_rex o) ], []) ] + | Setcc (t, o1, c) -> [ assn t o1 Bil.(Cast (UNSIGNED, !!t, c)) ] + | Shift (st, s, dst, shift) -> + let old = tmp ~name:"tmp" s in + let s' = !!s in + let size = int_exp s' s' in + let s_f = + Bil.( + match st with + | LSHIFT -> ( lsl ) + | RSHIFT -> ( lsr ) + | ARSHIFT -> ( asr ) + | _ -> disfailwith "invalid shift type") + in + let dste = op2e s dst in + let count_mask = Bil.(size - int_exp 1 s') in + let count = Bil.(op2e s shift land count_mask) in + let new_of = + match st with + | LSHIFT -> Bil.(Cast (HIGH, !!bool_t, dste) lxor cf_e) + | RSHIFT -> Bil.(Cast (HIGH, !!bool_t, var old)) + | ARSHIFT -> exp_false + | _ -> disfailwith "impossible" + in + let new_cf = + (* undefined for SHL and SHR instructions where the count is greater than + or equal to the size (in bits) of the destination operand *) + match st with + | LSHIFT -> Bil.(Cast (LOW, !!bool_t, var old lsr (size - count))) + | RSHIFT | ARSHIFT -> + Bil.(Cast (HIGH, !!bool_t, var old lsl (size - count))) + | _ -> failwith "impossible" + in + Bil. + [ + old := dste; + assn s dst (s_f dste count); + if_ + (count <> int_exp 0 s') + [ + cf := new_cf; + sf := compute_sf dste; + zf := compute_zf s' dste; + pf := compute_pf s dste; + af := unknown "after-shift" bool_t; + if_ + (count = int_exp 1 s') + [ oF := new_of ] + [ oF := unknown "after-shift" bool_t ]; + ] + []; + ] + | Shiftd (st, s, dst, fill, count) -> + let was = tmp ~name:"tmp" s in + let e_dst = op2e s dst in + let e_fill = op2e s fill in + let s' = !!s in + (* Check for 64-bit operand *) + let size = int_exp s' s' in + let count_mask = Bil.(size - int_exp 1 s') in + let e_count = Bil.(op2e s count land count_mask) in + let new_cf = + match st with + | LSHIFT -> Bil.(Cast (LOW, !!bool_t, var was lsr (size - e_count))) + | RSHIFT -> Bil.(Cast (HIGH, !!bool_t, var was lsl (size - e_count))) + | _ -> disfailwith "impossible" + in + let new_of = Bil.(Cast (HIGH, !!bool_t, var was lxor e_dst)) in + let unk_of = + Bil.Unknown ("OF undefined after shiftd of more then 1 bit", bool_t) + in + let ret1 = + match st with + | LSHIFT -> Bil.(e_fill lsr (size - e_count)) + | RSHIFT -> Bil.(e_fill lsl (size - e_count)) + | _ -> disfailwith "impossible" + in + let ret2 = + match st with + | LSHIFT -> Bil.(e_dst lsl e_count) + | RSHIFT -> Bil.(e_dst lsr e_count) + | _ -> disfailwith "impossible" + in + let result = Bil.(ret1 lor ret2) in + (* SWXXX If shift is greater than the operand size, dst and + flags are undefined *) + Bil. + [ + was := e_dst; + assn s dst result; + if_ + (e_count <> int_exp 0 s') + [ + cf := new_cf; + sf := compute_sf e_dst; + zf := compute_zf s' e_dst; + pf := compute_pf s e_dst; + (* For a 1-bit shift, the OF flag is set if a sign change occurred; + otherwise, it is cleared. For shifts greater than 1 bit, the OF flag + is undefined. *) + if_ (e_count = int_exp 1 s') [ oF := new_of ] [ oF := unk_of ]; + ] + []; + ] + | Rotate (shift_type, exp_type, dst_op, shift_op, use_cf) -> + if use_cf then unimplemented "rotate use_vf"; + let word_size = bitwidth_of_type exp_type in + let mask_size = word_size - 1 in + let count_var = tmp exp_type in + let count = Bil.var count_var in + let zero = int_exp 0 word_size in + let one = int_exp 1 word_size in + let dst = op2e exp_type dst_op in + let shift_mask = int_exp mask_size word_size in + let size = int_exp word_size word_size in + let shift = op2e exp_type shift_op in + + if [%compare.equal: binop] shift_type LSHIFT then + Bil. + [ + count_var := shift land shift_mask mod size; + assn exp_type dst_op ((dst lsl count) lor (dst lsr (size - count))); + if_ (count = zero) + [ cf := cast low 1 dst ] + (* else *) + [ + if_ (count = one) + [ oF := cf_e lxor cast high 1 dst ] + (* else *) + [ + oF := + unknown "OF undefined after rotate of more then 1 bit" + bool_t; + ]; + ]; + ] + else + Bil. + [ + count_var := shift land shift_mask mod size; + assn exp_type dst_op ((dst lsr count) lor (dst lsl (size - count))); + if_ (count = zero) + [ cf := cast high 1 dst ] + (* else *) + [ + if_ (count = one) + [ + oF := + cast high 1 dst + lxor cast high 1 (dst lsl int_exp 1 word_size); + ] + (* else *) + [ + oF := + unknown "OF undefined after rotate of more then 1 bit" + bool_t; + ]; + ]; + ] + | Bt (t, bitoffset, bitbase) -> + let t' = !!t in + let offset = op2e t bitoffset in + let value, shift = + match bitbase with + | Oreg _ -> + let reg = op2e t bitbase in + let shift = Bil.(offset land int_exp Stdlib.(t' - 1) t') in + (reg, shift) + | Oaddr a -> + let offset = Bil.(cast unsigned (width_of_mode mode) offset) in + let byte = + load (size_of_typ reg8_t) Bil.(a + (offset lsr int_exp 3 t')) + in + let shift = Bil.(Cast (LOW, !!reg8_t, offset) land int_exp 7 8) in + (byte, shift) + | Ovec _ | Oseg _ | Oimm _ -> disfailwith "Invalid bt operand" + in + [ + Bil.Move (cf, Bil.(Cast (LOW, !!bool_t, value lsr shift))); + Bil.Move (oF, Bil.Unknown ("OF undefined after bt", bool_t)); + Bil.Move (sf, Bil.Unknown ("SF undefined after bt", bool_t)); + Bil.Move (af, Bil.Unknown ("AF undefined after bt", bool_t)); + Bil.Move (pf, Bil.Unknown ("PF undefined after bt", bool_t)); + ] + | Bs (t, dst, src, dir) -> + let is_zero_count = List.rev pref |> List.exists ~f:Int.(( = ) 0xf3) in + let width = !!t in + let src_e = op2e t src in + let is_fwd = match dir with Backward -> false | Forward -> true in + let res = tmp t in + let assn_res = Bil.(res := src_e) in + let scan_bil = + if is_fwd then + match width with + | 16 -> ctz16 res + | 32 -> ctz32 res + | 64 -> ctz64 res + | _ -> disfailwith "Invalid bitscan width" + else + match width with + | 16 -> clz16 res + | 32 -> clz32 res + | 64 -> clz64 res + | _ -> disfailwith "Invalid bitscan width" + in + let assn_result = + let n1 = width - 1 in + assn t dst + @@ + if is_zero_count || is_fwd then Bil.var res + else Bil.(var res lxor int Word.(of_int n1 ~width)) + in + let bil = assn_res :: scan_bil in + let bil = + if is_zero_count then + bil + @ Bil. + [ + assn_result; + cf := var res = int Word.(of_int ~width width); + zf := var res = int Word.(zero width); + ] + else + Bil. + [ + if_ + (src_e = int (Word.zero width)) + [ zf := int Word.b1; assn t dst @@ unknown "bits" t ] + (bil @ Bil.[ assn_result; zf := int Word.b0 ]); + ] + in + bil @ bitscan_flags is_zero_count + | Hlt -> [] (* x86 Hlt is essentially a NOP *) + | Rdtsc -> + let undef reg = assn reg32_t reg (Bil.Unknown ("rdtsc", reg32_t)) in + List.map ~f:undef [ o_rax; o_rdx ] + | Cpuid -> + let undef reg = assn reg32_t reg (Bil.Unknown ("cpuid", reg32_t)) in + List.map ~f:undef [ o_rax; o_rbx; o_rcx; o_rdx ] + | Xgetbv -> + let undef reg = assn reg32_t reg (Bil.Unknown ("xgetbv", reg32_t)) in + List.map ~f:undef [ o_rax; o_rdx ] + | Stmxcsr dst -> + let dst = + match dst with + | Oaddr addr -> addr + | _ -> disfailwith "stmxcsr argument cannot be non-memory" + in + [ + store reg32_t dst (Bil.Var mxcsr); (*(Unknown ("stmxcsr", reg32_t));*) + ] + | Ldmxcsr src -> + let src = + match src with + | Oaddr addr -> addr + | _ -> disfailwith "ldmxcsr argument cannot be non-memory" + in + [ Bil.Move (mxcsr, load (size_of_typ reg32_t) src) ] + | Fnstcw dst -> + let dst = + match dst with + | Oaddr addr -> addr + | _ -> disfailwith "fnstcw argument cannot be non-memory" + in + [ store reg16_t dst (Bil.Var fpu_ctrl) ] + | Fldcw src -> + let src = + match src with + | Oaddr addr -> addr + | _ -> disfailwith "fldcw argument cannot be non-memory" + in + [ Bil.Move (fpu_ctrl, load (size_of_typ reg16_t) src) ] + | Fld _src -> unimplemented "unsupported FPU register stack" + | Fst (_dst, _pop) -> unimplemented "unsupported FPU flags" + | Cmps (Type.Imm _bits as t) -> + let t' = !!t in + let src1 = tmp t in + let src2 = tmp t in + let tmpres = tmp t in + let stmts = + Bil.Move (src1, op2e t (Oaddr rsi_e)) + :: Bil.Move (src2, op2e_s mode seg_es has_rex t (Oaddr rdi_e)) + :: Bil.Move (tmpres, Bil.(Var src1 - Var src2)) + :: string_incr mode t rsi :: string_incr mode t rdi + :: set_flags_sub t' (Bil.Var src1) (Bil.Var src2) (Bil.Var tmpres) + in + begin match pref with + | [] -> stmts + | [ single ] when single = repz || single = repnz -> + rep_wrap ~mode ~check_zf:single ~addr ~next stmts + | _ -> unimplemented "unsupported flags in cmps" + end + | Scas (Type.Imm _bits as t) -> + let t' = !!t in + let src1 = tmp t in + let src2 = tmp t in + let tmpres = tmp t in + let stmts = + let open Stmt in + Move (src1, Bil.(Cast (LOW, !!t, Var rax))) + :: Move (src2, op2e_s mode seg_es has_rex t (Oaddr rdi_e)) + :: Move (tmpres, Bil.(Var src1 - Var src2)) + :: string_incr mode t rdi + :: set_flags_sub t' (Bil.Var src1) (Bil.Var src2) (Bil.Var tmpres) + in + begin match pref with + | [] -> stmts + | [ single ] when single = repz || single = repnz -> + rep_wrap ~mode ~check_zf:single ~addr ~next stmts + | _ -> unimplemented "unsupported flags in scas" + end + | Stos (Type.Imm _bits as t) -> + let stmts = + [ store_s mode seg_es t rdi_e (op2e t o_rax); string_incr mode t rdi ] + in + begin match pref with + | [] -> stmts + | [ single ] when single = repz -> rep_wrap ~mode ~addr ~next stmts + | _ -> unimplemented "unsupported prefix for stos" + end + | Push (t, o) -> + let o = if is_small_imm o t then sign_extend_imm o t else op2e t o in + let tmp = tmp t in + (* only really needed when o involves esp *) + [ + Bil.Move (tmp, o); + Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width t)))); + store_s mode seg_ss t rsp_e (Bil.var tmp) + (* FIXME: can ss be overridden? *); + ] + | Pop (t, o) -> + (* From the manual: + + "The POP ESP instruction increments the stack pointer (ESP) + before data at the old top of stack is written into the + destination" + + So, effectively there is no incrementation. + *) + assn t o (load_s mode seg_ss (size_of_typ t) rsp_e) + :: + (if [%compare.equal: operand] o o_rsp then [] + else [ Bil.Move (rsp, Bil.(rsp_e + Int (mi (bytes_of_width t)))) ]) + | Pushf t -> + (* Note that we currently treat these fields as unknowns, but the + manual says: When copying the entire EFLAGS register to the + stack, the VM and RF flags (bits 16 and 17) are not copied; + instead, the values for these flags are cleared in the EFLAGS + image stored on the stack. *) + let flags_e = + match t with + | Type.Imm 16 -> flags_e + | Type.Imm 32 -> eflags_e + | Type.Imm 64 -> rflags_e + | _ -> failwith "impossible" + in + [ + Bil.Move (rsp, Bil.(rsp_e - Int (mi (bytes_of_width t)))); + store_s mode seg_ss t rsp_e flags_e; + ] + | Popf t -> + let assnsf = + match t with + | Type.Imm 16 -> assns_flags_to_bap + | Type.Imm 32 -> assns_eflags_to_bap + | Type.Imm 64 -> assns_rflags_to_bap + | _ -> failwith "impossible" + in + let tmp = tmp t in + let extractlist = + List.map + ~f:(fun i -> Bil.(Extract (i, i, Var tmp))) + (List.range ~stride:(-1) ~start:`exclusive ~stop:`inclusive !!t 0) + in + Bil.Move (tmp, load_s mode seg_ss (size_of_typ t) rsp_e) + :: Bil.Move (rsp, Bil.(rsp_e + Int (mi (bytes_of_width t)))) + :: List.concat (List.map2_exn ~f:(fun f e -> f e) assnsf extractlist) + | Popcnt (t, s, d) -> + let width = !!t in + let bits = op2e t s in + let res = tmp t in + let assn_src = Bil.(res := bits) in + let cnt = + match width with + | 16 -> popcnt16 res + | 32 -> popcnt32 res + | 64 -> popcnt64 res + | _ -> disfailwith "Invalid popcnt width" + in + let bil = (assn_src :: cnt) @ Bil.[ assn t d (var res) ] in + let flags = + List.map + ~f:(fun r -> Bil.Move (r, int_exp 0 1)) + [ cf; oF; sf; af; pf ] + in + set_zf width bits :: (bil @ flags) + | Sahf -> + let assnsf = assns_lflags_to_bap in + let tah = tmp ~name:"AH" reg8_t in + let extractlist = + List.map + ~f:(fun i -> Bil.(Extract (i, i, Var tah))) + (List.range ~stride:(-1) ~stop:`inclusive 7 0) + in + Bil.Move (tah, ah_e) + :: List.concat (List.map2_exn ~f:(fun f e -> f e) assnsf extractlist) + | Lahf -> + let o_ah = Oreg 4 in + [ assn reg8_t o_ah lflags_e ] + | Add (t, o1, o2) -> + let tmp = tmp t and tmp2 = tmp t in + Bil.Move (tmp, op2e t o1) + :: Bil.Move (tmp2, op2e t o2) + :: assn t o1 Bil.(op2e t o1 + Var tmp2) + :: + (let s1 = Bil.Var tmp in + let s2 = Bil.Var tmp2 in + let r = op2e t o1 in + set_flags_add !!t s1 s2 r) + | Adc (t, o1, o2) -> + let orig1 = tmp t in + let orig2 = tmp t in + let bits = !!t in + let t' = Type.Imm (bits + 1) in + let c e = Bil.(Cast (UNSIGNED, !!t', e)) in + (* Literally compute the addition with an extra bit and see + what the value is for CF *) + let s1 = Bil.Var orig1 in + let s2 = Bil.Var orig2 in + let r = op2e t o1 in + let bige = Bil.(c s1 + c s2 + c (Cast (UNSIGNED, !!t, cf_e))) in + Bil.Move (orig1, op2e t o1) + :: Bil.Move (orig2, op2e t o2) + :: assn t o1 Bil.(s1 + s2 + Cast (UNSIGNED, !!t, cf_e)) + :: Bil.Move (cf, Bil.Extract (bits, bits, bige)) + :: set_aopszf_add !!t s1 s2 r + | Inc (t, o) (* o = o + 1 *) -> + let t' = !!t in + let tmp = tmp t in + Bil.Move (tmp, op2e t o) + :: assn t o Bil.(op2e t o + int_exp 1 t') + :: set_aopszf_add t' (Bil.Var tmp) (int_exp 1 t') (op2e t o) + | Dec (t, o) (* o = o - 1 *) -> + let t' = !!t in + let tmp = tmp t in + Bil.Move (tmp, op2e t o) + :: assn t o Bil.(op2e t o - int_exp 1 t') + :: set_aopszf_sub t' (Bil.Var tmp) (int_exp 1 t') (op2e t o) + (* CF is maintained *) + | Sub (t, o1, o2) (* o1 = o1 - o2 *) -> + let oldo1 = tmp t in + let oldo2 = tmp t in + let op1 = op2e t o1 in + let op2 = + if is_small_imm o2 t then sign_extend_imm o2 t else op2e t o2 + in + Bil.( + [ oldo1 := op1; oldo2 := op2; assn t o1 (op1 - op2) ] + @ set_flags_sub (bitwidth_of_type t) (var oldo1) (var oldo2) op1) + | Sbb (t, o1, o2) -> + let tmp_s = tmp t in + let tmp_d = tmp t in + let orig_s = Bil.Var tmp_s in + let orig_d = Bil.Var tmp_d in + let sube = Bil.(orig_s + Cast (UNSIGNED, !!t, cf_e)) in + let d = op2e t o1 in + let s1 = + if is_small_imm o2 t then sign_extend_imm o2 t else op2e t o2 + in + Bil.Move (tmp_s, s1) + :: Bil.Move (tmp_d, d) + :: assn t o1 Bil.(orig_d - sube) + :: Bil.Move + ( oF, + Bil.( + Cast (HIGH, !!bool_t, orig_s lxor orig_d land (orig_d lxor d))) + ) + (* When src = 0xffffffff and cf=1, the processor sets CF=1. + + Note that we compute dest = dest - (0xffffffff + 1) = 0, so the + subtraction does not overflow. + + So, I am guessing that CF is set if the subtraction overflows + or the addition overflows. + + Maybe we should implement this by doing the actual computation, + like we do for adc. + *) + (* sub overflow | add overflow *) + :: Bil.Move (cf, Bil.((sube > orig_d) lor (sube < orig_s))) + :: set_apszf !!t orig_s orig_d d + | Cmp (t, o1, o2) -> + let tmp = tmp t in + Bil.Move (tmp, Bil.(op2e t o1 - op2e t o2)) + :: set_flags_sub !!t (op2e t o1) (op2e t o2) (Bil.Var tmp) + | Cmpxchg (t, src, dst) -> + let t' = !!t in + let eax_e = op2e t o_rax in + let dst_e = op2e t dst in + let src_e = op2e t src in + let tmp = tmp t in + Bil.Move (tmp, Bil.(eax_e - dst_e)) + :: set_flags_sub t' eax_e dst_e (Bil.Var tmp) + @ [ + assn t dst (Bil.Ite (zf_e, src_e, dst_e)); + assn t o_rax (Bil.Ite (zf_e, eax_e, dst_e)); + ] + | Cmpxchg8b o -> + (* only 32bit case *) + let accumulator = Bil.Concat (op2e reg32_t o_rdx, op2e reg32_t o_rax) in + let dst_e = op2e reg64_t o in + let src_e = Bil.Concat (op2e reg32_t o_rcx, op2e reg32_t o_rbx) in + let dst_low_e = Bil.Extract (63, 32, dst_e) in + let dst_hi_e = Bil.Extract (31, 0, dst_e) in + let eax_e = op2e reg32_t o_rax in + let edx_e = op2e reg32_t o_rdx in + let equal = tmp bool_t in + let equal_v = Bil.Var equal in + [ + Bil.Move (equal, Bil.(accumulator = dst_e)); + Bil.Move (zf, equal_v); + assn reg64_t o (Bil.Ite (equal_v, src_e, dst_e)); + assn reg32_t o_rax (Bil.Ite (equal_v, eax_e, dst_low_e)); + assn reg32_t o_rdx (Bil.Ite (equal_v, edx_e, dst_hi_e)); + ] + | Xadd (t, dst_op, src_op) -> + let tmp_res = tmp t in + let tmp_dst = tmp t in + let tmp_src = tmp t in + let dst = op2e t dst_op in + let src = op2e t src_op in + Bil. + [ + tmp_src := src; + tmp_dst := dst; + tmp_res := src + dst; + assn t src_op dst; + assn t dst_op (var tmp_res); + ] + @ set_flags_add !!t (Bil.var tmp_dst) (Bil.var tmp_src) dst + | Xchg (t, src, dst) -> + let tmp = tmp t in + [ + Bil.Move (tmp, op2e t src); + assn t src (op2e t dst); + assn t dst (Bil.Var tmp); + ] + | And (t, o1, o2) -> + assn t o1 Bil.(op2e t o1 land op2e t o2) + :: Bil.Move (oF, exp_false) + :: Bil.Move (cf, exp_false) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after and", bool_t)) + :: set_pszf t (op2e t o1) + | Or (t, o1, o2) -> + let o2 = + if is_small_imm o2 t then sign_extend_imm o2 t else op2e t o2 + in + assn t o1 Bil.(op2e t o1 lor o2) + :: Bil.Move (oF, exp_false) + :: Bil.Move (cf, exp_false) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after or", bool_t)) + :: set_pszf t (op2e t o1) + | Xor (t, o1, o2) when [%compare.equal: operand] o1 o2 -> + assn t o1 Bil.(Int (BV.of_int ~width:!!t 0)) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after xor", bool_t)) + :: List.map ~f:(fun v -> Bil.Move (v, exp_true)) [ zf; pf ] + @ List.map ~f:(fun v -> Bil.Move (v, exp_false)) [ oF; cf; sf ] + | Xor (t, o1, o2) -> + assn t o1 Bil.(op2e t o1 lxor op2e t o2) + :: Bil.Move (oF, exp_false) + :: Bil.Move (cf, exp_false) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after xor", bool_t)) + :: set_pszf t (op2e t o1) + | Test (t, o1, o2) -> + let o2 = + if is_small_imm o2 t then sign_extend_imm o2 t else op2e t o2 + in + let tmp = tmp t in + Bil.Move (tmp, Bil.(op2e t o1 land o2)) + :: Bil.Move (oF, exp_false) + :: Bil.Move (cf, exp_false) + :: Bil.Move (af, Bil.Unknown ("AF is undefined after and", bool_t)) + :: set_pszf t (Bil.Var tmp) + | Ptest (t, o1, o2) -> + let open Stmt in + let t' = !!t in + let tmp1 = tmp t and tmp2 = tmp t in + Move (tmp1, Bil.(op2e t o2 land op2e t o1)) + :: Move (tmp2, Bil.(op2e t o2 land exp_not (op2e t o1))) + :: Move (af, exp_false) + :: Move (oF, exp_false) + :: Move (pf, exp_false) + :: Move (sf, exp_false) + :: Move (zf, Bil.(Var tmp1 = Int (BV.of_int ~width:t' 0))) + :: [ Move (cf, Bil.(Var tmp2 = Int (BV.of_int ~width:t' 0))) ] + | Not (t, o) -> [ assn t o (exp_not (op2e t o)) ] + | Neg (t, o) -> + let t' = !!t in + let tmp = tmp t in + let min_int = Bil.BinOp (LSHIFT, int_exp 1 t', int_exp (t' - 1) t') in + Bil.Move (tmp, op2e t o) + :: assn t o Bil.(int_exp 0 t' - op2e t o) + :: Bil.Move + (cf, Bil.(Ite (Var tmp = int_exp 0 t', int_exp 0 1, int_exp 1 1))) + :: Bil.Move (oF, Bil.(Ite (Var tmp = min_int, int_exp 1 1, int_exp 0 1))) + :: set_apszf_sub t' (Bil.Var tmp) (int_exp 0 t') (op2e t o) + | Mul (t, src) -> + (* Mul always multiplies EAX by src and stores the result in EDX:EAX + starting from the "right hand side" based on the type t of src *) + + (* The OF and CF flags are set to 0 if the upper half of the result is 0; + otherwise, they are set to 1 *) + let new_t = Type.Imm (!!t * 2) in + let assnstmts, assne = + Bil.( + assn_dbl t + (Cast (UNSIGNED, !!new_t, op2e t o_rax) + * Cast (UNSIGNED, !!new_t, op2e t src))) + in + let flag = + let highbit = !!new_t - 1 in + let lowbit = !!new_t / 2 in + Bil.(Extract (highbit, lowbit, assne) <> int_exp 0 !!t) + in + assnstmts + @ [ + Bil.Move (oF, flag); + Bil.Move (cf, flag); + Bil.Move (sf, Bil.Unknown ("SF is undefined after Mul", bool_t)); + Bil.Move (zf, Bil.Unknown ("ZF is undefined after Mul", bool_t)); + Bil.Move (af, Bil.Unknown ("AF is undefined after Mul", bool_t)); + Bil.Move (pf, Bil.Unknown ("PF is undefined after Mul", bool_t)); + ] + | Imul (t, (oneopform, dst), src1, src2) -> + let new_t = Type.Imm (!!t * 2) in + let mul_stmts = + match oneopform with + | true -> + (* For one operand form, use assn_double *) + let assnstmts, assne = + assn_dbl t + Bil.( + Cast (SIGNED, !!new_t, op2e t src1) + * Cast (SIGNED, !!new_t, op2e t src2)) + in + let flag = + (* Intel checks if EAX == EDX:EAX. Instead of doing this, we are just + going to check if the upper bits are != 0 *) + let highbit = !!new_t - 1 in + let lowbit = !!new_t / 2 in + Bil.(Extract (highbit, lowbit, assne) <> int_exp 0 !!t) + in + assnstmts @ [ Bil.Move (oF, flag); Bil.Move (cf, flag) ] + | false -> + (* Two and three operand forms *) + let tmp = tmp new_t in + (* Flag is set when the result is truncated *) + let flag = Bil.(Var tmp <> Cast (SIGNED, !!new_t, op2e t dst)) in + [ + Bil.Move + ( tmp, + Bil.( + Cast (SIGNED, !!new_t, op2e t src1) + * Cast (SIGNED, !!new_t, op2e t src2)) ); + assn t dst Bil.(Cast (LOW, !!t, Var tmp)); + Bil.Move (oF, flag); + Bil.Move (cf, flag); + ] + in + mul_stmts + @ [ + Bil.Move (pf, Bil.Unknown ("PF is undefined after imul", bool_t)); + Bil.Move (sf, Bil.Unknown ("SF is undefined after imul", bool_t)); + Bil.Move (zf, Bil.Unknown ("ZF is undefined after imul", bool_t)); + Bil.Move (af, Bil.Unknown ("AF is undefined after imul", bool_t)); + ] + | Div (t, src) -> + let dt' = !!t * 2 in + let dt = Type.Imm dt' in + let zero = int_exp 0 dt' in + let dividend = tmp ~name:"dividend" dt in + let divisor = tmp ~name:"divisor" dt in + let tdiv = tmp ~name:"div" dt in + let trem = tmp ~name:"rem" dt in + let result = Bil.(cast low !!t (var trem) ^ cast low !!t (var tdiv)) in + let apply_result = fst (assn_dbl t result) in + Bil. + [ + divisor := cast unsigned !!dt (op2e t src); + dividend := op2e_dbl t; + if_ + (var divisor = zero) + [ Cpu_exceptions.divide_by_zero ] + (* else *) + [ + tdiv := var dividend / var divisor; + trem := var dividend mod var divisor; + if_ + (cast high !!t (var tdiv) = int_exp 0 !!t) + apply_result (* else *) + [ Cpu_exceptions.divide_by_zero ]; + ]; + ] + @ undefine [ cf; oF; sf; zf; af; pf ] + | Idiv (t, src) -> + let dt' = !!t * 2 in + let dt = Type.Imm dt' in + let zero = int_exp 0 dt' in + let dividend = tmp ~name:"dividend" dt in + let divisor = tmp ~name:"divisor" dt in + let tdiv = tmp ~name:"div" dt in + let trem = tmp ~name:"rem" dt in + let result = Bil.(cast low !!t (var trem) ^ cast low !!t (var tdiv)) in + let apply_result = fst @@ assn_dbl t result in + let lbound = + let dtm1 = dt' - 1 in + Word.(one dt' lsl of_int ~width:dt' dtm1) + in + let ubound = Word.(lbound - one dt') in + Bil. + [ + divisor := cast signed !!dt (op2e t src); + dividend := op2e_dbl t; + if_ + (var divisor = zero) + [ Cpu_exceptions.divide_by_zero ] + (* else *) + [ + tdiv := var dividend /$ var divisor; + trem := var dividend %$ var divisor; + if_ + ((var tdiv >$ int ubound) lor (var tdiv <$ int lbound)) + [ Cpu_exceptions.divide_by_zero ] (* else *) + apply_result; + ]; + ] + @ undefine [ cf; oF; sf; zf; af; pf ] + | Cld -> [ Bil.Move (df, exp_false) ] + | Leave t when List.is_empty pref -> + (* #UD if Lock prefix is used *) + Bil.Move (rsp, rbp_e) + :: to_ir mode addr next ss pref has_rex has_vex (Pop (t, o_rbp)) + | Interrupt3 -> [ Bil.CpuExn 3 ] + | Interrupt (Oimm i) -> + [ + (match Addr.to_int i with + | Ok i -> Bil.cpuexn i + | Error _ -> + let dst = asprintf "interrupt@%s" (Addr.string_of_value i) in + Bil.(encode call dst)); + ] + | Sysenter | Syscall -> [ Bil.(encode call "syscall") ] + (* Match everything exhaustively *) + | Leave _ -> unimplemented "to_ir: Leave" + | Lea _ -> unimplemented "to_ir: Lea" + | Movs _ -> unimplemented "to_ir: Movs" + | Cmps _ -> unimplemented "to_ir: Cmps" + | Scas _ -> unimplemented "to_ir: Scas" + | Stos _ -> unimplemented "to_ir: Stos" + | Retn _ -> unimplemented "to_ir: Retn" + | Interrupt _ -> unimplemented "to_ir: Interrupt" +end +(* ToIR *) + +let disasm_instr mode mem addr = + let module D = X86_disasm in + let pref, prefix, op, na = D.parse_instr mode mem addr in + let has_rex = Option.is_some prefix.rex in + let has_vex = Option.is_some prefix.vex in + let ss, pref = D.parse_prefixes mode pref op in + ToIR.to_ir mode addr na ss pref has_rex has_vex op + +let insn arch mem insn = + let mode = match arch with `x86 -> X86 | `x86_64 -> X8664 in + let addr = Memory.min_addr mem in + match disasm_instr mode mem addr with + | exception No_semantics -> Ok [] + | exception Arch_exception (_, msg) -> + Or_error.errorf "invalid instruction: %s" msg + | exception exn -> + Or_error.errorf "internal error in the legacy lifter: %s@\n%s@\n" + (Exn.to_string exn) + (Printexc.get_backtrace ()) + | bil -> ( + match Type.check bil with + | Ok () -> Ok bil + | Error err -> + warning "BIL is not well-typed in the legacy lifter at %a - %a" + pp_insn (mem, insn) Type.Error.pp err; + Error (Error.of_string "type error")) + +module AMD64 = struct + module CPU = X86_cpu.AMD64 + + let lift mem i = insn `x86_64 mem i +end + +module IA32 = struct + module CPU = X86_cpu.IA32 + + let lift mem i = insn `x86 mem i +end diff --git a/plugins/x86/x86_sym_imm_lifter.mli b/plugins/x86/x86_sym_imm_lifter.mli new file mode 100644 index 000000000..741877bd6 --- /dev/null +++ b/plugins/x86/x86_sym_imm_lifter.mli @@ -0,0 +1,12 @@ +open Core_kernel[@@warning "-D"] +open Bap.Std + +module IA32 : sig + module CPU : CPU + val lift : lifter +end + +module AMD64 : sig + module CPU : CPU + val lift : lifter +end diff --git a/plugins/x86/x86_sym_imm_targets.ml b/plugins/x86/x86_sym_imm_targets.ml new file mode 100644 index 000000000..4203ede12 --- /dev/null +++ b/plugins/x86/x86_sym_imm_targets.ml @@ -0,0 +1,22 @@ +open Core_kernel [@@warning "-D"] +open Bap.Std +module Insn = Disasm_expert.Basic.Insn +module IA32SI_L = X86_sym_imm_lifter.IA32 +module AMD64SI_L = X86_sym_imm_lifter.AMD64 + +module IA32SI_D = struct + module CPU = IA32SI_L.CPU + + let lift _mem _insn = Ok [] +end + +module AMD64SI_D = struct + module CPU = AMD64SI_L.CPU + + let lift _mem _insn = Ok [] +end + +module IA32SI = X86_backend.IA32.Make (IA32SI_D) +module AMD64SI = X86_backend.AMD64.Make (AMD64SI_D) +module IA32SI_M = X86_backend.IA32.Make (IA32SI_L) +module AMD64SI_M = X86_backend.AMD64.Make (AMD64SI_L) diff --git a/plugins/x86/x86_sym_imm_targets.mli b/plugins/x86/x86_sym_imm_targets.mli new file mode 100644 index 000000000..71aeb55de --- /dev/null +++ b/plugins/x86/x86_sym_imm_targets.mli @@ -0,0 +1,14 @@ +open Core_kernel[@@warning "-D"] +open Bap.Std + +module IA32SI : Target + +module AMD64SI : Target + +module IA32SI_L : Target + +module AMD64SI_L : Target + +module IA32SI_M : Target + +module AMD64SI_M : Target From 543dc5f8cd359f3971984fbc989659f9fdbc1bca Mon Sep 17 00:00:00 2001 From: Angs12 Date: Thu, 25 Jun 2026 03:17:19 +0300 Subject: [PATCH 04/44] opt: restore the optimization pass cache --- plugins/optimization/optimization_main.ml | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/plugins/optimization/optimization_main.ml b/plugins/optimization/optimization_main.ml index 4b3f89c1d..b504a0ba8 100644 --- a/plugins/optimization/optimization_main.ml +++ b/plugins/optimization/optimization_main.ml @@ -160,10 +160,15 @@ let run level proj = Project.map_program proj ~f:(fun prog -> let free = free_vars prog in Term.map sub_t prog ~f:(fun sub -> - let data = process_sub free can_touch sub in - let sub = O.update sub data in - let data = O.find_unreachable sub data in - O.remove_dead_code sub data)) + let digest = digest_of_sub sub level in + match O.Cache.load digest with + | Some data -> O.apply sub data + | None -> + let data = process_sub free can_touch sub in + let sub = O.update sub data in + let data = O.find_unreachable sub data in + O.Cache.save digest data; + O.remove_dead_code sub data)) let () = Config.manpage @@ -220,4 +225,5 @@ let () = ~provides:[ "pass"; "optimization"; "analysis"; "simplification" ] (fun { Config.get = ( ! ) } -> if !level > 0 then - Project.register_pass ~deps:[ "api" ] ~autorun:true (run !level)) + Project.register_pass ~deps:[ "api" ] ~runonce:false ~autorun:true + (run !level)) From 02f83632177df6bfb24c691b90085a75f30a7881 Mon Sep 17 00:00:00 2001 From: Angs12 Date: Mon, 27 Jul 2026 23:42:54 +0300 Subject: [PATCH 05/44] x86: add symbolic immediates for mov and lea --- plugins/x86/x86_sym_imm_lifter.ml | 154 +++++++++++++++++++++++++---- plugins/x86/x86_sym_imm_targets.ml | 7 +- 2 files changed, 139 insertions(+), 22 deletions(-) diff --git a/plugins/x86/x86_sym_imm_lifter.ml b/plugins/x86/x86_sym_imm_lifter.ml index 695a480c3..288e5d4b9 100644 --- a/plugins/x86/x86_sym_imm_lifter.ml +++ b/plugins/x86/x86_sym_imm_lifter.ml @@ -9,6 +9,115 @@ open X86_utils open X86_env include Self () +(* Per-lift cache mapping a memory operand's addressing signature to its + symbolized address. The same memory operand is lifted twice for a + read-modify-write (load address and store address); those two address + expressions may be structurally unequal (e.g. one carries a trailing +0), + but they share the same (base, index, scale, displacement) signature, so + keying on that signature yields ONE shared displacement IMM var. Two + distinct operands keep distinct vars even when their displacement values + coincide (e.g. add [rax+1],[rbx+1]). Cleared at the start of each lift. *) +type disp_key = string option * string option * int option * int64 option +let disp_cache : (disp_key, Bil.exp) Hashtbl.Poly.t = Hashtbl.Poly.create () + +(* Helper to create an IMM virtual variable *) +let imm_var width = Bil.Var (Var.create ~is_virtual:true "IMM" (Type.Imm width)) + +(* Find the displacement Int in an address expression. The address is built as + base + index*scale + disp. The displacement is the Int addend of a + PLUS/MINUS whose sibling is the base/scaled-index part; a trailing +0 (from + lifting normalization) and the scale shift (inside LSHIFT) are excluded. + Returns None when there is no displacement (e.g. [rax], [rax+rcx*4], [rip]). *) +let rec find_disp_node = function + | BinOp (op, e1, e2) + when [%compare.equal: binop] op PLUS || [%compare.equal: binop] op MINUS -> + (match find_disp_node e1 with + | Some _ as r -> r + | None -> + (match find_disp_node e2 with + | Some _ as r -> r + | None -> + (* No nested displacement: the displacement is the Int addend + of this sum (preferring e1, then e2). A trailing +0 is never + picked because find_disp_node already descended into the + base part. *) + match e1 with + | Int _ -> Some e1 + | _ -> + (match e2 with + | Int _ -> Some e2 + | _ -> None))) + | _ -> None + +(* Rebuild exp, substituting the exact displacement Int node (matched by + physical identity) with the given variable. *) +let rec replace_disp_node target var = function + | e when phys_equal e target -> var + | BinOp (op, e1, e2) -> + BinOp (op, replace_disp_node target var e1, replace_disp_node target var e2) + | Load (m, a, en, sz) -> + Load (m, replace_disp_node target var a, en, sz) + | Store (m, a, d, en, sz) -> + Store (m, replace_disp_node target var a, replace_disp_node target var d, en, sz) + | Cast (k, n, e) -> Cast (k, n, replace_disp_node target var e) + | UnOp (op, e) -> UnOp (op, replace_disp_node target var e) + | Extract (hi, lo, e) -> Extract (hi, lo, replace_disp_node target var e) + | Concat (e1, e2) -> Concat (replace_disp_node target var e1, replace_disp_node target var e2) + | Let (v, e1, e2) -> Let (v, replace_disp_node target var e1, replace_disp_node target var e2) + | Ite (c, t, f) -> Ite (replace_disp_node target var c, replace_disp_node target var t, replace_disp_node target var f) + | e -> e + +(* Walk an address collecting (base register name, index register name, scale + shift). The scale is the LSHIFT shift operand; the base is the register + added directly (not inside the scale). The displacement, scale-shift + constant, and trailing +0 are not collected here. *) +let rec collect_bis a (base, index, scale) = + match a with + | Var v -> (Some (Var.name v), index, scale) + | BinOp (LSHIFT, Var v, Int s) -> + (base, Some (Var.name v), Some (Word.to_int_exn (Word.signed s))) + | BinOp (LSHIFT, _, _) -> (base, index, scale) + | BinOp (_, x, y) -> collect_bis y (collect_bis x (base, index, scale)) + | Cast (_, _, e) | UnOp (_, e) | Extract (_, _, e) + | Concat (e, _) | Ite (_, e, _) | Let (_, _, e) -> + collect_bis e (base, index, scale) + | Load (_, e, _, _) | Store (_, e, _, _, _) -> collect_bis e (base, index, scale) + | _ -> (base, index, scale) + +let int64_of_word w = Or_error.ok_exn (Word.to_int64 (Word.signed w)) + +(* Addressing signature of an expression: (base, index, scale, displacement). + For a bare Int (moffs) the displacement is the whole value and base is None. *) +let addr_key a = + let dv = + match find_disp_node a with + | Some (Int d) -> Some (int64_of_word d) + | _ -> (match a with Int d -> Some (int64_of_word d) | _ -> None) + in + let (base, index, scale) = collect_bis a (None, None, None) in + (base, index, scale, dv) + +(* Symbolize the displacement (or moffs offset) of an address expression, + sharing the resulting IMM var across all uses of the same memory operand + (matched by addr_key) via disp_cache. *) + let symbolize_addr a = + let key = addr_key a in + match Hashtbl.Poly.find disp_cache key with + | Some ca -> ca + | None -> + let ca = + match a with + | Int d -> imm_var (Word.bitwidth d) + | _ -> + (match find_disp_node a with + | Some (Int d as dnode) -> + replace_disp_node dnode (imm_var (Word.bitwidth d)) a + | Some _ | None -> a) + in + Hashtbl.Poly.set disp_cache ~key ~data:ca; + ca + + module ToIR = struct let cf_e = Bil.var cf let pf_e = Bil.var pf @@ -55,7 +164,7 @@ module ToIR = struct (* There is no 32-bit extension of segment selectors; this is not a bug *) | Oseg r when t = reg16_t -> (bits2segrege r, t) | Oseg _ -> (disfailwith mode "Segment register when t is not r16", t) - | Oaddr e -> (load_s mode ss (size_of_typ t) e, t) + | Oaddr e -> (load_s mode ss (size_of_typ t) (symbolize_addr e), t) | Oimm i -> Bil.(Var (Var.create ~is_virtual:true "IMM" t), t) let op2e_s mode ss has_rex t operand = @@ -78,7 +187,7 @@ module ToIR = struct (* There is no 32-bit extension of segment selectors; this is not a bug *) | Oseg r when t = reg16_t -> bits2segrege r | Oseg _ -> disfailwith mode "Segment register when t is not r16" - | Oaddr e -> load_s mode ss (size_of_typ t) e + | Oaddr e -> load_s mode ss (size_of_typ t) (symbolize_addr e) | Oimm i -> Bil.(Var (Var.create ~is_virtual:true "IMM" t)) let assn_s mode s has_rex has_vex t v e = @@ -136,7 +245,7 @@ module ToIR = struct Bil.Move (v, e) | Oseg _, _ -> disfailwith mode "Can't assign to non 16 bit segment register" - | Oaddr a, _ -> store_s mode s t a e + | Oaddr a, _ -> store_s mode s t (symbolize_addr a) e | Oimm _, _ -> disfailwith mode "disasm x86: Can't assign to an immediate value" @@ -513,7 +622,7 @@ module ToIR = struct let s, al = match s with | Ovec _ | Oreg _ -> (op2e ts s, []) - | Oaddr a -> (op2e ts s, [ a ]) + | Oaddr a -> (op2e ts s, [ symbolize_addr a ]) | Oimm _ | Oseg _ -> disfailwith "invalid source operand for movdq" in let d, al = @@ -521,7 +630,7 @@ module ToIR = struct (* Behavior is to clear the xmm bits *) | Ovec _ -> (assn td d Bil.(Cast (UNSIGNED, !!td, s)), al) | Oreg _ -> (assn td d s, al) - | Oaddr a -> (assn td d s, a :: al) + | Oaddr a -> (assn td d s, symbolize_addr a :: al) | Oimm _ | Oseg _ -> disfailwith "invalid dest operand for movdq" in (* sources tell me that movdqa raises a general protection exception @@ -643,7 +752,7 @@ module ToIR = struct let src = match src with | Ovec _ -> op2e t src - | Oaddr a -> load (size_of_typ t) a + | Oaddr a -> load (size_of_typ t) (symbolize_addr a) | Oreg _ | Oimm _ | Oseg _ -> disfailwith "invalid" in let vsrc = Option.value ~default:dst vsrc in @@ -1099,7 +1208,7 @@ module ToIR = struct let word_size = width_of_mode mode in let zero = Bil.int (Word.zero word_size) in let oxf = Bil.int (Word.of_int ~width:word_size 0xf) in - [ Bil.(if_ (oxf land addr <> zero) [ cpuexn 13 ] []) ] + [ Bil.(if_ (oxf land symbolize_addr addr <> zero) [ cpuexn 13 ] []) ] | _ -> [] in @@ -1129,14 +1238,16 @@ module ToIR = struct ]); [ assn exp_type dst_op (Bil.var tmp_dst) ]; ] - | Lea (t, r, a) when List.is_empty pref -> - (* See Table 3-64 *) - (* previously, it checked whether addrbits > opbits before the cast_low. - * The conclusion we came to was that - - if they were equal, the cast is basically a nop - - if it was the other way round, you want to extend it anyway. - * (I may be remembering things wrongly) *) - [ assn t r Bil.(Cast (LOW, !!t, a)) ] + | Lea (t, r, a) when List.is_empty pref -> + (* See Table 3-64 *) + (* previously, it checked whether addrbits > opbits before the cast_low. + * The conclusion we came to was that + - if they were equal, the cast is basically a nop + - if it was the other way round, you want to extend it anyway. + * (I may be remembering things wrongly) *) + (* Symbolize the displacement/moffs offset in the computed address so + that LEA participates in the sym-imm scheme like real loads/stores. *) + [ assn t r Bil.(Cast (LOW, !!t, symbolize_addr a)) ] | Call (o1, ra) -> ( (* If o1 is an immediate, we should syntactically have Jump(imm) so that the CFG algorithm knows where the jump goes. Otherwise @@ -1334,7 +1445,7 @@ module ToIR = struct | Oaddr a -> let offset = Bil.(cast unsigned (width_of_mode mode) offset) in let byte = - load (size_of_typ reg8_t) Bil.(a + (offset lsr int_exp 3 t')) + load (size_of_typ reg8_t) Bil.(symbolize_addr a + (offset lsr int_exp 3 t')) in let shift = Bil.(Cast (LOW, !!reg8_t, offset) land int_exp 7 8) in (byte, shift) @@ -1408,7 +1519,7 @@ module ToIR = struct | Stmxcsr dst -> let dst = match dst with - | Oaddr addr -> addr + | Oaddr addr -> symbolize_addr addr | _ -> disfailwith "stmxcsr argument cannot be non-memory" in [ @@ -1417,21 +1528,21 @@ module ToIR = struct | Ldmxcsr src -> let src = match src with - | Oaddr addr -> addr + | Oaddr addr -> symbolize_addr addr | _ -> disfailwith "ldmxcsr argument cannot be non-memory" in [ Bil.Move (mxcsr, load (size_of_typ reg32_t) src) ] | Fnstcw dst -> let dst = match dst with - | Oaddr addr -> addr + | Oaddr addr -> symbolize_addr addr | _ -> disfailwith "fnstcw argument cannot be non-memory" in [ store reg16_t dst (Bil.Var fpu_ctrl) ] | Fldcw src -> let src = match src with - | Oaddr addr -> addr + | Oaddr addr -> symbolize_addr addr | _ -> disfailwith "fldcw argument cannot be non-memory" in [ Bil.Move (fpu_ctrl, load (size_of_typ reg16_t) src) ] @@ -1938,6 +2049,9 @@ let disasm_instr mode mem addr = let insn arch mem insn = let mode = match arch with `x86 -> X86 | `x86_64 -> X8664 in let addr = Memory.min_addr mem in + (* Fresh displacement-cache for this lift so each instruction gets its own + (independent) displacement IMM vars. *) + Hashtbl.Poly.clear disp_cache; match disasm_instr mode mem addr with | exception No_semantics -> Ok [] | exception Arch_exception (_, msg) -> diff --git a/plugins/x86/x86_sym_imm_targets.ml b/plugins/x86/x86_sym_imm_targets.ml index 4203ede12..8b97b8822 100644 --- a/plugins/x86/x86_sym_imm_targets.ml +++ b/plugins/x86/x86_sym_imm_targets.ml @@ -18,5 +18,8 @@ end module IA32SI = X86_backend.IA32.Make (IA32SI_D) module AMD64SI = X86_backend.AMD64.Make (AMD64SI_D) -module IA32SI_M = X86_backend.IA32.Make (IA32SI_L) -module AMD64SI_M = X86_backend.AMD64.Make (AMD64SI_L) + +(* Bypass the shared backend table so the monolithic sym-imm lifter handles all opcodes. + This makes operand immediates and moffs offsets symbolic via op2e_s/assn_s (Oimm -> Var IMM). *) +module IA32SI_M = IA32SI_L +module AMD64SI_M = AMD64SI_L \ No newline at end of file From c2120f2256a8ae6e4d0ebbc7002bbddac088c9a6 Mon Sep 17 00:00:00 2001 From: Angs12 Date: Thu, 20 Aug 2026 15:03:23 +0300 Subject: [PATCH 06/44] x86: tag RIP-relative addresses before resolution --- lib/bap/bap.mli | 13 +++ lib/bap_core_theory/bap_core_theory.mli | 3 + .../bap_core_theory_program.ml | 2 + .../bap_core_theory_program.mli | 1 + lib/bap_sema/bap_sema_lift.ml | 26 ++++- lib/bap_types/bap_ir.ml | 17 ++- lib/bap_types/bap_ir.mli | 3 + lib/bap_types/bap_stmt.ml | 8 ++ lib/bap_types/bap_stmt.mli | 1 + lib/bap_types/bap_types.ml | 1 + lib/x86_cpu/x86_types.ml | 3 +- plugins/x86/x86_disasm.ml | 104 +++++++++++------- plugins/x86/x86_disasm.mli | 2 +- plugins/x86/x86_legacy_bil_disasm_i386.ml | 1 + plugins/x86/x86_lifter.ml | 32 +++--- plugins/x86/x86_main.ml | 21 ++++ plugins/x86/x86_sym_imm_lifter.ml | 32 +++--- 17 files changed, 195 insertions(+), 75 deletions(-) diff --git a/lib/bap/bap.mli b/lib/bap/bap.mli index f9d94dbc2..fb71e93e3 100644 --- a/lib/bap/bap.mli +++ b/lib/bap/bap.mli @@ -2062,6 +2062,9 @@ module Std : sig @since 2.3.0 *) val code : (Theory.program, stmt list) KB.slot + (** RIP-relative addressing is used in the semantics. *) + val rip_relative : (Theory.Program.Semantics.cls, bool) Knowledge.slot + (** [printf "%a" pp_binop op] prints a binary operation [op]. *) val pp_binop : Format.formatter -> binop -> unit @@ -8982,6 +8985,11 @@ module Std : sig (** updates the right hand side of a definition *) val with_rhs : t -> exp -> t + (** [with_value def v] replaces the RHS with a Core Theory value [v], + preserving the BIL expression inside. Useful for attaching KB + properties to the def's value. *) + val with_value : t -> unit Theory.value -> t + (** [map_exp def f] applies [f] to a [rhs] of [def] and returns an updated definition. *) val map_exp : t -> f:(exp -> exp) -> t @@ -9001,6 +9009,11 @@ module Std : sig include Regular.S with type t := t end + (** [rip_relative_addr] marks a Core Theory value as a RIP-relative + address. Set on the RHS value of defs whose assigned address is + RIP-relative (e.g., Load/Store from RIP-relative instructions). *) + val rip_relative_addr : (Theory.Value.cls, bool) Knowledge.slot + (** A control transfer operation. *) module Jmp : sig (** Jmp is the only way to transfer control from block to block. diff --git a/lib/bap_core_theory/bap_core_theory.mli b/lib/bap_core_theory/bap_core_theory.mli index d0968f920..22dab0ff4 100644 --- a/lib/bap_core_theory/bap_core_theory.mli +++ b/lib/bap_core_theory/bap_core_theory.mli @@ -1987,6 +1987,9 @@ module Theory : sig (** a link is subroutine if it is an entry point to a subroutine. *) val is_subroutine : (program, bool option) KB.slot + (** the instruction uses RIP-relative addressing. *) + val is_rip_relative : (program, bool option) KB.slot + (** [fresh] a fresh label (a shortcut for [KB.create cls]). diff --git a/lib/bap_core_theory/bap_core_theory_program.ml b/lib/bap_core_theory/bap_core_theory_program.ml index 46131b593..94f31fb26 100644 --- a/lib/bap_core_theory/bap_core_theory_program.ml +++ b/lib/bap_core_theory/bap_core_theory_program.ml @@ -211,6 +211,8 @@ module Label = struct "is the program valid or not" let is_subroutine = attr "is-subroutine" "is the program a subroutine entry point" + let is_rip_relative = attr "is-rip-relative" + "the instruction uses RIP-relative addressing" let encoding = Knowledge.Class.property ~package cls "encoding" Language.domain diff --git a/lib/bap_core_theory/bap_core_theory_program.mli b/lib/bap_core_theory/bap_core_theory_program.mli index 6dc903969..350bcb4ba 100644 --- a/lib/bap_core_theory/bap_core_theory_program.mli +++ b/lib/bap_core_theory/bap_core_theory_program.mli @@ -95,6 +95,7 @@ module Label : sig val possible_name : (program, string option opinions) slot val is_valid : (program, bool option) slot val is_subroutine : (program, bool option) slot + val is_rip_relative : (program, bool option) slot val fresh : t knowledge val null : t val for_addr : ?package:string -> Bitvec.t -> t knowledge diff --git a/lib/bap_sema/bap_sema_lift.ml b/lib/bap_sema/bap_sema_lift.ml index bc5c85ed4..810bb4352 100644 --- a/lib/bap_sema/bap_sema_lift.ml +++ b/lib/bap_sema/bap_sema_lift.ml @@ -99,6 +99,19 @@ module IrBuilder = struct let ir_of_insn insn = KB.Value.get Term.slot insn + let mark_rip_relative blks = + let mark_def def = + let v = KB.Value.put rip_relative_addr (Ir_def.value def) true in + Ir_def.with_value def v in + List.map blks ~f:(fun blk -> + Term.map def_t blk ~f:(fun def -> + match Ir_def.rhs def with + | Load _ | Store _ -> mark_def def + | Int _ -> mark_def def (* RIP-relative lea: RAX := 0x404030 *) + | Cast (_, _, (Load _ | Store _)) -> mark_def def + (* RIP-relative movzx/movsx: RDX := pad:64[mem[0x401C, el]:u32] *) + | _ -> def)) + let set_attributes ?addr insn blks = let set_attributes k b = Term.map k b ~f:(fun t -> @@ -113,8 +126,17 @@ module IrBuilder = struct pre: the first block of [blks] is the exit block; post: the first block of [lift_insn insn blks] is the new exit block. *) let lift_insn ?addr insn blks = - append blks @@ - set_attributes ?addr insn (ir_of_insn insn) + let insn_blks = set_attributes ?addr insn (ir_of_insn insn) in + let mark_rip_relative_if_needed insn_blks = + match addr with + | None -> !!insn_blks + | Some addr -> + Theory.Label.for_addr (Word.to_bitvec addr) >>= fun label -> + KB.collect Theory.Label.is_rip_relative label >>= function + | Some true -> KB.return (mark_rip_relative insn_blks) + | _ -> KB.return insn_blks in + mark_rip_relative_if_needed insn_blks >>= fun insn_blks -> + append blks insn_blks let with_first_blk_addressed addr = function | [] -> [] diff --git a/lib/bap_types/bap_ir.ml b/lib/bap_types/bap_ir.ml index d17fbb7ba..fd5cac1f3 100644 --- a/lib/bap_types/bap_ir.ml +++ b/lib/bap_types/bap_ir.ml @@ -200,9 +200,17 @@ end = struct include (val KB.Value.derive cls) end - let to_var v = Theory.Var.create (Var.sort v) (Var.ident v) +let rip_relative_addr = + let bool_domain = Knowledge.Domain.flat ~inspect:Bool.sexp_of_t + ~equal:Bool.equal ~empty:false "bool" in + Knowledge.Class.property ~package + Theory.Value.cls "rip-relative-addr" bool_domain + ~public:true + ~desc:"this value is a RIP-relative address" + + module Def : sig type t = { var : unit Theory.var; @@ -706,6 +714,13 @@ module Ir_def = struct } } + let with_value ({self={Def.var}} as t) v = { + t with self = Def.{ + var; + rhs = Rhs.of_value v + } + } + let map_exp def ~f : def term = with_rhs def (f (rhs def)) diff --git a/lib/bap_types/bap_ir.mli b/lib/bap_types/bap_ir.mli index 7641e809a..6a712d2dc 100644 --- a/lib/bap_types/bap_ir.mli +++ b/lib/bap_types/bap_ir.mli @@ -316,6 +316,7 @@ module Ir_def : sig val rhs : t -> exp val with_lhs : t -> var -> t val with_rhs : t -> exp -> t + val with_value : t -> unit Theory.value -> t val map_exp : t -> f:(exp -> exp) -> t val substitute : t -> exp -> exp -> t val free_vars : t -> Bap_var.Set.t @@ -431,6 +432,8 @@ module Call : sig include Regular.S with type t := t end +val rip_relative_addr : (Theory.Value.cls, bool) KB.slot + module Label : sig type t = label val create : unit -> t diff --git a/lib/bap_types/bap_stmt.ml b/lib/bap_types/bap_stmt.ml index 6f3c366f9..fd3ebd92b 100644 --- a/lib/bap_types/bap_stmt.ml +++ b/lib/bap_types/bap_stmt.ml @@ -212,6 +212,14 @@ let slot = Knowledge.Class.property ~package:"bap" ~public:true ~desc:"semantics of statements in BIL" +let bool_domain = Knowledge.Domain.flat "bool" + ~inspect:sexp_of_bool ~equal:Bool.equal ~empty:false + +let rip_relative = Knowledge.Class.property ~package:"bap" + Theory.Semantics.cls "rip-relative" bool_domain + ~public:true + ~desc:"RIP-relative addressing is used in the semantics" + let code = KB.Class.property ~package:"bap" ~persistent Theory.Program.cls "bil-code" domain ~public:true diff --git a/lib/bap_types/bap_stmt.mli b/lib/bap_types/bap_stmt.mli index 10f70625c..b35bcf98b 100644 --- a/lib/bap_types/bap_stmt.mli +++ b/lib/bap_types/bap_stmt.mli @@ -44,5 +44,6 @@ module Stmts_data : Data.S with type t = stmt list val slot : (Theory.Semantics.cls, stmt list) Knowledge.slot val code : (Theory.program, stmt list) KB.slot +val rip_relative : (Theory.Semantics.cls, bool) Knowledge.slot val domain : stmt list Knowledge.domain val persistent : stmt list Knowledge.persistent diff --git a/lib/bap_types/bap_types.ml b/lib/bap_types/bap_types.ml index 28163a344..f7236dc12 100644 --- a/lib/bap_types/bap_types.ml +++ b/lib/bap_types/bap_types.ml @@ -106,6 +106,7 @@ module Std = struct end let slot = Bap_stmt.slot let code = Bap_stmt.code + let rip_relative = Bap_stmt.rip_relative let domain = Bap_stmt.domain let persistent = Bap_stmt.persistent end diff --git a/lib/x86_cpu/x86_types.ml b/lib/x86_cpu/x86_types.ml index d304bb6a2..14c5cffaa 100644 --- a/lib/x86_cpu/x86_types.ml +++ b/lib/x86_cpu/x86_types.ml @@ -16,6 +16,7 @@ type operand = | Ovec of int | Oseg of int | Oaddr of Exp.t + | Oaddr_rip_relative of Exp.t | Oimm of addr [@@deriving compare] @@ -105,7 +106,7 @@ type opcode = | Movdq of typ * operand * typ * operand * bool (** dst type, dst op, src type, src op, aligned *) | Movoffset of (typ * operand) * offsetinfo list (** dest type, dest, (src copy length, src type, src, src src offset, src dest offset)* *) - | Lea of typ * operand * Exp.t + | Lea of typ * operand * Exp.t * bool | Call of operand * addr (** addr is RA *) | Shift of binop * typ * operand * operand | Shiftd of binop * typ * operand * operand * operand diff --git a/plugins/x86/x86_disasm.ml b/plugins/x86/x86_disasm.ml index e3bbede85..a5135ff63 100644 --- a/plugins/x86/x86_disasm.ml +++ b/plugins/x86/x86_disasm.ml @@ -298,12 +298,12 @@ let parse_instr mode mem addr = (match mode with | X86 -> let (disp, na) = parse_disp32 na in (r, Oaddr (b32 disp), na) - | X8664 -> - let immoff = match naoffset with - | Some (Type.Imm nbits) -> int_exp (nbits / 8) 64 - | _ -> int_exp 0 64 - in - let (disp, na) = parse_disp32 na in (r, Oaddr Bil.(b64 disp + b64 na + immoff), na)) + | X8664 -> + let immoff = match naoffset with + | Some (Type.Imm nbits) -> int_exp (nbits / 8) 64 + | _ -> int_exp 0 64 + in + let (disp, na) = parse_disp32 na in (r, Oaddr_rip_relative Bil.(b64 disp + b64 na + immoff), na)) | _ -> (r, Oaddr(bits2rege rm), na) ) | 1 | 2 -> @@ -510,8 +510,9 @@ let parse_instr mode mem addr = let extend = if Type.equal prefix.opsize reg64_t then reg64_t else reg16_t in (Mov(extend, rm, r, None), na) | 0x8d -> let (r, rm, na) = parse_modrm_addr None na in + let rip_rel = match rm with Oaddr_rip_relative _ -> true | _ -> false in (match rm with - | Oaddr a -> (Lea(prefix.opsize, r, a), na) + | (Oaddr a | Oaddr_rip_relative a) -> (Lea(prefix.opsize, r, a, rip_rel), na) | _ -> disfailwith "invalid lea (must be address)") | 0x8e -> let (r, rm, na) = parse_modrmseg_addr None na in (Mov(reg16_t, r, rm, None), na) @@ -593,34 +594,34 @@ let parse_instr mode mem addr = let b2, _ = parse_int8 na in let (r, rm, na) = parse_modrmext_addr None na in (match r, rm with - | 2, Oaddr _ -> - (match b1 with - | 0xd9 | 0xdd -> (Fst(rm, false), na) - | _ -> - unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) - ) - | 3, Oaddr _ -> - (match b1 with - | 0xd9 | 0xdd -> (Fst(rm, true), na) - | _ -> - unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) - ) - | 5, Oaddr _ -> - (match b1 with - | 0xd9 -> (Fldcw rm, na) - | 0xdb -> (Fld rm, na) - | _ -> - unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) - ) - | 7, Oaddr _ -> - (match b1 with - | 0xd9 -> (Fnstcw rm, na) - | 0xdb -> (Fst(rm, true), na) - | _ -> - unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) - ) - | _, Oaddr _ -> - unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) + | (2, Oaddr _ | 2, Oaddr_rip_relative _) -> + (match b1 with + | 0xd9 | 0xdd -> (Fst(rm, false), na) + | _ -> + unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) + ) + | (3, Oaddr _ | 3, Oaddr_rip_relative _) -> + (match b1 with + | 0xd9 | 0xdd -> (Fst(rm, true), na) + | _ -> + unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) + ) + | (5, Oaddr _ | 5, Oaddr_rip_relative _) -> + (match b1 with + | 0xd9 -> (Fldcw rm, na) + | 0xdb -> (Fld rm, na) + | _ -> + unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) + ) + | (7, Oaddr _ | 7, Oaddr_rip_relative _) -> + (match b1 with + | 0xd9 -> (Fnstcw rm, na) + | 0xdb -> (Fst(rm, true), na) + | _ -> + unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) + ) + | (_, Oaddr _ | _, Oaddr_rip_relative _) -> + unimplemented (Printf.sprintf "unsupported opcode: %02x/%d" b1 r) | _, _ -> unimplemented (Printf.sprintf "unsupported opcode: %02x %s" b1 (Word.string_of_value b2)) ) @@ -801,8 +802,8 @@ let parse_instr mode mem addr = :: {offlen=t; offtyp=reg128_t; offop=s; offsrcoffset=0; offdstoffset=0} :: []), na) | Ovec _, None -> (Movdq(t, s, t, d, false), na) - | Oaddr _, _ -> - (Movdq(t, s, td, d, false), na) + | (Oaddr _, _ | Oaddr_rip_relative _, _) -> + (Movdq(t, s, td, d, false), na) | _ -> disfailwith "impossible") | 0x12 | 0x13 | 0x16 | 0x17 -> (* MOVLPS, MOVLPD, MOVHPS, MOVHPD, MOVHLPS, MOVHLPD, MOVLHPS, MOVLHPD *) let r, rm, rv, na = parse_modrm_vec None na in @@ -1252,8 +1253,35 @@ let parse_instr mode mem addr = sib_extend; } in + let op_has_rip_relative = + let is_rip = function Oaddr_rip_relative _ -> true | _ -> false in + function + | Lea(_, _, _, b) -> b + | Inc(_, a) | Dec(_, a) | Push(_, a) | Pop(_, a) | Not(_, a) | Neg(_, a) + | Mul(_, a) | Div(_, a) | Idiv(_, a) | Bswap(_, a) -> is_rip a + | Stmxcsr a | Ldmxcsr a | Fnstcw a | Fldcw a | Fld a | Cmpxchg8b a + | Interrupt a -> is_rip a + | Mov(_, a, b, _) | Movzx(_, a, _, b) | Movsx(_, a, _, b) + | Movdq(_, a, _, b, _) | Add(_, a, b) | Sub(_, a, b) + | And(_, a, b) | Or(_, a, b) | Xor(_, a, b) | Cmp(_, a, b) + | Adc(_, a, b) | Sbb(_, a, b) | Test(_, a, b) | Xchg(_, a, b) + | Cmpxchg(_, a, b) | Xadd(_, a, b) | Ptest(_, a, b) + | Bt(_, a, b) | Popcnt(_, a, b) | Pmovmskb(_, a, b) + | Rotate(_, _, a, b, _) | Shift(_, _, a, b) | Shiftd(_, _, a, b, _) -> + is_rip a || is_rip b + | Imul(_, _, a, b) | Bs(_, a, b, _) -> is_rip a || is_rip b + | Setcc(_, a, _) | Fst(a, _) -> is_rip a + | Movoffset((_, a), _) -> is_rip a + | Pmov(_, _, _, a, b, _, _) | Pcmp(_, _, _, _, a, b, _) + | Pshufb(_, a, b, _) | Pshufd(_, a, b, _, _) + | Palignr(_, a, b, _, _) | Pcmpstr(_, a, b, _, _, _) + | Pbinop(_, _, _, a, b, _) | Ppackedbinop(_, _, _, _, a, b, _) + | Punpck(_, _, _, a, b, _) -> is_rip a || is_rip b + | Jump(Jabs a) | Call(a, _) | Jcc(Jabs a, _) -> is_rip a + | _ -> false + in let op, a = get_opcode pref prefix a in - (pref, prefix, op, a) + (pref, prefix, op, a, op_has_rip_relative op) let parse_prefixes mode pref _ = let module R = (val (vars_of_mode mode)) in diff --git a/plugins/x86/x86_disasm.mli b/plugins/x86/x86_disasm.mli index e440cab1d..182033146 100644 --- a/plugins/x86/x86_disasm.mli +++ b/plugins/x86/x86_disasm.mli @@ -2,6 +2,6 @@ open Core_kernel[@@warning "-D"] open Bap.Std open X86_types -val parse_instr: mode -> mem -> addr -> int list * prefix * opcode * addr +val parse_instr: mode -> mem -> addr -> int list * prefix * opcode * addr * bool val parse_prefixes: mode -> int list -> opcode -> var option * int List.t diff --git a/plugins/x86/x86_legacy_bil_disasm_i386.ml b/plugins/x86/x86_legacy_bil_disasm_i386.ml index d71378ce1..c79698e8c 100644 --- a/plugins/x86/x86_legacy_bil_disasm_i386.ml +++ b/plugins/x86/x86_legacy_bil_disasm_i386.ml @@ -77,6 +77,7 @@ type operand = | Ovec of int | Oseg of int | Oaddr of Ast.exp + | Oaddr_rip_relative of Ast.exp | Oimm of big_int type jumptarget = diff --git a/plugins/x86/x86_lifter.ml b/plugins/x86/x86_lifter.ml index b4b6459ac..b0b82d804 100644 --- a/plugins/x86/x86_lifter.ml +++ b/plugins/x86/x86_lifter.ml @@ -55,7 +55,7 @@ module ToIR = struct (* There is no 32-bit extension of segment selectors; this is not a bug *) | Oseg r when t = reg16_t -> (bits2segrege r, t) | Oseg _ -> (disfailwith mode "Segment register when t is not r16", t) - | Oaddr e -> (load_s mode ss (size_of_typ t) e, t) + | (Oaddr e | Oaddr_rip_relative e) -> (load_s mode ss (size_of_typ t) e, t) | Oimm i -> Bil.(Int (resize_word i !!t), t) let op2e_s mode ss has_rex t operand = @@ -78,7 +78,7 @@ module ToIR = struct (* There is no 32-bit extension of segment selectors; this is not a bug *) | Oseg r when t = reg16_t -> bits2segrege r | Oseg _ -> disfailwith mode "Segment register when t is not r16" - | Oaddr e -> load_s mode ss (size_of_typ t) e + | (Oaddr e | Oaddr_rip_relative e) -> load_s mode ss (size_of_typ t) e | Oimm i -> Bil.Int (resize_word i !!t) let assn_s mode s has_rex has_vex t v e = @@ -136,7 +136,7 @@ module ToIR = struct Bil.Move (v, e) | Oseg _, _ -> disfailwith mode "Can't assign to non 16 bit segment register" - | Oaddr a, _ -> store_s mode s t a e + | (Oaddr a | Oaddr_rip_relative a), _ -> store_s mode s t a e | Oimm _, _ -> disfailwith mode "disasm x86: Can't assign to an immediate value" @@ -513,7 +513,7 @@ module ToIR = struct let s, al = match s with | Ovec _ | Oreg _ -> (op2e ts s, []) - | Oaddr a -> (op2e ts s, [ a ]) + | (Oaddr a | Oaddr_rip_relative a) -> (op2e ts s, [ a ]) | Oimm _ | Oseg _ -> disfailwith "invalid source operand for movdq" in let d, al = @@ -521,7 +521,7 @@ module ToIR = struct (* Behavior is to clear the xmm bits *) | Ovec _ -> (assn td d Bil.(Cast (UNSIGNED, !!td, s)), al) | Oreg _ -> (assn td d s, al) - | Oaddr a -> (assn td d s, a :: al) + | (Oaddr a | Oaddr_rip_relative a) -> (assn td d s, a :: al) | Oimm _ | Oseg _ -> disfailwith "invalid dest operand for movdq" in (* sources tell me that movdqa raises a general protection exception @@ -643,7 +643,7 @@ module ToIR = struct let src = match src with | Ovec _ -> op2e t src - | Oaddr a -> load (size_of_typ t) a + | (Oaddr a | Oaddr_rip_relative a) -> load (size_of_typ t) a | Oreg _ | Oimm _ | Oseg _ -> disfailwith "invalid" in let vsrc = Option.value ~default:dst vsrc in @@ -752,7 +752,7 @@ module ToIR = struct let im i = Bil.Int (int_of_mode mode i) in let addresses = List.fold - ~f:(fun acc -> function Oaddr a -> a :: acc | _ -> acc) + ~f:(fun acc -> function (Oaddr a | Oaddr_rip_relative a) -> a :: acc | _ -> acc) ~init:[] [ src; dst ] in (* Palignr seems to cause a CPU general protection exception if this fails. @@ -1095,7 +1095,7 @@ module ToIR = struct let check_mem_alignment = match src_op with - | Oaddr addr when op_size = 128 -> + | (Oaddr addr | Oaddr_rip_relative addr) when op_size = 128 -> let word_size = width_of_mode mode in let zero = Bil.int (Word.zero word_size) in let oxf = Bil.int (Word.of_int ~width:word_size 0xf) in @@ -1129,7 +1129,7 @@ module ToIR = struct ]); [ assn exp_type dst_op (Bil.var tmp_dst) ]; ] - | Lea (t, r, a) when List.is_empty pref -> + | Lea (t, r, a, _) when List.is_empty pref -> (* See Table 3-64 *) (* previously, it checked whether addrbits > opbits before the cast_low. * The conclusion we came to was that @@ -1331,7 +1331,7 @@ module ToIR = struct let reg = op2e t bitbase in let shift = Bil.(offset land int_exp Stdlib.(t' - 1) t') in (reg, shift) - | Oaddr a -> + | (Oaddr a | Oaddr_rip_relative a) -> let offset = Bil.(cast unsigned (width_of_mode mode) offset) in let byte = load (size_of_typ reg8_t) Bil.(a + (offset lsr int_exp 3 t')) @@ -1408,7 +1408,7 @@ module ToIR = struct | Stmxcsr dst -> let dst = match dst with - | Oaddr addr -> addr + | (Oaddr addr | Oaddr_rip_relative addr) -> addr | _ -> disfailwith "stmxcsr argument cannot be non-memory" in [ @@ -1417,21 +1417,21 @@ module ToIR = struct | Ldmxcsr src -> let src = match src with - | Oaddr addr -> addr + | (Oaddr addr | Oaddr_rip_relative addr) -> addr | _ -> disfailwith "ldmxcsr argument cannot be non-memory" in [ Bil.Move (mxcsr, load (size_of_typ reg32_t) src) ] | Fnstcw dst -> let dst = match dst with - | Oaddr addr -> addr + | (Oaddr addr | Oaddr_rip_relative addr) -> addr | _ -> disfailwith "fnstcw argument cannot be non-memory" in [ store reg16_t dst (Bil.Var fpu_ctrl) ] | Fldcw src -> let src = match src with - | Oaddr addr -> addr + | (Oaddr addr | Oaddr_rip_relative addr) -> addr | _ -> disfailwith "fldcw argument cannot be non-memory" in [ Bil.Move (fpu_ctrl, load (size_of_typ reg16_t) src) ] @@ -1917,7 +1917,7 @@ module ToIR = struct | Sysenter | Syscall -> [ Bil.(encode call "syscall") ] (* Match everything exhaustively *) | Leave _ -> unimplemented "to_ir: Leave" - | Lea _ -> unimplemented "to_ir: Lea" + | Lea _ -> unimplemented "to_ir: Lea1" | Movs _ -> unimplemented "to_ir: Movs" | Cmps _ -> unimplemented "to_ir: Cmps" | Scas _ -> unimplemented "to_ir: Scas" @@ -1929,7 +1929,7 @@ end let disasm_instr mode mem addr = let module D = X86_disasm in - let pref, prefix, op, na = D.parse_instr mode mem addr in + let pref, prefix, op, na, _rip_rel = D.parse_instr mode mem addr in let has_rex = Option.is_some prefix.rex in let has_vex = Option.is_some prefix.vex in let ss, pref = D.parse_prefixes mode pref op in diff --git a/plugins/x86/x86_main.ml b/plugins/x86/x86_main.ml index 08c190398..918a9b16d 100644 --- a/plugins/x86/x86_main.ml +++ b/plugins/x86/x86_main.ml @@ -93,6 +93,27 @@ let () = let open Bap_core_theory in let open Bap_primus.Std in main !!backend !!kind !!abi; + begin + let open KB.Syntax in + KB.promise Theory.Label.is_rip_relative @@ fun label -> + KB.collect Arch.slot label >>= fun arch -> + match arch with + | `x86_64 -> + begin + KB.collect Memory.slot label >>= fun mem -> + match mem with + | Some mem -> + let addr = Memory.min_addr mem in + let rip_rel = try + let (_pref, _prefix, _op, _a, rip_rel) = + X86_disasm.parse_instr X86_types.X8664 mem addr in + Some rip_rel + with _ -> None in + KB.return rip_rel + | _ -> KB.return None + end + | _ -> KB.return None + end; if !!fp_lifter || !!legacy_lifter then begin let open Bap_core_theory in let open Bap_primus.Std in diff --git a/plugins/x86/x86_sym_imm_lifter.ml b/plugins/x86/x86_sym_imm_lifter.ml index 288e5d4b9..966ee3cb2 100644 --- a/plugins/x86/x86_sym_imm_lifter.ml +++ b/plugins/x86/x86_sym_imm_lifter.ml @@ -164,7 +164,7 @@ module ToIR = struct (* There is no 32-bit extension of segment selectors; this is not a bug *) | Oseg r when t = reg16_t -> (bits2segrege r, t) | Oseg _ -> (disfailwith mode "Segment register when t is not r16", t) - | Oaddr e -> (load_s mode ss (size_of_typ t) (symbolize_addr e), t) + | (Oaddr e | Oaddr_rip_relative e) -> (load_s mode ss (size_of_typ t) (symbolize_addr e), t) | Oimm i -> Bil.(Var (Var.create ~is_virtual:true "IMM" t), t) let op2e_s mode ss has_rex t operand = @@ -187,7 +187,7 @@ module ToIR = struct (* There is no 32-bit extension of segment selectors; this is not a bug *) | Oseg r when t = reg16_t -> bits2segrege r | Oseg _ -> disfailwith mode "Segment register when t is not r16" - | Oaddr e -> load_s mode ss (size_of_typ t) (symbolize_addr e) + | (Oaddr e | Oaddr_rip_relative e) -> load_s mode ss (size_of_typ t) (symbolize_addr e) | Oimm i -> Bil.(Var (Var.create ~is_virtual:true "IMM" t)) let assn_s mode s has_rex has_vex t v e = @@ -245,7 +245,7 @@ module ToIR = struct Bil.Move (v, e) | Oseg _, _ -> disfailwith mode "Can't assign to non 16 bit segment register" - | Oaddr a, _ -> store_s mode s t (symbolize_addr a) e + | (Oaddr a | Oaddr_rip_relative a), _ -> store_s mode s t (symbolize_addr a) e | Oimm _, _ -> disfailwith mode "disasm x86: Can't assign to an immediate value" @@ -622,7 +622,7 @@ module ToIR = struct let s, al = match s with | Ovec _ | Oreg _ -> (op2e ts s, []) - | Oaddr a -> (op2e ts s, [ symbolize_addr a ]) + | (Oaddr a | Oaddr_rip_relative a) -> (op2e ts s, [ symbolize_addr a ]) | Oimm _ | Oseg _ -> disfailwith "invalid source operand for movdq" in let d, al = @@ -630,7 +630,7 @@ module ToIR = struct (* Behavior is to clear the xmm bits *) | Ovec _ -> (assn td d Bil.(Cast (UNSIGNED, !!td, s)), al) | Oreg _ -> (assn td d s, al) - | Oaddr a -> (assn td d s, symbolize_addr a :: al) + | (Oaddr a | Oaddr_rip_relative a) -> (assn td d s, symbolize_addr a :: al) | Oimm _ | Oseg _ -> disfailwith "invalid dest operand for movdq" in (* sources tell me that movdqa raises a general protection exception @@ -752,7 +752,7 @@ module ToIR = struct let src = match src with | Ovec _ -> op2e t src - | Oaddr a -> load (size_of_typ t) (symbolize_addr a) + | (Oaddr a | Oaddr_rip_relative a) -> load (size_of_typ t) (symbolize_addr a) | Oreg _ | Oimm _ | Oseg _ -> disfailwith "invalid" in let vsrc = Option.value ~default:dst vsrc in @@ -861,7 +861,7 @@ module ToIR = struct let im i = Bil.Int (int_of_mode mode i) in let addresses = List.fold - ~f:(fun acc -> function Oaddr a -> a :: acc | _ -> acc) + ~f:(fun acc -> function (Oaddr a | Oaddr_rip_relative a) -> a :: acc | _ -> acc) ~init:[] [ src; dst ] in (* Palignr seems to cause a CPU general protection exception if this fails. @@ -1204,7 +1204,7 @@ module ToIR = struct let check_mem_alignment = match src_op with - | Oaddr addr when op_size = 128 -> + | (Oaddr addr | Oaddr_rip_relative addr) when op_size = 128 -> let word_size = width_of_mode mode in let zero = Bil.int (Word.zero word_size) in let oxf = Bil.int (Word.of_int ~width:word_size 0xf) in @@ -1238,7 +1238,7 @@ module ToIR = struct ]); [ assn exp_type dst_op (Bil.var tmp_dst) ]; ] - | Lea (t, r, a) when List.is_empty pref -> + | Lea (t, r, a, _) when List.is_empty pref -> (* See Table 3-64 *) (* previously, it checked whether addrbits > opbits before the cast_low. * The conclusion we came to was that @@ -1442,7 +1442,7 @@ module ToIR = struct let reg = op2e t bitbase in let shift = Bil.(offset land int_exp Stdlib.(t' - 1) t') in (reg, shift) - | Oaddr a -> + | (Oaddr a | Oaddr_rip_relative a) -> let offset = Bil.(cast unsigned (width_of_mode mode) offset) in let byte = load (size_of_typ reg8_t) Bil.(symbolize_addr a + (offset lsr int_exp 3 t')) @@ -1519,7 +1519,7 @@ module ToIR = struct | Stmxcsr dst -> let dst = match dst with - | Oaddr addr -> symbolize_addr addr + | (Oaddr addr | Oaddr_rip_relative addr) -> symbolize_addr addr | _ -> disfailwith "stmxcsr argument cannot be non-memory" in [ @@ -1528,21 +1528,21 @@ module ToIR = struct | Ldmxcsr src -> let src = match src with - | Oaddr addr -> symbolize_addr addr + | (Oaddr addr | Oaddr_rip_relative addr) -> symbolize_addr addr | _ -> disfailwith "ldmxcsr argument cannot be non-memory" in [ Bil.Move (mxcsr, load (size_of_typ reg32_t) src) ] | Fnstcw dst -> let dst = match dst with - | Oaddr addr -> symbolize_addr addr + | (Oaddr addr | Oaddr_rip_relative addr) -> symbolize_addr addr | _ -> disfailwith "fnstcw argument cannot be non-memory" in [ store reg16_t dst (Bil.Var fpu_ctrl) ] | Fldcw src -> let src = match src with - | Oaddr addr -> symbolize_addr addr + | (Oaddr addr | Oaddr_rip_relative addr) -> symbolize_addr addr | _ -> disfailwith "fldcw argument cannot be non-memory" in [ Bil.Move (fpu_ctrl, load (size_of_typ reg16_t) src) ] @@ -2028,7 +2028,7 @@ module ToIR = struct | Sysenter | Syscall -> [ Bil.(encode call "syscall") ] (* Match everything exhaustively *) | Leave _ -> unimplemented "to_ir: Leave" - | Lea _ -> unimplemented "to_ir: Lea" + | Lea _ -> unimplemented "to_ir: Lea1" | Movs _ -> unimplemented "to_ir: Movs" | Cmps _ -> unimplemented "to_ir: Cmps" | Scas _ -> unimplemented "to_ir: Scas" @@ -2040,7 +2040,7 @@ end let disasm_instr mode mem addr = let module D = X86_disasm in - let pref, prefix, op, na = D.parse_instr mode mem addr in + let pref, prefix, op, na, _rip_rel = D.parse_instr mode mem addr in let has_rex = Option.is_some prefix.rex in let has_vex = Option.is_some prefix.vex in let ss, pref = D.parse_prefixes mode pref op in From 1a81e7b3ea41a8f82fa3d10ea75a4d38631dcb0a Mon Sep 17 00:00:00 2001 From: Angs12 Date: Fri, 21 Aug 2026 18:23:27 +0300 Subject: [PATCH 07/44] build: migrate to OCaml 5.3 and Jane Street 0.17 --- bap-abi.opam | 4 +- bap-analyze.opam | 4 +- bap-api.opam | 4 +- bap-arm.opam | 4 +- bap-beagle-strings.opam | 4 +- bap-beagle.opam | 4 +- bap-bil.opam | 4 +- bap-bml.opam | 4 +- bap-build.opam | 4 +- bap-bundle.opam | 4 +- bap-byteweight-frontend.opam | 4 +- bap-byteweight.opam | 4 +- bap-c.opam | 4 +- bap-cache.opam | 4 +- bap-callgraph-collator.opam | 4 +- bap-callsites.opam | 4 +- bap-common.opam | 8 +- bap-constant-tracker.opam | 4 +- bap-core-theory.opam | 4 +- bap-core.opam | 2 +- bap-cxxfilt.opam | 4 +- bap-demangle.opam | 4 +- bap-dependencies.opam | 4 +- bap-disassemble.opam | 4 +- bap-dump-symbols.opam | 4 +- bap-dwarf.opam | 4 +- bap-elementary.opam | 4 +- bap-elf.opam | 6 +- bap-extra.opam | 2 +- bap-flatten.opam | 4 +- bap-frontc.opam | 4 +- bap-frontend.opam | 4 +- bap-future.opam | 4 +- bap-ghidra.opam | 4 +- bap-glibc-runtime.opam | 4 +- bap-ida-plugin.opam | 4 +- bap-ida.opam | 4 +- bap-knowledge.opam | 4 +- bap-llvm.opam | 4 +- bap-main.opam | 6 +- bap-mc.opam | 4 +- bap-microx.opam | 4 +- bap-mips.opam | 4 +- bap-objdump.opam | 4 +- bap-optimization.opam | 4 +- bap-patterns.opam | 4 +- bap-phoenix.opam | 5 +- bap-piqi.opam | 35 --- bap-plugins.opam | 4 +- bap-powerpc.opam | 4 +- bap-primus-dictionary.opam | 4 +- bap-primus-exploring-scheduler.opam | 4 +- bap-primus-greedy-scheduler.opam | 4 +- bap-primus-limit.opam | 4 +- bap-primus-lisp.opam | 4 +- bap-primus-loader.opam | 4 +- bap-primus-mark-visited.opam | 4 +- bap-primus-powerpc.opam | 4 +- bap-primus-print.opam | 4 +- bap-primus-promiscuous.opam | 4 +- bap-primus-propagate-taint.opam | 4 +- bap-primus-random.opam | 4 +- bap-primus-region.opam | 4 +- bap-primus-round-robin-scheduler.opam | 4 +- bap-primus-support.opam | 2 +- bap-primus-symbolic-executor.opam | 4 +- bap-primus-systems.opam | 4 +- bap-primus-taint.opam | 4 +- bap-primus-test.opam | 4 +- bap-primus-track-visited.opam | 4 +- bap-primus-wandering-scheduler.opam | 4 +- bap-primus-x86.opam | 4 +- bap-primus.opam | 6 +- bap-print.opam | 4 +- bap-radare2.opam | 4 +- bap-raw.opam | 4 +- bap-recipe-command.opam | 4 +- bap-recipe.opam | 6 +- bap-relation.opam | 2 +- bap-relocatable.opam | 4 +- bap-report.opam | 4 +- bap-riscv.opam | 4 +- bap-run.opam | 4 +- bap-signatures.opam | 2 +- bap-specification.opam | 4 +- bap-ssa.opam | 4 +- bap-std.opam | 6 +- bap-strings.opam | 4 +- bap-stub-resolver.opam | 4 +- bap-symbol-reader.opam | 4 +- bap-systemz.opam | 4 +- bap-taint-propagator.opam | 4 +- bap-taint.opam | 4 +- bap-term-mapper.opam | 4 +- bap-thumb.opam | 4 +- bap-toplevel.opam | 4 +- bap-trace.opam | 4 +- bap-traces.opam | 4 +- bap-trivial-condition-form.opam | 4 +- bap-warn-unused.opam | 4 +- bap-x86.opam | 4 +- bap.opam | 2 +- bare.opam | 6 +- bitvec-binprot.opam | 4 +- bitvec-order.opam | 4 +- bitvec-sexp.opam | 4 +- bitvec.opam | 2 +- dune-project | 269 +++++++++--------- graphlib.opam | 4 +- lib/arm/arm_lifter.ml | 10 +- lib/arm/arm_target.ml | 2 +- lib/bap/bap.mli | 2 +- lib/bap/bap_project.ml | 8 +- lib/bap/bap_self.ml | 8 +- lib/bap_bml/bap_bml.ml | 2 +- lib/bap_bundle/bap_bundle.ml | 14 +- lib/bap_byteweight/bap_byteweight.ml | 4 +- .../bap_byteweight_signatures.ml | 8 +- lib/bap_c/bap_c_abi.ml | 10 +- lib/bap_core_theory/bap_core_theory.ml | 4 +- lib/bap_core_theory/bap_core_theory.mli | 10 +- .../bap_core_theory_definition.ml | 4 +- .../bap_core_theory_manager.ml | 4 +- .../bap_core_theory_program.ml | 2 +- lib/bap_core_theory/bap_core_theory_target.ml | 20 +- lib/bap_core_theory/bap_core_theory_value.ml | 4 +- lib/bap_core_theory/bap_core_theory_value.mli | 2 +- lib/bap_core_theory/bap_core_theory_var.ml | 2 +- lib/bap_disasm/bap_disasm_basic.ml | 26 +- lib/bap_disasm/bap_disasm_brancher.ml | 8 +- lib/bap_disasm/bap_disasm_calls.ml | 8 +- lib/bap_disasm/bap_disasm_driver.ml | 32 +-- lib/bap_disasm/bap_disasm_insn.ml | 22 +- lib/bap_disasm/bap_disasm_reconstructor.ml | 22 +- lib/bap_disasm/bap_disasm_rooter.ml | 6 +- lib/bap_disasm/bap_disasm_symbolizer.ml | 6 +- lib/bap_disasm/bap_disasm_symtab.ml | 26 +- lib/bap_disasm/bap_disasm_target_factory.ml | 4 +- lib/bap_dwarf/dwarf_data.ml | 4 +- lib/bap_dwarf/dwarf_fbi.ml | 20 +- lib/bap_elf/elf_parse.ml | 2 +- lib/bap_future/bap_future.ml | 2 +- lib/bap_image/bap_image.ml | 10 +- lib/bap_image/bap_memory.ml | 2 +- lib/bap_image/bap_table.ml | 68 ++--- lib/bap_llvm/bap_llvm_loader.ml | 4 +- lib/bap_llvm/config/llvm_configurator.ml | 8 +- lib/bap_main/bap_main.ml | 22 +- lib/bap_main/bap_main_event.ml | 10 +- lib/bap_main/bap_main_log.ml | 6 +- lib/bap_piqi/bil_piqi.ml | 261 ----------------- lib/bap_piqi/bil_piqi.mli | 18 -- lib/bap_piqi/bir_piqi.ml | 160 ----------- lib/bap_piqi/bir_piqi.mli | 18 -- lib/bap_piqi/dune | 27 -- lib/bap_piqi/exp.piqi | 193 ------------- lib/bap_piqi/ir.piqi | 97 ------- lib/bap_piqi/stmt.piqi | 79 ----- lib/bap_piqi/test/run_piqi_tests.ml | 100 ------- lib/bap_piqi/type.piqi | 110 ------- lib/bap_plugins/bap_common.ml | 4 +- lib/bap_plugins/bap_plugins.ml | 10 +- lib/bap_plugins/bap_plugins_units.ml | 6 +- lib/bap_primus/bap_primus.mli | 4 +- lib/bap_primus/bap_primus_env.ml | 8 +- lib/bap_primus/bap_primus_exn.ml | 4 +- lib/bap_primus/bap_primus_generator.ml | 2 +- lib/bap_primus/bap_primus_interpreter.ml | 4 +- lib/bap_primus/bap_primus_linker.ml | 10 +- lib/bap_primus/bap_primus_lisp.ml | 12 +- lib/bap_primus/bap_primus_lisp_attribute.ml | 4 +- lib/bap_primus/bap_primus_lisp_attributes.ml | 8 +- lib/bap_primus/bap_primus_lisp_context.ml | 16 +- lib/bap_primus/bap_primus_lisp_def.ml | 10 +- lib/bap_primus/bap_primus_lisp_parse.ml | 8 +- lib/bap_primus/bap_primus_lisp_program.ml | 55 ++-- lib/bap_primus/bap_primus_lisp_resolve.ml | 2 +- lib/bap_primus/bap_primus_lisp_semantics.ml | 16 +- lib/bap_primus/bap_primus_lisp_source.ml | 16 +- lib/bap_primus/bap_primus_machine.ml | 8 +- lib/bap_primus/bap_primus_memory.ml | 4 +- lib/bap_primus/bap_primus_state.ml | 2 +- lib/bap_primus/bap_primus_types.ml | 4 +- lib/bap_primus_machine/bap_primus_machine.ml | 8 +- .../bap_primus_track_visited.ml | 2 +- lib/bap_recipe/bap_recipe.ml | 4 +- lib/bap_relation/bap_relation.ml | 4 +- lib/bap_sema/bap_sema_free_vars.ml | 20 +- lib/bap_sema/bap_sema_lift.ml | 2 +- lib/bap_sema/bap_sema_ssa.ml | 14 +- lib/bap_sema/bap_sema_taint.ml | 8 +- lib/bap_strings/bap_strings_detector.ml | 2 +- lib/bap_strings/bap_strings_index.ml | 2 +- lib/bap_strings/bap_strings_scanner.ml | 4 +- lib/bap_strings/bap_strings_unscrambler.ml | 2 +- lib/bap_taint/bap_taint.ml | 20 +- lib/bap_traces/bap_trace.ml | 8 +- lib/bap_traces/bap_trace_id.ml | 2 +- lib/bap_traces/bap_trace_meta.ml | 4 +- lib/bap_traces/bap_trace_traces.ml | 2 +- lib/bap_types/bap_bil_optimizations.ml | 4 +- lib/bap_types/bap_bil_pass.ml | 2 +- lib/bap_types/bap_bitvector.ml | 6 +- lib/bap_types/bap_context.ml | 2 +- lib/bap_types/bap_helpers.ml | 18 +- lib/bap_types/bap_ir.ml | 20 +- lib/bap_types/bap_ir_callgraph.ml | 2 +- lib/bap_types/bap_ir_graph.ml | 12 +- lib/bap_types/bap_ogre.ml | 2 +- lib/bap_types/bap_result.ml | 2 +- lib/bap_types/bap_toplevel.ml | 2 +- lib/bap_types/bap_trie.ml | 70 ++++- lib/bap_types/bap_value.ml | 10 +- lib/bap_types/bap_var.ml | 2 +- lib/bare/bare.ml | 6 +- lib/bitvec_binprot/bitvec_binprot.ml | 2 +- lib/graphlib/graphlib.mli | 2 +- lib/graphlib/graphlib_graph.ml | 42 +-- lib/graphlib/graphlib_pp.ml | 2 +- lib/graphlib/graphlib_regular.ml | 6 +- lib/knowledge/bap_knowledge.ml | 52 ++-- lib/knowledge/bap_knowledge.mli | 8 +- lib/microx/microx_conqueror.ml | 8 +- lib/monads/dune | 2 +- lib/monads/monads_monad.ml | 14 +- lib/monads/monads_monad.mli | 4 +- lib/monads/monads_monoid.ml | 14 +- lib/ogre/ogre.ml | 17 +- lib/regular/regular.mli | 2 + lib/regular/regular_bytes.ml | 2 +- lib/regular/regular_cache.ml | 2 +- lib/regular/regular_data.ml | 65 ++--- lib/regular/regular_opaque.ml | 4 + lib/regular/regular_seq.ml | 2 +- lib/text_tags/text_tags.ml | 30 +- lib/x86_cpu/x86_cpu.ml | 4 +- lib_test/bap/run_tests.ml | 4 +- lib_test/bap_image/test_image.ml | 8 +- lib_test/bap_types/test_graph.ml | 30 +- lib_test/powerpc/powerpc_move_tests.ml | 2 +- lib_test/powerpc/powerpc_tests_helpers.ml | 16 +- monads.opam | 4 +- ogre.opam | 4 +- plugins/analyze/analyze_main.ml | 4 +- plugins/api/api_main.ml | 4 +- plugins/beagle/beagle_main.ml | 10 +- plugins/bil/bil_float.ml | 32 +-- plugins/bil/bil_ir.ml | 4 +- plugins/bil/bil_lifter.ml | 4 +- plugins/bil/bil_semantics.ml | 6 +- plugins/byteweight/byteweight_main.ml | 4 +- plugins/cache/bap_cache.ml | 8 +- plugins/cache/bap_cache_gc.ml | 6 +- plugins/cache/bap_cache_main.ml | 4 +- plugins/cache/bap_cache_utils.ml | 4 +- .../callgraph_collator_main.ml | 6 +- .../constant_tracker/constant_tracker_main.ml | 2 +- plugins/dependencies/dependencies_main.ml | 10 +- plugins/disassemble/disassemble_main.ml | 20 +- plugins/disassemble/disassemble_main_rules.ml | 8 +- .../emit_ida_script/emit_ida_script_main.ml | 2 +- plugins/frontc_parser/frontc_parser_main.ml | 4 +- plugins/glibc_runtime/glibc_runtime_main.ml | 4 +- plugins/ida/bap_ida_info.ml | 2 +- plugins/ida/bap_ida_service.ml | 8 +- plugins/ida/ida_main.ml | 8 +- plugins/mips/mips.ml | 4 +- plugins/mips/mips_cpu.ml | 4 +- plugins/mips/mips_model.ml | 32 +-- plugins/mips/mips_rtl.ml | 2 +- plugins/objdump/objdump_main.ml | 8 +- plugins/optimization/optimization_data.ml | 2 +- plugins/optimization/optimization_main.ml | 10 +- plugins/patterns/patterns_main.ml | 16 +- plugins/phoenix/phoenix_root.ml | 2 +- plugins/piqi_printers/dune | 12 - plugins/piqi_printers/piqi_printers_main.ml | 71 ----- plugins/piqi_printers/piqi_printers_main.mli | 0 plugins/powerpc/powerpc.ml | 2 +- plugins/powerpc/powerpc.mli | 5 + plugins/powerpc/powerpc_dsl.ml | 18 ++ plugins/powerpc/powerpc_dsl.mli | 5 + plugins/powerpc/powerpc_load.ml | 16 +- plugins/powerpc/powerpc_model.ml | 24 +- plugins/powerpc/powerpc_rtl.ml | 2 +- plugins/powerpc/powerpc_store.ml | 12 +- .../primus_dictionary_main.ml | 6 +- .../primus_exploring/primus_exploring_main.ml | 2 +- plugins/primus_limit/primus_limit_main.ml | 2 +- .../primus_lisp/primus_lisp_documentation.ml | 2 +- plugins/primus_lisp/primus_lisp_ieee754.ml | 2 +- plugins/primus_lisp/primus_lisp_io.ml | 8 +- plugins/primus_lisp/primus_lisp_main.ml | 2 +- plugins/primus_lisp/primus_lisp_primitives.ml | 2 +- plugins/primus_loader/primus_loader_basic.ml | 2 +- plugins/primus_print/primus_print_main.ml | 2 +- .../primus_promiscuous_main.ml | 2 +- .../primus_propagate_taint_main.ml | 12 +- plugins/primus_random/primus_random_main.ml | 4 +- plugins/primus_region/primus_region_main.ml | 2 +- .../primus_round_robin_main.ml | 2 +- .../primus_symbolic_executor_main.ml | 22 +- plugins/primus_systems/primus_systems_main.ml | 2 +- plugins/primus_test/primus_test_main.ml | 6 +- .../primus_wandering/primus_wandering_main.ml | 4 +- plugins/primus_x86/primus_x86_loader.ml | 2 +- plugins/print/print_main.ml | 4 +- .../propagate_taint/propagate_taint_main.ml | 12 +- plugins/propagate_taint/propagator.ml | 18 +- plugins/raw/raw_main.ml | 4 +- plugins/read_symbols/read_symbols_main.ml | 2 +- plugins/report/report_main.ml | 2 +- plugins/run/run_main.ml | 6 +- plugins/strings/strings_main.ml | 4 +- plugins/stub_resolver/stub_resolver.ml | 16 +- plugins/stub_resolver/stub_resolver_main.ml | 16 +- plugins/thumb/thumb_branch.ml | 2 +- plugins/thumb/thumb_branch.mli | 2 +- plugins/thumb/thumb_main.ml | 2 +- plugins/thumb/thumb_mem.ml | 2 +- plugins/thumb/thumb_mem.mli | 2 +- plugins/warn_unused/warn_unused_main.ml | 2 +- plugins/x86/x86_backend.ml | 6 +- plugins/x86/x86_legacy_bil_arithmetic.ml | 2 +- plugins/x86/x86_legacy_bil_pp.ml | 12 +- plugins/x86/x86_legacy_bil_semantics.ml | 10 +- plugins/x86/x86_prefix.ml | 2 +- plugins/x86/x86_utils.ml | 2 +- ppx_bap.opam | 34 +-- regular.opam | 4 +- src/bap_byteweight_main.ml | 12 +- src/bap_frontend.ml | 4 +- text-tags.opam | 4 +- tools/bapbundle.ml | 2 +- tools/bapdoc.ml | 4 +- tools/rewrite.ml | 12 +- 336 files changed, 1340 insertions(+), 2438 deletions(-) delete mode 100644 bap-piqi.opam delete mode 100644 lib/bap_piqi/bil_piqi.ml delete mode 100644 lib/bap_piqi/bil_piqi.mli delete mode 100644 lib/bap_piqi/bir_piqi.ml delete mode 100644 lib/bap_piqi/bir_piqi.mli delete mode 100644 lib/bap_piqi/dune delete mode 100644 lib/bap_piqi/exp.piqi delete mode 100644 lib/bap_piqi/ir.piqi delete mode 100644 lib/bap_piqi/stmt.piqi delete mode 100644 lib/bap_piqi/test/run_piqi_tests.ml delete mode 100644 lib/bap_piqi/type.piqi delete mode 100644 plugins/piqi_printers/dune delete mode 100644 plugins/piqi_printers/piqi_printers_main.ml delete mode 100644 plugins/piqi_printers/piqi_printers_main.mli diff --git a/bap-abi.opam b/bap-abi.opam index f9b888bcd..3d506934f 100644 --- a/bap-abi.opam +++ b/bap-abi.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-pass" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "regular" {= version} diff --git a/bap-analyze.opam b/bap-analyze.opam index 46ecdfa53..563ef40ee 100644 --- a/bap-analyze.opam +++ b/bap-analyze.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-command" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} "bap-std" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "linenoise" {>= "1.1.0" & < "2.0.0"} "monads" {= version} "bap-common" {= version} diff --git a/bap-api.opam b/bap-api.opam index 646e14c57..99b89556a 100644 --- a/bap-api.opam +++ b/bap-api.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-plugin" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "fileutils" "ppx_bap" {= version} "regular" {= version} diff --git a/bap-arm.opam b/bap-arm.opam index b83285d8f..863c7507b 100644 --- a/bap-arm.opam +++ b/bap-arm.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin" "bap-library" "arm"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-api" {= version} "bap-core-theory" {= version} @@ -21,7 +21,7 @@ depends: [ "bap-traces" {= version} "bitvec-order" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "bap-common" {= version} "ogre" {= version} diff --git a/bap-beagle-strings.opam b/bap-beagle-strings.opam index 9a6d57979..c7a2ba231 100644 --- a/bap-beagle-strings.opam +++ b/bap-beagle-strings.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "bap-beagle" {= version} "ppx_bap" {= version} diff --git a/bap-beagle.opam b/bap-beagle.opam index 7270ca63c..de745dace 100644 --- a/bap-beagle.opam +++ b/bap-beagle.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-future" {= version} "bap-microx" {= version} "bap-primus" {= version} "bap-std" {= version} "bap-strings" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "bap-common" {= version} "ppx_bap" {= version} diff --git a/bap-bil.opam b/bap-bil.opam index e83bc7991..c099aea35 100644 --- a/bap-bil.opam +++ b/bap-bil.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core-theory" {= version} "bap-future" {= version} "bap-knowledge" {= version} @@ -17,7 +17,7 @@ depends: [ "bap-std" {= version} "bitvec-order" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "bap-common" {= version} "ogre" {= version} diff --git a/bap-bml.opam b/bap-bml.opam index e8b751a24..b6c172535 100644 --- a/bap-bml.opam +++ b/bap-bml.opam @@ -9,9 +9,9 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "odoc" {with-doc} diff --git a/bap-build.opam b/bap-build.opam index 91519beba..1a5b66718 100644 --- a/bap-build.opam +++ b/bap-build.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-tool" "ocamlbuild"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ocamlbuild" "ocamlfind" diff --git a/bap-bundle.opam b/bap-bundle.opam index ac9cc7adf..0837a59c3 100644 --- a/bap-bundle.opam +++ b/bap-bundle.opam @@ -9,9 +9,9 @@ tags: ["bap" "bap-tool"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "camlzip" {>= "1.0" & < "2.0"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "fileutils" "bap-common" {= version} "ppx_bap" {= version} diff --git a/bap-byteweight-frontend.opam b/bap-byteweight-frontend.opam index 82ce3b459..6d410703f 100644 --- a/bap-byteweight-frontend.opam +++ b/bap-byteweight-frontend.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-frontend" "bap-command"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-byteweight" {= version} "bap-std" {= version} "cmdliner" {>= "1.0" & < "2.0"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "fileutils" "bap-common" {= version} "ocurl" {>= "0.9.0"} diff --git a/bap-byteweight.opam b/bap-byteweight.opam index 30eebb787..5340b46f1 100644 --- a/bap-byteweight.opam +++ b/bap-byteweight.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-library" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-signatures" {= version} "bap-std" {= version} "camlzip" {>= "1.0" & < "2.0"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "regular" {= version} diff --git a/bap-c.opam b/bap-c.opam index 03065f4c5..0ff67b9a6 100644 --- a/bap-c.opam +++ b/bap-c.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-library" "c"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-api" {= version} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "odoc" {with-doc} diff --git a/bap-cache.opam b/bap-cache.opam index 5091474c2..d3322c2f0 100644 --- a/bap-cache.opam +++ b/bap-cache.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "fileutils" "mmap" "bap-common" {= version} diff --git a/bap-callgraph-collator.opam b/bap-callgraph-collator.opam index 818d1bba6..4d29a1d3c 100644 --- a/bap-callgraph-collator.opam +++ b/bap-callgraph-collator.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-analysis"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "graphlib" {= version} "bap-common" {= version} "ppx_bap" {= version} diff --git a/bap-callsites.opam b/bap-callsites.opam index f3ab5be24..1c46c2948 100644 --- a/bap-callsites.opam +++ b/bap-callsites.opam @@ -9,9 +9,9 @@ tags: ["bap" "bap-plugin" "bap-pass"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "odoc" {with-doc} ] diff --git a/bap-common.opam b/bap-common.opam index 38b5e8d38..826ba295e 100644 --- a/bap-common.opam +++ b/bap-common.opam @@ -9,12 +9,12 @@ tags: ["bap" "meta"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "base" {>= "v0.14" & < "v0.16"} - "dune" {>= "3.1"} + "base" {>= "v0.17" & < "v0.18"} + "dune" {>= "3.8"} "dune-configurator" "dune-site" - "ocaml" {> "4.08.0"} - "stdio" {>= "v0.14" & < "v0.16"} + "ocaml" {>= "5.1.0"} + "stdio" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-constant-tracker.opam b/bap-constant-tracker.opam index 5694ea248..947818b0e 100644 --- a/bap-constant-tracker.opam +++ b/bap-constant-tracker.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-analysis" "bap-plugin" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "odoc" {with-doc} ] diff --git a/bap-core-theory.opam b/bap-core-theory.opam index 23dba49f1..f88dad394 100644 --- a/bap-core-theory.opam +++ b/bap-core-theory.opam @@ -11,14 +11,14 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-knowledge" {= version} "bap-main" {= version} "bitvec" {= version} "bitvec-binprot" {= version} "bitvec-order" {= version} "bitvec-sexp" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "odoc" {with-doc} diff --git a/bap-core.opam b/bap-core.opam index 9e5ecf3e9..1e1fc987e 100644 --- a/bap-core.opam +++ b/bap-core.opam @@ -10,7 +10,7 @@ tags: ["bap" "meta"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-analyze" {= version} "bap-api" {= version} diff --git a/bap-cxxfilt.opam b/bap-cxxfilt.opam index cacc15a35..2046f1464 100644 --- a/bap-cxxfilt.opam +++ b/bap-cxxfilt.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-demangle" {= version} "bap-std" {= version} "conf-binutils" {>= "0.3"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "odoc" {with-doc} ] diff --git a/bap-demangle.opam b/bap-demangle.opam index 35563b8a5..ab813f50c 100644 --- a/bap-demangle.opam +++ b/bap-demangle.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "odoc" {with-doc} ] diff --git a/bap-dependencies.opam b/bap-dependencies.opam index d7410b4cf..640b94abe 100644 --- a/bap-dependencies.opam +++ b/bap-dependencies.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-command"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ogre" {= version} "ppx_bap" {= version} diff --git a/bap-disassemble.opam b/bap-disassemble.opam index 86181fbd0..db79e51b3 100644 --- a/bap-disassemble.opam +++ b/bap-disassemble.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-command"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} @@ -19,7 +19,7 @@ depends: [ "bitvec-order" {= version} "bitvec-sexp" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "bap-common" {= version} "ogre" {= version} diff --git a/bap-dump-symbols.opam b/bap-dump-symbols.opam index f5e68a388..a8b15e0dc 100644 --- a/bap-dump-symbols.opam +++ b/bap-dump-symbols.opam @@ -9,9 +9,9 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "graphlib" {= version} "bap-common" {= version} "ppx_bap" {= version} diff --git a/bap-dwarf.opam b/bap-dwarf.opam index 04f466622..3f81e5d1d 100644 --- a/bap-dwarf.opam +++ b/bap-dwarf.opam @@ -9,9 +9,9 @@ tags: ["bap" "bap-library" "dwarf"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "regular" {= version} diff --git a/bap-elementary.opam b/bap-elementary.opam index 23ada57ad..91b354e12 100644 --- a/bap-elementary.opam +++ b/bap-elementary.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-library" "floating-points"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-std" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-elf.opam b/bap-elf.opam index 000bfa8e4..2807bcd85 100644 --- a/bap-elf.opam +++ b/bap-elf.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-plugin" "elf"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-dwarf" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} - "ppx_bitstring" {>= "4.0.0" & < "5.0.0"} + "ppx_bitstring" {>= "4.0.0"} "regular" {= version} "odoc" {with-doc} ] diff --git a/bap-extra.opam b/bap-extra.opam index 73afb837f..b03168bf6 100644 --- a/bap-extra.opam +++ b/bap-extra.opam @@ -10,7 +10,7 @@ tags: ["bap" "meta"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap" {= version} "bap-byteweight-frontend" {= version} "bap-elf" {= version} diff --git a/bap-flatten.opam b/bap-flatten.opam index bbd4f305a..1d1e50ec0 100644 --- a/bap-flatten.opam +++ b/bap-flatten.opam @@ -9,9 +9,9 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "odoc" {with-doc} ] diff --git a/bap-frontc.opam b/bap-frontc.opam index aaa71bcb4..31a327946 100644 --- a/bap-frontc.opam +++ b/bap-frontc.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-plugin" "c"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-c" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "FrontC" {>= "4.1.0"} "bap-common" {= version} "odoc" {with-doc} diff --git a/bap-frontend.opam b/bap-frontend.opam index 9352f4ce0..f3279a95e 100644 --- a/bap-frontend.opam +++ b/bap-frontend.opam @@ -9,12 +9,12 @@ tags: ["bap" "bap-command"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ocamlfind" "regular" {= version} diff --git a/bap-future.opam b/bap-future.opam index f3de322c7..6430511ad 100644 --- a/bap-future.opam +++ b/bap-future.opam @@ -11,8 +11,8 @@ tags: ["bap" "future"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "bap-common" {= version} "odoc" {with-doc} diff --git a/bap-ghidra.opam b/bap-ghidra.opam index eead1e0f5..9d6a9f39a 100644 --- a/bap-ghidra.opam +++ b/bap-ghidra.opam @@ -9,8 +9,8 @@ tags: ["bap" "ghidra" "disassembler"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ppx_bap" {= version} "bap-common" {= version} "bap-std" {= version} diff --git a/bap-glibc-runtime.opam b/bap-glibc-runtime.opam index e45ad10b0..072455f8b 100644 --- a/bap-glibc-runtime.opam +++ b/bap-glibc-runtime.opam @@ -9,12 +9,12 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-c" {= version} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ogre" {= version} "odoc" {with-doc} diff --git a/bap-ida-plugin.opam b/bap-ida-plugin.opam index 64e0120f6..091095dcc 100644 --- a/bap-ida-plugin.opam +++ b/bap-ida-plugin.opam @@ -9,9 +9,9 @@ tags: ["bap" "bap-plugin" "bap-ida" "ida-pro"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "regular" {= version} diff --git a/bap-ida.opam b/bap-ida.opam index 3e7a7c1c8..7c3a75ece 100644 --- a/bap-ida.opam +++ b/bap-ida.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-library" "ida-pro"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "regular" {= version} "fileutils" "bap-common" {= version} diff --git a/bap-knowledge.opam b/bap-knowledge.opam index 0d7ace58d..e7ce1188b 100644 --- a/bap-knowledge.opam +++ b/bap-knowledge.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-library" "knowledge"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ppx_bap" {= version} "bap-common" {= version} "monads" {= version} diff --git a/bap-llvm.opam b/bap-llvm.opam index fbcfcc1a2..c2b3714ee 100644 --- a/bap-llvm.opam +++ b/bap-llvm.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-plugin" "llvm"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-std" {= version} "conf-bap-llvm" {>= "1.8"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "mmap" "monads" {= version} "bap-common" {= version} diff --git a/bap-main.opam b/bap-main.opam index 1384328d1..1ea2f4ae8 100644 --- a/bap-main.opam +++ b/bap-main.opam @@ -9,15 +9,15 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-build" {= version} "bap-future" {= version} "bap-plugins" {= version} "bap-recipe" {= version} - "base" {>= "v0.14" & < "v0.16"} + "base" {>= "v0.17" & < "v0.18"} "cmdliner" {>= "1.0" & < "2.0"} "bap-common" {= version} - "stdio" {>= "v0.14" & < "v0.16"} + "stdio" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-mc.opam b/bap-mc.opam index 40a9a4496..9e0896d0b 100644 --- a/bap-mc.opam +++ b/bap-mc.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-command"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} "bap-std" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ogre" {= version} "ppx_bap" {= version} diff --git a/bap-microx.opam b/bap-microx.opam index 5ca6452db..b92fa299d 100644 --- a/bap-microx.opam +++ b/bap-microx.opam @@ -9,9 +9,9 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "bap-common" {= version} "ppx_bap" {= version} diff --git a/bap-mips.opam b/bap-mips.opam index f1ea9e606..8a630b1a8 100644 --- a/bap-mips.opam +++ b/bap-mips.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin" "mips"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-api" {= version} "bap-core-theory" {= version} @@ -17,7 +17,7 @@ depends: [ "bap-knowledge" {= version} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ogre" {= version} "ppx_bap" {= version} diff --git a/bap-objdump.opam b/bap-objdump.opam index 0aebe19d9..192453d16 100644 --- a/bap-objdump.opam +++ b/bap-objdump.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} @@ -19,7 +19,7 @@ depends: [ "bitvec-sexp" {= version} "bitvec" {= version} "conf-binutils" {>= "0.3"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "re" {>= "1.0" & < "2.0"} diff --git a/bap-optimization.opam b/bap-optimization.opam index 3a7cc8a3c..232290c88 100644 --- a/bap-optimization.opam +++ b/bap-optimization.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-plugin" "bap-pass"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "bap-std" {= version} diff --git a/bap-patterns.opam b/bap-patterns.opam index 7b9676e8b..f91705735 100644 --- a/bap-patterns.opam +++ b/bap-patterns.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin" "bap-command"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} @@ -20,7 +20,7 @@ depends: [ "bitvec-order" {= version} "bitvec-sexp" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "fileutils" "bap-common" {= version} "ppx_bap" {= version} diff --git a/bap-phoenix.opam b/bap-phoenix.opam index d8abb8ba0..10c5cb141 100644 --- a/bap-phoenix.opam +++ b/bap-phoenix.opam @@ -9,12 +9,11 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-std" {= version} "cmdliner" - "cmdliner" {>= "1.0" & < "2.0"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ezjsonm" "graphlib" {= version} "ppx_bap" {= version} diff --git a/bap-piqi.opam b/bap-piqi.opam deleted file mode 100644 index 61b3b62ab..000000000 --- a/bap-piqi.opam +++ /dev/null @@ -1,35 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -version: "dev" -synopsis: "Serializes BAP Project in various formats using piqi" -maintainer: ["Ivan Gotovchits "] -authors: ["The BAP Team"] -license: "MIT" -tags: ["bap" "bap-plugin"] -homepage: "https://github.com/BinaryAnalysisPlatform/bap" -bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" -depends: [ - "dune" {>= "3.1"} - "bap-common" {= version} - "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} - "piqi" {>= "0.7.8"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "--promote-install-files=false" - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] - ["dune" "install" "-p" name "--create-install-files" name] -] -dev-repo: "git+https://github.com/BinaryAnalysisPlatform/bap.git" diff --git a/bap-plugins.opam b/bap-plugins.opam index 784ef9f73..91dba4d41 100644 --- a/bap-plugins.opam +++ b/bap-plugins.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-bundle" {= version} "bap-future" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "fileutils" "ocamlfind" "ppx_bap" {= version} diff --git a/bap-powerpc.opam b/bap-powerpc.opam index ac5cee521..bda618443 100644 --- a/bap-powerpc.opam +++ b/bap-powerpc.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin" "powerpc"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-api" {= version} "bap-common" {= version} @@ -18,7 +18,7 @@ depends: [ "bap-knowledge" {= version} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "ogre" {= version} "ppx_bap" {= version} diff --git a/bap-primus-dictionary.opam b/bap-primus-dictionary.opam index 450a6485a..0d18481d6 100644 --- a/bap-primus-dictionary.opam +++ b/bap-primus-dictionary.opam @@ -9,12 +9,12 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-core-theory" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-primus-exploring-scheduler.opam b/bap-primus-exploring-scheduler.opam index e8d0b2bf0..c5ebf915c 100644 --- a/bap-primus-exploring-scheduler.opam +++ b/bap-primus-exploring-scheduler.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-greedy-scheduler.opam b/bap-primus-greedy-scheduler.opam index e8d0b2bf0..c5ebf915c 100644 --- a/bap-primus-greedy-scheduler.opam +++ b/bap-primus-greedy-scheduler.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-limit.opam b/bap-primus-limit.opam index b461ad79a..bb94d2a07 100644 --- a/bap-primus-limit.opam +++ b/bap-primus-limit.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-primus-lisp.opam b/bap-primus-lisp.opam index 1b2adc595..f9ffbbbc5 100644 --- a/bap-primus-lisp.opam +++ b/bap-primus-lisp.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-core-theory" {= version} "bap-knowledge" {= version} @@ -17,7 +17,7 @@ depends: [ "bap-primus" {= version} "bap-std" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "regular" {= version} "odoc" {with-doc} diff --git a/bap-primus-loader.opam b/bap-primus-loader.opam index d8072e954..fbc4915de 100644 --- a/bap-primus-loader.opam +++ b/bap-primus-loader.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ogre" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-mark-visited.opam b/bap-primus-mark-visited.opam index f0dbd8429..ae9e61222 100644 --- a/bap-primus-mark-visited.opam +++ b/bap-primus-mark-visited.opam @@ -9,12 +9,12 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus-track-visited" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-primus-powerpc.opam b/bap-primus-powerpc.opam index ca01881cc..ead6a4fe6 100644 --- a/bap-primus-powerpc.opam +++ b/bap-primus-powerpc.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-primus-print.opam b/bap-primus-print.opam index 9c7a5e889..852aa4efa 100644 --- a/bap-primus-print.opam +++ b/bap-primus-print.opam @@ -9,14 +9,14 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-core-theory" {= version} "bap-future" {= version} "bap-primus" {= version} "bap-std" {= version} "bare" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-promiscuous.opam b/bap-primus-promiscuous.opam index b98fbb057..5cfd499a0 100644 --- a/bap-primus-promiscuous.opam +++ b/bap-primus-promiscuous.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-propagate-taint.opam b/bap-primus-propagate-taint.opam index 849dcf30f..e71fa56e0 100644 --- a/bap-primus-propagate-taint.opam +++ b/bap-primus-propagate-taint.opam @@ -9,12 +9,12 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} "bap-taint" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-random.opam b/bap-primus-random.opam index 6c2fe76a2..54a13403f 100644 --- a/bap-primus-random.opam +++ b/bap-primus-random.opam @@ -9,14 +9,14 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-main" {= version} "bap-primus" {= version} "bap-std" {= version} "bitvec-sexp" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "zarith" "odoc" {with-doc} diff --git a/bap-primus-region.opam b/bap-primus-region.opam index c331c980c..797271912 100644 --- a/bap-primus-region.opam +++ b/bap-primus-region.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus" "bap-primus-lisp"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-round-robin-scheduler.opam b/bap-primus-round-robin-scheduler.opam index e8d0b2bf0..c5ebf915c 100644 --- a/bap-primus-round-robin-scheduler.opam +++ b/bap-primus-round-robin-scheduler.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-support.opam b/bap-primus-support.opam index f111dfd89..dd8651a36 100644 --- a/bap-primus-support.opam +++ b/bap-primus-support.opam @@ -9,7 +9,7 @@ tags: ["bap" "meta"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-primus-exploring-scheduler" {= version} "bap-primus-greedy-scheduler" {= version} "bap-primus-limit" {= version} diff --git a/bap-primus-symbolic-executor.opam b/bap-primus-symbolic-executor.opam index c8bae944b..2a7e8e3a9 100644 --- a/bap-primus-symbolic-executor.opam +++ b/bap-primus-symbolic-executor.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-primus-track-visited" {= version} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "regular" {= version} "bitvec" {= version} diff --git a/bap-primus-systems.opam b/bap-primus-systems.opam index a5ea180a2..6ceb4742d 100644 --- a/bap-primus-systems.opam +++ b/bap-primus-systems.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-knowledge" {= version} "bap-main" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-taint.opam b/bap-primus-taint.opam index 26e77081b..bccec681a 100644 --- a/bap-primus-taint.opam +++ b/bap-primus-taint.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-taint" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-test.opam b/bap-primus-test.opam index 93c8c67ad..520935b0b 100644 --- a/bap-primus-test.opam +++ b/bap-primus-test.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-primus-track-visited.opam b/bap-primus-track-visited.opam index b9b4d4b4e..3246fee56 100644 --- a/bap-primus-track-visited.opam +++ b/bap-primus-track-visited.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-primus-wandering-scheduler.opam b/bap-primus-wandering-scheduler.opam index e8d0b2bf0..c5ebf915c 100644 --- a/bap-primus-wandering-scheduler.opam +++ b/bap-primus-wandering-scheduler.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "odoc" {with-doc} ] diff --git a/bap-primus-x86.opam b/bap-primus-x86.opam index 8287f7ff6..c68dd76f2 100644 --- a/bap-primus-x86.opam +++ b/bap-primus-x86.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-x86" {= version} "odoc" {with-doc} ] diff --git a/bap-primus.opam b/bap-primus.opam index c5d395e63..93d9eb2cb 100644 --- a/bap-primus.opam +++ b/bap-primus.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-library" "bap-primus"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-common" {= version} "bap-core-theory" {= version} @@ -20,10 +20,10 @@ depends: [ "bap-strings" {= version} "bitvec-binprot" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "graphlib" {= version} "monads" {= version} - "parsexp" {>= "v0.14" & < "v0.16"} + "parsexp" {>= "v0.17" & < "v0.18"} "ppx_bap" {= version} "regular" {= version} "uuidm" {>= "0.9.7"} diff --git a/bap-print.opam b/bap-print.opam index e96015b10..344980490 100644 --- a/bap-print.opam +++ b/bap-print.opam @@ -9,12 +9,12 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-demangle" {= version} "bap-knowledge" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "graphlib" {= version} "ogre" {= version} "ppx_bap" {= version} diff --git a/bap-radare2.opam b/bap-radare2.opam index 6dec2df3f..3d0c5265b 100644 --- a/bap-radare2.opam +++ b/bap-radare2.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin" "radare2"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-arm" {= version} "bap-common" {= version} @@ -21,7 +21,7 @@ depends: [ "bap-std" {= version} "bitvec" {= version} "conf-radare2" - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ogre" {= version} "ppx_bap" {= version} "re" {>= "1.0" & < "2.0"} diff --git a/bap-raw.opam b/bap-raw.opam index 8d8a4935d..2c665d437 100644 --- a/bap-raw.opam +++ b/bap-raw.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "bap-std" {= version} diff --git a/bap-recipe-command.opam b/bap-recipe-command.opam index 1c83d1688..7aebcfa7c 100644 --- a/bap-recipe-command.opam +++ b/bap-recipe-command.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-command" "bap-tool"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-main" {= version} "bap-recipe" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-recipe.opam b/bap-recipe.opam index 30bfdf7d2..84a3d9698 100644 --- a/bap-recipe.opam +++ b/bap-recipe.opam @@ -11,10 +11,10 @@ tags: ["bap" "bap-tool" "command-line"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} - "parsexp" {>= "v0.14" & < "v0.16"} - "stdio" {>= "v0.14" & < "v0.16"} + "parsexp" {>= "v0.17" & < "v0.18"} + "stdio" {>= "v0.17" & < "v0.18"} "stdlib-shims" "uuidm" {>= "0.9.7"} "odoc" {with-doc} diff --git a/bap-relation.opam b/bap-relation.opam index a4169dc0a..ae2bc85f8 100644 --- a/bap-relation.opam +++ b/bap-relation.opam @@ -11,7 +11,7 @@ tags: ["bap" "data-structure"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "odoc" {with-doc} ] diff --git a/bap-relocatable.opam b/bap-relocatable.opam index 5ca8913cd..62adaee03 100644 --- a/bap-relocatable.opam +++ b/bap-relocatable.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-arm" {= version} "bap-common" {= version} @@ -23,7 +23,7 @@ depends: [ "bitvec-order" {= version} "bitvec-sexp" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "ogre" {= version} "ppx_bap" {= version} diff --git a/bap-report.opam b/bap-report.opam index bd1decb2c..53e0df24a 100644 --- a/bap-report.opam +++ b/bap-report.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "bap-std" {= version} "odoc" {with-doc} diff --git a/bap-riscv.opam b/bap-riscv.opam index ba986487e..fd1b3b508 100644 --- a/bap-riscv.opam +++ b/bap-riscv.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin" "riscv"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-api" {= version} "bap-common" {= version} @@ -17,7 +17,7 @@ depends: [ "bap-c" {= version} "bap-knowledge" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "ogre" {= version} "ppx_bap" {= version} diff --git a/bap-run.opam b/bap-run.opam index 38acb0bfb..a2b63d7ff 100644 --- a/bap-run.opam +++ b/bap-run.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-primus" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "graphlib" {= version} "monads" {= version} "regular" {= version} diff --git a/bap-signatures.opam b/bap-signatures.opam index 2a6d77568..7293e31d8 100644 --- a/bap-signatures.opam +++ b/bap-signatures.opam @@ -9,7 +9,7 @@ tags: ["bap" "data"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "odoc" {with-doc} ] dev-repo: "git+https://github.com/BinaryAnalysisPlatform/bap.git" diff --git a/bap-specification.opam b/bap-specification.opam index 74e4dff1d..a84f53219 100644 --- a/bap-specification.opam +++ b/bap-specification.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-command"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ogre" {= version} "odoc" {with-doc} ] diff --git a/bap-ssa.opam b/bap-ssa.opam index bbf6c0638..055aa5c1e 100644 --- a/bap-ssa.opam +++ b/bap-ssa.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-std.opam b/bap-std.opam index 91c0c275b..d18af7e8c 100644 --- a/bap-std.opam +++ b/bap-std.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-bundle" {= version} "bap-core-theory" {= version} @@ -23,12 +23,12 @@ depends: [ "bitvec" {= version} "camlzip" {>= "1.07" & < "2.0"} "cmdliner" - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "fileutils" "graphlib" {= version} "mmap" "monads" {= version} - "ocamlfind" {>= "1.5.6" & < "2.0.0"} + "ocamlfind" {>= "1.9.0" & < "2.0.0"} "ogre" {= version} "ounit" "ppx_bap" {= version} diff --git a/bap-strings.opam b/bap-strings.opam index 2a1970abd..87754a48c 100644 --- a/bap-strings.opam +++ b/bap-strings.opam @@ -21,8 +21,8 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "ppx_bap" {= version} "odoc" {with-doc} diff --git a/bap-stub-resolver.opam b/bap-stub-resolver.opam index d1dd3c727..82f9e8c29 100644 --- a/bap-stub-resolver.opam +++ b/bap-stub-resolver.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-common" {= version} "bap-core-theory" {= version} @@ -19,7 +19,7 @@ depends: [ "bitvec-order" {= version} "bitvec-sexp" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ogre" {= version} "ppx_bap" {= version} "odoc" {with-doc} diff --git a/bap-symbol-reader.opam b/bap-symbol-reader.opam index f4a6d0124..1eee24de3 100644 --- a/bap-symbol-reader.opam +++ b/bap-symbol-reader.opam @@ -9,14 +9,14 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} "bap-relation" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bap-systemz.opam b/bap-systemz.opam index 46f2949d4..64edfdd52 100644 --- a/bap-systemz.opam +++ b/bap-systemz.opam @@ -9,14 +9,14 @@ tags: ["bap" "bap-plugins"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-core-theory" {= version} "bap-knowledge" {= version} "bap-main" {= version} "bap-std" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ogre" {= version} "ppx_bap" {= version} "odoc" {with-doc} diff --git a/bap-taint-propagator.opam b/bap-taint-propagator.opam index b7918b6cc..13998ac9f 100644 --- a/bap-taint-propagator.opam +++ b/bap-taint-propagator.opam @@ -9,11 +9,11 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-core-theory" {= version} "bap-microx" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "graphlib" {= version} "monads" {= version} "regular" {= version} diff --git a/bap-taint.opam b/bap-taint.opam index 4fc2a1581..d14c3e1b8 100644 --- a/bap-taint.opam +++ b/bap-taint.opam @@ -9,12 +9,12 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-primus" {= version} "bap-std" {= version} "bap-strings" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "monads" {= version} "ppx_bap" {= version} "regular" {= version} diff --git a/bap-term-mapper.opam b/bap-term-mapper.opam index b57b3d56c..7a0566e7b 100644 --- a/bap-term-mapper.opam +++ b/bap-term-mapper.opam @@ -9,12 +9,12 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-bml" {= version} "bap-common" {= version} "bap-main" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ppx_bap" {= version} "regular" {= version} "odoc" {with-doc} diff --git a/bap-thumb.opam b/bap-thumb.opam index 96c77c4bc..7704ed6ef 100644 --- a/bap-thumb.opam +++ b/bap-thumb.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-arm" {= version} "bap-common" {= version} "bap-core-theory" {= version} @@ -17,7 +17,7 @@ depends: [ "bap-main" {= version} "bap-std" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ogre" {= version} "ppx_bap" {= version} "odoc" {with-doc} diff --git a/bap-toplevel.opam b/bap-toplevel.opam index 3c4179888..b549ecfde 100644 --- a/bap-toplevel.opam +++ b/bap-toplevel.opam @@ -11,10 +11,10 @@ tags: ["bap" "toplevel"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ocamlfind" "odoc" {with-doc} ] diff --git a/bap-trace.opam b/bap-trace.opam index 3d18922c2..de4012802 100644 --- a/bap-trace.opam +++ b/bap-trace.opam @@ -9,13 +9,13 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-future" {= version} "bap-plugins" {= version} "bap-std" {= version} "bap-traces" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ppx_bap" {= version} "regular" {= version} "uri" diff --git a/bap-traces.opam b/bap-traces.opam index fd3a34b41..496577ab9 100644 --- a/bap-traces.opam +++ b/bap-traces.opam @@ -9,10 +9,10 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} "bap-std" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ppx_bap" {= version} "regular" {= version} "uri" {>= "1.9.0"} diff --git a/bap-trivial-condition-form.opam b/bap-trivial-condition-form.opam index c4ae59347..653d09000 100644 --- a/bap-trivial-condition-form.opam +++ b/bap-trivial-condition-form.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "bap-std" {= version} "odoc" {with-doc} diff --git a/bap-warn-unused.opam b/bap-warn-unused.opam index 0bb27692c..ee2adfb07 100644 --- a/bap-warn-unused.opam +++ b/bap-warn-unused.opam @@ -9,8 +9,8 @@ tags: ["bap" "bap-plugin"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "bap-std" {= version} "odoc" {with-doc} diff --git a/bap-x86.opam b/bap-x86.opam index 4305b3a1a..7745cfb57 100644 --- a/bap-x86.opam +++ b/bap-x86.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-plugin" "bap-library" "x86" "x86-64"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-abi" {= version} "bap-api" {= version} "bap-common" {= version} @@ -23,7 +23,7 @@ depends: [ "bap-primus" {= version} "bap-std" {= version} "bitvec" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ogre" {= version} "ppx_bap" {= version} "regular" {= version} diff --git a/bap.opam b/bap.opam index c55fb23e2..af65bb6f6 100644 --- a/bap.opam +++ b/bap.opam @@ -9,7 +9,7 @@ tags: ["bap" "meta"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-core" {= version} "bap-beagle" {= version} "bap-beagle-strings" {= version} diff --git a/bare.opam b/bare.opam index 3cd1fc74d..01836e872 100644 --- a/bare.opam +++ b/bare.opam @@ -11,10 +11,10 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} - "parsexp" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} + "parsexp" {>= "v0.17" & < "v0.18"} "odoc" {with-doc} ] build: [ diff --git a/bitvec-binprot.opam b/bitvec-binprot.opam index 3d7b3f5fa..f077606b3 100644 --- a/bitvec-binprot.opam +++ b/bitvec-binprot.opam @@ -9,8 +9,8 @@ tags: ["bap"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "bin_prot" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "bin_prot" {>= "v0.17" & < "v0.18"} "bitvec" {= version} "ppx_bap" {= version} "odoc" {with-doc} diff --git a/bitvec-order.opam b/bitvec-order.opam index a600fc070..fdc69b90d 100644 --- a/bitvec-order.opam +++ b/bitvec-order.opam @@ -9,8 +9,8 @@ tags: ["bap"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "base" {>= "v0.14"} + "dune" {>= "3.8"} + "base" {>= "v0.16"} "bitvec-sexp" {= version} "bitvec" {= version} "odoc" {with-doc} diff --git a/bitvec-sexp.opam b/bitvec-sexp.opam index d8259050c..bf3499749 100644 --- a/bitvec-sexp.opam +++ b/bitvec-sexp.opam @@ -9,8 +9,8 @@ tags: ["bap" "sexp"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "sexplib0" {>= "v0.14"} + "dune" {>= "3.8"} + "sexplib0" {>= "v0.16"} "bitvec" {= version} "odoc" {with-doc} ] diff --git a/bitvec.opam b/bitvec.opam index 1e4555cad..82e278e7b 100644 --- a/bitvec.opam +++ b/bitvec.opam @@ -9,7 +9,7 @@ tags: ["bap" "bap-library"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "zarith" {>= "1.4"} "odoc" {with-doc} ] diff --git a/dune-project b/dune-project index 52e68ced4..3cece679b 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.1) +(lang dune 3.8) (cram enable) (using dune_site 0.1) @@ -136,12 +136,12 @@ (share signatures) (share site_lisp)) (depends - (base (and (>= v0.14) (< v0.16))) + (base (and (>= v0.17) (< v0.18))) dune dune-configurator dune-site - (ocaml (> 4.08.0)) - (stdio (and (>= v0.14) (< v0.16))))) + (ocaml (>= 5.1.0)) + (stdio (and (>= v0.17) (< v0.18))))) (package (name bap-primus-support) @@ -176,7 +176,7 @@ (depends (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)) (regular (= :version)))) @@ -191,7 +191,7 @@ (bap-main (= :version)) (bap-std (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (linenoise (and (>= 1.1.0) (< 2.0.0))) (monads (= :version)) (bap-common (= :version)) @@ -204,7 +204,7 @@ (depends (bap-common (= :version)) (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) fileutils (ppx_bap (= :version)) (regular (= :version)))) @@ -225,7 +225,7 @@ (bap-traces (= :version)) (bitvec-order (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (bap-common (= :version)) (ogre (= :version)) @@ -243,7 +243,7 @@ (bap-primus (= :version)) (bap-std (= :version)) (bap-strings (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (bap-common (= :version)) (ppx_bap (= :version)) @@ -261,7 +261,7 @@ (bap-std (= :version)) (bitvec-order (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (bap-common (= :version)) (ogre (= :version)) @@ -273,7 +273,7 @@ (tags (bap bap-library)) (depends (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)))) @@ -285,7 +285,7 @@ (bap-signatures (= :version)) (bap-std (= :version)) (camlzip (and (>= 1.0) (< 2.0))) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)) (regular (= :version)) @@ -299,7 +299,7 @@ (bap-byteweight (= :version)) (bap-std (= :version)) (cmdliner (and (>= 1.0) (< 2.0))) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) fileutils (bap-common (= :version)) (ocurl (>= 0.9.0)) @@ -311,7 +311,7 @@ (synopsis "BAP Build Tool (ocamlbuild+bap)") (tags (bap bap-tool ocamlbuild)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) ocamlbuild ocamlfind @@ -323,7 +323,7 @@ (tags (bap bap-tool)) (depends (camlzip (and (>= 1.0) (< 2.0))) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) fileutils (bap-common (= :version)) (ppx_bap (= :version)) @@ -339,7 +339,7 @@ (bap-core-theory (= :version)) (bap-knowledge (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)))) @@ -350,7 +350,7 @@ (depends (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) fileutils mmap (bap-common (= :version)) @@ -365,7 +365,7 @@ (depends (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (graphlib (= :version)) (bap-common (= :version)) (ppx_bap (= :version)) @@ -378,7 +378,7 @@ (tags (bap bap-plugin bap-pass)) (depends (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)))) (package @@ -398,7 +398,7 @@ details of the program behavior.") (bitvec-binprot (= :version)) (bitvec-order (= :version)) (bitvec-sexp (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)))) @@ -409,7 +409,7 @@ details of the program behavior.") (depends (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)))) (package @@ -420,7 +420,7 @@ details of the program behavior.") (bap-demangle (= :version)) (bap-std (= :version)) (conf-binutils (>= 0.3)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)))) (package @@ -431,7 +431,7 @@ details of the program behavior.") (bap-core-theory (= :version)) (bap-knowledge (= :version)) (bap-main (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)))) (package @@ -441,7 +441,7 @@ details of the program behavior.") (depends (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ogre (= :version)) (ppx_bap (= :version)) @@ -461,7 +461,7 @@ details of the program behavior.") (bitvec-order (= :version)) (bitvec-sexp (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (bap-common (= :version)) (ogre (= :version)) @@ -474,7 +474,7 @@ details of the program behavior.") (tags (bap bap-plugin)) (depends (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (graphlib (= :version)) (bap-common (= :version)) (ppx_bap (= :version)) @@ -486,7 +486,7 @@ details of the program behavior.") (tags (bap bap-library dwarf)) (depends (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)) (regular (= :version)))) @@ -501,7 +501,7 @@ details of the program behavior.") (bap-knowledge (= :version)) (bap-std (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-elf) @@ -510,10 +510,10 @@ details of the program behavior.") (depends (bap-dwarf (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)) - (ppx_bitstring (and (>= 4.0.0) (< 5.0.0))) + (ppx_bitstring (>= 4.0.0)) (regular (= :version)))) (package @@ -522,7 +522,7 @@ details of the program behavior.") (tags (bap bap-plugin)) (depends (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)))) (package @@ -534,7 +534,7 @@ details of the program behavior.") (bap-knowledge (= :version)) (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) ocamlfind (regular (= :version)))) @@ -546,7 +546,7 @@ details of the program behavior.") (depends (bap-c (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (FrontC (>= 4.1.0)) (bap-common (= :version)))) @@ -558,7 +558,7 @@ A library for reasoning about state based dynamic systems. This can \ be seen as a common denominator between Lwt and Async libraries.") (tags (bap future)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (bap-common (= :version)))) @@ -568,7 +568,7 @@ be seen as a common denominator between Lwt and Async libraries.") (tags (bap ghidra disassembler)) (allow_empty) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ppx_bap (= :version)) (bap-common (= :version)) (bap-std (= :version)) @@ -583,7 +583,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-c (= :version)) (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ogre (= :version)))) @@ -591,7 +591,7 @@ be seen as a common denominator between Lwt and Async libraries.") (synopsis "BAP IDA Pro integration") (tags (bap bap-library ida-pro)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (regular (= :version)) fileutils (bap-common (= :version)) @@ -604,7 +604,7 @@ be seen as a common denominator between Lwt and Async libraries.") (tags (bap bap-plugin bap-ida ida-pro)) (depends (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)) (regular (= :version)))) @@ -614,7 +614,7 @@ be seen as a common denominator between Lwt and Async libraries.") (synopsis "Knowledge Reasoning and Representation Framework") (tags (bap bap-library knowledge)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ppx_bap (= :version)) (bap-common (= :version)) (monads (= :version)))) @@ -626,7 +626,7 @@ be seen as a common denominator between Lwt and Async libraries.") (depends (bap-std (= :version)) (conf-bap-llvm (>= 1.8)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) mmap (monads (= :version)) (bap-common (= :version)) @@ -642,10 +642,10 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-future (= :version)) (bap-plugins (= :version)) (bap-recipe (= :version)) - (base (and (>= v0.14) (< v0.16))) + (base (and (>= v0.17) (< v0.18))) (cmdliner (and (>= 1.0) (< 2.0))) (bap-common (= :version)) - (stdio (and (>= v0.14) (< v0.16))))) + (stdio (and (>= v0.17) (< v0.18))))) (package (name bap-mc) @@ -657,7 +657,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-main (= :version)) (bap-std (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ogre (= :version)) (ppx_bap (= :version)) @@ -669,7 +669,7 @@ be seen as a common denominator between Lwt and Async libraries.") (tags (bap bap-plugin)) (depends (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (bap-common (= :version)) (ppx_bap (= :version)))) @@ -686,7 +686,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-knowledge (= :version)) (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ogre (= :version)) (ppx_bap (= :version)) @@ -707,7 +707,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bitvec-sexp (= :version)) (bitvec (= :version)) (conf-binutils (>= 0.3)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)) (re (and (>= 1.0) (< 2.0))))) @@ -717,7 +717,7 @@ be seen as a common denominator between Lwt and Async libraries.") (synopsis "A BAP IR optimization pass") (tags (bap bap-plugin bap-pass)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)) (bap-std (= :version)) @@ -739,7 +739,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bitvec-order (= :version)) (bitvec-sexp (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) fileutils (bap-common (= :version)) (ppx_bap (= :version)) @@ -754,24 +754,13 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-std (= :version)) cmdliner - (cmdliner (and (>= 1.0) (< 2.0))) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) ezjsonm (graphlib (= :version)) (ppx_bap (= :version)) (regular (= :version)) (text-tags (= :version)))) -(package - (name bap-piqi) - (synopsis "Serializes BAP Project in various formats using piqi") - (tags (bap bap-plugin)) - (depends - (bap-common (= :version)) - (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) - (piqi (>= 0.7.8)))) - (package (name bap-plugins) (synopsis "BAP Plugin management library") @@ -780,7 +769,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-bundle (= :version)) (bap-future (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) fileutils ocamlfind (ppx_bap (= :version)) @@ -799,7 +788,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-knowledge (= :version)) (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (ogre (= :version)) (ppx_bap (= :version)) @@ -821,10 +810,10 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-strings (= :version)) (bitvec-binprot (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (graphlib (= :version)) (monads (= :version)) - (parsexp (and (>= v0.14) (< v0.16))) + (parsexp (and (>= v0.17) (< v0.18))) (ppx_bap (= :version)) (regular (= :version)) (uuidm (>= 0.9.7)))) @@ -838,7 +827,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-core-theory (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-primus-exploring-scheduler) @@ -848,7 +837,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -859,7 +848,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -870,7 +859,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-primus-lisp) @@ -884,7 +873,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-primus (= :version)) (bap-std (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (regular (= :version)))) @@ -896,7 +885,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ogre (= :version)))) (package @@ -908,7 +897,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-primus-track-visited (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-primus-powerpc) @@ -918,7 +907,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-primus-print) @@ -931,7 +920,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-primus (= :version)) (bap-std (= :version)) (bare (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -942,7 +931,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -954,7 +943,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-primus (= :version)) (bap-std (= :version)) (bap-taint (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -968,7 +957,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-std (= :version)) (bitvec-sexp (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) zarith)) @@ -980,7 +969,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -991,7 +980,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -1005,7 +994,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-primus-track-visited (= :version)) (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (regular (= :version)) (bitvec (= :version)) @@ -1022,7 +1011,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-main (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -1033,7 +1022,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-taint (= :version)))) (package @@ -1044,7 +1033,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-primus-track-visited) @@ -1054,7 +1043,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-primus-wandering-scheduler) @@ -1064,7 +1053,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)))) (package @@ -1075,7 +1064,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-common (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-x86 (= :version)))) (package @@ -1087,7 +1076,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-demangle (= :version)) (bap-knowledge (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (graphlib (= :version)) (ogre (= :version)) (ppx_bap (= :version)) @@ -1112,7 +1101,7 @@ be seen as a common denominator between Lwt and Async libraries.") (bap-std (= :version)) (bitvec (= :version)) conf-radare2 - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ogre (= :version)) (ppx_bap (= :version)) (re (and (>= 1.0) (< 2.0))) @@ -1124,7 +1113,7 @@ be seen as a common denominator between Lwt and Async libraries.") (synopsis "BAP raw files loader") (tags (bap bap-plugin)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)) (bap-std (= :version)) @@ -1140,8 +1129,8 @@ and support files if necessary.") (tags (bap bap-tool command-line)) (depends (bap-common (= :version)) - (parsexp (and (>= v0.14) (< v0.16))) - (stdio (and (>= v0.14) (< v0.16))) + (parsexp (and (>= v0.17) (< v0.18))) + (stdio (and (>= v0.17) (< v0.18))) stdlib-shims (uuidm (>= 0.9.7)))) @@ -1153,7 +1142,7 @@ and support files if necessary.") (bap-common (= :version)) (bap-main (= :version)) (bap-recipe (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-relation) @@ -1184,7 +1173,7 @@ between the sets.") (bitvec-order (= :version)) (bitvec-sexp (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (ogre (= :version)) (ppx_bap (= :version)))) @@ -1194,7 +1183,7 @@ between the sets.") (synopsis "BAP plugin for reporting progress bars and statuses") (tags (bap bap-plugin)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (bap-std (= :version)))) @@ -1210,7 +1199,7 @@ between the sets.") (bap-c (= :version)) (bap-knowledge (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (ogre (= :version)) (ppx_bap (= :version)))) @@ -1225,7 +1214,7 @@ between the sets.") (bap-knowledge (= :version)) (bap-primus (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (graphlib (= :version)) (monads (= :version)) (regular (= :version)))) @@ -1238,7 +1227,7 @@ between the sets.") (bap-common (= :version)) (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ogre (= :version)))) (package @@ -1248,7 +1237,7 @@ between the sets.") (depends (bap-common (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-std) @@ -1268,12 +1257,12 @@ between the sets.") (bitvec (= :version)) (camlzip (and (>= 1.07) (< 2.0))) cmdliner - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) fileutils (graphlib (= :version)) mmap (monads (= :version)) - (ocamlfind (and (>= 1.5.6) (< 2.0.0))) + (ocamlfind (and (>= 1.9.0) (< 2.0.0))) (ogre (= :version)) ounit (ppx_bap (= :version)) @@ -1301,7 +1290,7 @@ The library provides several algorithms: - Scanner - a generic algorithm for finding strings of characters (a library variant of strings tool)") (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)))) @@ -1310,7 +1299,7 @@ The library provides several algorithms: (synopsis "Finds strings in binaries using microexecution") (tags (bap bap-plugin)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (bap-beagle (= :version)) (ppx_bap (= :version)) @@ -1332,7 +1321,7 @@ The library provides several algorithms: (bitvec-order (= :version)) (bitvec-sexp (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ogre (= :version)) (ppx_bap (= :version)))) @@ -1347,7 +1336,7 @@ The library provides several algorithms: (bap-main (= :version)) (bap-relation (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))))) (package (name bap-systemz) @@ -1360,7 +1349,7 @@ The library provides several algorithms: (bap-main (= :version)) (bap-std (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ogre (= :version)) (ppx_bap (= :version)))) @@ -1373,7 +1362,7 @@ The library provides several algorithms: (bap-primus (= :version)) (bap-std (= :version)) (bap-strings (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (monads (= :version)) (ppx_bap (= :version)) (regular (= :version)))) @@ -1386,7 +1375,7 @@ The library provides several algorithms: (bap-common (= :version)) (bap-core-theory (= :version)) (bap-microx (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (graphlib (= :version)) (monads (= :version)) (regular (= :version)))) @@ -1400,7 +1389,7 @@ The library provides several algorithms: (bap-common (= :version)) (bap-main (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ppx_bap (= :version)) (regular (= :version)))) @@ -1416,7 +1405,7 @@ The library provides several algorithms: (bap-main (= :version)) (bap-std (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ogre (= :version)) (ppx_bap (= :version)))) @@ -1432,7 +1421,7 @@ as the interpreter for your BAP scripts, e.g., `baptop myprog.ml`") (depends (bap-common (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) ocamlfind)) (package @@ -1445,7 +1434,7 @@ as the interpreter for your BAP scripts, e.g., `baptop myprog.ml`") (bap-plugins (= :version)) (bap-std (= :version)) (bap-traces (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ppx_bap (= :version)) (regular (= :version)) uri)) @@ -1457,7 +1446,7 @@ as the interpreter for your BAP scripts, e.g., `baptop myprog.ml`") (depends (bap-common (= :version)) (bap-std (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ppx_bap (= :version)) (regular (= :version)) (uri (>= 1.9.0)) @@ -1468,7 +1457,7 @@ as the interpreter for your BAP scripts, e.g., `baptop myprog.ml`") (synopsis "Eliminates complex branch conditions") (tags (bap bap-plugin)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (bap-std (= :version)))) @@ -1477,7 +1466,7 @@ as the interpreter for your BAP scripts, e.g., `baptop myprog.ml`") (synopsis "Warns if an unused argument may cause an issue") (tags (bap bap-plugin)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (bap-std (= :version)))) @@ -1500,7 +1489,7 @@ as the interpreter for your BAP scripts, e.g., `baptop myprog.ml`") (bap-primus (= :version)) (bap-std (= :version)) (bitvec (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ogre (= :version)) (ppx_bap (= :version)) (regular (= :version)) @@ -1515,8 +1504,8 @@ of facts that are represented as s-expressions.") (tags (bap bap-library)) (depends (bap-common (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) - (parsexp (and (>= v0.14) (< v0.16))))) + (core_kernel (and (>= v0.17) (< v0.18))) + (parsexp (and (>= v0.17) (< v0.18))))) (package (name bitvec) @@ -1529,7 +1518,7 @@ of facts that are represented as s-expressions.") (synopsis "Janestreet's Binprot serialization for Bitvec") (tags (bap)) (depends - (bin_prot (and (>= v0.14) (< v0.16))) + (bin_prot (and (>= v0.17) (< v0.18))) (bitvec (= :version)) (ppx_bap (= :version)))) @@ -1538,7 +1527,7 @@ of facts that are represented as s-expressions.") (synopsis "The Base-compatible comparators and orders for Bitvec ") (tags (bap)) (depends - (base (>= v0.14)) + (base (>= v0.16)) (bitvec-sexp (= :version)) (bitvec (= :version)))) @@ -1547,7 +1536,7 @@ of facts that are represented as s-expressions.") (synopsis "Sexp serializers for Bitvec") (tags (bap sexp)) (depends - (sexplib0 (>= v0.14)) + (sexplib0 (>= v0.16)) (bitvec (= :version)))) (package @@ -1564,7 +1553,7 @@ these functors, any algorithm written for OCamlGraph can be used on \ (tags (bap graph)) (depends (bap-common (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) ocamlgraph (ppx_bap (= :version)) (regular (= :version)))) @@ -1576,7 +1565,7 @@ these functors, any algorithm written for OCamlGraph can be used on \ (tags (bap monad)) (depends (bap-common (= :version)) - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (ppx_bap (= :version)))) (package @@ -1588,7 +1577,7 @@ representation and provides a type safe monadic interface for quering \ and updating documents") (tags (bap sexp)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (monads (= :version)))) @@ -1597,22 +1586,22 @@ and updating documents") (synopsis "BAP-blessed ppx rewriters") (tags (bap ppx)) (depends - (ppx_assert (and (>= v0.14) (< v0.16))) - (ppx_bench (and (>= v0.14) (< v0.16))) - (ppx_bin_prot (and (>= v0.14) (< v0.16))) - (ppx_cold (and (>= v0.14) (< v0.16))) - (ppx_compare (and (>= v0.14) (< v0.16))) - (ppx_enumerate (and (>= v0.14) (< v0.16))) - (ppx_fields_conv (and (>= v0.14) (< v0.16))) - (ppx_hash (and (>= v0.14) (< v0.16))) - (ppx_here (and (>= v0.14) (< v0.16))) - (ppxlib (>= 0.15.0)) - (ppx_optcomp (and (>= v0.14) (< v0.16))) - (ppx_expect (and (>= v0.14) (< v0.16))) - (ppx_inline_test (and (>= v0.14) (< v0.16))) - (ppx_sexp_conv (and (>= v0.14) (< v0.16))) - (ppx_sexp_value (and (>= v0.14) (< v0.16))) - (ppx_variants_conv (and (>= v0.14) (< v0.16))))) + (ppx_assert (and (>= v0.17) (< v0.18))) + (ppx_bench (and (>= v0.17) (< v0.18))) + (ppx_bin_prot (and (>= v0.17) (< v0.18))) + (ppx_cold (and (>= v0.17) (< v0.18))) + (ppx_compare (and (>= v0.17) (< v0.18))) + (ppx_enumerate (and (>= v0.17) (< v0.18))) + (ppx_fields_conv (and (>= v0.17) (< v0.18))) + (ppx_hash (and (>= v0.17) (< v0.18))) + (ppx_here (and (>= v0.17) (< v0.18))) + (ppxlib (>= 0.32.0)) + (ppx_optcomp (and (>= v0.17) (< v0.18))) + (ppx_expect (and (>= v0.17) (< v0.18))) + (ppx_inline_test (and (>= v0.17) (< v0.18))) + (ppx_sexp_conv (and (>= v0.17) (< v0.18))) + (ppx_sexp_value (and (>= v0.17) (< v0.18))) + (ppx_variants_conv (and (>= v0.17) (< v0.18))))) (package (name regular) @@ -1631,7 +1620,7 @@ In particular, the library includes: \ - module Seq that extends Core_kernel's sequence module \ - module Bytes that provides a rich core-like interface for Bytes data type.") (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)) (ppx_bap (= :version)))) @@ -1640,7 +1629,7 @@ In particular, the library includes: \ (synopsis "A library for rich formatting using semantic tags") (tags (bap)) (depends - (core_kernel (and (>= v0.14) (< v0.16))) + (core_kernel (and (>= v0.17) (< v0.18))) (bap-common (= :version)))) (generate_opam_files true) diff --git a/graphlib.opam b/graphlib.opam index db28362d1..daa2b8c92 100644 --- a/graphlib.opam +++ b/graphlib.opam @@ -11,9 +11,9 @@ tags: ["bap" "graph"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ocamlgraph" "ppx_bap" {= version} "regular" {= version} diff --git a/lib/arm/arm_lifter.ml b/lib/arm/arm_lifter.ml index 38f242c85..94602a56a 100644 --- a/lib/arm/arm_lifter.ml +++ b/lib/arm/arm_lifter.ml @@ -1060,7 +1060,7 @@ module CPU = struct let sp = sp - let regs = Var.Set.of_list [ + let regs = Set.of_list (module Var) [ r0; r1; r2; r3; r4; r5; r6; r7; r8; r9; r10; r11; r12; @@ -1069,17 +1069,17 @@ module CPU = struct ] (* although PC is stricly speaking is GPR we will rule it out *) - let non_gpr = Var.Set.of_list [ + let non_gpr = Set.of_list (module Var) [ pc; spsr; cpsr; itstate; ] - let gpr = Var.Set.diff regs non_gpr + let gpr = Set.diff regs non_gpr - let perms = Var.Set.of_list [ + let perms = Set.of_list (module Var) [ r4; r5; r6; r7; r8; r9; r10; r11; ] - let flags = Var.Set.of_list @@ [ + let flags = Set.of_list (module Var) @@ [ nf; zf; cf; qf; vf; ] @ Array.to_list ge diff --git a/lib/arm/arm_target.ml b/lib/arm/arm_target.ml index 1c2f793f8..32e00d92a 100644 --- a/lib/arm/arm_target.ml +++ b/lib/arm/arm_target.ml @@ -643,7 +643,7 @@ module Encodings = struct module Lambda = Primus.Lisp module Sigma = Lambda.Semantics - let empty = Map.empty (module Bitvec_order) + let empty = (Map.empty (module Bitvec_order)) let lsb x = Int64.(x land 1L) let is_thumb x = Int64.equal (lsb x) 1L diff --git a/lib/bap/bap.mli b/lib/bap/bap.mli index fb71e93e3..cd80f6dbf 100644 --- a/lib/bap/bap.mli +++ b/lib/bap/bap.mli @@ -164,7 +164,7 @@ module Std : sig contains all functions and types related to type [exp]. For example, to create a hashtable of statements, just type: - [let table = Exp.Table.create ()] + [let table = Hashtbl.create (module Exp) ()] If a type is a variant type (i.e., it defines constructors) then for each constructor named [Name], there exists a corresponding diff --git a/lib/bap/bap_project.ml b/lib/bap/bap_project.ml index 8327749ff..29e445d4f 100644 --- a/lib/bap/bap_project.ml +++ b/lib/bap/bap_project.ml @@ -13,7 +13,7 @@ open Format module Driver = Bap_disasm_driver -module Buffer = Caml.Buffer +module Buffer = Stdlib.Buffer include Bap_self.Create() let query doc attr = @@ -232,7 +232,7 @@ module Input = struct spec; } |> List.return - let loaders = String.Table.create () + let loaders = Hashtbl.create (module String) let register_loader name loader = Hashtbl.set loaders ~key:name ~data:loader @@ -263,7 +263,7 @@ module Input = struct let dedup xs = List.rev @@ fst @@ - List.fold xs ~init:([], String.Set.empty) ~f:(fun (xs, mems) x -> + List.fold xs ~init:([], Set.empty (module String)) ~f:(fun (xs, mems) x -> if Set.mem mems x then (xs, mems) else (x :: xs, Set.add mems x)) @@ -713,7 +713,7 @@ module Pass = struct let fail = function | Unsat_dep _ as err -> raise (Failed err) | Runtime_error (pass,exn) -> - let backtrace = Caml.Printexc.get_backtrace () in + let backtrace = Stdlib.Printexc.get_backtrace () in raise (Failed (Runtime_error (pass, Exn.Reraised (backtrace, exn)))) let is_evaled pass proj = diff --git a/lib/bap/bap_self.ml b/lib/bap/bap_self.ml index f972f2dd4..a4a129ffb 100644 --- a/lib/bap/bap_self.ml +++ b/lib/bap/bap_self.ml @@ -6,8 +6,8 @@ open Format open Cmdliner module Event = Bap_main_event -module Buffer = Caml.Buffer -module Sys = Caml.Sys +module Buffer = Stdlib.Buffer +module Sys = Stdlib.Sys module Create() = struct let main = @@ -50,7 +50,7 @@ module Create() = struct else filter_args name let has_var v = match Sys.getenv ("BAP_" ^ String.uppercase v) with - | exception Caml.Not_found -> false + | exception Stdlib.Not_found -> false | "false" | "0" -> false | _ -> true @@ -123,7 +123,7 @@ module Create() = struct try Ok (f {get = fun x -> Future.peek_exn x}) with | Invalid_argument s -> Error (Error.Invalid s) | exn -> - let backtrace = Caml.Printexc.get_backtrace () in + let backtrace = Stdlib.Printexc.get_backtrace () in Error (Error.Bug (exn,backtrace)) let when_ready f = declare_extension f diff --git a/lib/bap_bml/bap_bml.ml b/lib/bap_bml/bap_bml.ml index 1a3469811..f1756b59d 100644 --- a/lib/bap_bml/bap_bml.ml +++ b/lib/bap_bml/bap_bml.ml @@ -14,7 +14,7 @@ end module Registry(T : T) = struct type t = T.t - let registered : t String.Table.t = String.Table.create () + let registered : t String.Table.t = Hashtbl.create (module String) let register name v = Hashtbl.set registered ~key:name ~data:v let find = Hashtbl.find registered let list () = Hashtbl.to_alist registered diff --git a/lib/bap_bundle/bap_bundle.ml b/lib/bap_bundle/bap_bundle.ml index 28d092dbf..7a2558d4a 100644 --- a/lib/bap_bundle/bap_bundle.ml +++ b/lib/bap_bundle/bap_bundle.ml @@ -1,14 +1,14 @@ open Core_kernel[@@warning "-D"] -module Filename = Caml.Filename -module Sys = Caml.Sys +module Filename = Stdlib.Filename +module Sys = Stdlib.Sys module Std = struct exception Not_a_bundle module Manifest = struct - let getenv key = try Sys.getenv key with Caml.Not_found -> "unknown" + let getenv key = try Sys.getenv key with Stdlib.Not_found -> "unknown" type t = { name : string; @@ -165,12 +165,12 @@ module Std = struct let name = Option.value name ~default:path in Zip.copy_entry_to_file zip entry name; Some (Uri.of_string name) - with Caml.Not_found -> None + with Stdlib.Not_found -> None let get_data b name = b >>> fun zip -> try Some Zip.(read_entry zip (find_entry zip name)) - with Caml.Not_found -> None + with Stdlib.Not_found -> None let list b = b >>> fun zip -> @@ -210,10 +210,10 @@ module Std = struct Zip.close_out zout let update bundle ~f = - transform (String.Table.create ()) bundle ~f + transform (Hashtbl.create (module String)) bundle ~f let insert bundle files = - let files = String.Table.of_alist_exn files in + let files = Hashtbl.of_alist_exn (module String) files in transform files bundle ~f:(fun _ -> `Copy) let insert_files bundle files = diff --git a/lib/bap_byteweight/bap_byteweight.ml b/lib/bap_byteweight/bap_byteweight.ml index 3fc8e609d..1faa5a90a 100644 --- a/lib/bap_byteweight/bap_byteweight.ml +++ b/lib/bap_byteweight/bap_byteweight.ml @@ -117,9 +117,9 @@ module Bytes = struct let t = Bap_byteweight_signatures.Data.declare "bytes" ~load:(fun bytes -> Binable.of_string (module Self) - (Caml.Bytes.unsafe_to_string bytes)) + (Stdlib.Bytes.unsafe_to_string bytes)) ~save:(fun data -> - Caml.Bytes.unsafe_of_string @@ + Stdlib.Bytes.unsafe_of_string @@ Binable.to_string (module Self) data) include Self diff --git a/lib/bap_byteweight/bap_byteweight_signatures.ml b/lib/bap_byteweight/bap_byteweight_signatures.ml index 0ecc78596..581fb4092 100644 --- a/lib/bap_byteweight/bap_byteweight_signatures.ml +++ b/lib/bap_byteweight/bap_byteweight_signatures.ml @@ -1,7 +1,7 @@ open Core_kernel[@@warning "-D"] open Bap_core_theory open Bap.Std -module Sys = Caml.Sys +module Sys = Stdlib.Sys module Config = Bap_main.Extension.Configuration @@ -122,7 +122,7 @@ let copy input output = loop () let temporary_copy file = - let tmp,output = Caml.Filename.open_temp_file "byteweight" "copy" in + let tmp,output = Stdlib.Filename.open_temp_file "byteweight" "copy" in In_channel.with_file file ~f:(fun input -> copy input output); Out_channel.close output; tmp @@ -169,8 +169,8 @@ let load_exn ?comp ?path ~mode arch = let entry_path = entry ?comp ~mode arch in let r = try let entry = Zip.find_entry zip entry_path in - Ok (Zip.read_entry zip entry |> Caml.Bytes.unsafe_of_string) - with Caml.Not_found -> fail (`No_entry entry_path) + Ok (Zip.read_entry zip entry |> Stdlib.Bytes.unsafe_of_string) + with Stdlib.Not_found -> fail (`No_entry entry_path) | Zip.Error (_,ent,err) -> zip_error ent err in Zip.close_in zip; r diff --git a/lib/bap_c/bap_c_abi.ml b/lib/bap_c/bap_c_abi.ml index c9740b134..6383fe2e9 100644 --- a/lib/bap_c/bap_c_abi.ml +++ b/lib/bap_c/bap_c_abi.ml @@ -299,7 +299,7 @@ let create_api_processor size abi : Bap_api.t = let language = "c" type t = Term.mapper let parse_exn get_api intfs : t = - let gamma = String.Table.create () in + let gamma = Hashtbl.create (module String) in List.iter intfs ~f:(fun api -> match get_api api with | None -> fail (`Unknown_interface api) @@ -400,7 +400,7 @@ module Arg = struct | None -> None | Some sp -> Some { base = Var.reify sp; - data = Map.empty (module Int); + data = (Map.empty (module Int)); align; } @@ -442,7 +442,7 @@ module Arg = struct let bits self = self.bits - let deplet self = {self with args = Map.empty (module Int)} + let deplet self = {self with args = (Map.empty (module Int))} let pop self = match Map.min_elt self.args with | None -> None @@ -471,7 +471,7 @@ module Arg = struct let of_list = List.foldi ~f:(fun pos regs reg -> Map.add_exn regs pos reg) - ~init:Int.Map.empty + ~init:(Map.empty (module Int)) let of_exps args = { @@ -783,7 +783,7 @@ module Arg = struct let init = { stack = Stack.create ruler target; ruler; - files = Map.empty (module Int); + files = (Map.empty (module Int)); where = `Inputs; return = None; inputs = []; diff --git a/lib/bap_core_theory/bap_core_theory.ml b/lib/bap_core_theory/bap_core_theory.ml index 54cc3740f..4c64a1b6b 100644 --- a/lib/bap_core_theory/bap_core_theory.ml +++ b/lib/bap_core_theory/bap_core_theory.ml @@ -45,9 +45,9 @@ module Theory = struct type filetype = Filetype.t type 'a value = 'a Value.t - type 'a effect = 'a Effect.t + type 'a eff0 = 'a Effect.t type 'a pure = 'a value knowledge - type 'a eff = 'a effect knowledge + type 'a eff = 'a eff0 knowledge type bool = Bool.t pure diff --git a/lib/bap_core_theory/bap_core_theory.mli b/lib/bap_core_theory/bap_core_theory.mli index 22dab0ff4..dfec50db4 100644 --- a/lib/bap_core_theory/bap_core_theory.mli +++ b/lib/bap_core_theory/bap_core_theory.mli @@ -364,7 +364,7 @@ *) open Core_kernel[@@warning "-D"] -open Caml.Format +open Stdlib.Format open Bap_knowledge @@ -774,7 +774,7 @@ module Theory : sig This module enables construction of complex data structures on sorts, like maps, sets, etc, e.g., - [let sorts = Set.empty (module Value.Sort.Top)] + [let sorts = (Set.empty (module Value.Sort.Top))] Since such structures are required to be monomorphic, the sort type index should be removed using the [forget] function, @@ -953,7 +953,7 @@ module Theory : sig end type 'a value = 'a Value.t - type 'a effect = 'a Effect.t + type 'a eff0 = 'a Effect.t (** The sort for boolean values. @@ -1074,7 +1074,7 @@ module Theory : sig end type 'a pure = 'a value knowledge - type 'a eff = 'a effect knowledge + type 'a eff = 'a eff0 knowledge type ('r,'s) format = ('r,'s) Float.format @@ -1194,7 +1194,7 @@ module Theory : sig (** Variables with erased sort index. This module enables construction of complex data structures on - variables, e.g., [Set.empty (module Theory.Var.Top)]. + variables, e.g., [(Set.empty (module Theory.Var.Top))]. The variables are ordered by their identifiers so that two variables with the same name but different sorts are compared diff --git a/lib/bap_core_theory/bap_core_theory_definition.ml b/lib/bap_core_theory/bap_core_theory_definition.ml index a4cc37ea3..7f8904e80 100644 --- a/lib/bap_core_theory/bap_core_theory_definition.ml +++ b/lib/bap_core_theory/bap_core_theory_definition.ml @@ -9,12 +9,12 @@ module Program = Bap_core_theory_program module Label = Program.Label type 'a value = 'a Value.t -type 'a effect = 'a Effect.t +type 'a eff0 = 'a Effect.t type program = Program.cls type 'a pure = 'a value knowledge -type 'a eff = 'a effect knowledge +type 'a eff = 'a eff0 knowledge type bool = Bool.t pure type 'a bitv = 'a Bitv.t pure diff --git a/lib/bap_core_theory/bap_core_theory_manager.ml b/lib/bap_core_theory/bap_core_theory_manager.ml index 58f2abcbe..565fc8e56 100644 --- a/lib/bap_core_theory/bap_core_theory_manager.ml +++ b/lib/bap_core_theory/bap_core_theory_manager.ml @@ -323,7 +323,7 @@ let theories () = KB.Context.get theories >>= function | Some theories -> !!theories | None -> - let init = Map.empty (module Theory) in + let init = (Map.empty (module Theory)) in Hashtbl.to_alist known_theories |> Knowledge.List.fold ~init ~f:(fun theories (name,def) -> Knowledge.Symbol.intern (Name.unqualified name) theory @@ -385,7 +385,7 @@ let is_instantiated id = thus it will drop it from the final structure. [1]: Leroy, Xavier."A proposal for recursive modules in Objective - Caml." Available from the author’s website (2003). + Stdlib." Available from the author’s website (2003). *) let instantiate t = theory_for_id t.id >>= fun id -> diff --git a/lib/bap_core_theory/bap_core_theory_program.ml b/lib/bap_core_theory/bap_core_theory_program.ml index 94f31fb26..8d37ce078 100644 --- a/lib/bap_core_theory/bap_core_theory_program.ml +++ b/lib/bap_core_theory/bap_core_theory_program.ml @@ -101,7 +101,7 @@ module Compiler = struct let create ?(specs=[]) ?(version=[]) ?(options=[]) name = { name; version; options; - specs = String.Map.of_alist_exn specs; + specs = Map.of_alist_exn (module String) specs; } let pp ppf x = Sexp.pp_hum ppf (sexp_of_t x) diff --git a/lib/bap_core_theory/bap_core_theory_target.ml b/lib/bap_core_theory/bap_core_theory_target.ml index 7cd8b60c4..092d6961c 100644 --- a/lib/bap_core_theory/bap_core_theory_target.ml +++ b/lib/bap_core_theory/bap_core_theory_target.ml @@ -172,11 +172,11 @@ let unknown = { alignment = {code=8; data=8}; data = pack@@mem "mem" 32 8; code = pack@@mem "mem" 32 8; - vars = Set.empty (module Var.Top); - regs = Map.empty (module Role); + vars = (Set.empty (module Var.Top)); + regs = (Map.empty (module Role)); aliasing = { - subs = Map.empty (module Var.Top); - sups = Map.empty (module Var.Top); + subs = (Map.empty (module Var.Top)); + sups = (Map.empty (module Var.Top)); }; endianness = Endianness.eb; system = System.unknown; @@ -184,7 +184,7 @@ let unknown = { fabi = Fabi.unknown; filetype = Filetype.unknown; options = Options.empty; - names = String.Caseless.Set.empty; + names = (Set.empty (module String.Caseless)); } let targets = Hashtbl.of_alist_exn (module Self) [ @@ -219,8 +219,8 @@ module Alias = struct | None -> assert false let init = { - sups = Map.empty (module Var.Top); - subs = Map.empty (module Var.Top); + sups = (Map.empty (module Var.Top)); + subs = (Map.empty (module Var.Top)); } let is_solved {subs; sups} v = (Map.mem subs v || Map.mem sups v) @@ -307,7 +307,7 @@ module Alias = struct let solve regs spec = let aliases = match Map.find regs Role.Register.alias with - | None -> Set.empty (module Var.Top) + | None -> (Set.empty (module Var.Top)) | Some vars -> vars in let is_alias = Set.mem aliases in let is_base = Fn.non is_alias in @@ -453,7 +453,7 @@ let extend parent }; names = Option.value_map nicknames ~default:parent.names - ~f:String.Caseless.Set.of_list; + ~f:(Set.of_list (module String.Caseless)); } let declare @@ -632,7 +632,7 @@ let family t = sort_family_by_order let partition xs = - let families = Map.empty (module Self) in + let families = (Map.empty (module Self)) in let universe = Set.of_list (module Self) xs in let rec grandest t = let p = parent t in diff --git a/lib/bap_core_theory/bap_core_theory_value.ml b/lib/bap_core_theory/bap_core_theory_value.ml index 648626d6e..5fd7484cf 100644 --- a/lib/bap_core_theory/bap_core_theory_value.ml +++ b/lib/bap_core_theory/bap_core_theory_value.ml @@ -1,5 +1,5 @@ open Core_kernel[@@warning "-D"] -open Caml.Format +open Stdlib.Format open Bap_knowledge module KB = Knowledge @@ -158,7 +158,7 @@ end let of_sexpable x = x end) - include Binable.Of_binable(Exp)(struct + include Binable.Of_binable_without_uuid(Exp)(struct type t = top let to_binable x = x let of_binable x = x diff --git a/lib/bap_core_theory/bap_core_theory_value.mli b/lib/bap_core_theory/bap_core_theory_value.mli index f05a8da58..680bcddbf 100644 --- a/lib/bap_core_theory/bap_core_theory_value.mli +++ b/lib/bap_core_theory/bap_core_theory_value.mli @@ -1,5 +1,5 @@ open Core_kernel[@@warning "-D"] -open Caml.Format +open Stdlib.Format open Bap_knowledge module KB = Knowledge diff --git a/lib/bap_core_theory/bap_core_theory_var.ml b/lib/bap_core_theory/bap_core_theory_var.ml index 0b89dc7ef..d77d6c2d0 100644 --- a/lib/bap_core_theory/bap_core_theory_var.ml +++ b/lib/bap_core_theory/bap_core_theory_var.ml @@ -1,6 +1,6 @@ open Core_kernel[@@warning "-D"] -open Caml.Format +open Stdlib.Format open Bap_knowledge open Bap_core_theory_value open Knowledge.Syntax diff --git a/lib/bap_disasm/bap_disasm_basic.ml b/lib/bap_disasm/bap_disasm_basic.ml index 5d5344f5c..e23eee519 100644 --- a/lib/bap_disasm/bap_disasm_basic.ml +++ b/lib/bap_disasm/bap_disasm_basic.ml @@ -90,11 +90,11 @@ module Table = struct let create data = { data; size = Bigstring.length data; - cache = Int.Table.create (); + cache = Hashtbl.create (module Int); } let lookup t pos = - Int.Table.find_or_add t.cache pos ~default:(fun () -> + Hashtbl.find_or_add t.cache pos ~default:(fun () -> if pos < 0 || pos >= t.size then "ERROR" else match Bigstring.find ~pos '\x00' t.data with | None -> "ERROR" @@ -427,9 +427,13 @@ let compare_full_insn i1 i2 = type (+'a,+'k) insns = (mem * ('a,'k) insn option) list -module Pred = Comparable.Make(struct +module Pred = struct + type t = pred + module T = struct type t = pred [@@deriving compare, sexp] - end) + end + include Comparable.Make(T) +end module Preds = Pred.Set type preds = Preds.t [@@deriving compare, sexp] @@ -464,7 +468,7 @@ let create_state ?(backlog=0) ?(stop_on=[]) ?stopped ?invalid ?hit dis mem ~return = { backlog; dis; return; hit; - current = {mem; off=0; preds = Preds.of_list stop_on}; + current = {mem; off=0; preds = Set.of_list (module Pred) stop_on}; stopped; invalid; history = []; @@ -500,14 +504,14 @@ let push_pred s p = let reset_predicates s ps = C.predicates_clear !!(s.dis); - Preds.iter ps ~f:(push_pred s); + Set.iter ps ~f:(push_pred s); C.predicates_push !!(s.dis) Is_invalid let with_preds s (ps : pred list) = - let ps = Preds.of_list ps in - let drop = Preds.diff s.current.preds ps in - if Preds.is_empty drop - then Preds.iter (Preds.diff ps s.current.preds) ~f:(push_pred s) + let ps = Set.of_list (module Pred) ps in + let drop = Set.diff s.current.preds ps in + if Set.is_empty drop + then Set.iter (Set.diff ps s.current.preds) ~f:(push_pred s) else reset_predicates s ps; {s with current = {s.current with preds = ps}} @@ -519,7 +523,7 @@ let last s n = let n = min n m in List.init n ~f:(fun i -> s.insns.(m - i - 1)) -let preds s = Preds.to_list s.current.preds +let preds s = Set.to_list s.current.preds let addr s = Addr.(Mem.min_addr s.current.mem ++ s.current.off) diff --git a/lib/bap_disasm/bap_disasm_brancher.ml b/lib/bap_disasm/bap_disasm_brancher.ml index c3d4b7f1a..9d37d2134 100644 --- a/lib/bap_disasm/bap_disasm_brancher.ml +++ b/lib/bap_disasm/bap_disasm_brancher.ml @@ -40,7 +40,7 @@ module Rel_info = struct open Fact.Syntax let of_aseq s = - Seq.fold s ~init:Addr.Map.empty ~f:(fun m (key,data) -> + Seq.fold s ~init:(Map.empty (module Addr)) ~f:(fun m (key,data) -> Map.set m ~key ~data) let arch_width = @@ -58,13 +58,13 @@ module Rel_info = struct Fact.collect Ogre.Query.( select (from external_reference)) >>= fun s -> Fact.return - (Seq.fold s ~init:Addr.Set.empty ~f:(fun addrs (addr, _) -> + (Seq.fold s ~init:(Set.empty (module Addr)) ~f:(fun addrs (addr, _) -> Set.add addrs (Addr.of_int64 ~width addr))) end let relocations = Fact.eval Request.relocations let external_symbols = Fact.eval Request.external_symbols - let empty = {rels = Addr.Map.empty; exts = Addr.Set.empty} + let empty = {rels = (Map.empty (module Addr)); exts = (Set.empty (module Addr))} let of_spec spec = match relocations spec, external_symbols spec with @@ -173,7 +173,7 @@ let (>>=?) x f = x >>= function | Some x -> f x let provide_brancher brancher label = - let init = Set.empty (module Theory.Label) in + let init = (Set.empty (module Theory.Label)) in KB.collect Memory.slot label >>=? fun mem -> KB.collect Dis.Insn.slot label >>=? fun insn -> Context.for_label label >>= fun ctxt -> diff --git a/lib/bap_disasm/bap_disasm_calls.ml b/lib/bap_disasm/bap_disasm_calls.ml index 9fb64d0dd..0f31f6a17 100644 --- a/lib/bap_disasm/bap_disasm_calls.ml +++ b/lib/bap_disasm/bap_disasm_calls.ml @@ -61,7 +61,7 @@ end *) module Parent = struct type t = Top | Set of Word.Set.t [@@deriving compare, bin_io] - let none = Set Word.Set.empty + let none = Set (Set.empty (module Word)) let unknown = Top let equal x y = match x,y with | Top,Top -> true @@ -93,7 +93,7 @@ end module Parents = struct type t = (word,Parent.t) Solution.t - include Binable.Of_binable(struct + include Binable.Of_binable_without_uuid(struct type t = (word * Parent.t) Seq.t [@@deriving bin_io] end)(struct type t = (word,Parent.t) Solution.t @@ -150,7 +150,7 @@ let empty = let root = Map.singleton (module Addr) Callgraph.entry Parent.none in { parents = Solution.create root Parent.unknown; - entries = Set.empty (module Addr); + entries = (Set.empty (module Addr)); } let belongs {parents} ~entry:parent addr = @@ -179,7 +179,7 @@ let siblings {parents} x y = not @@ Set.is_empty (Set.inter p1 p2) let entries graph parents = - let init = Set.empty (module Addr) in + let init = (Set.empty (module Addr)) in Callgraph.nodes graph |> Seq.fold ~init ~f:(fun entries n -> if Word.equal n Callgraph.entry then entries else match Solution.get parents n with diff --git a/lib/bap_disasm/bap_disasm_driver.ml b/lib/bap_disasm/bap_disasm_driver.ml index 80ba17393..90e2acc96 100644 --- a/lib/bap_disasm/bap_disasm_driver.ml +++ b/lib/bap_disasm/bap_disasm_driver.ml @@ -203,7 +203,7 @@ end = struct let rec step s = match s.work with | [] when Set.is_empty s.usat -> { s with stop = true; - code = Map.empty (module Addr); + code = (Map.empty (module Addr)); } | [] -> restart s | Dest {dst=next; encoding} as curr :: work @@ -356,10 +356,10 @@ end = struct debt = []; curr = Dest {dst = start; parent = None; encoding=unknown}; stop = false; - dels = Set.empty (module Addr); - begs = Map.empty (module Addr); - jmps = Map.empty (module Addr); - code = Map.empty (module Addr); + dels = (Set.empty (module Addr)); + begs = (Map.empty (module Addr)); + jmps = (Map.empty (module Addr)); + code = (Map.empty (module Addr)); } mem end @@ -392,8 +392,8 @@ let collect_dests source code = call = Insn.(is call insn); barrier = Insn.(is barrier insn); indirect = false; - resolved = Set.empty (module Addr); - unresolved = Set.empty (module Theory.Label); + resolved = (Set.empty (module Addr)); + unresolved = (Set.empty (module Theory.Label)); } in KB.Value.get Insn.Slot.dests insn |> function | None -> KB.return {init with encoding = source} @@ -439,7 +439,7 @@ let unit_for_mem mem = KB.collect Theory.Label.unit label let classify mem = - let empty = Set.empty (module Addr) in + let empty = (Set.empty (module Addr)) in let base = Memory.min_addr mem in unit_for_mem mem >>= fun unit -> Seq.range 0 (Memory.length mem) |> @@ -551,13 +551,13 @@ type state = { } [@@deriving bin_io] let init = { - funs = Set.empty (module Addr); - begs = Set.empty (module Addr); - jmps = Map.empty (module Addr); - data = Set.empty (module Addr); + funs = (Set.empty (module Addr)); + begs = (Set.empty (module Addr)); + jmps = (Map.empty (module Addr)); + data = (Set.empty (module Addr)); mems = []; debt = []; - exts = Set.empty (module Theory.Label); + exts = (Set.empty (module Theory.Label)); } let forget_debt s = {s with debt=[]} @@ -593,7 +593,7 @@ let fold_calls field ~f ~init jmps = let commit_calls = fold_calls resolved - ~init:Addr.Set.empty + ~init:(Set.empty (module Addr)) ~f:(fun calls addr -> Theory.Label.for_addr (Word.to_bitvec addr) >>= fun dst -> KB.provide Theory.Label.is_valid dst (Some true) >>= fun () -> @@ -613,7 +613,7 @@ let owns mem s = | Machine.Dest {dst} -> Memory.contains mem dst | _ -> false) -let empty = Addr.Set.empty +let empty = (Set.empty (module Addr)) let merge_dests d1 d2 = { encoding = d1.encoding; @@ -768,7 +768,7 @@ let explore | Some beg,None -> Seq.singleton beg | None, Some begs -> begs | Some beg, Some begs -> Seq.cons beg begs in - let empty = Map.empty (module Addr) in + let empty = (Map.empty (module Addr)) in KB.Seq.fold entries ~init:(empty,init) ~f:(fun (blocks,cfg) beg -> build blocks cfg beg >>| fun (blocks,cfg,_) -> blocks,cfg) >>| snd diff --git a/lib/bap_disasm/bap_disasm_insn.ml b/lib/bap_disasm/bap_disasm_insn.ml index 7606a217a..5f25b5801 100644 --- a/lib/bap_disasm/bap_disasm_insn.ml +++ b/lib/bap_disasm/bap_disasm_insn.ml @@ -52,7 +52,7 @@ module Props = struct module T = struct type t = Z.t include Sexpable.Of_stringable(Bits) - include Binable.Of_stringable(Bits) + include Binable.Of_stringable_without_uuid(Bits) [@@warning "-D"] end @@ -241,11 +241,11 @@ module Analyzer = struct | _ -> indirect jump jumps method! enter_stmt s (effs,jumps) = match Bil.(decode call s) with | None -> super#enter_stmt s (effs,jumps) - | Some _ -> Effects.add effs `Call, jumps + | Some _ -> Set.add effs `Call, jumps end let run bil = - let cons c = Fn.flip @@ if c then Effects.add else Fn.const in + let cons c = Fn.flip @@ if c then Set.add else Fn.const in let effs,jump = analyzer#run bil (Effects.empty,no_jumps) in if not jump.jump then effs else @@ -260,7 +260,7 @@ let derive_props ?bil insn = | None -> Analyzer.Effects.empty in let is = Insn.is insn in let is_bil = if Option.is_some bil - then Analyzer.Effects.mem bil_effects else is in + then Set.mem bil_effects else is in let is_return = is `Return in let is_call = is_bil `Call || is `Call in let is_conditional_jump = is_bil `Conditional_branch in @@ -288,25 +288,25 @@ let (<--) slot value insn = KB.Value.put slot insn value let write init ops = List.fold ~init ops ~f:(fun init f -> f init) -let set_basic effect insn : t = - write effect Slot.[ +let set_basic eff insn : t = + write eff Slot.[ name <-- Insn.name insn; asm <-- Insn.asm insn; ops <-- Some (Insn.ops insn); ] let of_basic ?bil insn : t = - let effect = + let eff = KB.Value.put Bil.slot (KB.Value.empty Theory.Semantics.cls) (Option.value bil ~default:[]) in - write (set_basic effect insn) Slot.[ + write (set_basic eff insn) Slot.[ Props.slot <-- derive_props ?bil insn; ] -let with_basic effect insn : t = - let bil = KB.Value.get Bil.slot effect in - write (set_basic effect insn) Slot.[ +let with_basic eff insn : t = + let bil = KB.Value.get Bil.slot eff in + write (set_basic eff insn) Slot.[ Props.slot <-- derive_props ~bil insn ] diff --git a/lib/bap_disasm/bap_disasm_reconstructor.ml b/lib/bap_disasm/bap_disasm_reconstructor.ml index 93e1c4778..7045ab7fb 100644 --- a/lib/bap_disasm/bap_disasm_reconstructor.ml +++ b/lib/bap_disasm/bap_disasm_reconstructor.ml @@ -51,8 +51,8 @@ let is_call b = Insn.(is call) (Block.terminator b) let entries_of_block cfg roots blk = let entries = - if is_start roots cfg blk then Block.Set.singleton blk - else Block.Set.empty in + if is_start roots cfg blk then Set.singleton (module Block) blk + else (Set.empty (module Block)) in if is_call blk then Seq.fold ~init:entries (Cfg.Node.outputs blk cfg) ~f:(fun entries e -> @@ -79,7 +79,7 @@ let add_unresolved syms name cfg blk = else syms let collect name cfg roots = - Seq.fold (Cfg.nodes cfg) ~init:(Block.Set.empty, Symtab.empty) + Seq.fold (Cfg.nodes cfg) ~init:(Set.empty (module Block), Symtab.empty) ~f:(fun (entries, syms) blk -> let entries' = entries_of_block cfg roots blk in Set.union entries entries', add_unresolved syms name cfg blk) @@ -91,12 +91,12 @@ let reachable cfg from = ~f:(fun nodes edge -> if Set.mem nodes ( Cfg.Edge.dst edge) then nodes else loop nodes (Cfg.Edge.dst edge)) in - loop Block.Set.empty from + loop (Set.empty (module Block)) from let sub roots prog start = let is_call e = Set.mem roots (Cfg.Edge.dst e) in let update_inputs node init = - Seq.fold ~init (Cfg.Node.inputs node prog) ~f:Set.add in + Seq.fold ~init (Cfg.Node.inputs node prog) ~f:(fun s x -> Set.add s x) in let rec loop cfg inputs node = Seq.fold (Cfg.Node.outputs node prog) ~init:(cfg, update_inputs node inputs) @@ -107,9 +107,9 @@ let sub roots prog start = if Cfg.Node.mem (Cfg.Edge.dst edge) cfg then cfg',inputs else loop cfg' inputs (Cfg.Edge.dst edge)) in let cfg = Cfg.Node.insert start Cfg.empty in - loop cfg Cfg.Edge.Set.empty start + loop cfg (Set.empty (module Cfg.Edge)) start -let edges_of_seq s = Seq.fold s ~init:Cfg.Edge.Set.empty ~f:Set.add +let edges_of_seq s = Seq.fold s ~init:(Set.empty (module Cfg.Edge)) ~f:(fun s x -> Set.add s x) let reconstruct name initial_roots prog = let (--) = Set.diff in @@ -125,7 +125,7 @@ let reconstruct name initial_roots prog = let cfg = Set.fold reachable ~init:cfg ~f:remove_node in remove_node cfg from in let collect_destinations edges = - Set.fold edges ~init:Block.Set.empty ~f:(fun bs e -> + Set.fold edges ~init:(Set.empty (module Block)) ~f:(fun bs e -> Set.add bs (Cfg.Edge.dst e)) in let rec loop known_roots syms = function | [] -> syms,known_roots @@ -139,14 +139,14 @@ let reconstruct name initial_roots prog = let syms = update_symtab syms cfg root self_inputs in let syms,known = loop known syms (Set.to_list calls) in loop known syms roots in - let initial_roots = Addr.Set.of_list initial_roots in + let initial_roots = Set.of_list (module Addr) initial_roots in let roots,syms = collect name prog initial_roots in fst @@ loop roots syms (Set.to_list roots) let of_blocks syms = let reconstruct (cfg : cfg) = - let blocks = Addr.Table.create () in - let symtab = String.Table.create () in + let blocks = Hashtbl.create (module Addr) in + let symtab = Hashtbl.create (module String) in Seq.iter (Cfg.nodes cfg) ~f:(fun blk -> Hashtbl.set blocks ~key:(Block.addr blk) ~data:blk); Seq.iter syms ~f:(fun (name,b,_) -> match Hashtbl.find blocks b with diff --git a/lib/bap_disasm/bap_disasm_rooter.ml b/lib/bap_disasm/bap_disasm_rooter.ml index 1447e1b50..c7abe90d1 100644 --- a/lib/bap_disasm/bap_disasm_rooter.ml +++ b/lib/bap_disasm/bap_disasm_rooter.ml @@ -47,7 +47,7 @@ let of_image img = { } let of_blocks blocks = - let roots = String.Table.create () in + let roots = Hashtbl.create (module String) in Seq.iter blocks ~f:(fun (name,sa,_) -> Hashtbl.change roots name (function | Some a when Addr.(a < sa) -> Some a @@ -55,10 +55,10 @@ let of_blocks blocks = create (Hashtbl.data roots |> Seq.of_list) let make_provider rooter = - let init = Set.empty (module Word) in + let init = (Set.empty (module Word)) in let roots = roots rooter |> - Seq.fold ~init ~f:Set.add in + Seq.fold ~init ~f:(fun s x -> Set.add s x) in fun label -> KB.collect Theory.Label.addr label >>=? fun addr -> Context.for_label label >>| fun ctxt -> diff --git a/lib/bap_disasm/bap_disasm_symbolizer.ml b/lib/bap_disasm/bap_disasm_symbolizer.ml index 35ba9c187..c3870693c 100644 --- a/lib/bap_disasm/bap_disasm_symbolizer.ml +++ b/lib/bap_disasm/bap_disasm_symbolizer.ml @@ -63,7 +63,7 @@ let report_broken = function let of_image img = let symtab = Image.symbols img in - let names = Addr.Table.create () in + let names = Hashtbl.create (module Addr) in let init = Bap_relation.empty Addr.compare String.compare in Table.foldi symtab ~init ~f:(fun mem sym rels -> let name = Image.Symbol.name sym @@ -79,14 +79,14 @@ let of_image img = let of_blocks seq = let names = let empty_rel = Bap_relation.empty Addr.compare String.compare in - Seq.fold seq ~init:String.Map.empty ~f:(fun addrs (name,addr,_) -> + Seq.fold seq ~init:(Map.empty (module String)) ~f:(fun addrs (name,addr,_) -> Map.update addrs name (function | Some addr' -> Addr.min addr addr' | None -> addr)) |> Map.to_sequence |> Seq.fold ~init:empty_rel ~f:(fun rels (name,entry) -> Bap_relation.add rels entry name) |> fun rels -> - Bap_relation.matching rels Addr.Map.empty + Bap_relation.matching rels (Map.empty (module Addr)) ~saturated:(fun addr name names -> Map.add_exn names addr name) ~unmatched:(fun reason names -> report_broken reason; names) in create @@ Map.find names diff --git a/lib/bap_disasm/bap_disasm_symtab.ml b/lib/bap_disasm/bap_disasm_symtab.ml index a13ffa1e0..4e85a8f60 100644 --- a/lib/bap_disasm/bap_disasm_symtab.ml +++ b/lib/bap_disasm/bap_disasm_symtab.ml @@ -27,10 +27,14 @@ type fn = string * block * cfg [@@deriving compare] let sexp_of_fn (name,block,_cfg) = Sexp.List [sexp_of_string name; sexp_of_addr (Block.addr block)] -module Fn = Opaque.Make(struct - type t = fn [@@deriving compare] - let hash x = String.hash (fst3 x) - end) +module Fn = struct + type t = fn [@@deriving compare] + let hash x = String.hash (fst3 x) + include Opaque.Make(struct + type nonrec t = t [@@deriving compare] + let hash x = String.hash (fst3 x) + end) +end type t = { @@ -44,7 +48,7 @@ type t = { let compare t1 t2 = - Addr.Map.compare Fn.compare t1.addrs t2.addrs + Base.Map.compare_direct Poly.compare t1.addrs t2.addrs type symtab = t [@@deriving compare, sexp_of] @@ -53,12 +57,12 @@ let span ((_name,_entry,cfg) as fn) = Memmap.add map (Block.memory blk) fn) let empty = { - addrs = Addr.Map.empty; - names = String.Map.empty; + addrs = (Map.empty (module Addr)); + names = (Map.empty (module String)); memory = Memmap.empty; - ecalls = Map.empty (module Addr); - icalls = Map.empty (module Addr); - extern = Map.empty (module Theory.Label); + ecalls = (Map.empty (module Addr)); + icalls = (Map.empty (module Addr)); + extern = (Map.empty (module Theory.Label)); } let merge m1 m2 = @@ -98,7 +102,7 @@ let find_by_start tab = Map.find tab.addrs let find_by_name tab = Map.find tab.names let fns_of_seq seq = - Seq.map seq ~f:snd |> Seq.to_list |> Fn.Set.of_list |> + Seq.map seq ~f:snd |> Seq.to_list |> Set.of_list (module Fn) |> Set.to_list let owners t addr = Memmap.lookup t.memory addr |> fns_of_seq diff --git a/lib/bap_disasm/bap_disasm_target_factory.ml b/lib/bap_disasm/bap_disasm_target_factory.ml index a5e27ca69..00f929fa4 100644 --- a/lib/bap_disasm/bap_disasm_target_factory.ml +++ b/lib/bap_disasm/bap_disasm_target_factory.ml @@ -9,7 +9,7 @@ let create_stub_target arch = let addr_size = Arch.addr_size arch module CPU = struct - let gpr = Var.Set.empty + let gpr = (Set.empty (module Var)) let nil = Var.create "nil" (Type.imm (Size.in_bits addr_size)) let mem = Var.create "mem" (Type.mem addr_size `r8) let pc = nil @@ -35,7 +35,7 @@ let create_stub_target arch = end in (module Lifter : Target) -let targets = Arch.Table.create () +let targets = Hashtbl.create (module Arch) let target_of_arch = let get arch = match Hashtbl.find targets arch with diff --git a/lib/bap_dwarf/dwarf_data.ml b/lib/bap_dwarf/dwarf_data.ml index b11d32162..da75bac7b 100644 --- a/lib/bap_dwarf/dwarf_data.ml +++ b/lib/bap_dwarf/dwarf_data.ml @@ -35,12 +35,12 @@ type 'a t = { let create endian ss : 'a t Or_error.t = let open Or_error.Monad_infix in - Section.Map.of_alist_or_error ss >>| + Map.of_alist_or_error (module Section) ss >>| fun sections -> {sections; endian} let section t section = - match Section.Map.find t.sections section with + match Map.find t.sections section with | Some buf -> Ok buf | None -> Or_error.errorf "section %s is not available" @@ diff --git a/lib/bap_dwarf/dwarf_fbi.ml b/lib/bap_dwarf/dwarf_fbi.ml index 0bf00e12d..e47789956 100644 --- a/lib/bap_dwarf/dwarf_fbi.ml +++ b/lib/bap_dwarf/dwarf_fbi.ml @@ -140,7 +140,7 @@ let read_scheme s str_sec action str ~pos_ref = loop [] let create_table s str_sec str ~pos_ref = - let abbrs : table = Table.create () in + let abbrs : table = Hashtbl.create (module Int) in let rec fill () = Input.code str ~pos_ref >>= function | 0 -> return () @@ -152,15 +152,13 @@ let create_table s str_sec str ~pos_ref = | Subprogram | Entry_point | Inlined_subroutine -> Input.take | _ -> Input.drop in read_scheme s str_sec action str ~pos_ref - >>= fun scheme -> match Table.add abbrs ~key:code ~data:scheme with - | `Ok -> fill () - | `Duplicate -> errorf "Duplicate entry code: %d" code in + >>= fun scheme -> Hashtbl.set abbrs ~key:code ~data:scheme; fill () in fill () >>| fun () -> abbrs let lookup table code = let error = Error.create "unknown code" code sexp_of_int in - Result.of_option ~error @@ Table.find table code + Result.of_option ~error @@ Hashtbl.find table code let run_scheme scheme str ~pos_ref : value list Or_error.t = @@ -173,12 +171,12 @@ let read_function cu_end abbrs str ~pos_ref = let open Sequence.Step in if pos_ref.contents < cu_end then Input.code str ~pos_ref >>= function - | 0 -> return @@ Skip () + | 0 -> return @@ Skip {state=()} | code -> lookup abbrs code >>= fun scheme -> run_scheme scheme str ~pos_ref >>| fun vs -> match fn_of_values vs with - | Ok fn -> Yield (fn, ()) - | Error _ -> Skip () + | Ok fn -> Yield {value=fn; state=()} + | Error _ -> Skip {state=()} else return Done let create data : t Or_error.t = @@ -213,14 +211,14 @@ let create data : t Or_error.t = abbr_pos := Buffer.pos abbr_sec; if info_pos.contents < String.length info then match read_header () with - | Ok abbrs -> Skip abbrs + | Ok abbrs -> Skip {state=abbrs} | Error err -> eprintf "Failed to move to a next CU: %s" @@ (Error.to_string_hum err); Done else Done - | Ok (Yield (fn,())) -> Yield (fn,(abbrs,cu_end)) - | Ok (Skip ()) -> Skip (abbrs,cu_end) + | Ok (Yield {value=fn;state=()}) -> Yield {value=fn; state=(abbrs,cu_end)} + | Ok (Skip {state=()}) -> Skip {state=(abbrs,cu_end)} | Error err -> eprintf "Warning: Dwarf parser stopped prematurely: %s\n\ diff --git a/lib/bap_elf/elf_parse.ml b/lib/bap_elf/elf_parse.ml index 9d4ec35c6..b1dd761ae 100644 --- a/lib/bap_elf/elf_parse.ml +++ b/lib/bap_elf/elf_parse.ml @@ -34,7 +34,7 @@ open Bitstring open Elf_types open Elf_internal_utils -module Char = Caml.Char +module Char = Stdlib.Char let elf_max_header_size = 64 (* no magick! *) diff --git a/lib/bap_future/bap_future.ml b/lib/bap_future/bap_future.ml index 4e9915883..d092f32fb 100644 --- a/lib/bap_future/bap_future.ml +++ b/lib/bap_future/bap_future.ml @@ -232,7 +232,7 @@ module Std = struct let create () = let stream = { - subs = Id.Table.create (); + subs = Hashtbl.create (module Id); last_id = Id.zero; on_subs = []; on_unsubs = []; diff --git a/lib/bap_image/bap_image.ml b/lib/bap_image/bap_image.ml index 6598dfd53..8dc590f84 100644 --- a/lib/bap_image/bap_image.ml +++ b/lib/bap_image/bap_image.ml @@ -6,7 +6,7 @@ open Bap_types.Std open Monads.Std open Format open Image_internal_std -module Sys = Caml.Sys +module Sys = Stdlib.Sys module Fact = Ogre.Make(Monad.Ident) module Result = Monad.Result.Error @@ -21,7 +21,7 @@ end type loader = (module Loader) let backends : loader String.Table.t = - String.Table.create () + Hashtbl.create (module String) module KB = struct module type Loader = sig @@ -373,15 +373,15 @@ let create_words secs = { let available_backends () = Hashtbl.keys backends let create_segment_of_symbol_table syms secs = - let tab = Symbol.Table.create () + let tab = Hashtbl.create (module Symbol) ~growth_allowed:false ~size:(Table.length syms) in Table.iteri syms ~f:(fun mem sym -> match Table.find_addr secs (Memory.min_addr mem) with | None -> () | Some (_,sec) -> - Symbol.Table.add_exn tab ~key:sym ~data:sec); - Symbol.Table.find_exn tab + Hashtbl.add_exn tab ~key:sym ~data:sec); + Hashtbl.find_exn tab let from_spec query base doc = Fact.eval query doc >>= function diff --git a/lib/bap_image/bap_memory.ml b/lib/bap_image/bap_memory.ml index 4e3c705c2..91bcbf584 100644 --- a/lib/bap_image/bap_memory.ml +++ b/lib/bap_image/bap_memory.ml @@ -32,7 +32,7 @@ module Repr = struct } [@@deriving bin_io] end -include Binable.Of_binable(Repr)(struct +include Binable.Of_binable_without_uuid(Repr)(struct type nonrec t = t let to_binable {endian; addr; data; off; size} : Repr.t = { endian; diff --git a/lib/bap_image/bap_table.ml b/lib/bap_image/bap_table.ml index bcdd768d9..78427a6a2 100644 --- a/lib/bap_image/bap_table.ml +++ b/lib/bap_image/bap_table.ml @@ -68,12 +68,12 @@ type 'a ranged -> 'a let empty = { - map = Map.empty; + map = (Base.Map.empty (module Mem)); bound = Bound.empty; } let singleton k v = { - map = Map.singleton k v; + map = Base.Map.singleton (module Mem) k v; bound = Bound.(update empty k); } @@ -84,12 +84,12 @@ let pp_elt f fmt = function (** @pre [x <= y] *) let intersects x y = Addr.(Mem.max_addr x >= Mem.min_addr y) -let prev_key map key = Map.closest_key map `Less_than key -let next_key map key = Map.closest_key map `Greater_than key +let prev_key map key = Base.Map.closest_key map `Less_than key +let next_key map key = Base.Map.closest_key map `Greater_than key let has_intersections tab (x : mem) : bool = Bound.is_bound tab.bound x && - match Map.find tab.map x with + match Base.Map.find tab.map x with | Some _ -> true | None -> match prev_key tab.map x with | Some (p,_) when intersects p x -> true @@ -117,7 +117,7 @@ let left_bound tab x = | _ -> p in if has_intersections tab x then match prev_key tab.map x with | Some (p,_) when intersects p x -> Some (search_left p) - | _ when Map.mem tab.map x -> Some x (* see note above*) + | _ when Base.Map.mem tab.map x -> Some x (* see note above*) | _ -> next_key tab.map x |> Option.map ~f:fst else None @@ -129,7 +129,7 @@ let fold_intersections tab x ~init ~f = | _ -> init in match left_bound tab x with | None -> init - | Some p -> match Map.find tab.map p with + | Some p -> match Base.Map.find tab.map p with | Some d -> loop (p,d) init | None -> assert false @@ -146,16 +146,16 @@ let change tab mem ~f = | `ignore -> tab | `update _ | `rebind _ | `remove as cmd -> let map = - Seq.fold ins ~init:tab.map ~f:(fun m (k,_) -> Map.remove m k) in + Seq.fold ins ~init:tab.map ~f:(fun m (k,_) -> Base.Map.remove m k) in let map, bound = match cmd with | `remove -> map, tab.bound | `update f -> Seq.fold ins ~init:(map, tab.bound) ~f:(fun (map,bnd) (mem,x) -> - Map.set map ~key:mem ~data:(f (mem,x)), + Base.Map.set map ~key:mem ~data:(f (mem,x)), Bound.update bnd mem) | `rebind (mem,data) -> - Map.set map ~key:mem ~data, + Base.Map.set map ~key:mem ~data, Bound.update tab.bound mem in { map; bound } @@ -163,28 +163,28 @@ let add tab mem x = if has_intersections tab mem then error "memory has intersections" mem sexp_of_mem else Ok { - map = Mem.Map.set tab.map ~key:mem ~data:x; + map = Base.Map.set tab.map ~key:mem ~data:x; bound = Bound.update tab.bound mem; } let remove tab x = (* we shouldn't invalidate our cache if nothing changes *) - if Map.mem tab.map x + if Base.Map.mem tab.map x then { tab with - map = Map.remove tab.map x; + map = Base.Map.remove tab.map x; } else tab -let length tab = Map.length tab.map +let length tab = Base.Map.length tab.map -let find tab mem = Map.find tab.map mem -let mem tab mem = Map.mem tab.map mem +let find tab mem = Base.Map.find tab.map mem +let mem tab mem = Base.Map.mem tab.map mem let next tab = next_key tab.map let prev tab = prev_key tab.map -let min tab = Map.min_elt tab.map -let max tab = Map.max_elt tab.map +let min tab = Base.Map.min_elt tab.map +let max tab = Base.Map.max_elt tab.map let first_some user our = Option.first_some user (Option.map ~f:fst our) @@ -192,19 +192,19 @@ let first_some user our = let foldi ?start ?until (tab : 'a t) ~(init : 'b) ~f : 'b = let f_labeled = fun ~key ~data s -> f key data s in if Option.is_none start && Option.is_none until - then Map.fold tab.map ~init:init ~f:f_labeled + then Base.Map.fold tab.map ~init:init ~f:f_labeled else - let from = first_some start (Map.min_elt tab.map) in - let last = first_some until (Map.max_elt tab.map) in + let from = first_some start (Base.Map.min_elt tab.map) in + let last = first_some until (Base.Map.max_elt tab.map) in match from,last with | Some from, Some last -> if Mem.(from <= last) - then Map.fold_range_inclusive tab.map + then Base.Map.fold_range_inclusive tab.map ~init ~min:from ~max:last ~f:f_labeled else let last,from = from,last in let seq = - Map.to_sequence tab.map + Base.Map.to_sequence tab.map ~order:`Decreasing_key ~keys_less_or_equal_to:from |> Seq.take_while ~f:(fun (m,_) -> Mem.(m >= last)) in @@ -283,14 +283,14 @@ let make_map map add ?start ?until tab ~f = map = map tab.map ~f:(fun ~key ~data -> f key data); } else let map,bound = - foldi ?start ?until tab ~init:(Map.empty,Bound.empty) + foldi ?start ?until tab ~init:((Base.Map.empty (module Mem)),Bound.empty) ~f:(fun addr x (map,bound) -> add map ~key:addr ~data:(f addr x), Bound.update bound addr) in { map; bound} let mapi ?start ?until tab ~f = - make_map Map.mapi Map.set ?start ?until tab ~f + make_map Base.Map.mapi Base.Map.set ?start ?until tab ~f let map ?start ?until tab ~f = mapi ?start ?until tab ~f:(fun _ x -> f x) @@ -298,8 +298,8 @@ let map ?start ?until tab ~f = let filter_mapi ?start ?until tab ~f = let add map ~key ~data = match data with | None -> map - | Some data -> Map.set map ~key ~data in - make_map Map.filter_mapi add ?start ?until tab ~f + | Some data -> Base.Map.set map ~key ~data in + make_map Base.Map.filter_mapi add ?start ?until tab ~f let filter_map ?start ?until tab ~f = filter_mapi ?start ?until tab ~f:(fun _ v -> f v) @@ -312,16 +312,16 @@ let filter ?start ?until tab ~f = filteri ?start ?until tab ~f:(fun _ x -> f x) let make_mapping t map = - let size = Map.length map in + let size = Base.Map.length map in let table = Hashtbl.Using_hashable.create ~growth_allowed:false ~size ~hashable:t () in - Map.iteri map ~f:(fun ~key:_ ~data:(v1,v2) -> + Base.Map.iteri map ~f:(fun ~key:_ ~data:(v1,v2) -> Hashtbl.add_exn table ~key:v1 ~data:v2); table let link_maybe_one t (t1 : 'a t) (t2 : 'b t) : 'a -> 'b option = let mapping = - Map.merge t1.map t2.map ~f:(fun ~key -> function + Base.Map.merge t1.map t2.map ~f:(fun ~key -> function | `Both (v1,v2) -> Some (v1,v2) | `Left _ | `Right _ -> None) |> make_mapping t in @@ -339,10 +339,10 @@ let link_one t t1 t2 = Error.raise err let link_many t t1 t2 = - let size = Map.length t1.map in + let size = Base.Map.length t1.map in let table = Hashtbl.Using_hashable.create ~growth_allowed:false ~size ~hashable:t () in - Map.iteri t1.map ~f:(fun ~key:mem ~data:x -> + Base.Map.iteri t1.map ~f:(fun ~key:mem ~data:x -> let data = intersections t2 mem |> Seq.map ~f:snd in Hashtbl.add_exn table ~key:x ~data); fun x -> match Hashtbl.find table x with @@ -383,10 +383,10 @@ let link : type b c . one_to:((b,c) r) -> (* reverse injective mapping *) let make_rev_map add find t tab = - let size = Map.length tab.map in + let size = Base.Map.length tab.map in let table = Hashtbl.Using_hashable.create ~growth_allowed:false ~hashable:t ~size () in - Map.iteri tab.map ~f:(fun ~key:mem ~data:x -> + Base.Map.iteri tab.map ~f:(fun ~key:mem ~data:x -> add t table ~key:x ~data:mem); find t table diff --git a/lib/bap_llvm/bap_llvm_loader.ml b/lib/bap_llvm/bap_llvm_loader.ml index b3db45b4b..9fc583f30 100644 --- a/lib/bap_llvm/bap_llvm_loader.ml +++ b/lib/bap_llvm/bap_llvm_loader.ml @@ -7,7 +7,7 @@ open Or_error include Self() -module Sys = Caml.Sys +module Sys = Stdlib.Sys module Unix = Caml_unix module Ogre = struct @@ -122,7 +122,7 @@ module LLVM = struct (scheme name $ addr $ size) Tuple.T3.create end -module Filename = Caml.Filename +module Filename = Stdlib.Filename open Image.Scheme open Ogre.Syntax diff --git a/lib/bap_llvm/config/llvm_configurator.ml b/lib/bap_llvm/config/llvm_configurator.ml index 961feabd3..56ee5e65f 100644 --- a/lib/bap_llvm/config/llvm_configurator.ml +++ b/lib/bap_llvm/config/llvm_configurator.ml @@ -2,9 +2,9 @@ open Base open Stdio module C = Configurator.V1 -module Buf = Caml.Buffer -module Arg = Caml.Arg -module Filename = Caml.Filename +module Buf = Stdlib.Buffer +module Arg = Stdlib.Arg +module Filename = Stdlib.Filename open Llvm_config let llvm_components = [ @@ -47,7 +47,7 @@ let () = C.main ~args ~name:"bap-llvm" @@ fun self -> String.strip @@ C.Process.run_capture_exn self llvm_config ["--version"] in let src = !filename in - let dst = Caml.Filename.chop_extension src in + let dst = Stdlib.Filename.chop_extension src in In_channel.with_file src ~f:(fun input -> Out_channel.with_file dst ~f:(fun output -> In_channel.iter_lines input ~f:(fun line -> diff --git a/lib/bap_main/bap_main.ml b/lib/bap_main/bap_main.ml index 726d4c802..8c5c1ce02 100644 --- a/lib/bap_main/bap_main.ml +++ b/lib/bap_main/bap_main.ml @@ -258,9 +258,9 @@ module Error = struct type t += Exit_requested of int type t += Bad_recipe of Bap_recipe.error - let register_printer = Caml.Printexc.register_printer + let register_printer = Stdlib.Printexc.register_printer let pp ppf e = - Format.pp_print_string ppf (Caml.Printexc.to_string e) + Format.pp_print_string ppf (Stdlib.Printexc.to_string e) let str fmt = Format.kasprintf Option.some fmt @@ -433,8 +433,8 @@ module Context = struct let command_descriptions = Hashtbl.create (module String) let builder = ref @@ Building { - env = Map.empty (module String); - plugins = Map.empty (module String); + env = (Map.empty (module String)); + plugins = (Map.empty (module String)); } let update f = match builder.contents with @@ -464,7 +464,7 @@ module Context = struct env = Map.filter ctxt.env ~f:(fun {scope} -> not (Set.mem disabled scope)); plugins = - let init = Map.empty (module String) in + let init = (Map.empty (module String)) in List.fold ~init plugins ~f:(fun plugins (name,{tags}) -> if Set.mem disabled name then plugins else @@ -531,7 +531,7 @@ module Context = struct Map.iteri ctxt.env ~f:(fun ~key ~data:{digest} -> Format.fprintf ppf "%s = %s@\n" key digest); Format.pp_print_flush ppf (); - Caml.Digest.string @@ + Stdlib.Digest.string @@ Buffer.contents buffer (* the info interface *) @@ -923,8 +923,8 @@ end = struct let get_from_env name = let name = env_var_for_option name in - try Some (Caml.Sys.getenv name) - with Caml.Not_found -> None + try Some (Stdlib.Sys.getenv name) + with Stdlib.Not_found -> None let get_from_config ctxt name = List.Assoc.find ~equal:String.equal ctxt.config name @@ -1002,7 +1002,7 @@ end = struct t1 >>> t2) let progname = - Caml.Filename.basename (Caml.Sys.executable_name) + Stdlib.Filename.basename (Stdlib.Sys.executable_name) let with_context name ~f = @@ -1011,7 +1011,7 @@ end = struct let try_eval f x = try f x with | Invalid_argument s -> Error (Error.Invalid s) | exn -> - let backtrace = Caml.Printexc.get_backtrace () in + let backtrace = Stdlib.Printexc.get_backtrace () in Error (Error.Bug (exn,backtrace)) @@ -1178,7 +1178,7 @@ module Extension = struct try Ok (f ctxt) with | Invalid_argument s -> Error (Error.Invalid s) | exn -> - let backtrace = Caml.Printexc.get_backtrace () in + let backtrace = Stdlib.Printexc.get_backtrace () in Error (Error.Bug (exn,backtrace)) let doc_enum = Arg.doc_alts_enum diff --git a/lib/bap_main/bap_main_event.ml b/lib/bap_main/bap_main_event.ml index cb65bf743..3be986aa5 100644 --- a/lib/bap_main/bap_main_event.ml +++ b/lib/bap_main/bap_main_event.ml @@ -4,8 +4,8 @@ open Bap_plugins.Std open Bap_bundle.Std open Format -module Buffer = Caml.Buffer -module Sys = Caml.Sys +module Buffer = Stdlib.Buffer +module Sys = Stdlib.Sys (* we're reusing [exn] type only because we want to use Printexc magic printer. It is not visible from outside, @@ -16,10 +16,10 @@ module Sys = Caml.Sys type t = exn = .. type event = t = .. -let register_printer = Caml.Printexc.register_printer +let register_printer = Stdlib.Printexc.register_printer let stream,new_event = Stream.create () let send (ev : t) = Signal.send new_event ev -let string_of_event = Caml.Printexc.to_string +let string_of_event = Stdlib.Printexc.to_string let pp ppf e = pp_print_string ppf (string_of_event e) @@ -98,7 +98,7 @@ module Log = struct progress ?note ?stage ?total task let has_var v = match Sys.getenv ("BAP_" ^ String.uppercase v) with - | exception Caml.Not_found -> false + | exception Stdlib.Not_found -> false | "false" | "0" -> false | _ -> true diff --git a/lib/bap_main/bap_main_log.ml b/lib/bap_main/bap_main_log.ml index ca4256b27..f9e2c9090 100644 --- a/lib/bap_main/bap_main_log.ml +++ b/lib/bap_main/bap_main_log.ml @@ -4,12 +4,12 @@ open Bap_plugins.Std open Format module Event = Bap_main_event -module Filename = Caml.Filename -module Sys = Caml.Sys +module Filename = Stdlib.Filename +module Sys = Stdlib.Sys module Unix = Caml_unix let perm = 0o770 -let getenv opt = try Some (Sys.getenv opt) with Caml.Not_found -> None +let getenv opt = try Some (Sys.getenv opt) with Stdlib.Not_found -> None let rec mkdir path = let par = Filename.dirname path in diff --git a/lib/bap_piqi/bil_piqi.ml b/lib/bap_piqi/bil_piqi.ml deleted file mode 100644 index c54ecd0d5..000000000 --- a/lib/bap_piqi/bil_piqi.ml +++ /dev/null @@ -1,261 +0,0 @@ -open Core_kernel[@@warning "-D"] -open Bap.Std -open Bil.Types - -module P = Stmt_piqi -open Type - -let casttype_to_piqi = function - | UNSIGNED -> `cast_unsigned - | SIGNED -> `cast_signed - | HIGH -> `cast_high - | LOW -> `cast_low - -let casttype_of_piqi = function - | `cast_unsigned -> UNSIGNED - | `cast_signed -> SIGNED - | `cast_high -> HIGH - | `cast_low -> LOW - -let unop_to_piqi : 'a -> Stmt_piqi.unop_type = function - | NEG -> `uneg - | NOT -> `unot - -let unop_of_piqi = function - | `uneg -> NEG - | `unot -> NOT - -let binop_to_piqi : 'a -> Stmt_piqi.binop_type = function - | PLUS -> `plus - | MINUS -> `minus - | TIMES -> `times - | DIVIDE -> `divide - | SDIVIDE -> `sdivide - | MOD -> `modbop - | SMOD -> `smod - | LSHIFT -> `lshift - | RSHIFT -> `rshift - | ARSHIFT -> `arshift - | AND -> `andbop - | OR -> `orbop - | XOR -> `x_or - | EQ -> `eq - | NEQ -> `neq - | LT -> `lt - | LE -> `le - | SLT -> `slt - | SLE -> `sle - -let binop_of_piqi = function - | `plus -> PLUS - | `minus -> MINUS - | `times -> TIMES - | `divide -> DIVIDE - | `sdivide -> SDIVIDE - | `modbop -> MOD - | `smod -> SMOD - | `lshift -> LSHIFT - | `rshift -> RSHIFT - | `arshift -> ARSHIFT - | `andbop -> AND - | `orbop -> OR - | `x_or -> XOR - | `eq -> EQ - | `neq -> NEQ - | `lt -> LT - | `le -> LE - | `slt -> SLT - | `sle -> SLE - -let type_to_piqi : typ -> Stmt_piqi.typ = function - | Imm s -> `imm s - | Mem (t, t') -> `mem {Stmt_piqi.Mem.index_type = t; element_type = t';} - | Unk -> `unk - -let type_of_piqi = function - | `imm n -> Imm n - | `mem {P.Mem.index_type; element_type} -> Mem (index_type, element_type) - | `unk -> Type.Unk - -let var_to_piqi v = - let module P = Stmt_piqi in { - P.Var.name = Var.name v; - P.Var.id = Var.index v; - P.Var.typ = type_to_piqi (Var.typ v); - P.Var.tmp = Var.is_virtual v; - } - -let var_of_piqi { P.Var.name; id; typ; tmp} = - let module P = Stmt_piqi in - let v = Var.create ~is_virtual:tmp name (type_of_piqi typ) in - Var.with_index v id - -let endianness_to_piqi : endian -> Stmt_piqi.endian = function - | LittleEndian -> `little_endian - | BigEndian -> `big_endian - -let endianness_of_piqi = function - | `little_endian -> LittleEndian - | `big_endian -> BigEndian - -let rec exp_to_piqi : exp -> Stmt_piqi.expr = - function - | Load (m, i, e, s) -> - let m = exp_to_piqi m in - let i = exp_to_piqi i in - let e = endianness_to_piqi e in - `load {P.Load.memory=m; address=i; endian=e; size=s;} - | Store (m, i, v, e, size) -> - let m = exp_to_piqi m in - let i = exp_to_piqi i in - let v = exp_to_piqi v in - let e = endianness_to_piqi e in - `store {P.Store.memory=m; address=i; value=v; endian=e; size;} - | BinOp (bop, e1, e2) -> - let bop = binop_to_piqi bop in - let e1 = exp_to_piqi e1 in - let e2 = exp_to_piqi e2 in - `binop {P.Binop.op=bop; lexp=e1; rexp=e2;} - | UnOp (uop, e) -> - let uop = unop_to_piqi uop in - let e = exp_to_piqi e in - `unop {P.Unop.op=uop; exp=e} - | Var v -> - `var (var_to_piqi v) - | Int v -> - `inte {P.Inte.int = Bitvector.to_string v;} - | Cast (ct, size, e) -> - let ct = casttype_to_piqi ct in - let e = exp_to_piqi e in - `cast {P.Cast.cast_type=ct; size; exp=e} - | Let (v, e, e') -> - let v = var_to_piqi v in - let e = exp_to_piqi e in - let e' = exp_to_piqi e' in - `let_exp {P.Let_exp.bound_var=v; definition=e; open_exp=e'} - | Unknown (s, t) -> - let t = type_to_piqi t in - `unknown {P.Unknown.descr=s; typ=t} - | Ite (e, te, fe) -> - let e = exp_to_piqi e in - let te = exp_to_piqi te in - let fe = exp_to_piqi fe in - `ite {P.Ite.condition=e; iftrue=te; iffalse=fe} - | Extract (h, l, e) -> - let e = exp_to_piqi e in - `extract {P.Extract.hbit=h; lbit=l; exp=e} - | Concat (e1, e2) -> - let e1 = exp_to_piqi e1 in - let e2 = exp_to_piqi e2 in - `concat {P.Concat.lexp=e1; rexp=e2} - -let rec exp_of_piqi = function - | `load {P.Load.memory; address; endian; size} -> - let m = exp_of_piqi memory in - let i = exp_of_piqi address in - let e = endianness_of_piqi endian in - Load (m, i, e, size) - | `store {P.Store.memory; address; value; endian; size} -> - let m = exp_of_piqi memory in - let i = exp_of_piqi address in - let v = exp_of_piqi value in - let e = endianness_of_piqi endian in - Store (m, i, v, e, size) - | `binop {P.Binop.op; lexp; rexp} -> - let bop = binop_of_piqi op in - let e1 = exp_of_piqi lexp in - let e2 = exp_of_piqi rexp in - BinOp (bop, e1, e2) - | `unop {P.Unop.op; exp} -> - let uop = unop_of_piqi op in - let e = exp_of_piqi exp in - UnOp (uop, e) - | `var v -> - Var (var_of_piqi v) - | `inte {P.Inte.int=s} -> - Int (Bitvector.of_string s) - | `cast {P.Cast.cast_type; size; exp} -> - let ct = casttype_of_piqi cast_type in - let e = exp_of_piqi exp in - Cast (ct, size, e) - | `let_exp {P.Let_exp.bound_var; definition; open_exp} -> - let v = var_of_piqi bound_var in - let d = exp_of_piqi definition in - let e = exp_of_piqi open_exp in - Let (v, d, e) - | `unknown {P.Unknown.descr; typ} -> - let t = type_of_piqi typ in - Unknown (descr, t) - | `ite {P.Ite.condition; iftrue; iffalse} -> - let cond = exp_of_piqi condition in - let te = exp_of_piqi iftrue in - let fe = exp_of_piqi iffalse in - Ite (cond, te, fe) - | `extract {P.Extract.hbit; lbit; exp} -> - let e = exp_of_piqi exp in - Extract (hbit, lbit, e) - | `concat {P.Concat.lexp; rexp} -> - let e1 = exp_of_piqi lexp in - let e2 = exp_of_piqi rexp in - Concat (e1, e2) - -let rec stmt_to_piqi : stmt -> Stmt_piqi.stmt = function - | Move (v, e) -> - let v = var_to_piqi v in - let e = exp_to_piqi e in - `move {P.Move.lvar=v; rexp=e} - | Jmp targ -> - let targ = exp_to_piqi targ in - `jmp {P.Jmp.target=targ} - | Special s -> `special s - | While (e, stmts) -> - let e = exp_to_piqi e in - let stmts = stmts_to_piqi stmts in - `while_stmt {P.While_stmt.cond=e; loop_body=stmts} - | If (e, then_branch, else_branch) -> - let e = exp_to_piqi e in - let then_branch = stmts_to_piqi then_branch in - let else_branch = stmts_to_piqi else_branch in - `if_stmt {P.If_stmt.cond=e; true_branch=then_branch; false_branch=else_branch} - | CpuExn n -> `cpuexn {P.Cpuexn.errnum=n} - -and stmts_to_piqi l = List.map ~f:stmt_to_piqi l - -let rec stmt_of_piqi = function - | `move {P.Move.lvar; rexp} -> - let v = var_of_piqi lvar in - let e = exp_of_piqi rexp in - Move (v, e) - | `jmp {P.Jmp.target} -> - let t = exp_of_piqi target in - Jmp t - | `special s -> Special s - | `while_stmt {P.While_stmt.cond; loop_body} -> - let e = exp_of_piqi cond in - let b = stmts_of_piqi loop_body in - While (e, b) - | `if_stmt {P.If_stmt.cond; true_branch; false_branch} -> - let e = exp_of_piqi cond in - let then_branch = stmts_of_piqi true_branch in - let else_branch = stmts_of_piqi false_branch in - If (e, then_branch, else_branch) - | `cpuexn {P.Cpuexn.errnum} -> CpuExn errnum - -and stmts_of_piqi l = List.map ~f:stmt_of_piqi l - -open Stmt_piqi_ext - -type fmt = [ `json | `pb | `piq | `pib | `xml ] [@@deriving sexp, enumerate] -type out_fmt = [fmt | `json_pretty | `xml_pretty] - -let loads f g fmt s = f (g s fmt) -let dumps g f fmt x = f (g x) (fmt : fmt :> out_fmt) - -let bil_of_string = loads stmts_of_piqi parse_stmt_list -let stmt_of_string = loads stmt_of_piqi parse_stmt -let exp_of_string = loads exp_of_piqi parse_expr -let string_of_bil = dumps stmts_to_piqi gen_stmt_list -let string_of_stmt = dumps stmt_to_piqi gen_stmt -let string_of_exp = dumps exp_to_piqi gen_expr -let piqi_of_exp = exp_to_piqi -let piqi_of_var = var_to_piqi diff --git a/lib/bap_piqi/bil_piqi.mli b/lib/bap_piqi/bil_piqi.mli deleted file mode 100644 index 05e52f2b6..000000000 --- a/lib/bap_piqi/bil_piqi.mli +++ /dev/null @@ -1,18 +0,0 @@ -open Bap.Std - -type fmt = [ `json | `pb | `piq | `pib | `xml ] -[@@deriving sexp, enumerate] - -val bil_of_string : fmt -> string -> bil -val string_of_bil : fmt -> bil -> string - -val stmt_of_string : fmt -> string -> stmt -val string_of_stmt : fmt -> stmt -> string - -val exp_of_string : fmt -> string -> exp -val string_of_exp : fmt -> exp -> string - -val exp_of_piqi : Stmt_piqi.expr -> exp -val var_of_piqi : Stmt_piqi.var -> var -val piqi_of_exp : exp -> Stmt_piqi.expr -val piqi_of_var : var -> Stmt_piqi.var diff --git a/lib/bap_piqi/bir_piqi.ml b/lib/bap_piqi/bir_piqi.ml deleted file mode 100644 index 65743811c..000000000 --- a/lib/bap_piqi/bir_piqi.ml +++ /dev/null @@ -1,160 +0,0 @@ -open Core_kernel[@@warning "-D"] -open Bap.Std - -open Option.Monad_infix - -module R = Ir_piqi - - -module Get = struct - let tid = Tid.from_string_exn - let exp = Bil_piqi.exp_of_piqi - let var = Bil_piqi.var_of_piqi - - let label = function - | `direct t -> Direct (tid t) - | `indirect e -> Indirect (exp e) - - let intent = function - | `in_ -> In - | `out -> Out - | `both -> Both - - let jump = function - | `goto dst -> Goto (label dst) - | `ret dst -> Ret (label dst) - | `exn {R.Exn.number; return=r} -> Int (number, tid r) - | `call {R.Call.target=t; return=r} -> - Call - (Call.create ?return:(r >>| label) ~target:(label t) ()) - - let arg {R.Arg.tid=t; lhs=v; rhs=e; intent=i} = - Arg.create ~tid:(tid t) ?intent:(i >>| intent) (var v) (exp e) - - let def {R.Def.tid=t; lhs; rhs} = - Def.create ~tid:(tid t) (var lhs) (exp rhs) - - let phi {R.Phi.tid=t; lhs; values} = - values |> - List.map ~f:(fun {R.Tid_exp_pair.tid=t;exp=e} -> tid t, exp e) |> - Phi.of_list ~tid:(tid t) (var lhs) - - let jmp {R.Jmp.tid=t; cond=c; jump=j} = - Jmp.create ~tid:(tid t) ~cond:(exp c) (jump j) - - let blk {R.Blk.tid=t; phis; defs; jmps} = - let b = Blk.Builder.create ~tid:(tid t) () in - List.iter phis ~f:(fun p -> Blk.Builder.add_phi b (phi p)); - List.iter defs ~f:(fun p -> Blk.Builder.add_def b (def p)); - List.iter jmps ~f:(fun p -> Blk.Builder.add_jmp b (jmp p)); - Blk.Builder.result b - - let sub {R.Sub.tid=t; args; blks; name} = - let b = Sub.Builder.create ~tid:(tid t) ~name () in - List.iter args ~f:(fun x -> Sub.Builder.add_arg b (arg x)); - List.iter blks ~f:(fun x -> Sub.Builder.add_blk b (blk x)); - Sub.Builder.result b - - let program {R.Program.tid=t; subs} = - let b = Program.Builder.create ~tid:(tid t) () in - List.iter subs ~f:(fun x -> Program.Builder.add_sub b (sub x)); - Program.Builder.result b -end - -module Put = struct - let tid = Tid.to_string - let exp = Bil_piqi.piqi_of_exp - let var = Bil_piqi.piqi_of_var - - let label = function - | Direct t -> `direct (tid t) - | Indirect e -> `indirect (exp e) - - let intent = function - | In -> `in_ - | Out -> `out - | Both -> `both - - let jump = function - | Goto d -> `goto (label d) - | Ret d -> `ret (label d) - | Int (n,r) -> `exn R.Exn.{number=n; return=(tid r)} - | Call c -> `call R.Call.{ - target = label (Call.target c); - return = Call.return c >>| label; - } - - let arg a = R.Arg.{ - tid = tid (Term.tid a); - lhs = var (Arg.lhs a); - rhs = exp (Arg.rhs a); - intent = Arg.intent a >>| intent; - } - - let def d = R.Def.{ - tid = tid (Term.tid d); - lhs = var (Def.lhs d); - rhs = exp (Def.rhs d); - } - - let pair (t,e) = R.Tid_exp_pair.{tid = tid t; exp = exp e} - - let phi t = R.Phi.{ - tid = tid (Term.tid t); - lhs = var (Phi.lhs t); - values = Phi.values t |> Seq.map ~f:pair |> Seq.to_list - } - - let jmp t = R.Jmp.{ - tid = tid (Term.tid t); - cond = exp (Jmp.cond t); - jump = jump (Jmp.kind t); - } - - let list t f term = - Term.enum t term |> Seq.map ~f |> Seq.to_list - - let blk t = R.Blk.{ - tid = tid (Term.tid t); - phis = list phi_t phi t; - defs = list def_t def t; - jmps = list jmp_t jmp t; - } - - let sub t = R.Sub.{ - tid = tid (Term.tid t); - name = Sub.name t; - args = list arg_t arg t; - blks = list blk_t blk t; - } - - let program t = R.Program.{ - tid = tid (Term.tid t); - subs = list sub_t sub t; - } -end - - -type fmt = [ `json | `pb | `piq | `pib | `xml ] -type out_fmt = [fmt | `json_pretty | `xml_pretty] - -let loads f g fmt s = f (g s fmt) -let dumps g f fmt x = f (g x) (fmt : fmt :> out_fmt) - -open Ir_piqi_ext - -let program_of_string = loads Get.program parse_program -let sub_of_string = loads Get.sub parse_sub -let blk_of_string = loads Get.blk parse_blk -let arg_of_string = loads Get.arg parse_arg -let phi_of_string = loads Get.phi parse_phi -let def_of_string = loads Get.def parse_def -let tid_of_string = loads Get.tid parse_tid - -let string_of_program = dumps Put.program gen_program -let string_of_sub = dumps Put.sub gen_sub -let string_of_blk = dumps Put.blk gen_blk -let string_of_arg = dumps Put.arg gen_arg -let string_of_phi = dumps Put.phi gen_phi -let string_of_def = dumps Put.def gen_def -let string_of_tid = dumps Put.tid gen_tid diff --git a/lib/bap_piqi/bir_piqi.mli b/lib/bap_piqi/bir_piqi.mli deleted file mode 100644 index d16b41106..000000000 --- a/lib/bap_piqi/bir_piqi.mli +++ /dev/null @@ -1,18 +0,0 @@ -open Bap.Std - -type fmt = [ `json | `pb | `piq | `pib | `xml ] - - -val program_of_string : fmt -> string -> program term -val sub_of_string : fmt -> string -> sub term -val blk_of_string : fmt -> string -> blk term -val arg_of_string : fmt -> string -> arg term -val phi_of_string : fmt -> string -> phi term -val def_of_string : fmt -> string -> def term - -val string_of_program : fmt -> program term -> string -val string_of_sub : fmt -> sub term -> string -val string_of_blk : fmt -> blk term -> string -val string_of_arg : fmt -> arg term -> string -val string_of_phi : fmt -> phi term -> string -val string_of_def : fmt -> def term -> string diff --git a/lib/bap_piqi/dune b/lib/bap_piqi/dune deleted file mode 100644 index a2d231e8b..000000000 --- a/lib/bap_piqi/dune +++ /dev/null @@ -1,27 +0,0 @@ -(library - (name bap_piqi) - (public_name bap-piqi) - (wrapped false) - (preprocess (pps ppx_bap)) - (libraries bap piqirun.pb piqirun.ext) - (private_modules stmt_piqi stmt_piqi_ext ir_piqi ir_piqi_ext)) - -(rule - (targets type__piqi.ml type__piqi_ext.ml) - (deps type.piqi) - (action (run piqic-ocaml --multi-format %{deps}))) - -(rule - (targets stmt_piqi.ml stmt_piqi_ext.ml) - (deps stmt.piqi) - (action (run piqic-ocaml --multi-format %{deps}))) - -(rule - (targets exp_piqi.ml exp_piqi_ext.ml) - (deps exp.piqi) - (action (run piqic-ocaml --multi-format %{deps}))) - -(rule - (targets ir_piqi.ml ir_piqi_ext.ml) - (deps ir.piqi) - (action (run piqic-ocaml --multi-format %{deps}))) diff --git a/lib/bap_piqi/exp.piqi b/lib/bap_piqi/exp.piqi deleted file mode 100644 index eda947fab..000000000 --- a/lib/bap_piqi/exp.piqi +++ /dev/null @@ -1,193 +0,0 @@ -.include [ - .module type -] - -.enum [ - .name endian - .option [.name little-endian] - .option [.name big-endian] -] - -.variant [ - .name expr - .option [.type var ] - .option [.type inte ] - .option [.type load ] - .option [.type store ] - .option [.type binop ] - .option [.type unop ] - .option [.type cast ] - .option [.type let-exp] - .option [.type unknown] - .option [.type ite ] - .option [.type extract] - .option [.type concat ] -] - -.record [ - .name load - .field [ - .name memory - .type expr - ] - .field [ - .name address - .type expr - ] - .field [ - .name endian - .type endian - ] - .field [ - .name size - .type size - ] -] - -.record [ - .name store - .field [ - .name memory - .type expr - ] - .field [ - .name address - .type expr - ] - .field [ - .name value - .type expr - ] - .field [ - .name endian - .type endian - ] - .field [ - .name size - .type size - ] -] - -.record [ - .name binop - .field [ - .name op - .type binop-type - ] - .field [ - .name lexp - .type expr - ] - .field [ - .name rexp - .type expr - ] -] - -.record [ - .name unop - .field [ - .name op - .type unop-type - ] - .field [ - .name exp - .type expr - ] -] - -.record [ - .name inte - .field [ - .name int - .type bitvector - ] -] - -.record [ - .name cast - .field [ - .name cast-type - .type cast-type - ] - .field [ - .name size - .type int - ] - .field [ - .name exp - .type expr - ] -] - -.record [ - .name let-exp - .field [ - .name bound-var - .type var - ] - .field [ - .name definition - .type expr - ] - .field [ - .name open-exp - .type expr - ] -] - -.record [ - .name unknown - .field [ - .name descr - .type string - ] - .field [ - .name typ - .type typ - ] -] - -.record [ - .name ite - .field [ - .name condition - .type expr - ] - .field [ - .name iftrue - .type expr - ] - .field [ - .name iffalse - .type expr - ] -] - -.record [ - .name extract - .field [ - .name hbit - .type int - ] - .field [ - .name lbit - .type int - ] - .field [ - .name exp - .type expr - ] -] - -.record [ - .name concat - .field [ - .name lexp - .type expr - ] - .field [ - .name rexp - .type expr - ] -] diff --git a/lib/bap_piqi/ir.piqi b/lib/bap_piqi/ir.piqi deleted file mode 100644 index 9da78bac9..000000000 --- a/lib/bap_piqi/ir.piqi +++ /dev/null @@ -1,97 +0,0 @@ -.import [ - .module stmt -] - -.record [ - .name program - .field [.name tid .type tid] - .field [.name subs .type sub .repeated] -] - -.record [ - .name sub - .field [ .name tid .type tid] - .field [ .name name .type string ] - .field [ .name args .type arg .repeated ] - .field [ .name blks .type blk .repeated ] -] - -.record [ - .name arg - .field [.name tid .type tid] - .field [ .name lhs .type stmt/var ] - .field [ .name rhs .type stmt/expr ] - .field [ .name intent .type intent .optional] -] - -.record [ - .name blk - .field [.name tid .type tid] - .field [ .name phis .type phi .repeated] - .field [ .name defs .type def .repeated] - .field [ .name jmps .type jmp .repeated] -] - -.record [ - .name phi - .field [.name tid .type tid] - .field [.name lhs .type stmt/var] - .field [.name values .type tid-exp-pair .repeated] -] - -.record [ - .name def - .field [.name tid .type tid] - .field [.name lhs .type stmt/var] - .field [.name rhs .type stmt/expr] -] - - -.record [ - .name jmp - .field [.name tid .type tid] - .field [.name cond .type stmt/expr] - .field [.name jump .type jump] -] - -.alias [.name tid .type string] - -.record [ - .name tid-exp-pair - .field [.name tid .type tid] - .field [.name exp .type stmt/expr] -] - -.variant [ - .name jump - .option [.type call] - .option [.name goto .type label] - .option [.name ret .type label] - .option [.type exn] -] - -.variant [ - .name label - .option [.name direct .type tid] - .option [.name indirect .type stmt/expr] -] - -.enum [ - .name intent - .option [.name in] - .option [.name out] - .option [.name both] -] - - -.record [ - .name call - .field [.name target .type label] - .field [.name return .type label .optional] -] - -.record [ - .name exn - .field [.name number .type int] - .field [.name return .type tid] -] \ No newline at end of file diff --git a/lib/bap_piqi/stmt.piqi b/lib/bap_piqi/stmt.piqi deleted file mode 100644 index 7277085a7..000000000 --- a/lib/bap_piqi/stmt.piqi +++ /dev/null @@ -1,79 +0,0 @@ -.include [ - .module exp -] - -.variant [ - .name stmt - .option [.type move ] - .option [.type jmp ] - .option [.type special] - .option [.type while-stmt] - .option [.type if-stmt] - .option [.type cpuexn] -] - -.list [ - .name stmt-list - .type stmt -] - -.record [ - .name move - .field [ - .name lvar - .type var - ] - .field [ - .name rexp - .type expr - ] -] - -.record [ - .name jmp - .field [ - .name target - .type expr - ] -] - -.alias [ - .name special - .type string -] - -.record [ - .name while-stmt - .field [ - .name cond - .type expr - ] - .field [ - .name loop-body - .type stmt-list - ] -] - -.record [ - .name if-stmt - .field [ - .name cond - .type expr - ] - .field [ - .name true-branch - .type stmt-list - ] - .field [ - .name false-branch - .type stmt-list - ] -] - -.record [ - .name cpuexn - .field [ - .name errnum - .type int - ] -] diff --git a/lib/bap_piqi/test/run_piqi_tests.ml b/lib/bap_piqi/test/run_piqi_tests.ml deleted file mode 100644 index 696fe9a7e..000000000 --- a/lib/bap_piqi/test/run_piqi_tests.ml +++ /dev/null @@ -1,100 +0,0 @@ -open OUnit2 -open Core_kernel[@@warning "-D"] -open Bap.Std - -module Example = struct - let entry = Blk.create () - let b1 = Blk.create () - let b2 = Blk.create () - let b3 = Blk.create () - let b4 = Blk.create () - let b5 = Blk.create () - let b6 = Blk.create () - let exit = Blk.create () - - let i = Var.create "i" reg32_t - let j = Var.create "j" reg32_t - let k = Var.create "k" bool_t - - let _1 = Bil.int (Word.one 32) - let _2 = Bil.int (Word.of_int32 2l) - let _F = Bil.int Word.b0 - let _T = Bil.int Word.b1 - - let def var exp b = Term.append def_t b @@ Def.create var exp - let cond blk cond t f = - let jt = Jmp.create_goto ~cond (Label.direct (Term.tid t)) in - let jf = Jmp.create_goto (Label.direct (Term.tid f)) in - let blk = Term.append jmp_t blk jt in - Term.append jmp_t blk jf - let goto dst src = Term.append jmp_t src @@ - Jmp.create_goto (Label.direct (Term.tid dst)) - - let entry = entry |> - goto b1 - - let b1 = b1 |> - def k _F |> - def i _1 |> - def j _2 |> - goto b2 - - let b2 = cond b2 Bil.(var i <= var j) b3 b4 - - let b3 = b3 |> - def j Bil.(var j * _2) |> - def k _T |> - def i Bil.(var i + _1) |> - goto b2 - - let b3_without_jumps = Term.filter jmp_t ~f:(fun _ -> false) b3 - - let b4 = cond b4 Bil.(var k) b5 b6 - - let b5 = - let call = Call.create () - ~return:(Label.direct (Term.tid exit)) - ~target:(Label.indirect (Bil.var j)) in - let use = Jmp.create_call call in - Term.append jmp_t b5 use - - let b3_with_jump_to_b5 = Term.map jmp_t ~f:(fun _ -> - Jmp.create_goto (Label.direct (Term.tid b5))) b3 - - - - let b6 = def i Bil.(var i + _1) b6 |> goto exit - - let sub_of_blk blks = - let sub = Sub.create ~name:"example" () in - List.fold blks ~init:sub ~f:(Term.append blk_t) - - let blks = [entry; b1; b2; b3; b4; b5; b6; exit] - let sub = sub_of_blk blks - let program = - Term.append sub_t (Program.create ()) sub -end - -let test fmt ctxt = - let prog = Example.program |> - Bir_piqi.string_of_program fmt |> - Bir_piqi.program_of_string fmt in - let cmp = Program.equal in - let printer = Program.to_string in - assert_equal ~ctxt ~cmp ~printer Example.program prog - - - -let suite = - let open Bil.Types in - "bir" >::: - [ - "json" >:: test `json; - "pb" >:: test `pb; - "piq" >:: test `piq; - "pib" >:: test `pib; - "xml" >:: test `xml; - ] - - -let () = run_test_tt_main suite diff --git a/lib/bap_piqi/type.piqi b/lib/bap_piqi/type.piqi deleted file mode 100644 index 1296e8517..000000000 --- a/lib/bap_piqi/type.piqi +++ /dev/null @@ -1,110 +0,0 @@ -.variant [ - .name typ - .option [.type imm] - .option [.type mem] - .option [.name unk] -] - -.variant [ - .name addr-size - .option [.name r32] - .option [.name r64] -] - -.variant [ - .name size - .option [.name r8] - .option [.name r16] - .option [.name r32] - .option [.name r64] - .option [.name r128] - .option [.name r256] -] - -.alias [ - .name imm - .type int -] - -.record [ - .name mem - .field [ - .name index-type - .type addr-size - ] - .field [ - .name element-type - .type size - ] -] - -.enum [ - .name cast-type - .option [.name cast-unsigned] - .option [.name cast-signed] - .option [.name cast-high] - .option [.name cast-low] -] - -.enum [ - .name binop-type - .option [.name plus ] - .option [.name minus ] - .option [.name times ] - .option [.name divide ] - .option [.name sdivide] - .option [.name modbop ] - .option [.name smod ] - .option [.name lshift ] - .option [.name rshift ] - .option [.name arshift] - .option [.name andbop ] - .option [.name orbop ] - .option [.name x-or ] - .option [.name eq ] - .option [.name neq ] - .option [.name lt ] - .option [.name le ] - .option [.name slt ] - .option [.name sle ] -] - -.enum [ - .name unop-type - .option [.name uneg] - .option [.name unot] -] - -.record [ - .name var - .field [ - .name name - .type string - ] - .field [ - .name id - .type int - ] - .field [ - .name typ - .type typ - ] - - .field [ - .name tmp - .type bool - ] - -] - -% bitvectors -.alias [ - .name bitvector - .type string -] - -% an address is now a bitvector -.alias [ - .name address - .type bitvector -] diff --git a/lib/bap_plugins/bap_common.ml b/lib/bap_plugins/bap_common.ml index 0a513eeb1..f4f390f49 100644 --- a/lib/bap_plugins/bap_common.ml +++ b/lib/bap_plugins/bap_common.ml @@ -1,8 +1,8 @@ open Base open Stdio -open Caml.Scanf -module Sys = Caml.Sys +open Stdlib.Scanf +module Sys = Stdlib.Sys module Package = Bap_plugins_package module Config = Bap_plugins_config module Units = Bap_plugins_units.Make() diff --git a/lib/bap_plugins/bap_plugins.ml b/lib/bap_plugins/bap_plugins.ml index dc20b7efa..7fc429736 100644 --- a/lib/bap_plugins/bap_plugins.ml +++ b/lib/bap_plugins/bap_plugins.ml @@ -5,8 +5,8 @@ open Or_error.Monad_infix module Units = Bap_plugins_units.Make() module Package = Bap_plugins_package -module Filename = Caml.Filename -module Sys = Caml.Sys +module Filename = Stdlib.Filename +module Sys = Stdlib.Sys module Plugin = struct @@ -92,7 +92,7 @@ module Plugin = struct let is_debugging () = - try String.(Sys.getenv "BAP_DEBUG" <> "0") with Caml.Not_found -> false + try String.(Sys.getenv "BAP_DEBUG" <> "0") with Stdlib.Not_found -> false let bundle = function {body=Bundle {bundle}} -> bundle | _ -> assert false @@ -254,7 +254,7 @@ end module Plugins = struct let paths_of_env () = try Sys.getenv "BAP_PLUGIN_PATH" |> String.split ~on:':' - with Caml.Not_found -> [] + with Stdlib.Not_found -> [] let path = Bap_plugins_config.plugindir @@ -338,7 +338,7 @@ module Plugins = struct implementation. The implementation is digested as the md5 sum of files comprising the plugin folder. *) let deduplicate names = - let init = Map.empty (module String) in + let init = (Map.empty (module String)) in List.fold names ~init ~f:(fun plugins name -> Map.update plugins name ~f:(function | None -> digests name diff --git a/lib/bap_plugins/bap_plugins_units.ml b/lib/bap_plugins/bap_plugins_units.ml index 21aac8dd0..f78a1f6f5 100644 --- a/lib/bap_plugins/bap_plugins_units.ml +++ b/lib/bap_plugins/bap_plugins_units.ml @@ -4,7 +4,7 @@ open Bap_plugins_units_intf module Findlib = struct let name = "findlib" - let units : reason String.Table.t = String.Table.create () + let units : reason String.Table.t = Hashtbl.create (module String) let has_meta_information pkg = try ignore (Findlib.package_meta_file pkg : string); true @@ -67,7 +67,7 @@ end module Dynlink = struct let name = "dynlink" - let units : reason String.Table.t = String.Table.create () + let units : reason String.Table.t = Hashtbl.create (module String) (* see https://github.com/ocaml/ocaml/issues/9338 this ugly clutch could only be removed after we phase out @@ -99,7 +99,7 @@ module Dynlink = struct end -let is_toplevel = Caml.Sys.interactive.contents +let is_toplevel = Stdlib.Sys.interactive.contents module Make() = (val if is_toplevel diff --git a/lib/bap_primus/bap_primus.mli b/lib/bap_primus/bap_primus.mli index 3bdab0a97..5696dde69 100644 --- a/lib/bap_primus/bap_primus.mli +++ b/lib/bap_primus/bap_primus.mli @@ -189,7 +189,7 @@ module Std : sig Machine run. That type is left abstract, and has no operations, as its purpose is to disallow running machine directly with a properly initialized system. *) - type 'a effect + type 'a eff (** value generator *) type generator @@ -575,7 +575,7 @@ module Std : sig ?boot:unit t -> ?init:unit t -> ?fini:unit t -> - (exit_status * project) m effect + (exit_status * project) m eff (** Local state of the machine. *) module Local : State with type 'a m := 'a t diff --git a/lib/bap_primus/bap_primus_env.ml b/lib/bap_primus/bap_primus_env.ml index 3b1bfbae8..8e7d85781 100644 --- a/lib/bap_primus/bap_primus_env.ml +++ b/lib/bap_primus/bap_primus_env.ml @@ -57,15 +57,15 @@ let state = Bap_primus_machine.State.declare ~inspect:sexp_of_env ~uuid:"44b24ea4-48fa-47e8-927e-f7ba65202743" ~name:"environment" (fun _ -> { - values = Var.Map.empty; - random = Var.Map.empty; + values = (Map.empty (module Var)); + random = (Map.empty (module Var)); }) let inspect_environment {values;random} = let keys = Set.union - (Var.Set.of_list (Map.keys values)) - (Var.Set.of_list (Map.keys random)) in + (Set.of_list (module Var) (Map.keys values)) + (Set.of_list (module Var) (Map.keys random)) in let sexp_of_var sexp_of_value var value = Sexp.(List [ Atom (Var.name var); sexp_of_value value; diff --git a/lib/bap_primus/bap_primus_exn.ml b/lib/bap_primus/bap_primus_exn.ml index e9ba04dd9..66c74fd0d 100644 --- a/lib/bap_primus/bap_primus_exn.ml +++ b/lib/bap_primus/bap_primus_exn.ml @@ -1,5 +1,5 @@ open Core_kernel[@@warning "-D"] type t = exn = .. -let to_string err = Caml.Printexc.to_string err -let add_printer pr = Caml.Printexc.register_printer pr +let to_string err = Stdlib.Printexc.to_string err +let add_printer pr = Stdlib.Printexc.register_printer pr diff --git a/lib/bap_primus/bap_primus_generator.ml b/lib/bap_primus/bap_primus_generator.ml index 364c6014e..d2dd6b6a6 100644 --- a/lib/bap_primus/bap_primus_generator.ml +++ b/lib/bap_primus/bap_primus_generator.ml @@ -24,7 +24,7 @@ type iterators = { let iterators = Bap_primus_machine.State.declare ~name:"iterators" ~uuid:"9927004d-fe57-4de9-8705-c3d6862238cf" @@ fun _ -> { - iterators = Int.Map.empty; + iterators = (Map.empty (module Int)); salt = 1; } diff --git a/lib/bap_primus/bap_primus_interpreter.ml b/lib/bap_primus/bap_primus_interpreter.ml index 1ac76a3f9..1555b408c 100644 --- a/lib/bap_primus/bap_primus_interpreter.ml +++ b/lib/bap_primus/bap_primus_interpreter.ml @@ -285,7 +285,7 @@ let null proj = let empty_scope = { stack = []; - bound = Var.Map.empty; + bound = (Map.empty (module Var)); } let state = Primus.Machine.State.declare @@ -965,7 +965,7 @@ module LinkBinaryProgram(Machine : Machine) = struct Machine.get () >>= fun proj -> let prog = Project.program proj in info "Linking binary program%!"; - collector#run prog !!Tid.Set.empty >>= fun linked -> + collector#run prog !!(Set.empty (module Tid)) >>= fun linked -> (linker linked)#run prog !!() >>| fun () -> info "Finished linking binary program%!" end diff --git a/lib/bap_primus/bap_primus_linker.ml b/lib/bap_primus/bap_primus_linker.ml index 1052708b9..c24c1150d 100644 --- a/lib/bap_primus/bap_primus_linker.ml +++ b/lib/bap_primus/bap_primus_linker.ml @@ -36,11 +36,11 @@ type t = { } let empty = { - codes = Int.Map.empty; - terms = Tid.Map.empty; - names = String.Map.empty; - addrs = Addr.Map.empty; - alias = Int.Map.empty; + codes = (Map.empty (module Int)); + terms = (Map.empty (module Tid)); + names = (Map.empty (module String)); + addrs = (Map.empty (module Addr)); + alias = (Map.empty (module Int)); } diff --git a/lib/bap_primus/bap_primus_lisp.ml b/lib/bap_primus/bap_primus_lisp.ml index 3ff7918ba..d165e0f90 100644 --- a/lib/bap_primus/bap_primus_lisp.ml +++ b/lib/bap_primus/bap_primus_lisp.ml @@ -62,14 +62,14 @@ let state = Bap_primus_state.declare ~inspect (fun proj -> { env = { stack = []; - vars = Var.Map.empty; + vars = (Map.empty (module Var)); }; cur = Id.null; program = Lisp.Program.empty; typeenv = Lisp.Program.Type.empty; - advices = Map.empty (module KB.Name); - places = Map.empty (module KB.Name); - signals = Map.empty (module KB.Name); + advices = (Map.empty (module KB.Name)); + places = (Map.empty (module KB.Name)); + signals = (Map.empty (module KB.Name)); width = width_of_ctxt proj; }) @@ -81,7 +81,7 @@ let lisp_primitive,primitive_called = Bap_primus_observation.provide let show = KB.Name.show let make_advisors cmethod name = - let empty = Set.empty (module KB.Name) in + let empty = (Set.empty (module KB.Name)) in let names = Set.add empty name in match cmethod with | Advice.Before -> {before = names; after = empty} @@ -599,7 +599,7 @@ module Make(Machine : Machine) = struct let collect_program_vars prog = (object inherit [Var.Set.t] Term.visitor method! enter_var v vs = Set.add vs v - end)#run prog Var.Set.empty |> Set.to_sequence + end)#run prog (Set.empty (module Var)) |> Set.to_sequence let add_places = diff --git a/lib/bap_primus/bap_primus_lisp_attribute.ml b/lib/bap_primus/bap_primus_lisp_attribute.ml index 9d744239f..4c23c8cbe 100644 --- a/lib/bap_primus/bap_primus_lisp_attribute.ml +++ b/lib/bap_primus/bap_primus_lisp_attribute.ml @@ -100,9 +100,9 @@ module Set = struct end -let () = Caml.Printexc.register_printer (function +let () = Stdlib.Printexc.register_printer (function | Failure (error,_) -> let msg = Format.asprintf "Attribute parse error: %s" - (Caml.Printexc.to_string error) in + (Stdlib.Printexc.to_string error) in Some msg | _ -> None) diff --git a/lib/bap_primus/bap_primus_lisp_attributes.ml b/lib/bap_primus/bap_primus_lisp_attributes.ml index 5ddd88019..e20348232 100644 --- a/lib/bap_primus/bap_primus_lisp_attributes.ml +++ b/lib/bap_primus/bap_primus_lisp_attributes.ml @@ -28,7 +28,7 @@ module Variables = struct | Error err -> fail (Var_error err) [t] let parse ~package xs = List.map xs ~f:(var package) |> - Var.Set.of_list + Set.of_list (module Var) let global = Attribute.declare "global" ~package @@ -63,7 +63,7 @@ module External = struct let domain = KB.Domain.powerset (module String) "names" let parse ~package:_ xs = List.map xs ~f:parse_name |> - String.Set.of_list + Set.of_list (module String) let t = Attribute.declare "external" ~package @@ -137,13 +137,13 @@ module Advice = struct let domain = KB.Domain.define "methods" ~join ~order ~empty - let methods = String.Map.of_alist_exn [ + let methods = Map.of_alist_exn (module String) [ ":before", Before; ":after", After; ] let targets {methods} m = match Map.find methods m with - | None -> Set.empty (module KB.Name) + | None -> (Set.empty (module KB.Name)) | Some targets -> targets diff --git a/lib/bap_primus/bap_primus_lisp_context.ml b/lib/bap_primus/bap_primus_lisp_context.ml index 94cd0c5dd..24516022d 100644 --- a/lib/bap_primus/bap_primus_lisp_context.ml +++ b/lib/bap_primus/bap_primus_lisp_context.ml @@ -10,7 +10,7 @@ module Feature = String module Name = String type t = Feature.Set.t Name.Map.t [@@deriving bin_io, compare, equal, sexp] -let empty = Name.Map.empty +let empty = (Map.empty (module Name)) type Attribute.error += Unterminated_quote @@ -29,7 +29,7 @@ let endian proj = Project.arch proj |> Arch.endian |> function | LittleEndian -> "little" | BigEndian -> "big" -let features = Feature.Set.of_list +let features = Set.of_list (module Feature) let enum (type t) (module E : KB.Enum.S with type t = t) v = KB.Name.unqualified (E.name v) @@ -41,7 +41,7 @@ let of_project proj = List.concat_map ~f:(fun t -> KB.Name.unqualified (Theory.Target.name t) :: Set.to_list (Theory.Target.nicknames t)) in - Name.Map.of_alist_exn [ + Map.of_alist_exn (module Name) [ "arch", features @@ [ Arch.to_string (Project.arch proj); ] @ attr proj Bap_abi.name; @@ -72,7 +72,7 @@ let of_project proj = let create descs = List.map descs ~f:(fun (name,xs) -> name,features xs) |> - Name.Map.of_alist_reduce ~f:Set.union + Map.of_alist_reduce (module Name) ~f:Set.union let sexp_of_context (name,values) = Sexp.List (List.map (name :: Set.to_list values) @@ -100,7 +100,7 @@ let parse_name = function let context_of_tree = function | {data=List (x :: xs)} -> - parse_name x, Feature.Set.of_list (List.map xs ~f:parse_name) + parse_name x, Set.of_list (module Feature) (List.map xs ~f:parse_name) | s -> expect_list s @@ -111,7 +111,7 @@ let push cs name vs = let parse ~package:_ : tree list -> t = - List.fold ~init:Name.Map.empty ~f:(fun cs tree -> + List.fold ~init:(Map.empty (module Name)) ~f:(fun cs tree -> let (name,vs) = context_of_tree tree in push cs name vs) @@ -149,7 +149,7 @@ let pp ppf ctxt = let (<=) xs ys = Map.fold_symmetric_diff xs ys - ~data_equal:String.Set.equal + ~data_equal:Set.equal ~init:true ~f:(fun matches (_,diff) -> matches && match diff with | `Left xs -> Set.is_empty xs @@ -166,7 +166,7 @@ let order c1 c2 : KB.Order.partial = let merge xs ys : t = Map.merge xs ys ~f:(fun ~key:_ -> function | `Left v | `Right v -> Some v - | `Both (x,y) -> Some (Feature.Set.union x y) ) + | `Both (x,y) -> Some (Set.union x y) ) let join xs ys = Ok (merge xs ys) diff --git a/lib/bap_primus/bap_primus_lisp_def.ml b/lib/bap_primus/bap_primus_lisp_def.ml index 1f086cd7d..41f5e8281 100644 --- a/lib/bap_primus/bap_primus_lisp_def.ml +++ b/lib/bap_primus/bap_primus_lisp_def.ml @@ -121,7 +121,7 @@ module Sema = struct meta = { name = KB.Name.show name; docs; - attrs=Attribute.Set.empty}; + attrs=(Attribute.Set.empty)}; code = {apply; types}; }; id = Source.Id.null; @@ -140,7 +140,7 @@ module Signal = struct meta = { name; docs; - attrs=Attribute.Set.empty}; + attrs=(Attribute.Set.empty)}; code = types; }; id = Source.Id.null; @@ -245,7 +245,7 @@ module Primitive = struct meta = { name = KB.Name.show@@KB.Name.read ?package name; docs; - attrs = Attribute.Set.empty + attrs = (Attribute.Set.empty) }; code; }; @@ -263,7 +263,7 @@ module Place = struct meta = { name = KB.Name.show@@KB.Name.read ?package name; docs = ""; - attrs = Attribute.Set.empty; + attrs = (Attribute.Set.empty); }; code = Theory.Var.forget var; }; @@ -292,7 +292,7 @@ module Closure = struct meta = { name = KB.Name.show@@KB.Name.read ~package name; docs; - attrs=Attribute.Set.empty}; + attrs=(Attribute.Set.empty)}; code = { types; lambda; diff --git a/lib/bap_primus/bap_primus_lisp_parse.ml b/lib/bap_primus/bap_primus_lisp_parse.ml index b2084b50c..d433d46c7 100644 --- a/lib/bap_primus/bap_primus_lisp_parse.ml +++ b/lib/bap_primus/bap_primus_lisp_parse.ml @@ -3,7 +3,7 @@ open Bap.Std open Format open Bap_core_theory -module Sys = Caml.Sys +module Sys = Stdlib.Sys open Bap_primus_lisp_types @@ -368,7 +368,7 @@ module Parse = struct Program.update_package_documentation prog name (unquote docs) | s -> fail (Bad_def Defpkg) s) - let toplevels = String.Set.of_list [ + let toplevels = Set.of_list (module String) [ "declare"; "defconstant"; "defparameter"; @@ -649,7 +649,7 @@ module Load = struct | _ -> None let required paths p = - Source.fold p ~init:String.Map.empty ~f:(fun _ trees required -> + Source.fold p ~init:(Map.empty (module String)) ~f:(fun _ trees required -> List.fold trees ~init:required ~f:(fun required tree -> match parse_require tree with | None -> required @@ -671,7 +671,7 @@ module Load = struct fixpoint p let features_of_list = - List.fold ~init:String.Map.empty ~f:(fun fs f -> + List.fold ~init:(Map.empty (module String)) ~f:(fun fs f -> Map.set fs ~key:f ~data:Cmdline) let features ?(paths=[Filename.current_dir_name]) proj fs = diff --git a/lib/bap_primus/bap_primus_lisp_program.ml b/lib/bap_primus/bap_primus_lisp_program.ml index 71f0b1731..6d9a90b2a 100644 --- a/lib/bap_primus/bap_primus_lisp_program.ml +++ b/lib/bap_primus/bap_primus_lisp_program.ml @@ -47,7 +47,7 @@ type program = t let default_package = "user" -let nodefs = Map.empty (module String) +let nodefs = (Map.empty (module String)) let empty_package = { semas = nodefs; codes = nodefs; @@ -65,9 +65,9 @@ let empty = { context = Lisp.Context.empty; sources = Source.empty; package = default_package; - exports = Map.empty (module String); - library = Map.empty (module String); - pkgdocs = Map.empty (module String); + exports = (Map.empty (module String)); + library = (Map.empty (module String)); + pkgdocs = (Map.empty (module String)); } let with_package program package = {program with package} @@ -111,7 +111,7 @@ let get_package ?(public=false) program package = if public then filter_package pkg {visit = is_public} else pkg let targets {exports} package = match Map.find exports package with - | None -> Set.empty (module String) + | None -> (Set.empty (module String)) | Some packs -> packs (* [transitive_closure p] is the set of packages in which @@ -144,7 +144,7 @@ let (++) : 'a defs -> 'a defs -> 'a defs = fun xs ys -> List.fold defs ~init ~f:(fun (set,defs) def -> if is_presented set def then set,defs else remember set def, Map.add_multi defs name def) in - let init = Map.empty (module String),nodefs in + let init = (Map.empty (module String)),nodefs in snd@@Map.fold ys ~f:add ~init:(Map.fold ~init xs ~f:add) let pp_defs ppf = @@ -396,7 +396,7 @@ module Callgraph = struct end) end)(Unit) - let empty = Set.empty (module KB.Name) + let empty = (Set.empty (module KB.Name)) let (++) = Set.union let call = Set.singleton (module KB.Name) let union xs ~f = @@ -413,7 +413,7 @@ module Callgraph = struct (** computes a mapping from name to id of definitions *) let compute_ids (defs : library) = - let init = Map.empty (module KB.Name) in + let init = (Map.empty (module KB.Name)) in fold_library defs ~init ~f:(fun ~package {defs} ids -> fold_multi ~init:ids defs ~f:(fun ids def -> let name = KB.Name.create ~package (Def.name def) in @@ -581,7 +581,7 @@ let pp ppf prog = let pp_ast ppf ast = Ast.pp ppf ast module Use = struct - let empty = Map.empty (module KB.Name) + let empty = (Map.empty (module KB.Name)) let union = union empty let use = Map.singleton (module KB.Name) @@ -613,7 +613,7 @@ module Use = struct | {data=Set (_,x)} -> calls x let collect {defs} = - let init = {calls = Id.Map.empty; vars = Id.Map.empty} in + let init = {calls = (Map.empty (module Id)); vars = (Map.empty (module Id))} in fold_multi ~init defs ~f:(fun s def -> let body = Def.Func.body def in let bound = Def.Func.args def |> @@ -652,26 +652,26 @@ end = struct type 'a m = 'a Monad.State.T1(Source)(Monad.Ident).t let rec ids_of_trees trees = - List.fold trees ~init:Id.Set.empty ~f:(fun xs t -> match t with + List.fold trees ~init:(Set.empty (module Id)) ~f:(fun xs t -> match t with | {data=Atom _; id} -> Set.add xs id | {data=List ts;id} -> Set.union (Set.add xs id) (ids_of_trees ts)) let ids_of_defs defs map reduce = - Id.Set.union_list [ - Id.Set.of_list @@ List.map (items defs) ~f:(fun d -> d.id); + Set.union_list (module Id) [ + Set.of_list (module Id) @@ List.map (items defs) ~f:(fun d -> d.id); map (items defs) ~f:reduce |> ids_of_trees ] let macro_ids prog = fold_library prog ~f:(fun ~package:_ p macros -> - Id.Set.union_list [ + Set.union_list (module Id) [ macros; ids_of_defs p.macros List.map Def.Macro.body; ids_of_defs p.consts List.map Def.Const.value; ids_of_defs p.substs List.concat_map Def.Subst.body; ]) - ~init:Id.Set.empty + ~init:(Set.empty (module Id)) let derive from = State.get () >>= fun src -> @@ -871,9 +871,12 @@ module Typing = struct | Tvar of Id.t [@@deriving compare, sexp_of] - module Tvar = Comparable.Make_plain(struct - type t = tvar [@@deriving compare, sexp_of] - end) + module Tvar = struct + type t = tvar [@@deriving compare, sexp_of] + include Comparable.Make_plain(struct + type nonrec t = t [@@deriving compare, sexp_of] + end) + end (** Typing environment. @@ -990,8 +993,8 @@ module Typing = struct } let empty = { - vars = Id.Map.empty; - vals = Tvar.Map.empty; + vars = (Map.empty (module Id)); + vals = (Map.empty (module Tvar)); } let get g x = match Map.find g.vars x with @@ -1123,7 +1126,7 @@ module Typing = struct | Type n -> constr_grnd id (Grnd n) g let join_vars vars = - let init = Tvar.Map.empty in + let init = (Map.empty (module Tvar)) in Map.fold vars ~init ~f:(fun ~key:x ~data:u joined -> Map.add_multi joined u x) @@ -1131,7 +1134,7 @@ module Typing = struct join_vars vars |> Map.fold ~init:[] ~f:(fun ~key ~data xs -> { var = key; - elements=Id.Set.of_list data; + elements=Set.of_list (module Id) data; values = Map.find vals key; } :: xs) @@ -1390,14 +1393,14 @@ module Typing = struct | None -> gamma | Some f -> let args = Def.Func.args f in - let init = Map.empty (module KB.Name) in + let init = (Map.empty (module KB.Name)) in let vars = List.fold args ~init ~f:push in let gamma = List.fold args ~init:gamma ~f:(fun gamma v -> Gamma.constr v.id v.data.typ gamma) in let gamma = infer_ast glob vars (Def.Func.body f) gamma in gamma - let empty_names = Map.empty (module KB.Name) + let empty_names = (Map.empty (module KB.Name)) let collect_prims program item signature init = @@ -1467,7 +1470,7 @@ module Typing = struct let problem = Unresolved_signal (met.id,name,Some pars) in Gamma.fail met.id problem g | Some g -> - let init = Map.empty (module KB.Name) in + let init = (Map.empty (module KB.Name)) in let vars = List.fold args ~init ~f:push in let g = List.fold args ~init:g ~f:(fun g v -> Gamma.constr v.id v.data.typ g) in @@ -1505,7 +1508,7 @@ module Typing = struct paras = make_paras p; } in let g = Callgraph.build library in - let init = Solution.create Callgraph.Node.Map.empty Gamma.empty in + let init = Solution.create (Map.empty (module Callgraph.Node)) Gamma.empty in let equal = gamma_equal in let fp = Graphlib.fixpoint (module Callgraph) ~rev:true ~start:Exit diff --git a/lib/bap_primus/bap_primus_lisp_resolve.ml b/lib/bap_primus/bap_primus_lisp_resolve.ml index a5b264574..77543a8fc 100644 --- a/lib/bap_primus/bap_primus_lisp_resolve.ml +++ b/lib/bap_primus/bap_primus_lisp_resolve.ml @@ -137,7 +137,7 @@ let overload_primitive s3 = List.map s3 ~f:(fun s -> s,()) let locs prog defs = let src = Program.sources prog in List.map defs ~f:(fun def -> - Source.loc src def.id) |> Loc.Set.of_list + Source.loc src def.id) |> Set.of_list (module Loc) type _ arity = | One : ('a list -> 'a option) arity diff --git a/lib/bap_primus/bap_primus_lisp_semantics.ml b/lib/bap_primus/bap_primus_lisp_semantics.ml index cd67467e9..36f359df7 100644 --- a/lib/bap_primus/bap_primus_lisp_semantics.ml +++ b/lib/bap_primus/bap_primus_lisp_semantics.ml @@ -26,9 +26,9 @@ module State = struct } let empty = { - binds = Map.empty (module Theory.Var.Top); + binds = (Map.empty (module Theory.Var.Top)); arith = (module Bitvec.M32); - scope = Map.empty (module Theory.Var.Top); + scope = (Map.empty (module Theory.Var.Top)); } let var = KB.Context.declare ~package:"bap" "lisp-interpter-state" @@ -42,7 +42,7 @@ end type value = unit Theory.Value.t -type effect = unit Theory.Effect.t +type effect0 = unit Theory.Effect.t type KB.Conflict.t += | Unresolved_definition of string @@ -284,7 +284,7 @@ module Value = struct end module Effect = struct - type t = effect + type t = effect0 let pure x : t = empty.$[Theory.Semantics.value] <- x let return x : t KB.t = KB.return@@pure x end @@ -400,7 +400,7 @@ module Scope = struct let clear = let* s = State.get in let+ () = State.set { - s with scope = Map.empty (module Theory.Var.Top) + s with scope = (Map.empty (module Theory.Var.Top)) } in s.scope @@ -741,7 +741,7 @@ let collect_names kind key prog = let merge_names names = List.reduce names ~f:(Map.merge_skewed ~combine:(fun ~key:_ _ v -> v)) |> - function None -> Map.empty (module KB.Name) + function None -> (Map.empty (module KB.Name)) | Some r -> r @@ -811,8 +811,8 @@ let provide_semantics ?(stdout=Format.std_formatter) () = let* target = KB.collect Theory.Unit.target unit in let bits = Theory.Target.bits target in KB.Context.set State.var State.{ - binds = Map.empty (module Theory.Var.Top); - scope = Map.empty (module Theory.Var.Top); + binds = (Map.empty (module Theory.Var.Top)); + scope = (Map.empty (module Theory.Var.Top)); arith = (module (Bitvec.Make(struct let modulus = Bitvec.modulus bits end))); diff --git a/lib/bap_primus/bap_primus_lisp_source.ml b/lib/bap_primus/bap_primus_lisp_source.ml index 9348466fc..860546e66 100644 --- a/lib/bap_primus/bap_primus_lisp_source.ml +++ b/lib/bap_primus/bap_primus_lisp_source.ml @@ -35,18 +35,18 @@ type t = { let empty = { lastid = Id.null; lasteq = Eq.null; - hashed = Sexp.Map.empty; - equivs = Id.Map.empty; - origin = Id.Map.empty; - ranges = Id.Map.empty; - source = String.Map.empty; - inputs = String.Map.empty; - rclass = Id.Map.empty; + hashed = (Map.empty (module Sexp)); + equivs = (Map.empty (module Id)); + origin = (Map.empty (module Id)); + ranges = (Map.empty (module Id)); + source = (Map.empty (module String)); + inputs = (Map.empty (module String)); + rclass = (Map.empty (module Id)); } let is_empty {lastid} = Id.equal Id.null lastid -let equal_inputs = String.Map.equal String.equal +let equal_inputs = Map.equal String.equal let equal x y = phys_equal x y || equal_inputs x.inputs y.inputs diff --git a/lib/bap_primus/bap_primus_machine.ml b/lib/bap_primus/bap_primus_machine.ml index b56075581..d34493731 100644 --- a/lib/bap_primus/bap_primus_machine.ml +++ b/lib/bap_primus/bap_primus_machine.ml @@ -84,7 +84,7 @@ module Make(M : Monad.S) = struct ?boot:unit t -> ?init:unit t -> ?fini:unit t -> - (exit_status * project) m effect + (exit_status * project) m eff type _ error = exn @@ -429,9 +429,9 @@ module Make(M : Monad.S) = struct args; envp; self = global; - conts = Map.empty (module Id); - local = Map.empty (module Id); - parent = Map.empty (module Id); + conts = (Map.empty (module Id)); + local = (Map.empty (module Id)); + parent = (Map.empty (module Id)); global = State.Bag.empty; observations = Bap_primus_observation.empty; deathrow = []; diff --git a/lib/bap_primus/bap_primus_memory.ml b/lib/bap_primus/bap_primus_memory.ml index ca8de860f..3dd0bda2a 100644 --- a/lib/bap_primus/bap_primus_memory.ml +++ b/lib/bap_primus/bap_primus_memory.ml @@ -135,7 +135,7 @@ let state = Bap_primus_machine.State.declare ~uuid:"4b94186d-3ae9-48e0-8a93-8c83c747bdbb" ~inspect:inspect_memory ~name:"memory" @@ fun p -> { - mems = Descriptor.Map.empty; + mems = (Map.empty (module Descriptor)); curr = virtual_memory (Project.target p); } @@ -153,7 +153,7 @@ let is_mapped addr {layers; values} = Option.is_some @@ find_layer addr layers let empty_state = { - values = Addr.Map.empty; + values = (Map.empty (module Addr)); layers = []; } diff --git a/lib/bap_primus/bap_primus_state.ml b/lib/bap_primus/bap_primus_state.ml index 1e235f67b..03b778606 100644 --- a/lib/bap_primus/bap_primus_state.ml +++ b/lib/bap_primus/bap_primus_state.ml @@ -37,7 +37,7 @@ module Bag = struct let empty = { dict = Dict.empty; - uids = String.Map.empty; + uids = (Map.empty (module String)); } let check_invariant t state = diff --git a/lib/bap_primus/bap_primus_types.ml b/lib/bap_primus/bap_primus_types.ml index 0b566ce47..b3bec2bfd 100644 --- a/lib/bap_primus/bap_primus_types.ml +++ b/lib/bap_primus/bap_primus_types.ml @@ -18,7 +18,7 @@ type exit_status = | Normal | Exn of exn -type 'a effect = +type 'a eff = ?envp:string array -> ?args:string array -> string -> @@ -67,7 +67,7 @@ module type Machine = sig ?boot:unit t -> ?init:unit t -> ?fini:unit t -> - (exit_status * project) m effect + (exit_status * project) m eff module Local : State with type 'a m := 'a t and type 'a t := 'a state diff --git a/lib/bap_primus_machine/bap_primus_machine.ml b/lib/bap_primus_machine/bap_primus_machine.ml index f4b300176..2833d5f0b 100644 --- a/lib/bap_primus_machine/bap_primus_machine.ml +++ b/lib/bap_primus_machine/bap_primus_machine.ml @@ -63,8 +63,8 @@ module Exception : sig end = struct type t = exn = .. - let to_string err = Caml.Printexc.to_string err - let add_printer pr = Caml.Printexc.register_printer pr + let to_string err = Stdlib.Printexc.to_string err + let add_printer pr = Stdlib.Printexc.register_printer pr end @@ -205,7 +205,7 @@ module Primus = struct open Observation let declare = Observation.declare - let empty = Set.empty (module Int) + let empty = (Set.empty (module Int)) let observations {observer} : _ observer list m = lifts @@ SM.gets @@ fun s -> @@ -429,7 +429,7 @@ module Primus = struct global = Univ_map.empty; local = Univ_map.empty; observations = Univ_map.empty; - inspectors = Map.empty (module String); + inspectors = (Map.empty (module String)); key = 0; deathrow = []; } diff --git a/lib/bap_primus_track_visited/bap_primus_track_visited.ml b/lib/bap_primus_track_visited/bap_primus_track_visited.ml index 9e2264aa1..d7ada0bcc 100644 --- a/lib/bap_primus_track_visited/bap_primus_track_visited.ml +++ b/lib/bap_primus_track_visited/bap_primus_track_visited.ml @@ -19,7 +19,7 @@ let init_visited prog = if Term.has_attr blk Term.visited then Set.add visited (Term.tid blk) else visited - end)#run prog Tid.Set.empty + end)#run prog (Set.empty (module Tid)) let state = Primus.Machine.State.declare ~name:"primus-track-visited" diff --git a/lib/bap_recipe/bap_recipe.ml b/lib/bap_recipe/bap_recipe.ml index f3c64cec2..e687c0570 100644 --- a/lib/bap_recipe/bap_recipe.ml +++ b/lib/bap_recipe/bap_recipe.ml @@ -1,7 +1,7 @@ open Base open Stdio open Result.Monad_infix -open Caml.Format +open Stdlib.Format module Filename = Stdlib.Filename module Buffer = Stdlib.Buffer @@ -158,7 +158,7 @@ let apply_subst root pars vars opts = try Ok (apply_subst_exn root pars vars opts) with Bad_substitution s -> Error (Bad_subst s) -let rng = Caml.Random.State.make_self_init () +let rng = Stdlib.Random.State.make_self_init () let mkdtemp ?(mode=0o0700) ?tmp_dir ?(prefix="") ?(suffix="") () = let genname () = Uuidm.v4_gen rng () |> Uuidm.to_string in diff --git a/lib/bap_relation/bap_relation.ml b/lib/bap_relation/bap_relation.ml index d83c15489..3b34f3d1e 100644 --- a/lib/bap_relation/bap_relation.ml +++ b/lib/bap_relation/bap_relation.ml @@ -23,8 +23,8 @@ let empty (type key) (type data) compare_key compare_data = end) end in Rel { - vals = Map.empty (module K); - keys = Map.empty (module D); + vals = (Map.empty (module K)); + keys = (Map.empty (module D)); } let add (Rel {vals; keys}) key value = Rel { diff --git a/lib/bap_sema/bap_sema_free_vars.ml b/lib/bap_sema/bap_sema_free_vars.ml index a391c49fe..fd55d2dfa 100644 --- a/lib/bap_sema/bap_sema_free_vars.ml +++ b/lib/bap_sema/bap_sema_free_vars.ml @@ -10,7 +10,7 @@ let (++) = Set.union and (--) = Set.diff let ssa_free_vars sub = let is_undefined v = Var.index v = 0 in - Term.enum blk_t sub |> Seq.fold ~init:Var.Set.empty ~f:(fun vars blk -> + Term.enum blk_t sub |> Seq.fold ~init:(Set.empty (module Var)) ~f:(fun vars blk -> vars ++ Set.filter (Ir_blk.free_vars blk) ~f:is_undefined) module Live = struct @@ -36,16 +36,16 @@ module Live = struct let blk_defs blk = Term.enum def_t blk |> - Seq.fold ~init:Var.Set.empty ~f:(fun defs def -> + Seq.fold ~init:(Set.empty (module Var)) ~f:(fun defs def -> Set.add defs (Ir_def.lhs def)) let update blk trans ~f = Map.update trans blk ~f:(function - | None -> f {defs=Var.Set.empty; uses=Var.Set.empty} + | None -> f {defs=(Set.empty (module Var)); uses=(Set.empty (module Var))} | Some had -> f had) let block_transitions sub = Term.enum blk_t sub |> - Seq.fold ~init:Tid.Map.empty ~f:(fun fs blk -> + Seq.fold ~init:(Map.empty (module Tid)) ~f:(fun fs blk -> Map.add_exn fs (Term.tid blk) { defs = blk_defs blk; uses = Ir_blk.free_vars blk; @@ -62,7 +62,7 @@ module Live = struct })))) let lookup blks n = match Map.find blks n with - | None -> {defs = Var.Set.empty; uses = Var.Set.empty} + | None -> {defs = (Set.empty (module Var)); uses = (Set.empty (module Var))} | Some t -> t let is_pseudo n = Tid.equal n G.exit || Tid.equal n G.start @@ -71,8 +71,8 @@ module Live = struct if is_pseudo n then vars else apply (lookup blks n) vars - let initialize ?(init=Var.Set.empty) sub = - Tid.Map.singleton G.exit @@ + let initialize ?(init=Set.empty (module Var)) sub = + Map.singleton (module Tid) G.exit @@ Seq.fold (Term.enum arg_t sub) ~init ~f:(fun vars arg -> match Ir_arg.intent arg with | None | Some In -> vars @@ -81,12 +81,12 @@ module Live = struct let compute ?keep:init sub = let g = G.create sub in - let init = Solution.create (initialize ?init sub) Var.Set.empty in + let init = Solution.create (initialize ?init sub) (Set.empty (module Var)) in let blks = block_transitions sub in { blks; outs = Graphlib.fixpoint (module G) ~init ~start:G.exit ~rev:true g ~merge:Set.union - ~equal:Var.Set.equal + ~equal:Set.equal ~f:(transfer blks) } @@ -103,7 +103,7 @@ module Live = struct f init blk (apply trans outs)) let blks live var = - fold live ~init:Tid.Set.empty ~f:(fun blks blk ins -> + fold live ~init:(Set.empty (module Tid)) ~f:(fun blks blk ins -> if Set.mem ins var then Set.add blks blk else blks) diff --git a/lib/bap_sema/bap_sema_lift.ml b/lib/bap_sema/bap_sema_lift.ml index 810bb4352..05ddc98a5 100644 --- a/lib/bap_sema/bap_sema_lift.ml +++ b/lib/bap_sema/bap_sema_lift.ml @@ -470,7 +470,7 @@ let fix_names prog = Theory.Label.for_name name >>| Fn.non (Tid.equal tid) in let keep_name tids name tid = Map.set tids ~key:name ~data:tid in Term.enum sub_t prog |> - KB.Seq.fold ~init:String.Map.empty ~f:(fun tids sub -> + KB.Seq.fold ~init:(Map.empty (module String)) ~f:(fun tids sub -> let tid = Term.tid sub in let name = Ir_sub.name sub in match Map.find tids name with diff --git a/lib/bap_sema/bap_sema_ssa.ml b/lib/bap_sema/bap_sema_ssa.ml index e025f6cc0..3876b0309 100644 --- a/lib/bap_sema/bap_sema_ssa.ml +++ b/lib/bap_sema/bap_sema_ssa.ml @@ -48,13 +48,13 @@ let ssa_form = Value.Tag.register [k] is a fixpoint, i.e., such value that [IDF_k = IDF_{k-1}]. See section 8.11 of [1].*) let iterated_frontier f blks = - let df = Set.fold ~init:Tid.Set.empty ~f:(fun dfs b -> - Seq.fold (Frontier.enum f b) ~init:dfs ~f:Set.add) in - let blks = List.fold blks ~init:Tid.Set.empty ~f:Set.add in + let df = Set.fold ~init:(Set.empty (module Tid)) ~f:(fun dfs b -> + Seq.fold (Frontier.enum f b) ~init:dfs ~f:(fun s x -> Set.add s x)) in + let blks = List.fold blks ~init:(Set.empty (module Tid)) ~f:(fun s x -> Set.add s x) in let rec fixpoint idf = let idf' = df (Set.union idf blks) in if Set.equal idf idf' then idf' else fixpoint idf' in - fixpoint Tid.Set.empty + fixpoint (Set.empty (module Tid)) let blk_of_tid sub tid = match Term.find blk_t sub tid with | Some blk -> Some blk @@ -74,7 +74,7 @@ let succs cfg sub tid = variables, that are live across multiple blocks. *) let collect_vars sub = Term.enum blk_t sub |> - Seq.fold ~init:Var.Set.empty ~f:(fun vars blk -> + Seq.fold ~init:(Set.empty (module Var)) ~f:(fun vars blk -> Set.union vars @@ Ir_blk.free_vars blk) (** returns a list of blocks that contains [def] terms with lhs equal @@ -106,8 +106,8 @@ end)#map_exp of a variable. And works well with our API to resolve input/output parameters.*) let rename t = - let vars : var list Var.Table.t = Var.Table.create () in - let nums : int Var.Table.t = Var.Table.create () in + let vars : var list Var.Table.t = Hashtbl.create (module Var) in + let nums : int Var.Table.t = Hashtbl.create (module Var) in let top v = match Hashtbl.find vars v with | None | Some [] -> v | Some (v :: _) -> v in diff --git a/lib/bap_sema/bap_sema_taint.ml b/lib/bap_sema/bap_sema_taint.ml index b393975e7..b5a6c9319 100644 --- a/lib/bap_sema/bap_sema_taint.ml +++ b/lib/bap_sema/bap_sema_taint.ml @@ -78,14 +78,14 @@ let collect_taints = Set.union ts ts') class context = object(self) - val tvs : set values = Values.empty - val tas : set Addr.Map.t = Addr.Map.empty + val tvs : set values = Base.(Map.empty (module Bil.Result.Id)) + val tas : set Addr.Map.t = (Map.empty (module Addr)) method taint_reg r ts = let key = Bil.Result.id r in if Set.is_empty ts - then {< tvs = Values.remove tvs key >} - else {< tvs = Values.set tvs ~key ~data:ts >} + then {< tvs = Base.Map.remove tvs key >} + else {< tvs = Base.Map.set tvs ~key ~data:ts >} method taint_ptr a (s : size) ts = if Set.is_empty ts then self diff --git a/lib/bap_strings/bap_strings_detector.ml b/lib/bap_strings/bap_strings_detector.ml index d769e99e3..693646205 100644 --- a/lib/bap_strings/bap_strings_detector.ml +++ b/lib/bap_strings/bap_strings_detector.ml @@ -112,7 +112,7 @@ let run t = let open Sequence.Step in Sequence.unfold_with ~init:t ~f:(fun t (x,c) -> let t = step t x c in - when_decided t (Skip t) ~f:(fun d -> Yield (d,t))) + when_decided t (Skip {state=t}) ~f:(fun d -> Yield {value=d; state=t})) let rev_zip_skip skip xs ys = diff --git a/lib/bap_strings/bap_strings_index.ml b/lib/bap_strings/bap_strings_index.ml index dcc7cfb0d..bda8828c1 100644 --- a/lib/bap_strings/bap_strings_index.ml +++ b/lib/bap_strings/bap_strings_index.ml @@ -34,7 +34,7 @@ module Persistent = struct let empty = { strings = Index.empty; - keys = String.Map.empty; + keys = (Map.empty (module String)); } let string {strings} key = diff --git a/lib/bap_strings/bap_strings_scanner.ml b/lib/bap_strings/bap_strings_scanner.ml index a35450c15..2836e2f0c 100644 --- a/lib/bap_strings/bap_strings_scanner.ml +++ b/lib/bap_strings/bap_strings_scanner.ml @@ -25,7 +25,7 @@ let run ?is_stop ~read off = let str = next ?is_stop ~read off in let len = String.length str in if len <> 0 - then Seq.Step.Yield ((off,str),(off+len)) + then Seq.Step.Yield {value=(off,str); state=off+len} else match read off with | None -> Seq.Step.Done - | Some _ -> Seq.Step.Skip (off+1)) + | Some _ -> Seq.Step.Skip {state=off+1}) diff --git a/lib/bap_strings/bap_strings_unscrambler.ml b/lib/bap_strings/bap_strings_unscrambler.ml index 5aefed61a..9d00cecc9 100644 --- a/lib/bap_strings/bap_strings_unscrambler.ml +++ b/lib/bap_strings/bap_strings_unscrambler.ml @@ -56,7 +56,7 @@ module Make(Alpha : Alphabet) = struct Array.init Alpha.length ~f:(fun i -> String.count word ~f:(fun c -> Alpha.index c = i)) - let empty = {dict = Int.Map.empty; data=[]} + let empty = {dict = (Map.empty (module Int)); data=[]} let add_word dict word = diff --git a/lib/bap_taint/bap_taint.ml b/lib/bap_taint/bap_taint.ml index 5396b9412..f770771ef 100644 --- a/lib/bap_taint/bap_taint.ml +++ b/lib/bap_taint/bap_taint.ml @@ -36,7 +36,7 @@ type kinds = { let kinds = Primus.Machine.State.declare ~name:"tainter-object-kinds" ~uuid:"a97f9cf6-541a-4127-9eb6-6c24f67ed8b9" - (fun _ -> {objects = Primus.Value.Map.empty}) + (fun _ -> {objects = (Map.empty (module Primus.Value))}) module Object = struct type Primus.exn += Bad_object of Primus.value @@ -130,8 +130,8 @@ type gc_local = { } let empty_tainter = { - direct = Vid.Map.empty; - indirect = Primus.Value.Map.empty; + direct = (Map.empty (module Vid)); + indirect = (Map.empty (module Primus.Value)); } let tainter = Primus.Machine.State.declare @@ -186,7 +186,7 @@ let objects {direct; indirect} : objects = let to_set m : objects = Map.to_sequence m |> Seq.map ~f:snd |> - Seq.fold ~init:Object.Set.empty ~f:Set.union in + Seq.fold ~init:(Set.empty (module Object)) ~f:Set.union in Set.union (to_set direct) (to_set indirect) module Taint = struct @@ -233,7 +233,7 @@ module Taint = struct let lookup v (Rel {field; key}) = Machine.Local.get tainter >>| fun t -> match Map.find (Field.get field t) (key v) with - | None -> Object.Set.empty + | None -> (Set.empty (module Object)) | Some s -> s @@ -248,7 +248,7 @@ module Taint = struct s with direct = Map.update s.direct (Primus.Value.id value) ~f:(function - | None -> Object.Set.singleton taint + | None -> Set.singleton (module Object) taint | Some taints -> Set.add taints taint) }) >>= fun () -> report_attached Rel.direct taint value >>| fun () -> @@ -263,7 +263,7 @@ module Taint = struct Value.nsucc addr off >>= fun addr -> report_attached Rel.indirect taint addr >>| fun () -> Map.update indirect addr ~f:(function - | None -> Object.Set.singleton taint + | None -> Set.singleton (module Object) taint | Some taints -> Set.add taints taint)) >>= fun indirect -> Machine.Local.put tainter {s with indirect} >>| fun () -> taint @@ -303,7 +303,7 @@ module Propagation = struct ~name:"taint-policies" ~uuid:"4c370c33-ef1b-4e10-be27-ee751a4d6cf3" (fun _ -> { - servers = Kind.Map.empty; + servers = (Map.empty (module Kind)); default = None; }) @@ -344,7 +344,7 @@ module Propagation = struct Machine.Global.get kinds >>= fun kinds -> Machine.Local.get policies >>| fun policies -> let filter = select_objects kinds policies ~policy:p in - List.fold srcs ~init:Object.Set.empty ~f:(fun objs src -> + List.fold srcs ~init:(Set.empty (module Object)) ~f:(fun objs src -> match Map.find (Field.get ms.field s) (ms.key src) with | None -> objs | Some objs' -> Set.union (filter objs') objs) @@ -405,7 +405,7 @@ module Gc = struct let collect_direct = Machine.Local.get tainter >>= fun s -> Env.all >>= fun vars -> - Machine.Seq.fold vars ~init:Vid.Set.empty ~f:(fun live var -> + Machine.Seq.fold vars ~init:(Set.empty (module Vid)) ~f:(fun live var -> Env.is_set var >>= function | false -> !!live | true -> diff --git a/lib/bap_traces/bap_trace.ml b/lib/bap_traces/bap_trace.ml index 4e2c76596..a5a2332c9 100644 --- a/lib/bap_traces/bap_trace.ml +++ b/lib/bap_traces/bap_trace.ml @@ -164,8 +164,8 @@ let supports t tag = supports_by_tool t tag && supports_by_proto t tag let read_events t : event seq = let map e = match t.mapper e with - | None -> Seq.Step.Skip () - | Some e -> Seq.Step.Yield (e,()) in + | None -> Seq.Step.Skip {state=()} + | Some e -> Seq.Step.Yield {value=e; state=()} in Seq.unfold_step ~init:() ~f:(fun () -> match t.reader.next () with | None -> Seq.Step.Done @@ -173,8 +173,8 @@ let read_events t : event seq = | Some Error e -> match t.monitor e with | `Stop -> Seq.Step.Done | `Fail -> Error.raise e - | `Skip -> Seq.Step.Skip () - | `Make e -> Seq.Step.Yield (e,())) + | `Skip -> Seq.Step.Skip {state=()} + | `Make e -> Seq.Step.Yield {value=e; state=()}) let read_all t tag = read_events t |> Seq.filter_map ~f:(Value.get tag) diff --git a/lib/bap_traces/bap_trace_id.ml b/lib/bap_traces/bap_trace_id.ml index d66758c21..98de13b55 100644 --- a/lib/bap_traces/bap_trace_id.ml +++ b/lib/bap_traces/bap_trace_id.ml @@ -2,7 +2,7 @@ open Core_kernel[@@warning "-D"] open Regular.Std open Bap.Std -module Bin = Bin_prot.Utils.Make_binable(struct +module Bin = Bin_prot.Utils.Make_binable_without_uuid(struct module Binable = String type t = Uuidm.t let to_binable = Uuidm.to_bytes diff --git a/lib/bap_traces/bap_trace_meta.ml b/lib/bap_traces/bap_trace_meta.ml index eaf58d29e..57759882d 100644 --- a/lib/bap_traces/bap_trace_meta.ml +++ b/lib/bap_traces/bap_trace_meta.ml @@ -39,7 +39,7 @@ let hexstring_of_bytestring str = String.init (String.length str * 2) (fun dstix -> let srcix = dstix / 2 in let is_hi = dstix mod 2 = 0 in - let b = Caml.Char.code (String.get str srcix) in + let b = Stdlib.Char.code (String.get str srcix) in let nib = 0xF land if is_hi then (b lsr 4) else b in String.get byte2hexchar nib) @@ -52,7 +52,7 @@ module Binary = struct @\nmd5sum: %s\ @\n@[<2>\ args: %a@]\ - @\n@[<2>envp:@\n%a@]@]@\n}" t.path (Caml.Digest.to_hex t.md5sum) Args.pp t.args Envp.pp t.envp + @\n@[<2>envp:@\n%a@]@]@\n}" t.path (Stdlib.Digest.to_hex t.md5sum) Args.pp t.args Envp.pp t.envp end let pp_time fmt t = diff --git a/lib/bap_traces/bap_trace_traces.ml b/lib/bap_traces/bap_trace_traces.ml index 78189876f..d4ccea795 100644 --- a/lib/bap_traces/bap_trace_traces.ml +++ b/lib/bap_traces/bap_trace_traces.ml @@ -2,7 +2,7 @@ open Core_kernel[@@warning "-D"] module Trace = Bap_trace -let traces = Trace.Id.Table.create () +let traces = Hashtbl.create (module Trace.Id) let add t = Hashtbl.set traces ~key:(Trace.id t) ~data:t let remove t = Hashtbl.remove traces (Trace.id t) diff --git a/lib/bap_types/bap_bil_optimizations.ml b/lib/bap_types/bap_bil_optimizations.ml index 4adfd1a59..f9f588388 100644 --- a/lib/bap_types/bap_bil_optimizations.ml +++ b/lib/bap_types/bap_bil_optimizations.ml @@ -49,7 +49,7 @@ module Propagate(SM : Monad.State.S2) = struct type ctxt = const Var.Map.t type 'a r = ('a, ctxt) SM.t - let new_ctxt = Var.Map.empty + let new_ctxt = (Map.empty (module Var)) let find = Map.find let update = Map.set @@ -247,4 +247,4 @@ let prune_dead_virtuals bil = ~f:(fun live s -> live ++ Stmt_helpers.free_vars s) in let live = free cond ++ live' in s :: bil, live) in - fst (loop Var.Set.empty bil) + fst (loop (Set.empty (module Var)) bil) diff --git a/lib/bap_types/bap_bil_pass.ml b/lib/bap_types/bap_bil_pass.ml index 6aafb8e3b..b31b6ec1c 100644 --- a/lib/bap_types/bap_bil_pass.ml +++ b/lib/bap_types/bap_bil_pass.ml @@ -9,7 +9,7 @@ type t = { } type pass = t -let passes : t String.Table.t = String.Table.create () +let passes : t String.Table.t = Hashtbl.create (module String) let selected : (bil -> bil) list ref = ref [] let register_pass ?(desc="No description provided") name body = diff --git a/lib/bap_types/bap_bitvector.ml b/lib/bap_types/bap_bitvector.ml index bf6f9f28b..c88aabccc 100644 --- a/lib/bap_types/bap_bitvector.ml +++ b/lib/bap_types/bap_bitvector.ml @@ -135,7 +135,7 @@ end = struct let of_string s = {packed = Z.of_bits s} end - include Binable.Of_stringable(Stringable) [@@warning "-D"] + include Binable.Of_stringable_without_uuid(Stringable) [@@warning "-D"] include Sexpable.Of_stringable(Stringable) end @@ -691,7 +691,7 @@ module V1 = struct end include Z include Sexpable.Of_stringable(Repr) - include Binable.Of_stringable(Repr) [@@warning "-D"] + include Binable.Of_stringable_without_uuid(Repr) [@@warning "-D"] end type t = { @@ -717,7 +717,7 @@ module Stable = struct signed = is_signed x; } - include Binable.Of_binable(V1)(struct + include Binable.Of_binable_without_uuid(V1)(struct type t = Packed.t let to_binable = to_legacy let of_binable = of_legacy diff --git a/lib/bap_types/bap_context.ml b/lib/bap_types/bap_context.ml index 83c4f8bc3..e047eaa94 100644 --- a/lib/bap_types/bap_context.ml +++ b/lib/bap_types/bap_context.ml @@ -6,7 +6,7 @@ open Bap_bil type delta = result Bap_var.Map.t class t = object - val delta : delta = Bap_var.Map.empty + val delta : delta = (Map.empty (module Bap_var)) method lookup = Map.find delta method update key data = {< delta = Map.set delta ~key ~data >} method bindings = Map.to_sequence delta diff --git a/lib/bap_types/bap_helpers.ml b/lib/bap_types/bap_helpers.ml index 0e4a813b7..a6985a949 100644 --- a/lib/bap_types/bap_helpers.ml +++ b/lib/bap_types/bap_helpers.ml @@ -451,7 +451,7 @@ let substitute x y = (new rewriter x y)#run module Trie = struct type normalized_bil = bil - let vars = String.Table.create () + let vars = Hashtbl.create (module String) let pruned ty = Exp.Unknown ("", ty) @@ -460,7 +460,7 @@ module Trie = struct method! map_sym var = let name = Bap_var.name var in let ty = Bap_var.typ var in - String.Table.find_or_add vars name + Hashtbl.find_or_add vars name ~default:(fun () -> Bap_var.create name ty) method! map_int w = let ty = Type.Imm (Word.bitwidth w) in @@ -1002,7 +1002,7 @@ module Exp = struct let normalize = Normalize.normalize_exp let substitute x y = map (new rewriter x y) - let free_vars exp = fst @@ fold ~init:(VS.empty,[]) (object + let free_vars exp = fst @@ fold ~init:((Set.empty (module Bap_var)),[]) (object inherit [VS.t * var list] visitor method! enter_var var (vars,stack) = @@ -1038,19 +1038,19 @@ module Stmt = struct | Stmt.Move (_,e) | Stmt.Jmp e -> Exp.free_vars e | Stmt.While (e,ss) -> - VS.union_list @@ Exp.free_vars e :: List.map ss ~f:free_vars + Set.union_list (module Bap_var) @@ (Exp.free_vars e :: List.map ss ~f:free_vars) | Stmt.If (e,s1,s2) -> - VS.union_list @@ Exp.free_vars e :: List.map (s1@s2) ~f:free_vars + Set.union_list (module Bap_var) @@ (Exp.free_vars e :: List.map (s1@s2) ~f:free_vars) | Stmt.Special _ - | Stmt.CpuExn _ -> VS.empty + | Stmt.CpuExn _ -> (Set.empty (module Bap_var)) let bil_free_vars bil = let update news vars kill = - VS.union vars (VS.diff news kill) in - fst @@ List.fold bil ~init:(VS.empty,VS.empty) + Set.union vars (Set.diff news kill) in + fst @@ List.fold bil ~init:((Set.empty (module Bap_var)),(Set.empty (module Bap_var))) ~f:(fun (vars,kill) -> function | Stmt.Move (v,e) -> - update (Exp.free_vars e) vars kill, VS.add kill v + update (Exp.free_vars e) vars kill, Set.add kill v | stmt -> update (free_vars stmt) vars kill, kill) class constant_folder = Constant_folder.main diff --git a/lib/bap_types/bap_ir.ml b/lib/bap_types/bap_ir.ml index fd5cac1f3..92c9435e0 100644 --- a/lib/bap_types/bap_ir.ml +++ b/lib/bap_types/bap_ir.ml @@ -315,7 +315,7 @@ end = struct paths : path Tid.Table.t; } [@@deriving bin_io, fields, sexp] - let empty () = {subs = [| |] ; paths = Tid.Table.create () } + let empty () = {subs = [| |] ; paths = Hashtbl.create (module Tid) } let update p subs = { p with subs } @@ -461,7 +461,7 @@ let nil_def : def term = empty Def.{ let nil_phi : phi term = empty Phi.{ var = undefined_variable; - map = Map.empty (module Tid); + map = (Map.empty (module Tid)); } let nil_jmp : jmp term = empty Jmp.{ @@ -499,7 +499,7 @@ let term_pp ?(no_cut=false) ?(box=horizontal) pp_self ppf t = let open Format in let attrs = Dict.data t.dict in Seq.iter attrs ~f:(fun attr -> - pp_open_tag ppf (asprintf "%a" pp_attr attr)); + pp_open_stag ppf (String_tag (asprintf "%a" pp_attr attr))); let pp_cut ppf = if not no_cut then Format.pp_print_break ppf 1 0 else fprintf ppf " " in @@ -508,7 +508,7 @@ let term_pp ?(no_cut=false) ?(box=horizontal) pp_self ppf t = pp_cut pp_self t.self; Format.pp_close_box ppf (); - Seq.iter attrs ~f:(fun _ -> pp_close_tag ppf ()) + Seq.iter attrs ~f:(fun _ -> pp_close_stag ppf ()) [@@warning "-D"] (* for open and close tag *) let pp_value slots ppf x = @@ -824,7 +824,7 @@ module Ir_phi = struct let substitute phi x y = map_exp phi ~f:(Exp.substitute x y) let free_vars phi = - values phi |> Seq.fold ~init:Bap_var.Set.empty ~f:(fun vars (_,e) -> + values phi |> Seq.fold ~init:(Set.empty (module Bap_var)) ~f:(fun vars (_,e) -> Set.union vars (Exp.free_vars e)) let pp_self ppf {Phi.var; map} = @@ -1001,7 +1001,7 @@ module Ir_jmp = struct let substitute jmp x y = map_exp jmp ~f:(Exp.substitute x y) let free_vars jmp = - exps jmp |> Seq.fold ~init:Bap_var.Set.empty ~f:(fun vars e -> + exps jmp |> Seq.fold ~init:(Set.empty (module Bap_var)) ~f:(fun vars e -> Set.union vars (Exp.free_vars e)) let eval jmp bili = @@ -1657,7 +1657,7 @@ module Ir_blk = struct let free_vars blk = let (++) = Set.union and (--) = Set.diff in - let init = Bap_var.Set.empty,Bap_var.Set.empty in + let init = (Set.empty (module Bap_var)),(Set.empty (module Bap_var)) in fst @@ Seq.fold (elts blk) ~init ~f:(fun (vars,kill) -> function | `Phi _ -> vars, kill | `Def def -> @@ -1964,7 +1964,7 @@ module Ir_program = struct let get_and_cache (get : 'a getter) prog tid : 'a term option = let open Option.Monad_infix in get prog tid >>= fun (path,term) -> - Tid.Table.change prog.self.paths tid (fun _ -> Some path); + Hashtbl.change prog.self.paths tid (fun _ -> Some path); Some term type 'a entry = { @@ -1974,7 +1974,7 @@ module Ir_program = struct let make_getter (term : 'a entry) prog (tid : tid) : 'a term option = let open Option.Monad_infix in - match Tid.Table.find prog.self.paths tid with + match Hashtbl.find prog.self.paths tid with | None -> get_and_cache term.get prog tid | Some path -> try @@ -2002,7 +2002,7 @@ module Ir_program = struct match lookup t p tid with | None -> None | Some _ -> - let path = Tid.Table.find_exn p.self.paths tid in + let path = Hashtbl.find_exn p.self.paths tid in match t.par with | Blk -> Some (blk_of_path p path) | Arg -> Some (arg_of_path p path) diff --git a/lib/bap_types/bap_ir_callgraph.ml b/lib/bap_types/bap_ir_callgraph.ml index ed0e5b626..6a3469fcd 100644 --- a/lib/bap_types/bap_ir_callgraph.ml +++ b/lib/bap_types/bap_ir_callgraph.ml @@ -12,7 +12,7 @@ let create program = let init = G.Node.insert src g in Term.enum blk_t sub |> Seq.fold ~init ~f:(fun g blk -> Term.enum jmp_t blk |> - Seq.fold ~init:Tid.Map.empty ~f:(fun dsts jmp -> + Seq.fold ~init:(Map.empty (module Tid)) ~f:(fun dsts jmp -> match Ir_jmp.kind jmp with | Goto _ | Ret _ | Int _ -> dsts | Call call -> match Call.target call with diff --git a/lib/bap_types/bap_ir_graph.ml b/lib/bap_types/bap_ir_graph.ml index bb8117ba4..49f8391e2 100644 --- a/lib/bap_types/bap_ir_graph.ml +++ b/lib/bap_types/bap_ir_graph.ml @@ -30,7 +30,7 @@ module Pred = struct | Some xs -> Some (Set.add xs src)) let insert dst preds = - Map.set preds ~key:dst ~data:Tid.Set.empty + Map.set preds ~key:dst ~data:(Set.empty (module Tid)) end (* internal representation of a graph: @@ -82,7 +82,7 @@ type difference_kind = [@@deriving variants, sexp] let jmp_set b = Term.enum jmp_t b |> Seq.map ~f:Term.tid |> - Seq.fold ~init:Tid.Set.empty ~f:Set.add + Seq.fold ~init:(Set.empty (module Tid)) ~f:(fun s x -> Set.add s x) (** [control_flow_difference bx by] computes a changes in control flow produced by blocks [bx] and [by]. Only changes, that affects graph @@ -338,7 +338,7 @@ end let empty = { sub = Sub.create (); - preds = Tid.Map.empty; + preds = (Map.empty (module Tid)); } let create ?tid ?name () = { @@ -360,17 +360,17 @@ let number_of_nodes t = Term.length blk_t t.sub let preds_of_sub sub : Tid.Set.t Tid.Map.t = Term.enum blk_t sub |> - Seq.fold ~init:Tid.Map.empty ~f:(fun ins src -> + Seq.fold ~init:(Map.empty (module Tid)) ~f:(fun ins src -> let src_id = Term.tid src in let ins = Map.change ins src_id (function - | None -> Some Tid.Set.empty + | None -> Some (Set.empty (module Tid)) | other -> other) in Term.enum jmp_t src |> Seq.fold ~init:ins ~f:(fun ins jmp -> match succ_tid_of_jmp jmp with | None -> ins | Some tid -> Map.change ins tid (function - | None -> Some (Tid.Set.singleton src_id) + | None -> Some (Set.singleton (module Tid) src_id) | Some set -> Some (Set.add set src_id)))) let of_sub sub = { diff --git a/lib/bap_types/bap_ogre.ml b/lib/bap_types/bap_ogre.ml index 53967f240..bf475a65f 100644 --- a/lib/bap_types/bap_ogre.ml +++ b/lib/bap_types/bap_ogre.ml @@ -16,7 +16,7 @@ end let pp = Ogre.Doc.pp include Sexpable.Of_stringable(Stringable) -include Binable.Of_stringable(Stringable) [@@warning "-D"] +include Binable.Of_stringable_without_uuid(Stringable) [@@warning "-D"] type KB.Conflict.t += Spec_inconsistency of Error.t diff --git a/lib/bap_types/bap_result.ml b/lib/bap_types/bap_result.ml index b653d0d4d..b6bb97317 100644 --- a/lib/bap_types/bap_result.ml +++ b/lib/bap_types/bap_result.ml @@ -57,7 +57,7 @@ module Storage = struct end class sparse : storage = object - val storage = Bitvector.Map.empty + val storage = (Map.empty (module Bitvector)) method save x u = {< storage = Map.set storage ~key:x ~data:u >} method load x = Map.find storage x end diff --git a/lib/bap_types/bap_toplevel.ml b/lib/bap_types/bap_toplevel.ml index bc9968e52..7b79fb671 100644 --- a/lib/bap_types/bap_toplevel.ml +++ b/lib/bap_types/bap_toplevel.ml @@ -69,7 +69,7 @@ let get slot = eval slot this |> function | Some x -> x -let () = Caml.Printexc.register_printer @@ function +let () = Stdlib.Printexc.register_printer @@ function | Conflict err -> Some (Format.asprintf "%a" Knowledge.Conflict.pp err) | _ -> None diff --git a/lib/bap_types/bap_trie.ml b/lib/bap_types/bap_trie.ml index bcfb6a265..135c1604b 100644 --- a/lib/bap_types/bap_trie.ml +++ b/lib/bap_types/bap_trie.ml @@ -5,10 +5,66 @@ open Option.Monad_infix open Bap_trie_intf module Make(Key : Key) = struct - module Tokens = Hashtbl.Make_binable(struct - type t = Key.token [@@deriving bin_io, compare, sexp] - let hash = Key.token_hash - end) + module Token_key = struct + type t = Key.token [@@deriving bin_io, compare, sexp] + let hash = Key.token_hash + end + + (* Simple assoc-list based table (v0.17 compat) *) + module Tokens = struct + type 'a t = (Token_key.t * 'a) list ref + + let create () : 'a t = ref [] + + let find t k = + let rec loop = function + | [] -> None + | (k',v) :: rest -> + if Base.Poly.equal k k' then Some v else loop rest in + loop !t + + let change t k ~f = + let rec loop acc = function + | [] -> (match f None with + | Some v -> List.rev ((k,v) :: acc) + | None -> List.rev acc) + | (k',v) :: rest -> + if Base.Poly.equal k k' + then (match f (Some v) with + | Some v' -> List.rev acc @ [(k',v')] @ rest + | None -> List.rev acc @ rest) + else loop ((k',v) :: acc) rest in + t := loop [] !t + + let add_exn t ~key ~data = t := (key,data) :: !t + + let fold t ~init ~f = List.fold !t ~init ~f:(fun acc (k,v) -> f ~key:k ~data:v acc) + + let iteri t ~f = List.iter !t ~f:(fun (k,v) -> f ~key:k ~data:v) + + let sexp_of_t sa t = + Sexp.List (List.map !t ~f:(fun (k,v) -> Sexp.List [Token_key.sexp_of_t k; sa v])) + + let t_of_sexp sa = function + | Sexp.List items -> + ref (List.map items ~f:(function + | Sexp.List [k;v] -> (Token_key.t_of_sexp k, sa v) + | _ -> failwith "Trie.Sexp: bad pair")) + | _ -> failwith "Trie.Sexp: expected list" + + module A = struct + type 'a t = (Token_key.t * 'a) list [@@deriving bin_io] + end + + let bin_shape_t sa = A.bin_shape_t sa + let bin_size_t sa (t : 'a t) = A.bin_size_t sa !t + let bin_write_t wa (buf : Bin_prot.Common.buf) ~(pos:int) (t : 'a t) = A.bin_write_t wa buf ~pos !t + let bin_read_t ra buf ~pos_ref = ref (A.bin_read_t ra buf ~pos_ref) + let __bin_read_t__ ra buf ~pos_ref = ref (A.__bin_read_t__ ra buf ~pos_ref) + let bin_writer_t wa = A.bin_writer_t wa + let bin_reader_t ra = A.bin_reader_t ra + let bin_t tc = A.bin_t tc + end type key = Key.t type token = Key.token @@ -26,7 +82,7 @@ module Make(Key : Key) = struct let rec loop n {subs} = let c = Key.nth_token k n in if n + 1 = len then found subs c else find subs n c - and found parent c = Tokens.change parent c (function + and found parent c = Tokens.change parent c ~f:(function | None -> f None >>| init | Some t -> Some {t with data = f t.data}) and find parent n c = match Tokens.find parent c with @@ -35,7 +91,7 @@ module Make(Key : Key) = struct | None -> return () | Some _ -> let sub = create () in - Tokens.add_exn parent c sub; + ignore (Tokens.add_exn parent ~key:c ~data:sub); loop (n+1) sub in if len > 0 then loop 0 trie else trie.data <- f trie.data @@ -97,7 +153,7 @@ module Make(Key : Key) = struct pp_val data pp_prefix (List.rev rprefix)); pp_table ppf rprefix t.subs and pp_table ppf rprefix cs = - Tokens.iteri cs (fun ~key ~data -> + Tokens.iteri cs ~f:(fun ~key ~data -> let rprefix = key :: rprefix in pp_trie ppf rprefix data) in pp_trie ppf [] t diff --git a/lib/bap_types/bap_value.ml b/lib/bap_types/bap_value.ml index d865c09c9..ddcb71017 100644 --- a/lib/bap_types/bap_value.ml +++ b/lib/bap_types/bap_value.ml @@ -21,9 +21,7 @@ type 'a tag = { slot : (Theory.program,'a option) KB.slot; } -module Value = struct - type t = Univ_map.Packed.t = T : 'a Type_equal.Id.t * 'a -> t -end +module Value = Univ_map.Packed module Equal = struct type ('a,'b) t = ('a,'b) Type_equal.t = T : ('a,'a) t @@ -147,7 +145,7 @@ module Univ = struct } [@@deriving bin_io] end - include Binable.Of_binable(Repr)(struct + include Binable.Of_binable_without_uuid(Repr)(struct type t = Value.t let to_binable x = Repr.{ typeid = typeid x; @@ -208,7 +206,7 @@ module Match = struct handlers : (Value.t -> 's) Map.M(Uid).t; } - let empty = Map.empty (module Uid) + let empty = (Map.empty (module Uid)) let default default = { handlers = empty; @@ -261,7 +259,7 @@ module Dict = struct List.fold ~init:empty ~f:(fun dict (Value.T (k,x)) -> Univ_map.set dict k x) end - include Binable.Of_binable(Data)(struct + include Binable.Of_binable_without_uuid(Data)(struct type t = Univ_map.t let to_binable = Data.of_dict let of_binable = Data.to_dict diff --git a/lib/bap_types/bap_var.ml b/lib/bap_types/bap_var.ml index 724f4557c..e31d1d66d 100644 --- a/lib/bap_types/bap_var.ml +++ b/lib/bap_types/bap_var.ml @@ -115,7 +115,7 @@ module T = struct let of_sexpable = Repr.to_var end) - include Binable.Of_binable(Repr)(struct + include Binable.Of_binable_without_uuid(Repr)(struct type t = var let to_binable = Repr.of_var let of_binable = Repr.to_var diff --git a/lib/bare/bare.ml b/lib/bare/bare.ml index c935c166a..09b1d9fd6 100644 --- a/lib/bare/bare.ml +++ b/lib/bare/bare.ml @@ -66,8 +66,8 @@ module Rule = struct let reset {rule} = {rule; work = [rule]} - let empty = String.Map.empty - let binding x rhs = String.Map.singleton x rhs + let empty = (Map.empty (module String)) + let binding x rhs = Map.singleton (module String) x rhs let sexp_fold_atoms ~get_pos ~init ~f sexp = let rec loop init s = match s with @@ -84,7 +84,7 @@ module Rule = struct else atoms) let collect_free_vars ~get_pos xs = - List.fold ~init:String.Map.empty ~f:(vars_of_sexp ~get_pos) xs + List.fold ~init:(Map.empty (module String)) ~f:(vars_of_sexp ~get_pos) xs let check_rule ~get_pos lhs rhs = let def = collect_free_vars ~get_pos lhs diff --git a/lib/bitvec_binprot/bitvec_binprot.ml b/lib/bitvec_binprot/bitvec_binprot.ml index 19e8bfd25..2d8dcc376 100644 --- a/lib/bitvec_binprot/bitvec_binprot.ml +++ b/lib/bitvec_binprot/bitvec_binprot.ml @@ -1,6 +1,6 @@ open Bin_prot.Std type t = Bitvec.t -module Functions = Bin_prot.Utils.Make_binable(struct +module Functions = Bin_prot.Utils.Make_binable_without_uuid(struct module Binable = struct type t = string [@@deriving bin_io] end diff --git a/lib/graphlib/graphlib.mli b/lib/graphlib/graphlib.mli index b8f33e4e0..37641514a 100644 --- a/lib/graphlib/graphlib.mli +++ b/lib/graphlib/graphlib.mli @@ -1043,7 +1043,7 @@ module Std : sig [rev] is true, then the graph is reversed. For example, the following will build a set of reachable nodes: - [fold_reachable (module G) ~init:G.Node.Set.empty ~f:Set.add] + [fold_reachable (module G) ~init:(Set.empty (module G.Node)) ~f:Set.add] *) val fold_reachable : (module Graph with type t = 'c diff --git a/lib/graphlib/graphlib_graph.ml b/lib/graphlib/graphlib_graph.ml index af705673e..47fb4e44b 100644 --- a/lib/graphlib/graphlib_graph.ml +++ b/lib/graphlib/graphlib_graph.ml @@ -402,7 +402,7 @@ module To_ocamlgraph(G : Graph) = struct let find_edge g x y = match G.Node.edge x y g with | Some e -> e - | None -> raise Caml.Not_found + | None -> raise Stdlib.Not_found let find_all_edges g x y = G.Node.edge x y g |> function | None -> [] @@ -482,7 +482,7 @@ module Of_ocamlgraph(G : Graph.Sig.P) = struct let remove n g = G.remove_vertex g n let has_edge x y g = G.mem_edge g x y let edge x y g = - try Some (G.find_edge g x y) with Caml.Not_found -> None + try Some (G.find_edge g x y) with Stdlib.Not_found -> None let degree ?dir n g = try match dir with @@ -568,8 +568,8 @@ module Of_ocamlgraph(G : Graph.Sig.P) = struct let cmp (type t) (module C : Comparable with type t = t) enum x y = - let set x = Seq.fold (enum x) ~f:Set.add ~init:C.Set.empty in - C.Set.compare (set x) (set y) + let set x = Seq.fold (enum x) ~f:(fun s x -> Set.add s x) ~init:(Set.empty (module C)) in + Poly.compare (Set.to_list (set x)) (Set.to_list (set y)) (* complexity: O(e*log(e) + n*log(n)), where [e] is a number of edges and [n] is a number of nodes. See a note above for the @@ -605,7 +605,7 @@ let compare (type e) (type g) (type n) let t_of_sexp = opaque_of_sexp end) in let module Nodes = E.Node.Set in - let set empty x = Seq.fold x ~f:Set.add ~init:empty in + let set empty x = Seq.fold x ~f:(fun s x -> Set.add s x) ~init:empty in let edges edges src dst empty g = edges g |> Seq.map ~f:(fun e -> src e, dst e) |> set empty in let e_edges = edges E.edges E.Edge.src E.Edge.dst Edges.empty e in @@ -627,7 +627,7 @@ module Ordering(G : Graph) = struct } let init g = { - numbers = G.Node.Map.empty; + numbers = (Map.empty (module G.Node)); nodes_left = G.number_of_nodes g; nodes_entered = 0; } @@ -755,7 +755,7 @@ let postorder_traverse graph ?rev ?start g = let create_namer (type t) (type n) (module G : Graph with type t = t and type node = n) g = let namer = - depth_first_search (module G) g ~init:G.Node.Map.empty + depth_first_search (module G) g ~init:(Map.empty (module G.Node)) ~leave_node:(fun rpost n names -> Map.set names ~key:n ~data:(Int.to_string rpost)) in Map.find_exn namer @@ -829,10 +829,10 @@ let idom (type t) (type n) (type e) ~start_tree:(fun _ len -> if len <> 0 then return len else len) ~enter_node:(fun _ _ len -> len + 1)) in let node = Array.create ~len entry in - let pnums = G.Node.Table.create ~size:len () in + let pnums : (n, int) Hashtbl.Poly.t = Hashtbl.Poly.create ~size:len () in let doms = Array.create ~len ~-1 in let pnum = - Hashtbl.find_and_call pnums + Hashtbl.Poly.find_and_call pnums ~if_found:Fn.id ~if_not_found:(fun _ -> raise Unreachable) in if len > 0 then doms.(len - 1) <- len - 1; @@ -882,12 +882,12 @@ let dominators (type t) (type n) (type e) and type edge = e and type node = n) ?rev g entry = let `idom parent = idom ?rev (module G) g entry in - let init = G.nodes g |> Seq.fold ~init:G.Node.Map.empty ~f:(fun t n -> + let init = G.nodes g |> Seq.fold ~init:(Map.empty (module G.Node)) ~f:(fun t n -> Map.set t ~key:n ~data:[]) in let children = G.nodes g |> Seq.fold ~init ~f:(fun tree n -> match parent n with | Some p -> Map.add_multi tree ~key:p ~data:n - | None -> tree) |> Map.map ~f:G.Node.Set.of_list in + | None -> tree) |> Map.map ~f:(Set.of_list (module G.Node)) in create_tree parent children module type Dom_frontier_algo = functor (G : Graph) -> sig @@ -903,13 +903,13 @@ module Dom_frontier_cooper(G:Graph) = struct else match idom r with | None -> Set.add dfs r | Some p -> walk top (Set.add dfs r) p in - G.nodes g |> Seq.fold ~init:G.Node.Map.empty ~f:(fun dfs n -> + G.nodes g |> Seq.fold ~init:(Map.empty (module G.Node)) ~f:(fun dfs n -> let adj = adj n g in let dom = idom n in - Seq.fold adj ~init:G.Node.Set.empty ~f:(walk dom) |> + Seq.fold adj ~init:(Set.empty (module G.Node)) ~f:(walk dom) |> Set.fold ~init:dfs ~f:(fun dfs visited -> Map.change dfs visited (function - | None -> Some (G.Node.Set.singleton n) + | None -> Some (Set.singleton (module G.Node) n) | Some set -> Some (Set.add set n)))) end @@ -934,8 +934,8 @@ let strong_components (module G : Graph with type t = t and type node = n and type edge = e) g = - let roots = G.Node.Table.create () in - let comps = G.Node.Table.create ~size:(G.number_of_nodes g) () in + let roots = Hashtbl.create (module G.Node) in + let comps = Hashtbl.create (module G.Node) ~size:(G.number_of_nodes g) in let root = Hashtbl.find_exn roots in let spill_comp root stack = List.drop_while stack ~f:(fun c -> @@ -995,7 +995,7 @@ let shortest_path let adj = if rev then G.Node.inputs else G.Node.outputs in let dst = if rev then G.Edge.src else G.Edge.dst in let visited = G.Node.Hash_set.create () in - let dist = G.Node.Table.create () in + let dist = Hashtbl.create (module G.Node) in let q = Heap.create ~cmp () in let rec loop () = match Heap.pop q with | None -> None @@ -1358,11 +1358,11 @@ module Fixpoint = struct reverse_postorder_traverse (module G) ~rev ?start g |> Sequence.to_array in let rnodes = - Array.foldi nodes ~init:G.Node.Map.empty ~f:(fun i rnodes n -> + Array.foldi nodes ~init:(Map.empty (module G.Node)) ~f:(fun i rnodes n -> Map.set rnodes ~key:n ~data:i) in let succs = Array.map nodes ~f:(fun n -> let succs = if rev then G.Node.preds else G.Node.succs in - succs n g |> Sequence.fold ~init:Int.Set.empty ~f:(fun ns n -> + succs n g |> Sequence.fold ~init:(Set.empty (module Int)) ~f:(fun ns n -> match Map.find rnodes n with | None -> ns | Some i -> Set.add ns i)) in @@ -1410,12 +1410,12 @@ module Fixpoint = struct | Step (visits,works,approx) -> loop visits (iters+1) works approx else make_solution iters approx in let works = List.init (Array.length nodes) Fn.id in - let approx = Map.fold init ~init:Int.Map.empty + let approx = Map.fold init ~init:(Map.empty (module Int)) ~f:(fun ~key:node ~data approx -> match Map.find rnodes node with | None -> approx | Some n -> Map.set approx ~key:n ~data) in - loop Int.Map.empty iters (Int.Set.of_list works) approx + loop (Map.empty (module Int)) iters (Set.of_list (module Int) works) approx end let fixpoint = Fixpoint.compute diff --git a/lib/graphlib/graphlib_pp.ml b/lib/graphlib/graphlib_pp.ml index 501fd6ca6..add7a72fe 100644 --- a/lib/graphlib/graphlib_pp.ml +++ b/lib/graphlib/graphlib_pp.ml @@ -61,7 +61,7 @@ let by_natural_order (type a) variant compare nodes = let compare = compare let sexp_of_t = sexp_of_opaque end) end in - Seq.fold nodes ~init:(Set.empty (module T)) ~f:Set.add |> + Seq.fold nodes ~init:(Set.empty (module T)) ~f:(fun s x -> Set.add s x) |> Set.to_sequence |> by_given_order variant compare module Dot = struct diff --git a/lib/graphlib/graphlib_regular.ml b/lib/graphlib/graphlib_regular.ml index 2c7d86c5f..5a708e5d7 100644 --- a/lib/graphlib/graphlib_regular.ml +++ b/lib/graphlib/graphlib_regular.ml @@ -31,7 +31,7 @@ module Make(Node : Opaque.S)(Label : T) = struct type graph = node_info Node.Map.t [@@deriving compare] - let empty_node = {inc = Node.Map.empty; out = Node.Map.empty} + let empty_node = {inc = (Map.empty (module Node)); out = (Map.empty (module Node))} module Node = struct type nonrec edge = edge @@ -134,7 +134,7 @@ module Make(Node : Opaque.S)(Label : T) = struct Map.change g (src e) (function | None -> Some (Field.fset field empty_node - (Node.Map.singleton (dst e) e.data)) + (Map.singleton (module Node) (dst e) e.data)) | Some ns -> let map = Field.get field ns in Some (Field.fset field ns @@ -168,7 +168,7 @@ module Make(Node : Opaque.S)(Label : T) = struct let is_directed = true - let empty = Node.Map.empty + let empty = (Map.empty (module Node)) let nodes g = Map.keys g |> Seq.of_list diff --git a/lib/knowledge/bap_knowledge.ml b/lib/knowledge/bap_knowledge.ml index ea4d64797..625ac2cf8 100644 --- a/lib/knowledge/bap_knowledge.ml +++ b/lib/knowledge/bap_knowledge.ml @@ -17,9 +17,9 @@ type conflict = exn = .. module Conflict = struct type t = conflict = .. - let to_string = Caml.Printexc.to_string + let to_string = Stdlib.Printexc.to_string let pp ppf err = Format.fprintf ppf "%s" (to_string err) - let register_printer = Caml.Printexc.register_printer + let register_printer = Stdlib.Printexc.register_printer let sexp_of_t err = Sexp.Atom (to_string err) end @@ -159,21 +159,21 @@ end let branching_bit a b = highest_bit (a lxor b) let rec find_exn t k = match t with - | Nil -> raise Caml.Not_found + | Nil -> raise Stdlib.Not_found | Tip (k', v) when k = k' -> v - | Tip _ -> raise Caml.Not_found + | Tip _ -> raise Stdlib.Not_found | Bin (k', l, r) -> match Key.compare k' k with - | NA -> raise Caml.Not_found + | NA -> raise Stdlib.Not_found | LB -> find_exn l k | RB -> find_exn r k let find t k = try Some (find_exn t k) - with Caml.Not_found -> None + with Stdlib.Not_found -> None let mem k t = try ignore (find_exn k t); true - with Caml.Not_found -> false + with Stdlib.Not_found -> false let node payload branching l r = match l, r with | Nil, o | o, Nil -> o @@ -364,7 +364,7 @@ end = struct let unescaped_exists_so_escape ?(skip_pos=(-1)) s = let buf = Buffer.create (String.length s + 1) in - Caml.StringLabels.iteri s ~f:(fun p c -> + Stdlib.StringLabels.iteri s ~f:(fun p c -> if p <> skip_pos && is_separator_unescaped s p c then Buffer.add_char buf escape_char; Buffer.add_char buf c); @@ -594,7 +594,7 @@ end = struct ?package ?(reliability=trustworthy) name = let name = Name.create ?package name in - let agent = Caml.Digest.string (Name.show name) in + let agent = Stdlib.Digest.string (Name.show name) in if Hashtbl.mem agents agent then failwithf "An agent with name `%a' already exists, \ please choose another name" Name.str name (); @@ -775,7 +775,7 @@ module Domain = struct (module S : Comparator.S with type t = t and type comparator_witness = o) ?(inspect=S.comparator.sexp_of_t) name = - let empty = Set.empty (module S) in + let empty = (Set.empty (module S)) in let order x y : Order.partial = if Set.equal x y then EQ else if Set.is_subset x y then LT else @@ -801,7 +801,7 @@ module Domain = struct ?join ~equal name = - let empty = Map.empty (module K) in + let empty = (Map.empty (module K)) in let join = match join with | Some join -> join | None -> fun x y -> @@ -2121,7 +2121,7 @@ module Record = struct end } - include Binable.Of_binable(Repr)(struct + include Binable.Of_binable_without_uuid(Repr)(struct type t = record let to_binable s = Dict.foreach s ~init:[] { @@ -2265,8 +2265,8 @@ module Knowledge = struct let empty_class = { last = Oid.first; vals = Oid.Tree.empty; - objs = Map.empty (module Name.Full); - pubs = Map.empty (module String); + objs = (Map.empty (module Name.Full)); + pubs = (Map.empty (module String)); } type t = { @@ -2281,13 +2281,13 @@ module Knowledge = struct let empty : Env.t = { package = user_package; - classes = Map.empty (module Name); + classes = (Map.empty (module Name)); context = Dict.empty; } let noinfo : Env.info = { data = Record.empty; - comp = Map.empty (module Name); + comp = (Map.empty (module Name)); name = None; } @@ -2472,7 +2472,7 @@ module Knowledge = struct let t_of_sexp = opaque_of_sexp let empty = empty cls - include Binable.Of_binable(Record)(struct + include Binable.Of_binable_without_uuid(Record)(struct type t = (a,b) cls value let to_binable : 'a value -> Record.t = fun {data} -> data @@ -2700,7 +2700,7 @@ module Knowledge = struct end in let module R = struct include Comparator - include Binable.Of_binable(Oid)(struct + include Binable.Of_binable_without_uuid(Oid)(struct type t = a obj let to_binable = Fn.id let of_binable = Fn.id @@ -2714,7 +2714,7 @@ module Knowledge = struct slot : Name.t; repr : string; error : Conflict.t; - trace : Caml.Printexc.raw_backtrace; + trace : Stdlib.Printexc.raw_backtrace; } let () = Conflict.register_printer (function @@ -2724,7 +2724,7 @@ module Knowledge = struct "Unable to update the slot %a of %s,\n%a\n\ Backtrace:\n%s" Name.pp slot repr Conflict.pp error - (Caml.Printexc.raw_backtrace_to_string trace) + (Stdlib.Printexc.raw_backtrace_to_string trace) | _ -> None) @@ -2755,7 +2755,7 @@ module Knowledge = struct | Error err -> raise (Record.Merge_conflict err))}} with Record.Merge_conflict err -> non_monotonic slot obj err @@ - Caml.Printexc.get_raw_backtrace () + Stdlib.Printexc.get_raw_backtrace () let notify {Slot.watchers} obj data = Hashtbl.data watchers |> @@ -2852,7 +2852,7 @@ module Knowledge = struct fun slot obj -> objects slot.cls >>| fun {vals} -> match Oid.Tree.find_exn vals obj with - | exception Caml.Not_found -> Sleep + | exception Stdlib.Not_found -> Sleep | {data; comp=slots} -> match Map.find slots (uid slot) with | Some Work _ -> Awoke | other -> match other,Record.is_empty data with @@ -2933,7 +2933,7 @@ module Knowledge = struct fun slot id -> objects slot.cls >>| fun {Env.vals} -> match Oid.Tree.find_exn vals id with - | exception Caml.Not_found -> slot.dom.empty + | exception Stdlib.Not_found -> slot.dom.empty | {data} -> Record.get slot.key slot.dom data let rec collect_inner @@ -3213,7 +3213,7 @@ module Knowledge = struct compute_value cls obj >>= fun () -> objects cls >>| fun {Env.vals} -> match Oid.Tree.find_exn vals obj with - | exception Caml.Not_found -> Value.empty cls + | exception Stdlib.Not_found -> Value.empty cls | {data=x} -> Value.create cls x let run cls obj s = (obj >>= get_value cls).run s @@ -3368,7 +3368,7 @@ module Knowledge = struct } let of_canonical_v1 {payload} = - let init = Map.empty (module Name) in + let init = (Map.empty (module Name)) in let classes = List.fold payload ~init ~f:(fun state (cid,objs) -> Map.add_exn state ~key:cid @@ -3377,7 +3377,7 @@ module Knowledge = struct init_last {empty with classes} let of_canonical_v2 {payload} = - let init = Map.empty (module Name) in + let init = (Map.empty (module Name)) in let classes = List.fold payload ~init ~f:(fun state (cid,(last,objs)) -> let init = { diff --git a/lib/knowledge/bap_knowledge.mli b/lib/knowledge/bap_knowledge.mli index 175edb549..15d31efca 100644 --- a/lib/knowledge/bap_knowledge.mli +++ b/lib/knowledge/bap_knowledge.mli @@ -1471,7 +1471,7 @@ module Knowledge : sig return the least upper bound of [x] and [y], if it exists. *) val mapping : - ('a,'e) Map.comparator -> + (module Comparator.S with type t = 'a and type comparator_witness = 'e) -> ?inspect:('d -> Base.Sexp.t) -> ?join:('d -> 'd -> ('d, conflict) result) -> equal:('d -> 'd -> bool) -> @@ -1485,7 +1485,7 @@ module Knowledge : sig operator is the set union, and the order operator is the [is_subset] function. *) - val powerset : ('a,'e) Set.comparator -> + val powerset : (module Comparator.S with type t = 'a and type comparator_witness = 'e) -> ?inspect:('a -> Sexp.t) -> string -> ('a,'e) Set.t domain @@ -1595,11 +1595,11 @@ module Knowledge : sig val array : 'a persistent -> 'a array persistent (** [set order t] derives persistent for a set. *) - val set : ('a,'c) Set.comparator -> 'a t -> ('a,'c) Set.t persistent + val set : (module Comparator.S with type t = 'a and type comparator_witness = 'c) -> 'a t -> ('a,'c) Set.t persistent (** [map order t] derives persistent for a map. *) - val map : ('k,'c) Map.comparator -> 'k t -> 'd t -> ('k,'d,'c) Map.t persistent + val map : (module Comparator.S with type t = 'k and type comparator_witness = 'c) -> 'k t -> 'd t -> ('k,'d,'c) Map.t persistent end (** Conflicting information. diff --git a/lib/microx/microx_conqueror.ml b/lib/microx/microx_conqueror.ml index 8bfd00a1d..622a8ab5f 100644 --- a/lib/microx/microx_conqueror.ml +++ b/lib/microx/microx_conqueror.ml @@ -13,7 +13,7 @@ let visit vis tid = Map.change vis tid ~f:(function | Some n -> Some (n+1)) let create_mapping prog = - let addrs = Addr.Table.create () in + let addrs = Hashtbl.create (module Addr) in let add t a = Hashtbl.set addrs ~key:a ~data:(Term.tid t) in Term.enum sub_t prog |> Seq.iter ~f:(fun sub -> Term.enum blk_t sub |> Seq.iter ~f:(fun blk -> @@ -41,8 +41,8 @@ class context val blk : blk term option = None val callstack : sub term list = [] val steps_left = max_steps - val vis : int Tid.Map.t = Tid.Map.empty (* visited *) - val cps : 's Tid.Map.t Tid.Map.t = Tid.Map.empty + val vis : int Tid.Map.t = (Map.empty (module Tid)) (* visited *) + val cps : 's Tid.Map.t Tid.Map.t = (Map.empty (module Tid)) val rets : tid list = [] method visited = vis @@ -71,7 +71,7 @@ class context if Map.mem vis p then self else {< cps = Map.update cps key ~f:(function - | None -> Tid.Map.singleton p self + | None -> Map.singleton (module Tid) p self | Some ps -> Map.set ps p self) >} diff --git a/lib/monads/dune b/lib/monads/dune index 1977445b9..a5a66915e 100644 --- a/lib/monads/dune +++ b/lib/monads/dune @@ -3,5 +3,5 @@ (public_name monads) (wrapped false) (preprocess (pps ppx_bap)) - (libraries core_kernel core_kernel.rope) + (libraries core_kernel) (private_modules monads_monad monads_monoid monads_types)) diff --git a/lib/monads/monads_monad.ml b/lib/monads/monads_monad.ml index 79c72fe68..239d0af8b 100644 --- a/lib/monads/monads_monad.ml +++ b/lib/monads/monads_monad.ml @@ -651,7 +651,7 @@ module ResultT = struct module type S = sig include S - val failf : ('a, Caml.Format.formatter, unit, unit -> 'b t) format4 -> 'a + val failf : ('a, Stdlib.Format.formatter, unit, unit -> 'b t) format4 -> 'a end module Make(M : Monad.S) : S with type 'a t := 'a T(M).t @@ -662,7 +662,7 @@ module ResultT = struct include Make(struct type t = Error.t end)(M) let failf fmt = - let open Caml.Format in + let open Stdlib.Format in let buf = Buffer.create 512 in let ppf = formatter_of_buffer buf in let kon ppf () = @@ -1175,9 +1175,9 @@ module State = struct init = ctxt; created = global; current = global; - parents = Id.Map.empty; - children = Id.Map.empty; - forks = Id.Map.empty; + parents = (Map.empty (module Id)); + children = (Map.empty (module Id)); + forks = (Map.empty (module Id)); } let rec alive_parent k child = @@ -1204,7 +1204,7 @@ module State = struct let siblings () = SM.gets (fun k -> match Map.find k.children (alive_parent k k.current) with - | None -> Id.Set.empty + | None -> (Set.empty (module Id)) | Some cs -> Set.filter cs ~f:(Map.mem k.forks)) let context k = @@ -1237,7 +1237,7 @@ module State = struct let remove_dead_parents k = let parents = - Map.fold k.forks ~init:Id.Map.empty ~f:(fun ~key ~data:_ ps -> + Map.fold k.forks ~init:(Map.empty (module Id)) ~f:(fun ~key ~data:_ ps -> Map.set ps ~key ~data:(alive_parent k key)) in let children = Map.filter_keys k.children ~f:(Map.mem parents) in {k with children; parents} diff --git a/lib/monads/monads_monad.mli b/lib/monads/monads_monad.mli index fd5dd18ac..dea43da6a 100644 --- a/lib/monads/monads_monad.mli +++ b/lib/monads/monads_monad.mli @@ -99,7 +99,7 @@ module Result : sig module Error : sig module type S = sig include S - val failf : ('a, Caml.Format.formatter, unit, unit -> 'b t) format4 -> 'a + val failf : ('a, Stdlib.Format.formatter, unit, unit -> 'b t) format4 -> 'a end @@ -313,7 +313,7 @@ module State : sig include Identifiable.S with type t = id val zero : t val succ : t -> t - val pp : Caml.Format.formatter -> id -> unit + val pp : Stdlib.Format.formatter -> id -> unit end module T1(T : T)(M : Monad) : sig diff --git a/lib/monads/monads_monoid.ml b/lib/monads/monads_monoid.ml index 5af2545af..d01d3d926 100644 --- a/lib/monads/monads_monoid.ml +++ b/lib/monads/monads_monoid.ml @@ -42,14 +42,18 @@ module String = struct val run : t -> string end = struct module Base = struct - type t = Rope.t - let zero = Rope.of_string "" - let plus = Rope.(^) + type t = Buffer.t + let zero = Buffer.create 16 + let plus a b = + let c = Buffer.create (Buffer.length a + Buffer.length b) in + Buffer.add_buffer c a; + Buffer.add_buffer c b; + c end include Base include Make(Base) - let add t x = Rope.(t ^ of_string x) - let run = Rope.to_string + let add t x = Buffer.add_string t x; t + let run = Buffer.contents end type t = string diff --git a/lib/ogre/ogre.ml b/lib/ogre/ogre.ml index f6847ff8a..7b8e0a0af 100644 --- a/lib/ogre/ogre.ml +++ b/lib/ogre/ogre.ml @@ -87,7 +87,7 @@ module Type = struct fields = Map.set fields ~key:name ~data:(t.pack x) } - let empty = {fields = String.Map.empty} + let empty = {fields = (Map.empty (module String))} let scheme field = { signature = [{fname = field.name; ftype = field.t.typ}]; @@ -179,8 +179,8 @@ module Doc = struct } [@@deriving bin_io, compare] let empty = { - scheme = String.Map.empty; - entries = String.Map.empty; + scheme = (Map.empty (module String)); + entries = (Map.empty (module String)); } let is_empty {scheme}= Map.is_empty scheme @@ -189,7 +189,7 @@ module Doc = struct let declarations {scheme} = Map.length scheme let definitions {entries} = Map.length entries - let clear doc = {doc with entries = String.Map.empty} + let clear doc = {doc with entries = (Map.empty (module String))} let update_scheme name sign doc = match Map.find doc.scheme name with @@ -319,7 +319,7 @@ module Doc = struct Error.List.map (tabulate values) ~f:(function | pos, `Positional x -> positional header pos x | _, `Named (fnam,x) -> named header fnam x) >>= - String.Map.of_alist_or_error + Map.of_alist_or_error (module String) let parse_entry doc = function | Sexp.List (Sexp.Atom "declare" :: Sexp.Atom name :: flds) -> @@ -649,7 +649,7 @@ module Exp = struct | Var n -> sub n let offsets names = - List.foldi names ~init:String.Map.empty ~f:(fun pos offs name -> + List.foldi names ~init:(Map.empty (module String)) ~f:(fun pos offs name -> Map.set offs ~key:name ~data:pos) let names_index names = @@ -673,8 +673,9 @@ module Exp = struct Var {attr=x;field={Type.fname=n1}}, Var {attr=y;field={Type.fname=n2}}) -> Var (fun row -> - bool String.(Map.find_exn row.(x).fields n1 = - Map.find_exn row.(y).fields n2)) + bool (let v1 = Base.Map.find_exn row.(x).fields n1 in + let v2 = Base.Map.find_exn row.(y).fields n2 in + String.equal v1 v2)) | Bop (op,x,y) -> Bop (op,lambda x, lambda y) | Uop (op,x) -> Uop(op,lambda x) | Var n -> Var (get_indiced n) diff --git a/lib/regular/regular.mli b/lib/regular/regular.mli index ad8a888b6..6188ffd53 100644 --- a/lib/regular/regular.mli +++ b/lib/regular/regular.mli @@ -818,6 +818,8 @@ module Std : sig type t include Comparable.S with type t := t include Hashable.S with type t := t + val sexp_of_t : t -> Sexp.t + val t_of_sexp : Sexp.t -> t end (** creates a module implementing [Opaque] interface. *) diff --git a/lib/regular/regular_bytes.ml b/lib/regular/regular_bytes.ml index ec3f41882..627c34efa 100644 --- a/lib/regular/regular_bytes.ml +++ b/lib/regular/regular_bytes.ml @@ -2,7 +2,7 @@ module Std_bytes = Bytes open Core_kernel[@@warning "-D"] -module Binable = Bin_prot.Utils.Make_binable(struct +module Binable = Bin_prot.Utils.Make_binable_without_uuid(struct module Binable = String type t = Std_bytes.t let to_binable = Std_bytes.unsafe_to_string diff --git a/lib/regular/regular_cache.ml b/lib/regular/regular_cache.ml index e5dc7e5c8..b3c404536 100644 --- a/lib/regular/regular_cache.ml +++ b/lib/regular/regular_cache.ml @@ -47,7 +47,7 @@ module Digest = struct let add buf fmt = format ("%s"^^fmt) buf let add_sexp d sexp_of x = add d "%a" Sexp.pp (sexp_of x) - let add_file d name = add d "%s" (Caml.Digest.(file name |> to_hex)) + let add_file d name = add d "%s" (Stdlib.Digest.(file name |> to_hex)) let create ~namespace = make namespace end diff --git a/lib/regular/regular_data.ml b/lib/regular/regular_data.ml index a16db082a..623c9825c 100644 --- a/lib/regular/regular_data.ml +++ b/lib/regular/regular_data.ml @@ -54,19 +54,15 @@ let pretty_writer (type t) (module T : Pretty_printer.S with type t = t) = Write.create ~pp:T.pp () -module Ver = Comparable.Make(struct - type t = string [@@deriving sexp] - let sep = '.' - type strings = string list [@@deriving compare] - let compare x y = - let x = String.split ~on:sep x in - let y = String.split ~on:sep y in - compare_strings x y - end) - +module Ver = String module Id = String -type 'a table = 'a Ver.Map.t Id.Map.t +type 'a with_desc = { + cls : 'a; + desc : string option; +} + +type 'a table = (String.t, (String.t, 'a with_desc, String.comparator_witness) Map.t, String.comparator_witness) Map.t type 'a with_info = { serializer : 'a; @@ -75,10 +71,6 @@ type 'a with_info = { desc : string option; } -type 'a with_desc = { - cls : 'a; - desc : string option; -} type 'a definition = { @@ -86,8 +78,8 @@ type 'a definition = { default_printer : 'a writer with_info option; default_reader : 'a reader with_info; default_writer : 'a writer with_info; - writers : 'a writer with_desc table; - readers : 'a reader with_desc table; + writers : 'a writer table; + readers : 'a reader table; } @@ -132,16 +124,16 @@ module Class = struct let add_method field cls ?desc ~ver name met : unit = update field cls ~f:(fun mets -> Map.change mets name ~f:(function - | None -> Some (Ver.Map.singleton ver {cls=met; desc}) - | Some vs -> Some (Ver.Map.set vs ver {cls=met; desc}))) + | None -> Some (Map.singleton (module String) ver {cls=met; desc}) + | Some vs -> Some (Map.set vs ~key:ver ~data:{cls=met; desc}))) - let find_with_ver (table : 'a table) ?ver name : (string * 'a) option = - match Map.find table name with + let find_with_ver (table : 'a table) ?ver name = + match Base.Map.find table name with | None -> None | Some vs -> match ver with - | Some ver -> Option.(Map.find vs ver >>| fun x -> ver,x) - | None -> Map.max_elt vs + | Some ver -> Option.(Base.Map.find vs ver >>| fun x -> ver,x) + | None -> Base.Map.max_elt vs let find_with_info from ?ver name = match find_with_ver from ?ver name with @@ -151,7 +143,7 @@ module Class = struct desc; } - let find (table : 'a table) ?ver name : 'a option = + let find (table : 'a table) ?ver name = Option.(find_with_ver table ?ver name >>| snd) let find_info (table : 'a table) ?ver name = @@ -202,18 +194,19 @@ module Class = struct let writers cls = get writer_field cls let readers cls = get reader_field cls + type collector = { + collect : 'a. 'a definition -> string * info list + } + + let collect_info (get,_) def = let name = match def.module_name with | None -> "unknown" | Some name -> name in name, - Map.fold (get def) ~init:[] ~f:(fun ~key:name ~data:vers acc -> - Map.fold vers ~init:acc ~f:(fun ~key:ver ~data:{desc} acc -> - (name, `Ver ver, desc) :: acc)) - - type collector = { - collect : 'a. 'a definition -> string * info list - } + List.fold (Base.Map.to_alist (get def)) ~init:[] ~f:(fun acc (fname,vers) -> + Base.Map.fold vers ~init:acc ~f:(fun ~key:ver ~data:(vd : _ with_desc) acc -> + (fname, `Ver ver, vd.desc) :: acc)) let writers_collector = { collect = fun def -> collect_info writer_field def @@ -268,8 +261,8 @@ module New(T : Versioned.S) : Instance with type t = T.t = struct default_printer = None; default_writer; default_reader; - writers = Id.Map.empty; - readers = Id.Map.empty; + writers = (Map.empty (module Id)); + readers = (Map.empty (module Id)); } end @@ -291,9 +284,9 @@ module Extend(T : sig let find_writer = Class.get_method writer_field cls let enum_info (table : 'a table) : info list = - Map.fold table ~init:[] ~f:(fun ~key:name ~data:vers acc -> - Map.fold vers ~init:acc ~f:(fun ~key:ver ~data:{desc} acc -> - (name, `Ver ver, desc) :: acc)) + List.fold (Base.Map.to_alist table) ~init:[] ~f:(fun acc (_name,vers) -> + Base.Map.fold vers ~init:acc ~f:(fun ~key:ver ~data:vd acc -> + (_name, `Ver ver, vd.desc) :: acc)) let available_readers () = enum_info (Class.readers cls) let available_writers () = enum_info (Class.writers cls) diff --git a/lib/regular/regular_opaque.ml b/lib/regular/regular_opaque.ml index 5dcedd07e..21e9ecb69 100644 --- a/lib/regular/regular_opaque.ml +++ b/lib/regular/regular_opaque.ml @@ -7,6 +7,8 @@ module type S = sig type t include Comparable with type t := t include Hashable with type t := t + val sexp_of_t : t -> Sexp.t + val t_of_sexp : Sexp.t -> t end module Make(M : sig @@ -20,4 +22,6 @@ module Make(M : sig end include Comparable.Make(M) include Hashable.Make_and_derive_hash_fold_t(M) + let sexp_of_t = M.sexp_of_t + let t_of_sexp = M.t_of_sexp end diff --git a/lib/regular/regular_seq.ml b/lib/regular/regular_seq.ml index 4baa168ad..4212b84ed 100644 --- a/lib/regular/regular_seq.ml +++ b/lib/regular/regular_seq.ml @@ -35,7 +35,7 @@ let compare compare_a t1 t2 = then r.return c); 0) -module Binable = Bin_prot.Utils.Make_binable1(struct +module Binable = Bin_prot.Utils.Make_binable1_without_uuid(struct module Binable = List type 'a t = 'a Sequence.t let to_binable = Sequence.to_list diff --git a/lib/text_tags/text_tags.ml b/lib/text_tags/text_tags.ml index 3abc4a8db..c5c224db3 100644 --- a/lib/text_tags/text_tags.ml +++ b/lib/text_tags/text_tags.ml @@ -41,11 +41,11 @@ module Html = struct let install fmt = pp_set_mark_tags fmt true; pp_set_print_tags fmt true; - pp_set_formatter_tag_functions fmt { - mark_open_tag; - mark_close_tag; - print_open_tag = print_open_tag fmt; - print_close_tag = print_close_tag fmt; + pp_set_formatter_stag_functions fmt { + mark_open_stag = (function String_tag s -> mark_open_tag s | _ -> ""); + mark_close_stag = (function String_tag s -> mark_close_tag s | _ -> ""); + print_open_stag = (fun stag -> print_open_tag fmt (match stag with String_tag s -> s | _ -> "")); + print_close_stag = (fun stag -> print_close_tag fmt (match stag with String_tag s -> s | _ -> "")); } [@@warning "-D"] end @@ -91,11 +91,11 @@ module Blocks = struct let install fmt = pp_set_mark_tags fmt true; pp_set_print_tags fmt true; - pp_set_formatter_tag_functions fmt { - mark_open_tag; - mark_close_tag; - print_open_tag = print_open_tag fmt; - print_close_tag = print_close_tag fmt; + pp_set_formatter_stag_functions fmt { + mark_open_stag = (function String_tag s -> mark_open_tag s | _ -> ""); + mark_close_stag = (function String_tag s -> mark_close_tag s | _ -> ""); + print_open_stag = (fun stag -> print_open_tag fmt (match stag with String_tag s -> s | _ -> "")); + print_close_stag = (fun stag -> print_close_tag fmt (match stag with String_tag s -> s | _ -> "")); } [@@warning "-D"] end @@ -148,10 +148,10 @@ module Attr = struct let install ppf = pp_set_print_tags ppf true; - let tags = pp_get_formatter_tag_functions ppf () in - pp_set_formatter_tag_functions ppf { + let tags = pp_get_formatter_stag_functions ppf () in + pp_set_formatter_stag_functions ppf { tags with - print_open_tag = print_open_tag ppf; + print_open_stag = (fun stag -> print_open_tag ppf (match stag with String_tag s -> s | _ -> "")); }; let out = pp_get_formatter_out_functions ppf () in pp_set_formatter_out_functions ppf { @@ -183,13 +183,13 @@ let install fmt mode = | None -> raise (Unknown_mode mode) let with_mode fmt mode = - let g = pp_get_formatter_tag_functions fmt () in + let g = pp_get_formatter_stag_functions fmt () in let mark = pp_get_mark_tags fmt () in let print = pp_get_print_tags fmt () in let finally () = pp_set_mark_tags fmt mark; pp_set_print_tags fmt print; - pp_set_formatter_tag_functions fmt g in + pp_set_formatter_stag_functions fmt g in install fmt mode; Exn.protect ~finally [@@warning "-D"] diff --git a/lib/x86_cpu/x86_cpu.ml b/lib/x86_cpu/x86_cpu.ml index 3a56d9ff6..f2b54d8f5 100644 --- a/lib/x86_cpu/x86_cpu.ml +++ b/lib/x86_cpu/x86_cpu.ml @@ -7,13 +7,13 @@ module Make_CPU(Env : ModeVars) = struct include X86_env include Env (* we do not include pc into a set of gpr *) - let gpr = Var.Set.of_list @@ [ + let gpr = Set.of_list (module Var) @@ [ rax; rcx; rdx; rsi; rdi; rbx; rbp; rsp; ] @ Array.to_list r @ Array.to_list ymms - let flags = Var.Set.of_list [ + let flags = Set.of_list (module Var) [ cf; pf; af; zf; sf; oF; df ] diff --git a/lib_test/bap/run_tests.ml b/lib_test/bap/run_tests.ml index 3302b9e12..2419234c5 100644 --- a/lib_test/bap/run_tests.ml +++ b/lib_test/bap/run_tests.ml @@ -1,9 +1,9 @@ -open Core_kernel[@@warning "-D"] +open Core[@@warning "-D"] open Bap_plugins.Std open OUnit2 -module Sys = Caml.Sys +module Sys = Stdlib.Sys let suite () = "BAP" >::: [ diff --git a/lib_test/bap_image/test_image.ml b/lib_test/bap_image/test_image.ml index 513eee9bc..76196fa1f 100644 --- a/lib_test/bap_image/test_image.ml +++ b/lib_test/bap_image/test_image.ml @@ -30,7 +30,7 @@ let create_segment let create_file () = Bytes.create 0x1000 -let files : Bytes.t String.Table.t = String.Table.create () +let files : Bytes.t String.Table.t = Hashtbl.create (module String) let data ?(base=0) ?(gap=0) f ss asize name = @@ -39,7 +39,7 @@ let data ?(base=0) ?(gap=0) f ss asize name = let data = f data in let addr = !addr_ref in let len = Bytes.length data in - let dst = String.Table.find_or_add files name + let dst = Hashtbl.find_or_add files name ~default:create_file in let off = addr - base in Bytes.blit @@ -99,7 +99,7 @@ let print_list r = Or_error.sexp_of_t sexp_of_addr_list r let to_list ~word_size backend ~expect ctxt = - let data = String.Table.find_exn files backend |> Bytes.to_string in + let data = Hashtbl.find_exn files backend |> Bytes.to_string in let r = Image.of_string ~backend data >>| fun (img,warns) -> assert_bool "to_list: no warning" (List.is_empty warns); Table.to_sequence (Image.words img word_size) |> @@ -109,7 +109,7 @@ let to_list ~word_size backend ~expect ctxt = assert_equal ~ctxt ~printer:print_list (Ok expect) r let check ?(base=0) backend ~f ctxt = - let data = String.Table.find_exn files backend in + let data = Hashtbl.find_exn files backend in let data = Bytes.to_string data in let r = Image.of_string ~backend data >>= fun (img,warns) -> diff --git a/lib_test/bap_types/test_graph.ml b/lib_test/bap_types/test_graph.ml index 6f37d78c0..a9c9d8d73 100644 --- a/lib_test/bap_types/test_graph.ml +++ b/lib_test/bap_types/test_graph.ml @@ -54,7 +54,7 @@ module Test_algo(Gl : Graph_for_algo) = struct Note: time is incremented by any of the following events: enter_node, leave_node. Edges events are ignored. *) let timestamps ty gr : int * ('n,node_info,_) Map.t = - Graphlib.depth_first_search ty gr ~init:(0,Node.Map.empty) + Graphlib.depth_first_search ty gr ~init:(0,Map.empty (module Node)) ~enter_node:(fun pre node (time,stamps) -> time + 1, Map.change stamps node ~f:(function | None -> Some {empty with pre; enter = time} @@ -74,13 +74,13 @@ module Test_algo(Gl : Graph_for_algo) = struct } let empty = { - children = Node.Map.empty; - iparents = Node.Map.empty; + children = (Map.empty (module Node)); + iparents = (Map.empty (module Node)); } let add_relation t ~parent ~child = { children = Map.change t.children parent( function - | None -> Some (Node.Set.singleton child) + | None -> Some (Set.singleton (module Node) child) | Some cs when Set.mem cs child -> assert_failure "Child was already adopted" | Some cs -> Some (Set.add cs child)); @@ -90,7 +90,7 @@ module Test_algo(Gl : Graph_for_algo) = struct } let children t parent = match Map.find t.children parent with - | None -> Node.Set.empty + | None -> (Set.empty (module Node)) | Some children -> children let parent t child = Map.find t.iparents child @@ -99,7 +99,7 @@ module Test_algo(Gl : Graph_for_algo) = struct (transitive closure) *) let rec descendants t parent = (* according to [1] each node is descendant of itself. *) - let init = Node.Set.singleton parent in + let init = Set.singleton (module Node) parent in Set.fold (children t parent) ~init ~f:(fun ds parent -> Set.union ds (descendants t parent)) @@ -108,7 +108,7 @@ module Test_algo(Gl : Graph_for_algo) = struct let rec loop parents child = match parent t child with | None -> parents | Some parent -> loop (Set.add parents parent) parent in - loop Node.Set.empty child + loop (Set.empty (module Node)) child end let build_tree g = @@ -222,9 +222,9 @@ module Test_algo(Gl : Graph_for_algo) = struct Seq.to_list_rev in Seq.range 0 (Gl.number_of_nodes gr) |> Seq.map ~f:node |> Seq.iter ~f:(fun n -> - let exp = Node.Set.of_list (exp_dfrt n) in - let got = Node.Set.of_list (set_of_frontier n) in - assert_equal ~ctxt ~cmp:Node.Set.equal exp got) + let exp = Set.of_list (module Node) (exp_dfrt n) in + let got = Set.of_list (module Node) (set_of_frontier n) in + assert_equal ~ctxt ~cmp:Set.equal exp got) let compare_scc gr ctxt = let scc = Graphlib.strong_components (module Gl) gr in @@ -248,10 +248,10 @@ module Test_algo(Gl : Graph_for_algo) = struct ]) let nodes g = - Gl.nodes g |> Seq.fold ~init:Gl.Node.Set.empty ~f:Set.add + Gl.nodes g |> Seq.fold ~init:(Set.empty (module Gl.Node)) ~f:(fun s x -> Set.add s x) let edges g = - Gl.edges g |> Seq.fold ~init:Gl.Edge.Set.empty ~f:Set.add + Gl.edges g |> Seq.fold ~init:(Set.empty (module Gl.Edge)) ~f:(fun s x -> Set.add s x) let equal_sets s1 s2 ctxt = assert_equal ~ctxt ~cmp:Set.equal s1 s2 @@ -310,7 +310,7 @@ module Construction(Factory : Factory) = struct and type Edge.label = unit) g = G.edges g |> Seq.map ~f:(fun e -> G.Edge.src e, G.Edge.dst e, G.Edge.src e) |> - Seq.fold ~init:Edges.empty ~f:Set.add + Seq.fold ~init:Edges.empty ~f:(fun s x -> Set.add s x) let compare e g : int = let ees = make_edges (module E) e in @@ -319,7 +319,7 @@ module Construction(Factory : Factory) = struct | 0 -> 0 | n -> let set enum g = - enum g |> Seq.fold ~init:Nodes.empty ~f:Set.add in + enum g |> Seq.fold ~init:Nodes.empty ~f:(fun s x -> Set.add s x) in Nodes.compare (set E.nodes e) (set G.nodes g) let random_elt number enum e = @@ -570,7 +570,7 @@ module Test_partition = struct let add x s = Set.add s x - let s = Set.empty (module Int) + let s = (Set.empty (module Int)) |> add 0 |> add 1 |> add 2 diff --git a/lib_test/powerpc/powerpc_move_tests.ml b/lib_test/powerpc/powerpc_move_tests.ml index b6cf12dc3..479f2d182 100644 --- a/lib_test/powerpc/powerpc_move_tests.ml +++ b/lib_test/powerpc/powerpc_move_tests.ml @@ -61,7 +61,7 @@ let mtcrf arch _ctxt = j*4 <= i && i < (j + 1) * 4) then let expected = if r1_bits.(i) then Word.b1 else Word.b0 in - let cr_bit = Int.Map.find_exn cri i in + let cr_bit = Map.find_exn cri i in let value = lookup_var ctxt cr_bit in let err = sprintf "mtcrf assign to bit %d failed\n" i in assert_bool err (is_equal_words expected value)) diff --git a/lib_test/powerpc/powerpc_tests_helpers.ml b/lib_test/powerpc/powerpc_tests_helpers.ml index 0c048672c..ecda2962c 100644 --- a/lib_test/powerpc/powerpc_tests_helpers.ml +++ b/lib_test/powerpc/powerpc_tests_helpers.ml @@ -16,7 +16,7 @@ let make_name prefix i = sprintf "%s%d" prefix i let make_var_i typ prefix i = Var.create (make_name prefix i) typ let make_regs typ ?alias prefix range = - List.fold ~init:String.Map.empty ~f:(fun regs i -> + List.fold ~init:(Map.empty (module String)) ~f:(fun regs i -> let var = make_var_i typ prefix i in let name = Var.name var in let regs = Map.set regs name var in @@ -78,13 +78,13 @@ module Make(B : Bitwidth) = struct let cri = let _, bits = - List.fold (List.rev cr_bits) ~init:(0,Int.Map.empty) + List.fold (List.rev cr_bits) ~init:(0,Map.empty (module Int)) ~f:(fun (num, bits) bit -> num + 1, Map.set bits ~key:num ~data:bit) in bits let crn = - Int.Map.fold cri ~init:String.Map.empty + Map.fold cri ~init:(Map.empty (module String)) ~f:(fun ~key:_ ~data:var acc -> Map.set acc (Var.name var) var) @@ -100,11 +100,11 @@ module Make(B : Bitwidth) = struct ] let cr_fields = - List.fold fields ~init:String.Map.empty ~f:(fun fs (name, _, fd) -> + List.fold fields ~init:(Map.empty (module String)) ~f:(fun fs (name, _, fd) -> Map.set fs name fd) let cri_fields = - List.fold fields ~init:Int.Map.empty ~f:(fun fs (_, index, fd) -> + List.fold fields ~init:(Map.empty (module Int)) ~f:(fun fs (_, index, fd) -> Map.set fs index fd) (** fixed precision flags *) @@ -133,7 +133,7 @@ let raise_arch () = failwith "powerpc arch is the only expected" let cr_bit n = - Int.Map.find_exn Any_ppc.cri n + Map.find_exn Any_ppc.cri n let nf = cr_bit 0 let pf = cr_bit 1 @@ -219,8 +219,8 @@ let lookup_var c var = match c#lookup var with let find_gpr arch name = try match arch with - | `ppc -> String.Map.find_exn P32.gpr name - | _ -> String.Map.find_exn P64.gpr name + | `ppc -> Map.find_exn P32.gpr name + | _ -> Map.find_exn P64.gpr name with _ -> sprintf "gpr %s not" name |> failwith diff --git a/monads.opam b/monads.opam index 8e3c1e227..83e29cc65 100644 --- a/monads.opam +++ b/monads.opam @@ -10,9 +10,9 @@ tags: ["bap" "monad"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} + "dune" {>= "3.8"} "bap-common" {= version} - "core_kernel" {>= "v0.14" & < "v0.16"} + "core_kernel" {>= "v0.17" & < "v0.18"} "ppx_bap" {= version} "odoc" {with-doc} ] diff --git a/ogre.opam b/ogre.opam index 2153250da..739293021 100644 --- a/ogre.opam +++ b/ogre.opam @@ -11,8 +11,8 @@ tags: ["bap" "sexp"] homepage: "https://github.com/BinaryAnalysisPlatform/bap" bug-reports: "https://github.com/BinaryAnalysisPlatform/bap/issues" depends: [ - "dune" {>= "3.1"} - "core_kernel" {>= "v0.14" & < "v0.16"} + "dune" {>= "3.8"} + "core_kernel" {>= "v0.17" & < "v0.18"} "bap-common" {= version} "monads" {= version} "odoc" {with-doc} diff --git a/plugins/analyze/analyze_main.ml b/plugins/analyze/analyze_main.ml index 2361f0385..244fcb9b8 100644 --- a/plugins/analyze/analyze_main.ml +++ b/plugins/analyze/analyze_main.ml @@ -50,7 +50,7 @@ open Core_kernel[@@warning "-D"] open Bap_main open Bap_knowledge open Bap.Std -module Sys = Caml.Sys +module Sys = Stdlib.Sys include Loggers() @@ -87,7 +87,7 @@ let initial_ctxt ~history directives path = { commands = collect_commands (); history; directives = List.fold directives - ~init:String.Map.empty + ~init:(Map.empty (module String)) ~f:(fun dirs (name,_,desc) -> Map.add_exn dirs name desc) } diff --git a/plugins/api/api_main.ml b/plugins/api/api_main.ml index c8dfec761..f03d58cc9 100644 --- a/plugins/api/api_main.ml +++ b/plugins/api/api_main.ml @@ -1,7 +1,7 @@ open Core_kernel[@@warning "-D"] open Result.Monad_infix open Bap.Std -module Sys = Caml.Sys +module Sys = Stdlib.Sys include Self() module Configuration = Bap_main.Extension.Configuration @@ -16,7 +16,7 @@ let try_with_default ~default f = match try_with f with let getenv v = try Some (Sys.getenv v) - with Caml.Not_found -> None + with Stdlib.Not_found -> None module Path = FilePath.DefaultPath.Abstract type path = Path.filename diff --git a/plugins/beagle/beagle_main.ml b/plugins/beagle/beagle_main.ml index 5d38179dc..ada90fb15 100644 --- a/plugins/beagle/beagle_main.ml +++ b/plugins/beagle/beagle_main.ml @@ -86,7 +86,7 @@ module Param = struct end let make_alphabet (module A : Alphabet) = - Seq.range 0 256 |> Seq.fold ~init:Char.Set.empty ~f:(fun alpha c -> + Seq.range 0 256 |> Seq.fold ~init:(Set.empty (module Char)) ~f:(fun alpha c -> let c = Char.of_int_exn c in let i = A.index c in if i < 0 || i >= A.length then alpha @@ -115,9 +115,9 @@ let hunters_club = ~uuid:"1fa35cfe-f720-473c-a5ac-50fa8fa9f1fd" ~name:"beagle-hunters-club" (fun _ -> { - addrs = Addr.Set.empty; - checked = Bil.Result.Id.Set.empty; - cache = String.Map.empty; + addrs = (Set.empty (module Addr)); + checked = (Set.empty (module Bil.Result.Id)); + cache = (Map.empty (module String)); }) @@ -147,7 +147,7 @@ let hunter = ~f:Unscrambler.add_word ~init:dict in let build input = Unscrambler.build dict input |> - Seq.fold ~init:String.Set.empty ~f:Set.add in + Seq.fold ~init:(Set.empty (module String)) ~f:(fun s x -> Set.add s x) in Hunter (build)) diff --git a/plugins/bil/bil_float.ml b/plugins/bil/bil_float.ml index e3524b3ff..068b72f7f 100644 --- a/plugins/bil/bil_float.ml +++ b/plugins/bil/bil_float.ml @@ -78,7 +78,7 @@ module Make(B : Theory.Core) = struct let smin x y = ite (x <$ y) x y let leading_one sort = - one sort lsl (of_int sort Caml.(Theory.Bitv.size sort - 1)) + one sort lsl (of_int sort Stdlib.(Theory.Bitv.size sort - 1)) end @@ -125,7 +125,7 @@ module Make(B : Theory.Core) = struct let open IEEE754 in let bits = Sort.bits fsort in let bit = Bits.define 1 in - let bits_1 = Bits.define Caml.(Bits.size bits - 1) in + let bits_1 = Bits.define Stdlib.(Bits.size bits - 1) in let sign = ite sign (B.one bit) (B.zero bit) in B.append bits sign (B.append bits_1 expn coef) @@ -134,7 +134,7 @@ module Make(B : Theory.Core) = struct let {IEEE754.p; t} = IEEE754.Sort.spec fsort in let is_subnormal = (inv (msb coef)) && (is_one expn) in ite is_subnormal (pred expn) expn >>>= fun expn -> - if Caml.(p = t) then pack_raw fsort sign expn coef + if Stdlib.(p = t) then pack_raw fsort sign expn coef else B.low (Bits.define t) coef >>>= fun coef -> pack_raw fsort sign expn coef >>= fun r -> !!r @@ -172,7 +172,7 @@ module Make(B : Theory.Core) = struct let with_sign sign bitv = let open B in bitv >>-> fun s bitv -> - let s' = Bits.define Caml.(Bits.size s - 1) in + let s' = Bits.define Stdlib.(Bits.size s - 1) in let bit = Bits.define 1 in ite sign ((append s (one bit) (zero s')) lor !!bitv) ((append s (zero bit) (ones s')) land !!bitv) @@ -388,11 +388,11 @@ module Make(B : Theory.Core) = struct let size = Bits.size sort in let pow, num = nearest_pow2 size in let sort' = Bits.define num in - let shifts = List.init pow ~f:(fun p -> Caml.(num / (2 lsl p))) in + let shifts = List.init pow ~f:(fun p -> Stdlib.(num / (2 lsl p))) in let shifts,_ = List.fold shifts ~init:([],0) ~f:(fun (acc,prev) curr -> - let total = Caml.(curr + prev) in + let total = Stdlib.(curr + prev) in (total, curr) :: acc, total) in let shifts = List.rev shifts in let rec loop lets x = function @@ -403,7 +403,7 @@ module Make(B : Theory.Core) = struct ite (is_zero (x land mask)) (of_int sort shf) (zero sort) >>>= fun nextn -> loop (nextn :: lets) nextx shifts in loop [] (B.unsigned sort' !!x) shifts >>>= fun n -> - of_int sort Caml.(num - size) >>>= fun dif -> + of_int sort Stdlib.(num - size) >>>= fun dif -> ite (is_zero !!x) (of_int sort size) (n - dif) let possible_lshift expn coef = @@ -677,7 +677,7 @@ module Make(B : Theory.Core) = struct let lost_afew = b0, b0, b1 in nomin >>-> fun sort nomin -> let rec loop i bits nomin = - if Caml.(i < 0) then + if Stdlib.(i < 0) then List.fold bits ~f:(lor) ~init:(zero sort) >>>= fun coef -> match_ [ (nomin > denom) --> f coef lost_alot; @@ -690,8 +690,8 @@ module Make(B : Theory.Core) = struct ite (nomin > denom) (nomin - denom) nomin >>>= fun next_nomin -> next_nomin lsl one sort >>>= fun next_nomin -> bind next_nomin (fun next_nomin -> - loop Caml.(i - 1) (bit :: bits) next_nomin) in - loop Caml.(prec - 1) [] !!nomin + loop Stdlib.(i - 1) (bit :: bits) next_nomin) in + loop Stdlib.(prec - 1) [] !!nomin let fdiv_finite fsort rm x y = let open B in @@ -774,7 +774,7 @@ module Make(B : Theory.Core) = struct let truncate fsort x rm fsort' = let open B in let sigs_sh = Bits.size (sigs fsort') in - let d_bias = Caml.(bias fsort - bias fsort') in + let d_bias = Stdlib.(bias fsort - bias fsort') in let dst_maxe = max_exponent' (Bits.size @@ exps fsort') in unpack fsort x @@ fun sign expn coef -> if_ (is_all_ones expn || is_zero expn) @@ -806,8 +806,8 @@ module Make(B : Theory.Core) = struct (* pre: fsort "<=" fsort' *) let extend fsort x fsort' = let open B in - let d_sigs = Caml.(Bits.size (sigs fsort') - Bits.size (sigs fsort)) in - let d_bias = Caml.(bias fsort' - bias fsort) in + let d_sigs = Stdlib.(Bits.size (sigs fsort') - Bits.size (sigs fsort)) in + let d_bias = Stdlib.(bias fsort' - bias fsort) in unpack fsort x @@ fun sign expn coef -> match_ [ is_all_ones expn --> ones (exps fsort'); @@ -840,7 +840,7 @@ module Make(B : Theory.Core) = struct let exps = exps fsort in let sigs = Bits.define p in bitv >>-> fun inps bitv -> - of_int exps Caml.(bias + p - 1) >>>= fun expn -> + of_int exps Stdlib.(bias + p - 1) >>>= fun expn -> of_int sigs p >>>= fun prec -> clz !!bitv >>>= fun clz -> unsigned sigs clz >>>= fun clz -> @@ -886,8 +886,8 @@ module Make(B : Theory.Core) = struct let range_reduction fsort x f = let open B in let bias = bias fsort in - let low = of_int (exps fsort) Caml.(bias - 0) in - let top = of_int (exps fsort) Caml.(bias + 1) in + let low = of_int (exps fsort) Stdlib.(bias - 0) in + let top = of_int (exps fsort) Stdlib.(bias + 1) in unpack_raw fsort x @@ fun sign expn coef -> match_ [ (expn = top && non_zero coef) --> (expn - low); diff --git a/plugins/bil/bil_ir.ml b/plugins/bil/bil_ir.ml index 74a9a0187..e1fed3aaa 100644 --- a/plugins/bil/bil_ir.ml +++ b/plugins/bil/bil_ir.ml @@ -68,7 +68,7 @@ module BIR = struct List.filter_map blk.jmps ~f:dst let references blks = - List.fold ~init:Tid.Map.empty ~f:(fun refs {jmps} -> + List.fold ~init:(Map.empty (module Tid)) ~f:(fun refs {jmps} -> List.fold jmps ~init:refs ~f:(fun refs jmp -> match dst jmp with | Some tid when Map.mem blks tid -> @@ -78,7 +78,7 @@ module BIR = struct | _ -> refs)) let build_graph = List.fold - ~init:Tid.Map.empty + ~init:(Map.empty (module Tid)) ~f:(fun blks blk -> Map.add_exn blks blk.name blk) diff --git a/plugins/bil/bil_lifter.ml b/plugins/bil/bil_lifter.ml index 8b43b2468..0e1e2dcff 100644 --- a/plugins/bil/bil_lifter.ml +++ b/plugins/bil/bil_lifter.ml @@ -58,7 +58,7 @@ module Relocations = struct let relocations = Fact.eval Request.relocations let external_symbols = Fact.eval Request.external_symbols - let empty = {rels = Int64.Map.empty; exts = Int64.Map.empty} + let empty = {rels = (Map.empty (module Int64)); exts = (Map.empty (module Int64))} let of_spec spec = @@ -85,7 +85,7 @@ module Relocations = struct let references bil = snd @@ reference_analyzer#run bil - (Var.Map.empty, Addr.Set.empty) + (Map.empty (module Var), Set.empty (module Addr)) let addresses bil mem = let start = Memory.min_addr mem in diff --git a/plugins/bil/bil_semantics.ml b/plugins/bil/bil_semantics.ml index 2b0a89dab..9499bca5e 100644 --- a/plugins/bil/bil_semantics.ml +++ b/plugins/bil/bil_semantics.ml @@ -60,7 +60,7 @@ module Basic : Theory.Basic = struct let int s w = vec s @@ Bil.(int @@ Word.create w (size s)) - let effect x = KB.Value.get effects x + let get_eff x = KB.Value.get effects x let (>>->) v f = v >>= fun v -> f (sort v) (value v) @@ -183,7 +183,7 @@ module Basic : Theory.Basic = struct | _ -> exp s (Bil.ite cnd yes nay) - let (>>:=) v f = v >>= fun v -> f (effect v) + let (>>:=) v f = v >>= fun v -> f (get_eff v) let branch cnd yes nay = cnd >>= fun cnd -> @@ -284,7 +284,7 @@ module Basic : Theory.Basic = struct let seq x y = x >>= fun x -> y >>= fun y -> - eff (effect x @ effect y) + eff (get_eff x @ get_eff y) let blk lbl x y = x >>:= fun x -> diff --git a/plugins/byteweight/byteweight_main.ml b/plugins/byteweight/byteweight_main.ml index 100e31e63..7e34591de 100644 --- a/plugins/byteweight/byteweight_main.ml +++ b/plugins/byteweight/byteweight_main.ml @@ -45,7 +45,7 @@ open Core_kernel[@@warning "-D"] open Bap_main open Bap_core_theory open Bap.Std -module Sys = Caml.Sys +module Sys = Stdlib.Sys open KB.Syntax include Loggers() @@ -59,7 +59,7 @@ and p0 m n = float n /. float (m + n) let roots = KB.Class.property Theory.Unit.cls "byteweight-roots" ~package:"bap" @@ KB.Domain.powerset (module Bitvec_order) "roots" -let no_roots = Set.empty (module Bitvec_order) +let no_roots = (Set.empty (module Bitvec_order)) let of_addrs = List.fold ~init:no_roots ~f:(fun roots addr -> Set.add roots (Addr.to_bitvec addr)) diff --git a/plugins/cache/bap_cache.ml b/plugins/cache/bap_cache.ml index 15bb5057a..28ebb4627 100644 --- a/plugins/cache/bap_cache.ml +++ b/plugins/cache/bap_cache.ml @@ -5,9 +5,9 @@ open Bap_cache_types include Self () -module Filename = Caml.Filename -module Random = Caml.Random -module Sys = Caml.Sys +module Filename = Stdlib.Filename +module Random = Stdlib.Random +module Sys = Stdlib.Sys module Unix = Caml_unix module Utils = Bap_cache_utils @@ -56,7 +56,7 @@ end include Cfg -let getenv opt = try Some (Sys.getenv opt) with Caml.Not_found -> None +let getenv opt = try Some (Sys.getenv opt) with Stdlib.Not_found -> None let root () = match !default_root with | Some dir -> dir // ".cache" // "bap" diff --git a/plugins/cache/bap_cache_gc.ml b/plugins/cache/bap_cache_gc.ml index 22dc97bd2..711647646 100644 --- a/plugins/cache/bap_cache_gc.ml +++ b/plugins/cache/bap_cache_gc.ml @@ -80,7 +80,7 @@ include Self () module Cache = Bap_cache module CDF = Int.Map -module Sys = Caml.Sys +module Sys = Stdlib.Sys module Unix = Caml_unix type entry = { @@ -110,7 +110,7 @@ let cdf entries = Array.foldi entries ~init:(Map.empty (module Int),0) ~f:(fun i (m,prev) e -> let f_i = prev + max min_entry_size e.size in - CDF.add_exn m prev i, f_i) + Base.Map.add_exn m ~key:prev ~data:i, f_i) let select entries total_size size_to_free = let cdf = cdf entries in @@ -118,7 +118,7 @@ let select entries total_size size_to_free = if freed < size_to_free then let u = Random.int total_size in let (_,i) = - Option.value_exn (CDF.closest_key cdf `Less_or_equal_to u) in + Option.value_exn (Base.Map.closest_key cdf `Less_or_equal_to u) in if Set.mem indexes i then loop indexes freed else loop (Set.add indexes i) (freed + entries.(i).size) diff --git a/plugins/cache/bap_cache_main.ml b/plugins/cache/bap_cache_main.ml index 9345a61a3..bc69fe8a3 100644 --- a/plugins/cache/bap_cache_main.ml +++ b/plugins/cache/bap_cache_main.ml @@ -7,7 +7,7 @@ open Bap_main include Self() -module Filename = Caml.Filename +module Filename = Stdlib.Filename module Cache = Bap_cache module Utils = Bap_cache_utils module GC = Bap_cache_gc @@ -141,7 +141,7 @@ let () = provide_service (); Ok () -let opts = ref String.Map.empty +let opts = ref (Map.empty (module String)) let add_description ?arg name descr = let name = match arg with diff --git a/plugins/cache/bap_cache_utils.ml b/plugins/cache/bap_cache_utils.ml index 49be733fe..05428bd97 100644 --- a/plugins/cache/bap_cache_utils.ml +++ b/plugins/cache/bap_cache_utils.ml @@ -1,8 +1,8 @@ open Core_kernel[@@warning "-D"] open Regular.Std -module Filename = Caml.Filename -module Sys = Caml.Sys +module Filename = Stdlib.Filename +module Sys = Stdlib.Sys module Unix = Caml_unix let ( / ) = Filename.concat diff --git a/plugins/callgraph_collator/callgraph_collator_main.ml b/plugins/callgraph_collator/callgraph_collator_main.ml index 80655de1b..389e9048f 100644 --- a/plugins/callgraph_collator/callgraph_collator_main.ml +++ b/plugins/callgraph_collator/callgraph_collator_main.ml @@ -87,14 +87,14 @@ let () = Extension.declare ~provides:["collator"] ~doc @@ fun ctxt -> match name_of_dst jmp with | Some dst when filter src && filter dst -> src,Map.update calls src ~f:(function - | None -> String.Set.singleton dst + | None -> Set.singleton (module String) dst | Some dsts -> Set.add dsts dst) | _ -> src,calls end in let calls_of_project proj = let prog = Project.program proj in - snd @@ call_collector#run prog ("",String.Map.empty) in + snd @@ call_collector#run prog ("",Map.empty (module String)) in let prepare proj = calls_of_project proj,0 in @@ -105,7 +105,7 @@ let () = Extension.declare ~provides:["collator"] ~doc @@ fun ctxt -> let collate ver (base,diffs) proj = let alt = calls_of_project proj in let diff = Map.symmetric_diff base alt - ~data_equal:String.Set.equal in + ~data_equal:Set.equal in let is_different = not (Seq.is_empty diff) in if is_different then fprintf ppf "Version %d differs:@\n%!" ver diff --git a/plugins/constant_tracker/constant_tracker_main.ml b/plugins/constant_tracker/constant_tracker_main.ml index 4ad9bf7b7..9b268ec28 100644 --- a/plugins/constant_tracker/constant_tracker_main.ml +++ b/plugins/constant_tracker/constant_tracker_main.ml @@ -11,7 +11,7 @@ type state = { let state = Primus.Machine.State.declare ~uuid:"caf680aa-ef54-4468-9a24-4a125de6ace9" ~name:"constant-tracker" - (fun _ -> {consts = Primus.Value.Id.Set.empty}) + (fun _ -> {consts = (Set.empty (module Primus.Value.Id))}) let is_const x {consts} = Set.mem consts (Primus.Value.id x) diff --git a/plugins/dependencies/dependencies_main.ml b/plugins/dependencies/dependencies_main.ml index cd7a69d8f..49031df7e 100644 --- a/plugins/dependencies/dependencies_main.ml +++ b/plugins/dependencies/dependencies_main.ml @@ -58,7 +58,7 @@ open Core_kernel[@@warning "-D"] open Bap.Std open Regular.Std open Bap_main -module Sys = Caml.Sys +module Sys = Stdlib.Sys include Loggers() @@ -91,7 +91,7 @@ end = struct | None -> cache | Some path -> Map.set cache (Filename.basename path) path) - ~init:String.Map.empty) + ~init:(Map.empty (module String))) ~finally:(fun () -> match UnixLabels.close_process_in ldconfig with | WEXITED 0 -> () @@ -122,7 +122,7 @@ module Spec = struct let libraries = Ogre.collect Ogre.Query.(select (from require)) let set_of_seq = - Seq.fold ~f:Set.add ~init:(Set.empty (module String)) + Seq.fold ~f:(fun s x -> Set.add s x) ~init:(Set.empty (module String)) let build name = imports >>| set_of_seq >>= fun imports -> @@ -146,8 +146,8 @@ module Unit = struct let empty name = { name; - imports = Set.empty (module String); - exports = Set.empty (module String); + imports = (Set.empty (module String)); + exports = (Set.empty (module String)); libraries = []; } diff --git a/plugins/disassemble/disassemble_main.ml b/plugins/disassemble/disassemble_main.ml index 1e02a9ecd..e075df676 100644 --- a/plugins/disassemble/disassemble_main.ml +++ b/plugins/disassemble/disassemble_main.ml @@ -91,7 +91,7 @@ open Monads.Std open Format open Bap_plugins.Std -module Sys = Caml.Sys +module Sys = Stdlib.Sys include Self() open Bap_main @@ -178,7 +178,7 @@ end = struct | Some c -> c + 1) let build_histo = - Map.fold ~init:Int.Map.empty ~f:(fun ~key ~data -> + Map.fold ~init:(Map.empty (module Int)) ~f:(fun ~key ~data -> Map.add_multi ~key:data ~data:key) let pp_histo ppf stats = @@ -190,7 +190,7 @@ end = struct let print_missing () = let lifted = ref 0 and missed = ref 0 and failed = ref 0 in KB.objects Theory.Program.cls >>= - KB.Seq.fold ~init:String.Map.empty ~f:(fun stats insn -> + KB.Seq.fold ~init:(Map.empty (module String)) ~f:(fun stats insn -> let* sema = KB.collect Theory.Semantics.slot insn in let code = KB.Value.get Theory.Semantics.code sema in if Option.is_none code then KB.return stats @@ -323,8 +323,8 @@ let rw_file = Extension.Type.define ~name:"" ~print:Fn.id ~parse:Fn.id ~digest:(fun path -> if Sys.file_exists path - then Caml.Digest.file path - else Caml.Digest.string "empty") + then Stdlib.Digest.file path + else Stdlib.Digest.string "empty") "" let update = @@ -383,8 +383,8 @@ let target = let t = Extension.Type.define Theory.Target.unknown ~name:"NAME" ~digest:(fun t -> - let r = Caml.Digest.string@@Theory.Target.to_string t in - Format.eprintf "target digest = %s@\n" (Caml.Digest.to_hex r); + let r = Stdlib.Digest.string@@Theory.Target.to_string t in + Format.eprintf "target digest = %s@\n" (Stdlib.Digest.to_hex r); r) ~parse:(fun s -> match Theory.Target.lookup ~package:"bap" s with | Some t -> t @@ -458,9 +458,9 @@ module Dump_formats = struct end let setup_gc () = - let opts = Caml.Gc.get () in + let opts = Stdlib.Gc.get () in info "Setting GC parameters"; - Caml.Gc.set { + Stdlib.Gc.set { opts with minor_heap_size = 2 * 1024 * 1024; major_heap_increment = 64 * 1024 * 1024; @@ -499,7 +499,7 @@ let create_and_process input libraries outputs passes loader target update Fn.non Filename.is_implicit loader in let package = input in let digest = - let file = Caml.Digest.file in + let file = Stdlib.Digest.file in let config = Extension.Configuration.digest ctxt in let input = file input in let libraries = List.map libraries ~f:file in diff --git a/plugins/disassemble/disassemble_main_rules.ml b/plugins/disassemble/disassemble_main_rules.ml index 4babce8b9..84c37a2e3 100644 --- a/plugins/disassemble/disassemble_main_rules.ml +++ b/plugins/disassemble/disassemble_main_rules.ml @@ -109,9 +109,9 @@ module Symbols = struct } [@@deriving compare, equal, bin_io, sexp] let empty = { - roots = Set.empty (module Addr); - names = Map.empty (module Addr); - aliases = Map.empty (module Addr); + roots = (Set.empty (module Addr)); + names = (Map.empty (module Addr)); + aliases = (Map.empty (module Addr)); } let slot = KB.Class.property Theory.Unit.cls @@ -241,7 +241,7 @@ module Symbols = struct let* name = KB.resolve Theory.Label.possible_name obj in let init = match name with | Some name -> Set.singleton (module String) name - | None -> Set.empty (module String) in + | None -> (Set.empty (module String)) in match unit,addr with | None,_|_,None -> KB.return init | Some unit, Some addr -> diff --git a/plugins/emit_ida_script/emit_ida_script_main.ml b/plugins/emit_ida_script/emit_ida_script_main.ml index 5ce3a35f3..2c3c56716 100644 --- a/plugins/emit_ida_script/emit_ida_script_main.ml +++ b/plugins/emit_ida_script/emit_ida_script_main.ml @@ -3,7 +3,7 @@ open Bap.Std open Format include Self() -module Buffer = Caml.Buffer +module Buffer = Stdlib.Buffer (** ida uses a strange color coding, bgr, IIRC *) let idacode_of_color = function diff --git a/plugins/frontc_parser/frontc_parser_main.ml b/plugins/frontc_parser/frontc_parser_main.ml index 8820f69be..6e0317dc5 100644 --- a/plugins/frontc_parser/frontc_parser_main.ml +++ b/plugins/frontc_parser/frontc_parser_main.ml @@ -203,8 +203,8 @@ let resolver lookup = object(self) end let parse (size : C.Size.base) parse lexbuf = - let env = String.Table.create () in - let tags = String.Table.create () in + let env = Hashtbl.create (module String) in + let tags = Hashtbl.create (module String) in let gamma name = match Hashtbl.find env name with | Some t -> t | None -> `Void in diff --git a/plugins/glibc_runtime/glibc_runtime_main.ml b/plugins/glibc_runtime/glibc_runtime_main.ml index e1b95a18e..d13eb76c5 100644 --- a/plugins/glibc_runtime/glibc_runtime_main.ml +++ b/plugins/glibc_runtime/glibc_runtime_main.ml @@ -180,8 +180,8 @@ let refine_glibc_internal_aliases () = KB.collect Theory.Label.aliases label >>| fun aliases -> let init = match name with | Some name when is_glibc_internal name -> - String.Set.singleton @@ drop_glibc_internal name - | None | Some _ -> String.Set.empty in + Set.singleton (module String) @@ drop_glibc_internal name + | None | Some _ -> (Set.empty (module String)) in Set.fold aliases ~init ~f:(fun acc s -> if is_glibc_internal s then Set.add acc @@ drop_glibc_internal s diff --git a/plugins/ida/bap_ida_info.ml b/plugins/ida/bap_ida_info.ml index 0768e156d..a37e37752 100644 --- a/plugins/ida/bap_ida_info.ml +++ b/plugins/ida/bap_ida_info.ml @@ -2,7 +2,7 @@ open Core_kernel[@@warning "-D"] open Bap.Std include Self() -module Sys = Caml.Sys +module Sys = Stdlib.Sys type version = Vold | Vnew [@@deriving sexp, equal] diff --git a/plugins/ida/bap_ida_service.ml b/plugins/ida/bap_ida_service.ml index ea771b2fa..3ab321d17 100644 --- a/plugins/ida/bap_ida_service.ml +++ b/plugins/ida/bap_ida_service.ml @@ -4,10 +4,10 @@ open Bap.Std include Self () -module Buffer = Caml.Buffer -module Filename = Caml.Filename +module Buffer = Stdlib.Buffer +module Filename = Stdlib.Filename module Unix = Caml_unix -module Sys = Caml.Sys +module Sys = Stdlib.Sys module Info = Bap_ida_info @@ -63,7 +63,7 @@ let setup_headless_env path = let old_path,new_path = try Unix.getenv var, lib ^ ":" ^ Unix.getenv var - with Caml.Not_found -> "", lib in + with Stdlib.Not_found -> "", lib in Unix.putenv var new_path; fun () -> try diff --git a/plugins/ida/ida_main.ml b/plugins/ida/ida_main.ml index 598db1c50..4ac1f0980 100644 --- a/plugins/ida/ida_main.ml +++ b/plugins/ida/ida_main.ml @@ -25,7 +25,7 @@ module type Target = sig val provide : Knowledge.agent -> t -> unit end -let digest = Caml.Digest.file +let digest = Stdlib.Digest.file let request = sprintf " @@ -179,17 +179,17 @@ end = struct List.fold flows ~init:[] ~f:(fun acc addr -> (Some !addr, `Jump)::acc) in let helper tab (addr,_normal_flow,other_flows) = - Addr.Table.add_exn tab ~key:!addr + Hashtbl.add_exn tab ~key:!addr ~data:(other_flows_to_dests other_flows); tab in List.fold bf - ~init:(Addr.Table.create ()) + ~init:(Hashtbl.create (module Addr)) ~f:helper let resolve t mem _ = match - Addr.Table.find t (Memory.min_addr mem) + Hashtbl.find t (Memory.min_addr mem) with | Some dests -> dests | None -> [] diff --git a/plugins/mips/mips.ml b/plugins/mips/mips.ml index f0eba4da5..487193afe 100644 --- a/plugins/mips/mips.ml +++ b/plugins/mips/mips.ml @@ -36,7 +36,7 @@ module Std = struct let (^) = concat - let lifters = String.Table.create () + let lifters = Hashtbl.create (module String) let delayed_opcodes = Hashtbl.create (module String) @@ -63,7 +63,7 @@ module Std = struct sprintf "instruction %s doesn't have an operand with index %d" insn_name n in Error (Error.of_string str) in - match String.Table.find lifters (Insn.name insn) with + match Hashtbl.find lifters (Insn.name insn) with | None -> Ok [] | Some lifter -> lift lifter diff --git a/plugins/mips/mips_cpu.ml b/plugins/mips/mips_cpu.ml index eb4c81e45..c6c94e316 100644 --- a/plugins/mips/mips_cpu.ml +++ b/plugins/mips/mips_cpu.ml @@ -17,7 +17,7 @@ let find m reg = let (module M : MIPS) = m in let open M in let open E in - let find_reg regs reg = String.Map.find regs (Reg.name reg) in + let find_reg regs reg = Map.find regs (Reg.name reg) in let find_gpr = find_reg gpr in let find_fpr = find_reg fpr in let reg_searches = [find_gpr; find_fpr] in @@ -47,7 +47,7 @@ let make_cpu addr_size endian memory = | `r64 -> jmp e in let find name regs n = try - Int.Map.find_exn regs n + Map.find_exn regs n with _ -> mips_fail "%s with number %d not found" name n in let gpr n = find "GPR" gpri n in diff --git a/plugins/mips/mips_model.ml b/plugins/mips/mips_model.ml index d4530252a..878d0a653 100644 --- a/plugins/mips/mips_model.ml +++ b/plugins/mips/mips_model.ml @@ -36,23 +36,23 @@ let make_regs_list typ prefix size = Array.init ~f:(fun i -> make_var_i typ prefix i) size let reglist_to_map regs = - List.fold ~init:String.Map.empty ~f:(fun regs var -> - String.Map.set regs (Var.name var) var) regs + List.fold ~init:(Map.empty (module String)) ~f:(fun regs var -> + Map.set regs (Var.name var) var) regs let make_regs typ ?alias prefix range = - List.fold ~init:String.Map.empty ~f:(fun regs i -> + List.fold ~init:(Map.empty (module String)) ~f:(fun regs i -> let var = make_var_i typ prefix i in let name = Var.name var in - let regs = String.Map.set regs name var in + let regs = Map.set regs name var in match alias with | None -> regs | Some a -> let name = make_name a i in - String.Map.set regs name var) range + Map.set regs name var) range let make_regs_i typ prefix range = - List.fold ~init:Int.Map.empty ~f:(fun regs i -> - Int.Map.set regs i (make_var_i typ prefix i)) range + List.fold ~init:(Map.empty (module Int)) ~f:(fun regs i -> + Map.set regs i (make_var_i typ prefix i)) range let make_reg typ name = Var.create name typ let flag name = Var.create name (Type.imm 1) @@ -72,10 +72,10 @@ module Vars = struct end let of_vars vars = - String.Map.map vars ~f:(fun v -> Exp.of_var v) + Map.map vars ~f:(fun v -> Exp.of_var v) let of_vars_i vars = - Int.Map.map vars ~f:(fun v -> Exp.of_var v) + Map.map vars ~f:(fun v -> Exp.of_var v) module Exps = struct open Vars @@ -134,7 +134,7 @@ module Make_MIPS(S: Spec) : MIPS = struct ] let gpr = - List.fold gprs ~init:String.Map.empty ~f:(fun init (reg, alias) -> + List.fold gprs ~init:(Map.empty (module String)) ~f:(fun init (reg, alias) -> let name = Var.name reg in let names = [name; alias] in let names = @@ -142,7 +142,7 @@ module Make_MIPS(S: Spec) : MIPS = struct else names in List.fold names ~init ~f:(fun regs name -> Map.set regs name reg)) - let gpri = List.foldi ~init:Int.Map.empty ~f:(fun n regs (reg,_) -> + let gpri = List.foldi ~init:(Map.empty (module Int)) ~f:(fun n regs (reg,_) -> Map.set regs n reg) gprs let hi = make_reg (Type.imm gpr_bitwidth) "HI" @@ -179,11 +179,11 @@ module Make_cpu(M : MIPS) : CPU = struct let gpr = let data = Map.data gpr in - List.fold data ~init:Var.Set.empty - ~f:(fun regs v -> Var.Set.add regs v) + List.fold data ~init:(Set.empty (module Var)) + ~f:(fun regs v -> Set.add regs v) - let sp = Var.Set.find_exn gpr ~f:(fun v -> String.is_prefix ~prefix:"SP" (Var.name v)) - let fp = Var.Set.find_exn gpr ~f:(fun v -> String.is_prefix ~prefix:"FP" (Var.name v)) + let sp = Set.find_exn gpr ~f:(fun v -> String.is_prefix ~prefix:"SP" (Var.name v)) + let fp = Set.find_exn gpr ~f:(fun v -> String.is_prefix ~prefix:"FP" (Var.name v)) (* MIPS doesn't have flags, but structure requires them * We just make a stubs here *) @@ -193,7 +193,7 @@ module Make_cpu(M : MIPS) : CPU = struct let vf = flag "undefined" let nf = flag "undefined" - let flags = Var.Set.of_list [ + let flags = Set.of_list (module Var) [ ] let is = Var.same diff --git a/plugins/mips/mips_rtl.ml b/plugins/mips/mips_rtl.ml index dbe667bad..1bf691cd0 100644 --- a/plugins/mips/mips_rtl.ml +++ b/plugins/mips/mips_rtl.ml @@ -195,7 +195,7 @@ module Exp = struct if width = e.width then e else match e.body with - | Vars (v,vars) when Caml.not (List.is_empty vars) -> + | Vars (v,vars) when Stdlib.not (List.is_empty vars) -> extract_of_vars e hi lo (v :: vars) | _ -> { sign=Unsigned; width; body = Extract (hi,lo,e.body) } diff --git a/plugins/objdump/objdump_main.ml b/plugins/objdump/objdump_main.ml index 61d574163..7fcecbbfe 100644 --- a/plugins/objdump/objdump_main.ml +++ b/plugins/objdump/objdump_main.ml @@ -46,7 +46,7 @@ let demangler = Extension.Configuration.parameter let objdump_cmds demangler= - String.Set.stable_dedup_list objdumps|> + Set.stable_dedup_list (module String) objdumps |> List.map ~f:(fun cmd -> sprintf "%s %s %s" cmd default_objdump_opts @@ match demangler with @@ -118,8 +118,8 @@ end = struct } let empty_table = { - names = Map.empty (module Bitvec_order); - aliases = Map.empty (module Bitvec_order); + names = (Map.empty (module Bitvec_order)); + aliases = (Map.empty (module Bitvec_order)); } type t = { @@ -230,7 +230,7 @@ let provide_aliases repo = require addr |> provide aliases |> comment "extracts aliases from objdump"); - let empty = Set.empty (module String) in + let empty = (Set.empty (module String)) in KB.promise aliases @@ fun label -> KB.collect unit label >>= function | None -> !!empty diff --git a/plugins/optimization/optimization_data.ml b/plugins/optimization/optimization_data.ml index 15c07407e..ad2619697 100644 --- a/plugins/optimization/optimization_data.ml +++ b/plugins/optimization/optimization_data.ml @@ -38,7 +38,7 @@ let updates_of_sub sub = Map.set updates (Term.tid j) data in let add_if add updates t = if is_updated t then add updates t else updates in - fold sub blk_t Tid.Map.empty ~f:(fun updates b -> + fold sub blk_t (Map.empty (module Tid)) ~f:(fun updates b -> fold b def_t updates ~f:(add_if update_rhs) |> fold b jmp_t ~f:(add_if update_jmp)) diff --git a/plugins/optimization/optimization_main.ml b/plugins/optimization/optimization_main.ml index b504a0ba8..0a21efde3 100644 --- a/plugins/optimization/optimization_main.ml +++ b/plugins/optimization/optimization_main.ml @@ -32,14 +32,14 @@ let def_use_collector = end let computed_def_use sub = - def_use_collector#visit_sub sub (Var.Set.empty, Var.Set.empty) + def_use_collector#visit_sub sub (Set.empty (module Var), Set.empty (module Var)) let compute_dead can_touch protected sub = let defs, uses = computed_def_use sub in let dead = Set.diff defs uses in let live v = not (Set.mem dead v) in Term.enum blk_t sub - |> Seq.fold ~init:Tid.Set.empty ~f:(fun dead blk -> + |> Seq.fold ~init:(Set.empty (module Tid)) ~f:(fun dead blk -> Term.enum ~rev:true def_t blk |> Seq.fold ~init:(protected, dead) ~f:(fun (protected, dead) def -> let v = Def.lhs def in @@ -89,7 +89,7 @@ let substitute sub vars = (* A simple constant propagation. Note, the input is required to be in SSA. *) let propagate_consts can_touch sub = - Seq.fold (Term.enum blk_t sub) ~init:Var.Map.empty ~f:(fun vars b -> + Seq.fold (Term.enum blk_t sub) ~init:(Map.empty (module Var)) ~f:(fun vars b -> Seq.fold (Term.enum def_t b) ~init:vars ~f:(fun vars d -> let v = Def.lhs d in if can_touch v then @@ -111,7 +111,7 @@ let free_vars prog = report_progress ~note:"free-vars" (); let ( ++ ) = Set.union in let collect cls t ~f = - Seq.fold (Term.enum cls t) ~init:Var.Set.empty ~f:(fun acc x -> acc ++ f x) + Seq.fold (Term.enum cls t) ~init:(Set.empty (module Var)) ~f:(fun acc x -> acc ++ f x) in let sub_free sub = Sub.free_vars sub |> Set.filter ~f:Var.is_physical in let sub_args sub = @@ -128,7 +128,7 @@ let process_sub free can_touch sub = if Set.is_empty dead' then (s, dead) else loop dead (clean can_touch dead' s) in - let sub', dead = loop Tid.Set.empty (Sub.ssa sub) in + let sub', dead = loop (Set.empty (module Tid)) (Sub.ssa sub) in O.create dead sub' let digest_of_sub sub level = diff --git a/plugins/patterns/patterns_main.ml b/plugins/patterns/patterns_main.ml index 8406ad09c..38bf35d01 100644 --- a/plugins/patterns/patterns_main.ml +++ b/plugins/patterns/patterns_main.ml @@ -113,7 +113,7 @@ open Bap_core_theory open Bap.Std open Bap_main open Bap_primus.Std -module Sys = Caml.Sys +module Sys = Stdlib.Sys module Sigma = Primus.Lisp.Semantics module Lambda = Theory.Label @@ -999,7 +999,7 @@ module Rules = struct let empty = { cases = []; - known = Set.empty (module Action); + known = (Set.empty (module Action)); } let slot = KB.Class.property Theory.Unit.cls "pattern-rules" @@ -1029,7 +1029,7 @@ module Rules = struct let empty = { cases = []; - known = Set.empty (module Action); + known = (Set.empty (module Action)); } let concat x y = { @@ -1123,9 +1123,9 @@ end = struct Filename.concat folder file)) let dedup selected = - let empty = Set.empty (module String) in + let empty = (Set.empty (module String)) in List.fold selected ~init:(empty,empty) ~f:(fun (digests,files) file -> - let digest = Caml.Digest.file file in + let digest = Stdlib.Digest.file file in if Set.mem digests digest || Set.mem files file then digests,files else Set.add digests digest, @@ -1169,7 +1169,7 @@ end = struct include Bitvec_binprot end - let empty_roots = Set.empty (module Addr) + let empty_roots = (Set.empty (module Addr)) let empty_names = Bap_relation.empty Addr.compare String.compare type outcome = { @@ -1178,8 +1178,8 @@ end = struct } [@@deriving bin_io, compare, sexp, equal] let empty = { - roots = Set.empty (module Addr); - names = Map.empty (module Addr); + roots = (Set.empty (module Addr)); + names = (Map.empty (module Addr)); } let slot = KB.Class.property Theory.Unit.cls "patterns-outcome" diff --git a/plugins/phoenix/phoenix_root.ml b/plugins/phoenix/phoenix_root.ml index 02142002b..2f66460d8 100644 --- a/plugins/phoenix/phoenix_root.ml +++ b/plugins/phoenix/phoenix_root.ml @@ -1,6 +1,6 @@ open Core_kernel[@@warning "-D"] -module Sys = Caml.Sys +module Sys = Stdlib.Sys module Unix = Caml_unix exception Target_directory_is_a_file diff --git a/plugins/piqi_printers/dune b/plugins/piqi_printers/dune deleted file mode 100644 index a4f90d49b..000000000 --- a/plugins/piqi_printers/dune +++ /dev/null @@ -1,12 +0,0 @@ -(library - (name bap_piqi_printers_plugin) - (public_name bap-piqi.plugin) - (preprocess (pps ppx_bap)) - (libraries bap-piqi)) - -(plugin - (name piqi_printers) - (package bap-piqi) - (libraries bap-piqi.plugin) - (optional) - (site (bap-common plugins))) diff --git a/plugins/piqi_printers/piqi_printers_main.ml b/plugins/piqi_printers/piqi_printers_main.ml deleted file mode 100644 index e697573ac..000000000 --- a/plugins/piqi_printers/piqi_printers_main.ml +++ /dev/null @@ -1,71 +0,0 @@ -open Core_kernel[@@warning "-D"] -open Regular.Std -open Bap.Std -include Self() - - -let () = Config.manpage [ - `S "DESCRIPTION"; - `P - "Provide a serialization for BIR and BIL, using piqi - serialization files. The plugin provides five formats - of serialization: JSON, protobuf, textual, binary and XML."; - `P - "The serialization routines can be use programmatically, using - the Data interface, or from a print plugin"; - - `S "SEE ALSO"; - `P "$(b,regular)(3), $(b,bap-plugin-print)(1), $(b,bap-piqi)(3)" - ] - -module Bil = struct - open Bil_piqi - open Bir_piqi - - let writer f fmt = - let to_bytes s = f fmt s |> Bytes.of_string in - Data.Write.create ~to_bytes () - - let reader f fmt = - let of_bytes b = f fmt (Bytes.to_string b) in - Data.Read.create ~of_bytes () - - let ver = "0.1" - let desc_of_type = function - | `json -> "JSON" - | `pb -> "protobuf" - | `piq -> "textual" - | `pib -> "binary" - | `xml -> "XML" - let s fmt = - sprintf "Piqi generated %s serializer" (desc_of_type fmt) - - let register () = - List.iter all_of_fmt ~f:(fun fmt -> - let name = Sexp.to_string (sexp_of_fmt fmt) in - let desc = s fmt in - Stmt.add_reader ~desc ~ver name (reader stmt_of_string fmt); - Stmt.add_writer ~desc ~ver name (writer string_of_stmt fmt); - Exp.add_reader ~desc ~ver name (reader exp_of_string fmt); - Exp.add_writer ~desc ~ver name (writer string_of_exp fmt); - Bil.add_reader ~desc ~ver name (reader bil_of_string fmt); - Bil.add_writer ~desc ~ver name (writer string_of_bil fmt); - Sub.add_writer ~desc ~ver name (writer string_of_sub fmt); - Sub.add_reader ~desc ~ver name (reader sub_of_string fmt); - Blk.add_writer ~desc ~ver name (writer string_of_blk fmt); - Blk.add_reader ~desc ~ver name (reader blk_of_string fmt); - Arg.add_writer ~desc ~ver name (writer string_of_arg fmt); - Arg.add_reader ~desc ~ver name (reader arg_of_string fmt); - Phi.add_writer ~desc ~ver name (writer string_of_phi fmt); - Phi.add_reader ~desc ~ver name (reader phi_of_string fmt); - Def.add_writer ~desc ~ver name (writer string_of_def fmt); - Def.add_reader ~desc ~ver name (reader def_of_string fmt); - Program.add_writer ~desc ~ver name (writer string_of_program fmt); - Program.add_reader ~desc ~ver name (reader program_of_string fmt)) - -end - -let () = Config.declare_extension - ~doc:"provides piqi-based serialization for BIL and BIR" - ~provides:["printer"; "serialization"; "xml"; "json"; "protobuf"] - @@ fun _ -> Bil.register () diff --git a/plugins/piqi_printers/piqi_printers_main.mli b/plugins/piqi_printers/piqi_printers_main.mli deleted file mode 100644 index e69de29bb..000000000 diff --git a/plugins/powerpc/powerpc.ml b/plugins/powerpc/powerpc.ml index af8ed1662..fed596dc2 100644 --- a/plugins/powerpc/powerpc.ml +++ b/plugins/powerpc/powerpc.ml @@ -41,7 +41,7 @@ module Std = struct nth bit cpu.cr 2 := x = zero; ] - let lifters = String.Table.create () + let lifters = Hashtbl.create (module String) let register name lifter = Hashtbl.change lifters name ~f:(fun _ -> Some lifter) diff --git a/plugins/powerpc/powerpc.mli b/plugins/powerpc/powerpc.mli index 9ac219d38..711db6a9c 100644 --- a/plugins/powerpc/powerpc.mli +++ b/plugins/powerpc/powerpc.mli @@ -399,6 +399,11 @@ module Std : sig (** imm constructor - constructs an immediate from operand *) val imm : (op -> exp) ec + (** [immw width] is like [imm], but re-extends the sign from the + ISA-documented operand field [width], for backends that report + raw zero-extended fields (LLVM >= 15 PowerPC) *) + val immw : bitwidth -> (op -> exp) ec + (** var constructor - constructs a variable of bitwidth *) val var : (bitwidth -> exp) ec diff --git a/plugins/powerpc/powerpc_dsl.ml b/plugins/powerpc/powerpc_dsl.ml index c1664d590..7843ebdcc 100644 --- a/plugins/powerpc/powerpc_dsl.ml +++ b/plugins/powerpc/powerpc_dsl.ml @@ -27,11 +27,29 @@ let int_of_imm = function | Some x -> x | None -> ppc_fail "failed to convert imm operand to int" +(* [imm signed op] creates an immediate expression, trusting the value + reported by the disassembler backend. *) let imm signed op = let w = Word.of_int ~width:32 (int_of_imm op) in if signed then Exp.(signed @@ of_word w) else Exp.(unsigned @@ of_word w) +(* [immw width signed op] is like [imm], but [width] is the + ISA-documented width of the underlying operand field. Some LLVM + backends (PowerPC since ~LLVM 15) report raw zero-extended fields + instead of sign-decoded values, so when the value falls into the + upper half of the field and [signed] is requested, we re-extend the + sign from [width]. *) +let immw width signed op = + let v = int_of_imm op in + let v = + if width < 32 && v >= (1 lsl (width - 1)) && v < (1 lsl width) + then v - (1 lsl width) + else v in + let w = Word.of_int ~width:32 v in + if signed then Exp.(signed @@ of_word w) + else Exp.(unsigned @@ of_word w) + let signed f = f true let unsigned f = f false diff --git a/plugins/powerpc/powerpc_dsl.mli b/plugins/powerpc/powerpc_dsl.mli index f83c29ede..4714d8cb3 100644 --- a/plugins/powerpc/powerpc_dsl.mli +++ b/plugins/powerpc/powerpc_dsl.mli @@ -16,6 +16,11 @@ val bitwidth : int -> bitwidth val int_of_bitwidth : bitwidth -> int val imm : (op -> exp) ec + +(** [immw width] is like [imm], but re-extends the sign from the + ISA-documented operand field [width], for backends that report raw + zero-extended fields. *) +val immw : bitwidth -> (op -> exp) ec val var : (bitwidth -> exp) ec val reg : (reg -> exp) -> (op -> exp) ec val const : (bitwidth -> int -> exp) ec diff --git a/plugins/powerpc/powerpc_load.ml b/plugins/powerpc/powerpc_load.ml index e8640ad2a..b4033b0b1 100644 --- a/plugins/powerpc/powerpc_load.ml +++ b/plugins/powerpc/powerpc_load.ml @@ -9,19 +9,19 @@ open Powerpc.Std 83 eb ff fc - lwz r31, -4(r11) *) let lbz cpu ops = let rt = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(1) in + let im = signed (immw halfword) ops.(1) in let ra = signed cpu.reg ops.(2) in RTL.[ rt := cpu.load (ra + im) byte; ] let lhz cpu ops = let rt = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(1) in + let im = signed (immw halfword) ops.(1) in let ra = signed cpu.reg ops.(2) in RTL.[ rt := cpu.load (ra + im) halfword; ] let lwz cpu ops = let rt = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(1) in + let im = signed (immw halfword) ops.(1) in let ra = signed cpu.reg ops.(2) in RTL.[ rt := cpu.load (ra + im) word; ] @@ -57,7 +57,7 @@ let lwzx cpu ops = 85 3f ff fc lwzu r9, -4(r31) *) let lbzu cpu ops = let rt = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(2) in + let im = signed (immw halfword) ops.(2) in let ra = signed cpu.reg ops.(3) in RTL.[ rt := cpu.load (ra + im) byte; @@ -66,7 +66,7 @@ let lbzu cpu ops = let lhzu cpu ops = let rt = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(2) in + let im = signed (immw halfword) ops.(2) in let ra = signed cpu.reg ops.(3) in RTL.[ rt := cpu.load (ra + im) halfword; @@ -75,7 +75,7 @@ let lhzu cpu ops = let lwzu cpu ops = let rt = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(2) in + let im = signed (immw halfword) ops.(2) in let ra = signed cpu.reg ops.(3) in RTL.[ rt := cpu.load (ra + im) word; @@ -122,7 +122,7 @@ let lwzux cpu ops = a8 29 00 05 lha r1, 5(r9) *) let lha cpu ops = let rt = signed cpu.reg ops.(0) in - let im = signed imm ops.(1) in + let im = signed (immw halfword) ops.(1) in let ra = signed cpu.reg ops.(2) in RTL.[ rt := cpu.load (ra + im) halfword; @@ -168,7 +168,7 @@ let lwax cpu ops = let lhau cpu ops = let rt = signed cpu.reg ops.(0) in let ra = signed cpu.reg ops.(1) in - let im = signed imm ops.(2) in + let im = signed (immw halfword) ops.(2) in RTL.[ rt := cpu.load (ra + im) halfword; ra := ra + im diff --git a/plugins/powerpc/powerpc_model.ml b/plugins/powerpc/powerpc_model.ml index 26bd12c2a..6aa0df2f2 100644 --- a/plugins/powerpc/powerpc_model.ml +++ b/plugins/powerpc/powerpc_model.ml @@ -59,7 +59,7 @@ let make_name prefix i = sprintf "%s%d" prefix i let make_var_i typ prefix i = Var.create (make_name prefix i) typ let make_regs typ ?alias prefix range = - List.fold ~init:String.Map.empty ~f:(fun regs i -> + List.fold ~init:(Map.empty (module String)) ~f:(fun regs i -> let var = make_var_i typ prefix i in let name = Var.name var in let regs = Map.set regs name var in @@ -71,7 +71,7 @@ let make_regs typ ?alias prefix range = let make_regs_i typ prefix range = - List.fold ~init:Int.Map.empty ~f:(fun regs i -> + List.fold ~init:(Map.empty (module Int)) ~f:(fun regs i -> Map.set regs i (make_var_i typ prefix i)) range let flag name = Var.create name (Type.imm 1) @@ -150,13 +150,13 @@ module Vars (B : Bitwidth) = struct let cri = let _, bits = - List.fold (List.rev cr_bits) ~init:(0,Int.Map.empty) + List.fold (List.rev cr_bits) ~init:(0,Map.empty (module Int)) ~f:(fun (num, bits) bit -> num + 1, Map.set bits ~key:num ~data:bit) in bits let crn = - Int.Map.fold cri ~init:String.Map.empty + Map.fold cri ~init:(Map.empty (module String)) ~f:(fun ~key:_ ~data:var acc -> Map.set acc (Var.name var) var) @@ -172,11 +172,11 @@ module Vars (B : Bitwidth) = struct ] let cr_fields = - List.fold fields ~init:String.Map.empty ~f:(fun fs (name, _, fd) -> + List.fold fields ~init:(Map.empty (module String)) ~f:(fun fs (name, _, fd) -> Map.set fs name fd) let cri_fields = - List.fold fields ~init:Int.Map.empty ~f:(fun fs (_, index, fd) -> + List.fold fields ~init:(Map.empty (module Int)) ~f:(fun fs (_, index, fd) -> Map.set fs index fd) (** fixed precision flags *) @@ -211,7 +211,7 @@ module Exps(B : Bitwidth) = struct let cri = Map.map cri ~f:(fun v -> Exp.of_var v) let crn = - Int.Map.fold Vars.cri ~init:String.Map.empty + Map.fold Vars.cri ~init:(Map.empty (module String)) ~f:(fun ~key:_ ~data:var acc -> Map.set acc (Var.name var) (Exp.of_var var)) @@ -256,7 +256,7 @@ module Make_ppc(S : Spec) : PowerPC = struct let mem = Var.create "mem" (Type.mem S.addr_size `r8) - let flags = Var.Set.of_list [ + let flags = Set.of_list (module Var) [ so; ca; ca32; ov; ov32; Map.find_exn cri 0; Map.find_exn cri 1; @@ -285,16 +285,16 @@ module Make_cpu(P : PowerPC) : CPU = struct let gpr = let data = Map.data gpr in - List.fold data ~init:Var.Set.empty - ~f:(fun regs v -> Var.Set.add regs v) + List.fold data ~init:(Set.empty (module Var)) + ~f:(fun regs v -> Set.add regs v) - let sp = Var.Set.find_exn gpr ~f:(fun v -> String.equal (Var.name v) "R1") + let sp = Set.find_exn gpr ~f:(fun v -> String.equal (Var.name v) "R1") let vf = ov let cf = ca let nf = Map.find_exn cri 0 let zf = Map.find_exn cri 1 - let flags = Var.Set.of_list [ + let flags = Set.of_list (module Var) [ so; ca; ov; cf; nf; zf; ca32; ov32; ] diff --git a/plugins/powerpc/powerpc_rtl.ml b/plugins/powerpc/powerpc_rtl.ml index cafa6645b..021cfb933 100644 --- a/plugins/powerpc/powerpc_rtl.ml +++ b/plugins/powerpc/powerpc_rtl.ml @@ -222,7 +222,7 @@ module Exp = struct if width = e.width then { e with sign=Unsigned; } else match e.body with - | Vars (v,vars) when Caml.not (List.is_empty vars) -> + | Vars (v,vars) when Stdlib.not (List.is_empty vars) -> extract_of_vars e hi lo (v :: vars) | _ -> { sign=Unsigned; width; body = Extract (hi,lo,e.body) } diff --git a/plugins/powerpc/powerpc_store.ml b/plugins/powerpc/powerpc_store.ml index 28b5eb6c8..853bf2f67 100644 --- a/plugins/powerpc/powerpc_store.ml +++ b/plugins/powerpc/powerpc_store.ml @@ -9,19 +9,19 @@ open Powerpc.Std 91 28 ff d4 stw r9,-44(r8) *) let stb cpu ops = let rs = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(1) in + let im = signed (immw halfword) ops.(1) in let ra = signed cpu.reg ops.(2) in RTL.[ cpu.store (ra + im) rs byte; ] let sth cpu ops = let rs = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(1) in + let im = signed (immw halfword) ops.(1) in let ra = signed cpu.reg ops.(2) in RTL.[ cpu.store (ra + im) rs halfword; ] let stw cpu ops = let rs = unsigned cpu.reg ops.(0) in - let im = signed imm ops.(1) in + let im = signed (immw halfword) ops.(1) in let ra = signed cpu.reg ops.(2) in RTL.[ cpu.store (ra + im) rs word; ] @@ -64,7 +64,7 @@ let stdx cpu ops = 94 21 ff f0 stwu r1,-16(r1) *) let stbu cpu ops = let rs = unsigned cpu.reg ops.(1) in - let im = signed imm ops.(2) in + let im = signed (immw halfword) ops.(2) in let ra = signed cpu.reg ops.(3) in RTL.[ cpu.store (ra + im) rs byte; @@ -73,7 +73,7 @@ let stbu cpu ops = let sthu cpu ops = let rs = unsigned cpu.reg ops.(1) in - let im = signed imm ops.(2) in + let im = signed (immw halfword) ops.(2) in let ra = signed cpu.reg ops.(3) in RTL.[ cpu.store (ra + im) rs halfword; @@ -82,7 +82,7 @@ let sthu cpu ops = let stwu cpu ops = let rs = unsigned cpu.reg ops.(1) in - let im = signed imm ops.(2) in + let im = signed (immw halfword) ops.(2) in let ra = signed cpu.reg ops.(3) in RTL.[ cpu.store (ra + im) rs word; diff --git a/plugins/primus_dictionary/primus_dictionary_main.ml b/plugins/primus_dictionary/primus_dictionary_main.ml index b026e0017..6de0366ea 100644 --- a/plugins/primus_dictionary/primus_dictionary_main.ml +++ b/plugins/primus_dictionary/primus_dictionary_main.ml @@ -11,8 +11,8 @@ type t = { dicts : dict Primus.Value.Map.t; } -let pair key data = {dict = Primus.Value.Map.singleton key data} -let add key data s = {dict = Primus.Value.Map.set s.dict ~key ~data} +let pair key data = {dict = Map.singleton (module Primus.Value) key data} +let add key data s = {dict = Map.set s.dict ~key ~data} (* idea: initialize the dictionary with initial properties of a project and terms. @@ -21,7 +21,7 @@ let state = Primus.Machine.State.declare ~uuid:"F050079C-7FDB-4A8F-8A59-72C9693ADBCE" ~name:"lisp-dictionaries" (fun _ -> - {dicts = Primus.Value.Map.empty}) + {dicts = (Map.empty (module Primus.Value))}) module Pre(Machine : Primus.Machine.S) = struct include Machine.Syntax diff --git a/plugins/primus_exploring/primus_exploring_main.ml b/plugins/primus_exploring/primus_exploring_main.ml index 4496cae98..32252a13d 100644 --- a/plugins/primus_exploring/primus_exploring_main.ml +++ b/plugins/primus_exploring/primus_exploring_main.ml @@ -15,7 +15,7 @@ let state = Primus.Machine.State.declare ~name:"exploring-scheduler" (fun _ -> { pending=Fqueue.empty; - explored=Tid.Map.empty; + explored=(Map.empty (module Tid)); }) module Scheduler(Machine : Primus.Machine.S) = struct diff --git a/plugins/primus_limit/primus_limit_main.ml b/plugins/primus_limit/primus_limit_main.ml index 2f7625542..752574ee6 100644 --- a/plugins/primus_limit/primus_limit_main.ml +++ b/plugins/primus_limit/primus_limit_main.ml @@ -83,7 +83,7 @@ let state = Primus.Machine.State.declare ~name:"primus-limiter" ~uuid:"b1b58dff-54de-4611-abf8-88ff8f6c7481" (fun _ -> { - visited = Name.Map.empty; + visited = (Map.empty (module Name)); length = 0; }) diff --git a/plugins/primus_lisp/primus_lisp_documentation.ml b/plugins/primus_lisp/primus_lisp_documentation.ml index 090d80a5a..e25720dad 100644 --- a/plugins/primus_lisp/primus_lisp_documentation.ml +++ b/plugins/primus_lisp/primus_lisp_documentation.ml @@ -22,7 +22,7 @@ let fail prob = Error (Failed prob) let build_library index = let (%:) k v = Map.singleton (module String) k v in - let init = Map.empty (module String) in + let init = (Map.empty (module String)) in List.fold index ~init ~f:(fun library (cat,elts) -> let cat = Format.asprintf "%a" Doc.Category.pp cat in List.fold ~init:library elts ~f:(fun library (name,desc) -> diff --git a/plugins/primus_lisp/primus_lisp_ieee754.ml b/plugins/primus_lisp/primus_lisp_ieee754.ml index b07bf4475..724a6a361 100644 --- a/plugins/primus_lisp/primus_lisp_ieee754.ml +++ b/plugins/primus_lisp/primus_lisp_ieee754.ml @@ -104,7 +104,7 @@ module Primitives(Machine : Primus.Machine.S) = struct let is_nan x = Float.Class.(compare Nan (Float.classify x) = 0) - let init () = Machine.sequence Caml.[ + let init () = Machine.sequence Stdlib.[ define inf "add" ( +. ); define inf "sub" ( -. ); define inf "div" ( /. ); diff --git a/plugins/primus_lisp/primus_lisp_io.ml b/plugins/primus_lisp/primus_lisp_io.ml index 0f20aeb64..8cafe18ef 100644 --- a/plugins/primus_lisp/primus_lisp_io.ml +++ b/plugins/primus_lisp/primus_lisp_io.ml @@ -15,7 +15,7 @@ type state = { channels : channel Int.Map.t; } -let default_channels = Int.Map.of_alist_exn [ +let default_channels = Map.of_alist_exn (module Int) [ 0, { input = Some In_channel.stdin; output = Some Out_channel.stdout; @@ -59,7 +59,7 @@ let init_channels = Map.set chans ~key:fd ~data:chan) let init_redirections = - List.fold ~init:String.Map.empty ~f:(fun redirs (oldname,newname) -> + List.fold ~init:(Map.empty (module String)) ~f:(fun redirs (oldname,newname) -> match fd_of_name oldname with | Some _ -> redirs | None -> Map.set redirs ~key:oldname ~data:newname) @@ -90,8 +90,8 @@ let state = Primus.Machine.State.declare ~name:"io-channels" ~uuid:"f326a07d-16ed-42ec-958d-76ef584cb341" (fun _ -> { - redirections = String.Map.empty; - channels = Int.Map.empty; + redirections = (Map.empty (module String)); + channels = (Map.empty (module Int)); }) diff --git a/plugins/primus_lisp/primus_lisp_main.ml b/plugins/primus_lisp/primus_lisp_main.ml index 10c29b372..c69c2c4a2 100644 --- a/plugins/primus_lisp/primus_lisp_main.ml +++ b/plugins/primus_lisp/primus_lisp_main.ml @@ -4,7 +4,7 @@ open Bap.Std open Monads.Std open Bap_primus.Std open Format -module Sys = Caml.Sys +module Sys = Stdlib.Sys include Self() module Primitives = Primus_lisp_primitives diff --git a/plugins/primus_lisp/primus_lisp_primitives.ml b/plugins/primus_lisp/primus_lisp_primitives.ml index c067dec13..0a2420d8f 100644 --- a/plugins/primus_lisp/primus_lisp_primitives.ml +++ b/plugins/primus_lisp/primus_lisp_primitives.ml @@ -7,7 +7,7 @@ let registers = Primus.Machine.State.declare ~uuid:"3dd2b905-c019-4466-800f-95b13d7da85e" ~name:"backend-registers" @@ fun proj -> Project.disasm proj |> Disasm.insns |> - Seq.fold ~init:Int.Map.empty ~f:(fun regs (_,insn) -> + Seq.fold ~init:(Map.empty (module Int)) ~f:(fun regs (_,insn) -> Insn.ops insn |> Array.fold ~init:regs ~f:(fun regs -> function | Op.Reg r -> diff --git a/plugins/primus_loader/primus_loader_basic.ml b/plugins/primus_loader/primus_loader_basic.ml index 2ceec6631..6ba6e294b 100644 --- a/plugins/primus_loader/primus_loader_basic.ml +++ b/plugins/primus_loader/primus_loader_basic.ml @@ -273,7 +273,7 @@ module Make(Param : Param)(Machine : Primus.Machine.S) = struct method! enter_blk = add method! enter_sub = add end in - visitor#run prog String.Map.empty + visitor#run prog (Map.empty (module String)) let init_names () = Machine.get () >>= fun proj -> diff --git a/plugins/primus_print/primus_print_main.ml b/plugins/primus_print/primus_print_main.ml index 0fc003c8f..bc02bff7c 100644 --- a/plugins/primus_print/primus_print_main.ml +++ b/plugins/primus_print/primus_print_main.ml @@ -112,7 +112,7 @@ let concat streams = facts or another derived fact. *) let process_rule rule = let module Prov = Primus.Observation.Provider in - let observing = String.Set.of_list (rule_providers rule) in + let observing = Set.of_list (module String) (rule_providers rule) in let facts,to_facts = Primus.Observation.list_providers () |> List.filter ~f:(fun p -> Set.mem observing (Prov.name p)) |> diff --git a/plugins/primus_promiscuous/primus_promiscuous_main.ml b/plugins/primus_promiscuous/primus_promiscuous_main.ml index e1779347c..f4a81c24f 100644 --- a/plugins/primus_promiscuous/primus_promiscuous_main.ml +++ b/plugins/primus_promiscuous/primus_promiscuous_main.ml @@ -65,7 +65,7 @@ let init_visited prog = if Term.has_attr blk Term.visited then Set.add visited (Term.tid blk) else visited - end)#run prog Tid.Set.empty + end)#run prog (Set.empty (module Tid)) let state = Primus.Machine.State.declare ~name:"conflicts" diff --git a/plugins/primus_propagate_taint/primus_propagate_taint_main.ml b/plugins/primus_propagate_taint/primus_propagate_taint_main.ml index 0ed15f0d2..76c762b20 100644 --- a/plugins/primus_propagate_taint/primus_propagate_taint_main.ml +++ b/plugins/primus_propagate_taint/primus_propagate_taint_main.ml @@ -25,9 +25,9 @@ let mapper = Primus.Machine.State.declare ~name:"primus-taint-mapper" ~uuid:"12511d75-e626-4b0d-8dcd-2a3b597992cf" (fun _ -> { - regs = Tid.Map.empty; - ptrs = Tid.Map.empty; - tids = Taint.Object.Map.empty; + regs = (Map.empty (module Tid)); + ptrs = (Map.empty (module Tid)); + tids = (Map.empty (module Taint.Object)); }) let is_mem v = match Var.typ v with @@ -64,7 +64,7 @@ module Intro(Machine : Primus.Machine.S) = struct kind t >>= fun k -> Object.create k >>= fun taint -> connect t taint >>| fun () -> - Taint.Object.Set.singleton taint + Set.singleton (module Taint.Object) taint let introduces def = List.find_map translation ~f:(fun (k,s,r) -> @@ -126,7 +126,7 @@ module Mapper(Machine : Primus.Machine.S) = struct ] let remap tids objs = - Tid.Set.filter_map objs ~f:(Map.find tids) + Set.filter_map (module Tid) objs ~f:(Base.Map.find tids) let update vars term = Machine.List.iter relations ~f:(fun (rel,fld) -> @@ -139,7 +139,7 @@ module Mapper(Machine : Primus.Machine.S) = struct else Field.fset fld s @@ Map.update (Field.get fld s) (Term.tid term) ~f:(function - | None -> Var.Map.singleton var taints + | None -> Map.singleton (module Var) var taints | Some taints' -> Map.update taints' var ~f:(function | None -> taints diff --git a/plugins/primus_random/primus_random_main.ml b/plugins/primus_random/primus_random_main.ml index 9303020f6..e859be35b 100644 --- a/plugins/primus_random/primus_random_main.ml +++ b/plugins/primus_random/primus_random_main.ml @@ -407,7 +407,7 @@ let main ctxt = ~name:"generators-for-arguments" @@ fun proj -> let prog = Project.program proj in Term.enum sub_t prog |> - Seq.fold ~init:{args=Var.Map.empty} ~f:(fun init sub -> + Seq.fold ~init:{args=(Map.empty (module Var))} ~f:(fun init sub -> Term.enum arg_t sub |> Seq.fold ~init ~f:(fun {args} arg -> if Poly.(Arg.intent arg = Some In) then {args} @@ -430,7 +430,7 @@ let main ctxt = let randomize_vars _ = Machine.get () >>= fun proj -> - vars_collector#run (Project.program proj) Var.Set.empty |> + vars_collector#run (Project.program proj) (Set.empty (module Var)) |> Set.to_sequence |> Machine.Seq.iter ~f:(fun var -> match Var.typ var with | Mem _ | Unk -> Machine.return () diff --git a/plugins/primus_region/primus_region_main.ml b/plugins/primus_region/primus_region_main.ml index 74f94f3e7..091bb1494 100644 --- a/plugins/primus_region/primus_region_main.ml +++ b/plugins/primus_region/primus_region_main.ml @@ -24,7 +24,7 @@ let state = Primus.Machine.State.declare ~uuid:"0FC4AF7F-7237-4CE1-874A-4971801C6D67" ~name:"region" (fun _ -> { - regions = Primus.Value.Map.empty; + regions = (Map.empty (module Primus.Value)); }) module Pre(Machine : Primus.Machine.S) = struct diff --git a/plugins/primus_round_robin/primus_round_robin_main.ml b/plugins/primus_round_robin/primus_round_robin_main.ml index 5076ef8c2..098391f22 100644 --- a/plugins/primus_round_robin/primus_round_robin_main.ml +++ b/plugins/primus_round_robin/primus_round_robin_main.ml @@ -17,7 +17,7 @@ let state = Primus.Machine.State.declare ~name:"round-robin-scheduler" (fun _ -> { pending = Fqueue.empty; - finished = Mid.Set.empty; + finished = (Set.empty (module Mid)); }) diff --git a/plugins/primus_symbolic_executor/primus_symbolic_executor_main.ml b/plugins/primus_symbolic_executor/primus_symbolic_executor_main.ml index 3596259a4..1f83e64ab 100644 --- a/plugins/primus_symbolic_executor/primus_symbolic_executor_main.ml +++ b/plugins/primus_symbolic_executor/primus_symbolic_executor_main.ml @@ -26,7 +26,7 @@ type memory = { let memories = Primus.Machine.State.declare ~uuid:"15dbb89a-3bfb-421c-8b19-16605425c3f5" ~name:"symbolic-memories" @@ fun _ -> - String.Map.empty + (Map.empty (module String)) module Bank = Primus.Memory.Descriptor module Id = Monad.State.Multi.Id @@ -367,8 +367,8 @@ type executor = { let executor = Primus.Machine.State.declare ~uuid:"e21aa0fe-bc37-48e3-b398-ce7e764843c8" ~name:"symbolic-executor-formulae" @@ fun _ -> { - values = Primus.Value.Id.Map.empty; - inputs = Set.empty (module Input); + values = (Map.empty (module Primus.Value.Id)); + inputs = (Set.empty (module Input)); } @@ -400,7 +400,7 @@ end = struct let context = Primus.Machine.State.declare ~uuid:"9538b1fa-b6c0-464a-b11e-22377a10b0b6" ~name:"symbolic-context" @@ fun _ -> { - assertions = Map.empty (module String); + assertions = (Map.empty (module String)); } @@ -430,7 +430,7 @@ end = struct let get scope = Machine.Local.get context >>| fun s -> match Map.find s.assertions scope with - | None -> Set.empty (module SMT.Formula) + | None -> (Set.empty (module SMT.Formula)) | Some xs -> xs end end @@ -579,8 +579,8 @@ let master = Primus.Machine.State.declare ~uuid:"8d2b41d4-4852-40e9-917a-33f1f5af01a1" ~name:"symbolic-executor-master" @@ fun _ -> { self = None; - tasks = Int.Map.empty; - tries = Tid.Map.empty; (* queued or finished forks *) + tasks = (Map.empty (module Int)); + tries = (Map.empty (module Tid)); (* queued or finished forks *) ready = 0; } @@ -593,8 +593,8 @@ let worker = Primus.Machine.State.declare task = { id = null; edge = None; - constraints = Set.empty (module SMT.Formula); - inputs = Set.empty (module Input); + constraints = (Set.empty (module SMT.Formula)); + inputs = (Set.empty (module Input)); }; } @@ -689,7 +689,7 @@ let forker ctxt : Primus.component = Set.add (cs ++ self.task.constraints) constr in Executor.inputs >>= fun inputs -> let inputs = - Seq.fold inputs ~init:self.task.inputs ~f:Set.add in + Seq.fold inputs ~init:self.task.inputs ~f:(fun s x -> Set.add s x) in let task = {inputs; constraints; edge; id=self.tid} in Machine.Global.update master ~f:(push_task task) @@ -733,7 +733,7 @@ let forker ctxt : Primus.component = let ready = s.ready + Map.length s.tasks in report_progress ~stage:(ready-1) ~total:ready (); Machine.Global.put master { - s with tasks = Int.Map.empty + s with tasks = (Map.empty (module Int)) } >>| fun () -> None | Some (m,t,ts) -> let queued = Map.length s.tasks in diff --git a/plugins/primus_systems/primus_systems_main.ml b/plugins/primus_systems/primus_systems_main.ml index 0a155e6c6..6574aca2a 100644 --- a/plugins/primus_systems/primus_systems_main.ml +++ b/plugins/primus_systems/primus_systems_main.ml @@ -45,7 +45,7 @@ open Core_kernel[@@warning "-D"] open Bap_main open Bap_primus.Std open Format -module Sys = Caml.Sys +module Sys = Stdlib.Sys let command what = sprintf " diff --git a/plugins/primus_test/primus_test_main.ml b/plugins/primus_test/primus_test_main.ml index 88e571682..2b063f7c2 100644 --- a/plugins/primus_test/primus_test_main.ml +++ b/plugins/primus_test/primus_test_main.ml @@ -135,8 +135,8 @@ module Location = struct let state = Primus.Machine.State.declare ~uuid:"22d66ae9-82ad-4185-a1f8-5eb99f5569df" ~name:"incident-locations" @@ fun _ -> { - incidents = String.Map.empty; - locations = Primus.Value.Map.empty; + incidents = (Map.empty (module String)); + locations = (Map.empty (module Primus.Value)); } let push pc machine t = @@ -177,7 +177,7 @@ module Location = struct let set_cls name id cls s = { s with incidents = Map.update s.incidents name ~f:(function - | None -> Primus.Value.Map.singleton id cls + | None -> Map.singleton (module Primus.Value) id cls | Some classes -> Map.set classes id cls) } diff --git a/plugins/primus_wandering/primus_wandering_main.ml b/plugins/primus_wandering/primus_wandering_main.ml index d8a7a0be3..55a12e59d 100644 --- a/plugins/primus_wandering/primus_wandering_main.ml +++ b/plugins/primus_wandering/primus_wandering_main.ml @@ -14,7 +14,7 @@ type t = { let state = Primus.Machine.State.declare ~uuid:"99883d0e-94b2-41a4-bce6-1e4a949fd919" ~name:"wandering-scheduler" - (fun _ -> {pending = Int.Map.empty}) + (fun _ -> {pending = (Map.empty (module Int))}) module Make (Random : sig val generator : Primus.generator end) @@ -55,7 +55,7 @@ module Make | _ -> Machine.switch id >>| fun () -> drop i t else Machine.forks () >>| fun fs -> { - pending = Seq.foldi fs ~init:Int.Map.empty ~f:(fun i cs id -> + pending = Seq.foldi fs ~init:(Map.empty (module Int)) ~f:(fun i cs id -> Map.set cs ~key:i ~data:id); } diff --git a/plugins/primus_x86/primus_x86_loader.ml b/plugins/primus_x86/primus_x86_loader.ml index c0a7fdc09..66047d886 100644 --- a/plugins/primus_x86/primus_x86_loader.ml +++ b/plugins/primus_x86/primus_x86_loader.ml @@ -27,7 +27,7 @@ module SetupPLT(Machine : Primus.Machine.S) = struct let intrinsics = let+ prog = Machine.gets Project.program in Term.enum sub_t prog |> - Seq.fold ~init:String.Set.empty ~f:(fun intrinsics sub -> + Seq.fold ~init:(Set.empty (module String)) ~f:(fun intrinsics sub -> if Term.has_attr sub Sub.intrinsic then Set.add intrinsics (Sub.name sub) else intrinsics) diff --git a/plugins/print/print_main.ml b/plugins/print/print_main.ml index 59b3c0884..53fb4ff7e 100644 --- a/plugins/print/print_main.ml +++ b/plugins/print/print_main.ml @@ -349,8 +349,8 @@ let setup_tabs ppf = pp_set_tab ppf () let sorted_blocks nodes = - let init = Set.empty (module Block) in - Seq.fold nodes ~init ~f:Set.add |> + let init = (Set.empty (module Block)) in + Seq.fold nodes ~init ~f:(fun s x -> Set.add s x) |> Set.to_sequence let sort_fns fns = diff --git a/plugins/propagate_taint/propagate_taint_main.ml b/plugins/propagate_taint/propagate_taint_main.ml index 4bebc0498..2c56ff45b 100644 --- a/plugins/propagate_taint/propagate_taint_main.ml +++ b/plugins/propagate_taint/propagate_taint_main.ml @@ -52,14 +52,14 @@ let contains_seed sub = let seeded callgraph subs = let callers sub = Graphlib.fold_reachable (module Graphs.Callgraph) callgraph - ~rev:true ~init:Tid.Set.empty ~f:Set.add (Term.tid sub) in + ~rev:true ~init:(Set.empty (module Tid)) ~f:(fun s x -> Set.add s x) (Term.tid sub) in Seq.filter subs ~f:contains_seed |> - Seq.fold ~init:Tid.Set.empty ~f:(fun subs sub -> + Seq.fold ~init:(Set.empty (module Tid)) ~f:(fun subs sub -> Set.add (Set.union subs @@ callers sub) (Term.tid sub)) let tids_of_sub sub = let terms t p = - Term.enum t p |> Seq.fold ~init:Tid.Set.empty ~f:(fun set t -> + Term.enum t p |> Seq.fold ~init:(Set.empty (module Tid)) ~f:(fun set t -> Set.add set (Term.tid t)) in let (++) = Set.union in let init = terms arg_t sub in @@ -81,12 +81,12 @@ module State = struct let create sub_total = { sub_count = 0; sub_total; - visited = Tid.Set.empty; - terms = Tid.Set.empty; + visited = (Set.empty (module Tid)); + terms = (Set.empty (module Tid)); taints = Taints.empty; } - let keys = Map.fold ~init:Tid.Set.empty ~f:(fun ~key ~data set -> + let keys = Map.fold ~init:(Set.empty (module Tid)) ~f:(fun ~key ~data set -> Set.add set key) let update_taints t taints = { diff --git a/plugins/propagate_taint/propagator.ml b/plugins/propagate_taint/propagator.ml index cb0aae100..132e27def 100644 --- a/plugins/propagate_taint/propagator.ml +++ b/plugins/propagate_taint/propagator.ml @@ -24,9 +24,9 @@ module Result = struct let empty = { - visited = Tid.Map.empty; - tainted_regs = Tid.Map.empty; - tainted_ptrs = Tid.Map.empty; + visited = (Map.empty (module Tid)); + tainted_regs = (Map.empty (module Tid)); + tainted_ptrs = (Map.empty (module Tid)); } let of_context ctxt = { @@ -37,7 +37,7 @@ module Result = struct let taints_of_tid taints tid : Taint.map = Map.find taints tid |> function - | None -> Var.Map.empty + | None -> (Map.empty (module Var)) | Some ts -> ts let tainted_regs t = taints_of_tid t.tainted_regs @@ -79,7 +79,7 @@ let propagate taints vars tid v r : taints = let ts = taints r in Map.change vars tid (function | None when Set.is_empty ts -> None - | None -> Some (Var.Map.of_alist_exn [v, ts]) + | None -> Some (Map.of_alist_exn (module Var) [v, ts]) | Some vs -> Option.some @@ Map.change vs v (function | None when Set.is_empty ts -> None | None -> Some ts @@ -90,8 +90,8 @@ class context ?max_steps ?max_loop p = object(self : 's) inherit Taint.context as taints inherit Conqueror.context ?max_steps ?max_loop p as super - val tvs : taints = Tid.Map.empty - val tms : taints = Tid.Map.empty + val tvs : taints = (Map.empty (module Tid)) + val tms : taints = (Map.empty (module Tid)) method tvs = tvs method tms = tms @@ -116,13 +116,13 @@ class context ?max_steps ?max_loop p = object(self : 's) end let taint_reg ctxt x seed = - ctxt#taint_reg x (Tid.Set.singleton seed) + ctxt#taint_reg x (Set.singleton (module Tid) seed) let taint_ptr ctxt x seed = match Bil.Result.value x with | Bil.Mem _ | Bil.Bot -> ctxt | Bil.Imm a -> - ctxt#taint_ptr a `r8 (Tid.Set.singleton seed) + ctxt#taint_ptr a `r8 (Set.singleton (module Tid) seed) let taint_result t ctxt v = match Term.get_attr t Taint.reg, Term.get_attr t Taint.ptr with diff --git a/plugins/raw/raw_main.ml b/plugins/raw/raw_main.ml index aba396903..4744dcceb 100644 --- a/plugins/raw/raw_main.ml +++ b/plugins/raw/raw_main.ml @@ -12,7 +12,7 @@ open Bap_main open Core_kernel[@@warning "-D"] open Extension.Syntax -module Buffer = Caml.Buffer +module Buffer = Stdlib.Buffer module Unix = Caml_unix module Spec = struct @@ -98,7 +98,7 @@ let register_loader ctxt = "length", Int64.to_string @@ match ctxt-->length with | None -> Int64.(measure input - (ctxt-->offset)) | Some n -> n; - ] |> String.Map.of_alist_exn in + ] |> Map.of_alist_exn (module String) in let buf = Buffer.create 128 in let ppf = Format.formatter_of_buffer buf in doc_template |> diff --git a/plugins/read_symbols/read_symbols_main.ml b/plugins/read_symbols/read_symbols_main.ml index 6ebd46a7f..6a72cf766 100644 --- a/plugins/read_symbols/read_symbols_main.ml +++ b/plugins/read_symbols/read_symbols_main.ml @@ -88,7 +88,7 @@ open Core_kernel[@@warning "-D"] open Bap_main open Bap_core_theory open KB.Syntax -module Sys = Caml.Sys +module Sys = Stdlib.Sys include Bap_main.Loggers() let anonymous_prefix = "__anonymous_sub%" diff --git a/plugins/report/report_main.ml b/plugins/report/report_main.ml index ca7f96c26..0ea1aa5c3 100644 --- a/plugins/report/report_main.ml +++ b/plugins/report/report_main.ml @@ -22,7 +22,7 @@ type tasks = slot String.Table.t let ping_frames = "|/-\\|/-\\" -let tasks = String.Table.create () +let tasks = Hashtbl.create (module String) let startup = Unix.gettimeofday () diff --git a/plugins/run/run_main.ml b/plugins/run/run_main.ml index f6b90c279..e32b263f4 100644 --- a/plugins/run/run_main.ml +++ b/plugins/run/run_main.ml @@ -145,10 +145,10 @@ let callgraph start prog = let all_subroutines ?(marked=false) prog = let entries = entry_points prog in let start = Tid.create () in - let roots = Tid.Set.of_list (start :: entries) in - let unmarked = if not marked then Tid.Set.empty else + let roots = Set.of_list (module Tid) (start :: entries) in + let unmarked = if not marked then (Set.empty (module Tid)) else Term.enum sub_t prog |> - Seq.fold ~init:Tid.Set.empty ~f:(fun unmarked sub -> + Seq.fold ~init:(Set.empty (module Tid)) ~f:(fun unmarked sub -> if Term.has_attr sub mark then unmarked else Set.add unmarked (Term.tid sub)) in let marked_non_root_to_entry t = diff --git a/plugins/strings/strings_main.ml b/plugins/strings/strings_main.ml index f11850517..3754499c3 100644 --- a/plugins/strings/strings_main.ml +++ b/plugins/strings/strings_main.ml @@ -22,7 +22,7 @@ let scan (mem,value) = | Error _ -> assert false | Ok n -> Some (Char.of_int_exn n) in Strings.Scanner.run ~read 0 |> - Seq.fold ~init:Addr.Map.empty ~f:(fun strs (off,str) -> + Seq.fold ~init:(Map.empty (module Addr)) ~f:(fun strs (off,str) -> Map.set strs ~key:(Addr.nsucc (Memory.min_addr mem) off) ~data:str) @@ -38,7 +38,7 @@ let union = Map.merge ~f:(fun ~key -> function let collect ~min_length proj = let ms = Project.memory proj |> Memmap.to_sequence in Seq.(ms >>| scan |> reduce ~f:union) |> function - | None -> Addr.Map.empty + | None -> (Map.empty (module Addr)) | Some strs -> Map.filteri strs ~f:(fun ~key ~data -> String.length data >= min_length) diff --git a/plugins/stub_resolver/stub_resolver.ml b/plugins/stub_resolver/stub_resolver.ml index 1b50f8751..a18068bdb 100644 --- a/plugins/stub_resolver/stub_resolver.ml +++ b/plugins/stub_resolver/stub_resolver.ml @@ -49,9 +49,9 @@ end let empty = { graph = G.empty; - names = String.Map.empty; - stubs = Tid.Set.empty; - units = Tid.Map.empty; + names = (Map.empty (module String)); + stubs = (Set.empty (module Tid)); + units = (Map.empty (module Tid)); } let in_file file f = @@ -115,7 +115,7 @@ let update_names t sub ~link_only ~no_link = let tid = Term.tid sub in let names = Set.fold aliases ~init:t.names ~f:(fun m a -> Map.update m a ~f:(function - | None -> Tid.Set.singleton tid + | None -> Set.singleton (module Tid) tid | Some s -> Set.add s tid)) in update_graph {t with names} (Sub.name sub) aliases else t @@ -127,7 +127,7 @@ let add t sub ~link_only ~no_link = let partition_group t group = Group.enum group |> - Seq.fold ~init:Tid.Set.empty ~f:(fun default name -> + Seq.fold ~init:(Set.empty (module Tid)) ~f:(fun default name -> Map.find t.names name |> Option.value_map ~default ~f:(Set.union default)) |> Set.partition_tf ~f:(Set.mem t.stubs) @@ -135,7 +135,7 @@ let partition_group t group = let find_pairs t = let pp = Group.pp String.pp in Graphlib.strong_components (module G) t.graph |> - Partition.groups |> Seq.fold ~init:Tid.Map.empty ~f:(fun init group -> + Partition.groups |> Seq.fold ~init:(Map.empty (module Tid)) ~f:(fun init group -> let stubs, reals = partition_group t group in match Set.length reals with | 1 -> @@ -195,8 +195,8 @@ let provide prog ~link_only ~no_link = KB.return obj let run - ?(link_only = String.Set.empty) - ?(no_link = String.Set.empty) + ?(link_only = Set.empty (module String)) + ?(no_link = Set.empty (module String)) prog = Toplevel.current () |> Knowledge.run Class.t (provide prog ~link_only ~no_link) |> function diff --git a/plugins/stub_resolver/stub_resolver_main.ml b/plugins/stub_resolver/stub_resolver_main.ml index d6a864bf0..f46877166 100644 --- a/plugins/stub_resolver/stub_resolver_main.ml +++ b/plugins/stub_resolver/stub_resolver_main.ml @@ -43,7 +43,7 @@ open Bap_core_theory open Bap_knowledge open Bap_main open KB.Syntax -module Sys = Caml.Sys +module Sys = Stdlib.Sys include Loggers() @@ -161,7 +161,7 @@ end = struct let stubs ctxt = List.fold (Extension.Configuration.get ctxt names) ~init:(Set.of_list (module String) known_stub_names) - ~f:(fun init -> List.fold ~init ~f:Set.add) + ~f:(fun init -> List.fold ~init ~f:(fun s x -> Set.add s x)) let create ctxt t doc = match Ogre.eval (collect t (stubs ctxt)) doc with | Ok plt -> plt @@ -232,7 +232,7 @@ end = struct let parse_file file = In_channel.read_lines file |> - List.foldi ~init:Word.Set.empty ~f:(fun number words line -> + List.foldi ~init:(Set.empty (module Word)) ~f:(fun number words line -> match parse_line line with | Empty | Comment -> words | Success word -> Set.add words word @@ -266,7 +266,7 @@ end = struct try Array.fold ~init:sigs (Sys.readdir folder) ~f:(fun sigs path -> add_file sigs (Filename.concat folder path)) with _ -> sigs in - List.fold ~init:Word.Set.empty paths ~f:(fun sigs path -> + List.fold ~init:(Set.empty (module Word)) paths ~f:(fun sigs path -> if Sys.file_exists path && Sys.is_directory path then add_files sigs path else add_file sigs path) @@ -364,10 +364,10 @@ let update prog ~link_only ~no_link = let resolver = Stub_resolver.run prog ~link_only ~no_link in let stubs = Stub_resolver.stubs resolver and links = Stub_resolver.links resolver in - let impls = Map.data links |> Tid.Set.of_list in + let impls = Map.data links |> Set.of_list (module Tid) in let stub_names = Term.enum sub_t prog |> - Seq.fold ~init:String.Set.empty ~f:(fun s sub -> + Seq.fold ~init:(Set.empty (module String)) ~f:(fun s sub -> if Set.mem stubs @@ Term.tid sub then Set.add s @@ Sub.name sub else s) in @@ -399,10 +399,10 @@ let update prog ~link_only ~no_link = let abi_pass ctxt = let link_only = - String.Set.of_list @@ + Set.of_list (module String) @@ Extension.Configuration.get ctxt link_only in let no_link = - String.Set.of_list @@ + Set.of_list (module String) @@ Extension.Configuration.get ctxt no_link in Project.map_program ~f:(update ~link_only ~no_link) diff --git a/plugins/thumb/thumb_branch.ml b/plugins/thumb/thumb_branch.ml index 16e933928..b0b92fbec 100644 --- a/plugins/thumb/thumb_branch.ml +++ b/plugins/thumb/thumb_branch.ml @@ -4,7 +4,7 @@ open KB.Syntax open Thumb_core -type eff = unit Theory.effect KB.t +type eff = unit Theory.eff0 KB.t let mask = W32.int32 0xffff_fffel diff --git a/plugins/thumb/thumb_branch.mli b/plugins/thumb/thumb_branch.mli index 932210e79..bbd9bed54 100644 --- a/plugins/thumb/thumb_branch.mli +++ b/plugins/thumb/thumb_branch.mli @@ -3,7 +3,7 @@ open Theory open Thumb_core open Thumb_opcodes -type eff = unit effect KB.t +type eff = unit Theory.eff0 KB.t module Make(CT : Theory.Core) : sig (** [b