├── tests ├── veri_test.mli ├── veri_policy_test.mli ├── veri_rule_test.mli ├── veri_stat_test.mli ├── run_veri.sh ├── run_pin.sh ├── run_tests.ml ├── veri_policy_test.ml ├── veri_rule_test.ml ├── veri_stat_test.ml └── veri_test.ml ├── lib ├── veri_tab.mli ├── veri_error.ml ├── veri_policy.mli ├── veri_report.mli ├── veri.mli ├── veri_traci.mli ├── veri_report.ml ├── veri_rule.mli ├── veri_stat.mli ├── veri_tab.ml ├── veri_traci.ml ├── veri_rule.ml ├── veri_policy.ml ├── veri_stat.ml └── veri.ml ├── .gitignore ├── .merlin ├── tools └── build_plugin.sh ├── Makefile ├── opam └── opam ├── rules ├── arm_qemu ├── x86 ├── x86_no_errors └── x86_qemu ├── plugin ├── veri_out.ml └── veri_bil.ml ├── _oasis └── README.md /tests/veri_test.mli: -------------------------------------------------------------------------------- 1 | 2 | val suite : unit -> OUnit2.test 3 | -------------------------------------------------------------------------------- /tests/veri_policy_test.mli: -------------------------------------------------------------------------------- 1 | 2 | val suite : unit -> OUnit2.test 3 | -------------------------------------------------------------------------------- /tests/veri_rule_test.mli: -------------------------------------------------------------------------------- 1 | 2 | val suite : unit -> OUnit2.test 3 | -------------------------------------------------------------------------------- /tests/veri_stat_test.mli: -------------------------------------------------------------------------------- 1 | 2 | val suite : unit -> OUnit2.test 3 | -------------------------------------------------------------------------------- /lib/veri_tab.mli: -------------------------------------------------------------------------------- 1 | 2 | type t 3 | 4 | val create : string list -> t 5 | 6 | val add_row : t -> string list -> t 7 | 8 | val pp : Format.formatter -> t -> unit 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.mldylib 2 | *.mllib 3 | *.byte 4 | *.native 5 | *.plugin 6 | /_build 7 | /plugin/_build 8 | /setup.data 9 | /setup.log 10 | /setup.ml 11 | /_tags 12 | *META 13 | /configure 14 | myocamlbuild.ml -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | B _build/lib 2 | B _build/src 3 | B _build/tests 4 | S lib 5 | S src 6 | S tests 7 | 8 | PKG core_kernel 9 | PKG cmdliner 10 | PKG oUnit 11 | PKG bap 12 | PKG bap-traces 13 | PKG bap-piqi-traces 14 | PKG pcre 15 | PKG textutils -------------------------------------------------------------------------------- /tests/run_veri.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | frames=$(find $1 -name "*.frames") 4 | for file in $frames 5 | do 6 | res=$(./bil-verification/veri_main.native --show-stat --rules bil-verification/rules/x86 $file) 7 | echo "$file : $res" 8 | done 9 | -------------------------------------------------------------------------------- /tests/run_pin.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | bpt=$HOME/factory/bap-pintraces/obj-intel64/bpt.so 4 | 5 | files=$(ls $1 | grep gcc | grep O0) 6 | 7 | for file in $files 8 | do 9 | echo $file 10 | input="$1$file" 11 | basename=${file##*/} 12 | output="$2$basename.frames" 13 | pin -injection child -t $bpt -o $output -- $input --help 1 > /dev/null 14 | done 15 | 16 | -------------------------------------------------------------------------------- /tools/build_plugin.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -ue 4 | 5 | plugin=bap_plugin_veri 6 | TMPDIR=`mktemp -d` 7 | cd $TMPDIR 8 | touch $plugin.ml 9 | bapbuild -package bap-plugin-veri $plugin.plugin 10 | DESC="verifies bap lifters" 11 | bapbundle update -name veri -desc "$DESC" -tags "verification" $plugin.plugin 12 | mv $plugin.plugin veri.plugin 13 | bapbundle install veri.plugin 14 | cd - 15 | rm -rf $TMPDIR 16 | -------------------------------------------------------------------------------- /lib/veri_error.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | 3 | type t = [ 4 | | `Overloaded_chunk (** chunk contains more then one instruction *) 5 | | `Damaged_chunk of Error.t (** chunk data can't be transformed to memory *) 6 | | `Disasm_error of Error.t (** chunk data can't be disasmed *) 7 | | `Lifter_error of string * Error.t (** chunk data can't be lifted *) 8 | ] [@@deriving bin_io, compare, sexp] 9 | -------------------------------------------------------------------------------- /tests/run_tests.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open OUnit2 3 | open Bap_main 4 | 5 | let suite () = 6 | "Bap-veri" >::: [ 7 | Veri_test.suite (); 8 | Veri_policy_test.suite (); 9 | Veri_rule_test.suite (); 10 | Veri_stat_test.suite (); 11 | ] 12 | 13 | let () = 14 | let _ = 15 | match Bap_main.init ~name:"veri-runtests" () 16 | with Ok () -> () 17 | | Error err -> 18 | Format.eprintf "Program failed with: %a@\n%!" 19 | Extension.Error.pp err in 20 | run_test_tt_main (suite ()) 21 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build install uninstall clean 2 | 3 | build: 4 | oasis setup 5 | ocaml setup.ml -configure --prefix=`opam config var prefix` 6 | ocaml setup.ml -build 7 | 8 | install: install_plugin 9 | 10 | uninstall: 11 | ocamlfind remove bap-veri 12 | ocamlfind remove bap-plugin-veri 13 | bapbundle remove veri.plugin 14 | 15 | clean: 16 | git clean -fdX 17 | 18 | install_libs: 19 | ocaml setup.ml -install 20 | 21 | install_plugin: install_libs 22 | sh tools/build_plugin.sh 23 | 24 | test: 25 | oasis setup 26 | ocaml setup.ml -configure --prefix=`opam config var prefix` --enable-tests 27 | ocaml setup.ml -build 28 | ocaml setup.ml -install 29 | ocaml setup.ml -test 30 | 31 | reinstall: uninstall install 32 | -------------------------------------------------------------------------------- /lib/veri_policy.mli: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Bap.Std 3 | open Bap_traces.Std 4 | open Regular.Std 5 | 6 | type event = Trace.event 7 | type events = Value.Set.t 8 | type rule = Veri_rule.t 9 | 10 | module Matched : sig 11 | type t = event list * event list [@@deriving bin_io, compare, sexp] 12 | include Regular.S with type t := t 13 | end 14 | 15 | type matched = Matched.t [@@deriving bin_io, compare, sexp] 16 | type t [@@deriving bin_io, compare, sexp] 17 | 18 | val empty : t 19 | val add : t -> rule -> t 20 | 21 | (** [match events rule insn left right] *) 22 | val match_events: rule -> string -> events -> events -> matched option 23 | 24 | (** [denied policy insn left right] *) 25 | val denied: t -> string -> events -> events -> (rule * matched) list 26 | -------------------------------------------------------------------------------- /lib/veri_report.mli: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Bap.Std 3 | open Bap_traces.Std 4 | open Regular.Std 5 | 6 | type event = Trace.event [@@deriving bin_io, compare, sexp] 7 | type matched = Veri_policy.matched [@@deriving bin_io, compare, sexp] 8 | type rule = Veri_rule.t [@@deriving bin_io, compare, sexp] 9 | 10 | type t [@@deriving bin_io, sexp] 11 | include Regular.S with type t := t 12 | 13 | val create : 14 | bil:Bap.Std.bil -> 15 | insn:string -> 16 | code:string -> 17 | mode: Mode.t option -> 18 | left:event list -> 19 | right:event list -> 20 | data:(rule * matched) list -> t 21 | 22 | val bil : t -> bil 23 | val code : t -> string 24 | val mode : t -> Mode.t option 25 | val insn : t -> string 26 | val left : t -> Trace.event list 27 | val right: t -> Trace.event list 28 | val data : t -> (Veri_policy.rule * Veri_policy.matched) list 29 | -------------------------------------------------------------------------------- /opam/opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "bap-veri" 3 | version: "master" 4 | maintainer: "Ivan Gotovchits " 5 | authors: "BAP Team" 6 | license: "MIT" 7 | homepage: "https://github.com/BinaryAnalysisPlatform/bap-veri/" 8 | bug-reports: "https://github.com/BinaryAnalysisPlatform/bap-veri/issues" 9 | depends: [ 10 | "ocaml" {>= "4.07.0"} 11 | "bap" 12 | "oasis" {build} 13 | "ounit" 14 | "pcre" 15 | "textutils_kernel" 16 | "uri" 17 | ] 18 | flags: light-uninstall 19 | build: [ 20 | [make] 21 | ] 22 | install: [make "install"] 23 | remove: [ 24 | ["ocamlfind" "remove" "bap-veri"] 25 | ] 26 | dev-repo: "git://github.com/BinaryAnalysisPlatform/bap-veri/" 27 | 28 | synopsis: "BAP verification tool" 29 | description:""" 30 | compares results of instructions execution in trace with execution of BIL code, 31 | that describes this instructions """ 32 | -------------------------------------------------------------------------------- /rules/arm_qemu: -------------------------------------------------------------------------------- 1 | # skipping context switch events 2 | SKIP .* 'context-switch.*' '' 3 | 4 | # ignore all ours unmatched reads 5 | SKIP .* '' '.* => .*' 6 | 7 | SKIP .* '' '.F => .*' 8 | SKIP .* '' '.F <= .*' 9 | SKIP .* '.F <= .*' '' 10 | SKIP .* '.F => .*' '' 11 | SKIP .* 'GE <= .*' '' 12 | SKIP .* 'GE => .*' '' 13 | 14 | SKIP .* 'PC => .*' '' 15 | 16 | ## Kernel-provided User Helpers 17 | # See https://www.kernel.org/doc/Documentation/arm/kernel_user_helpers.txt 18 | 19 | # kuser_helper_version 20 | SKIP .* 'pc-update: .*' 'pc-update: 0xFFFF0FFC' 21 | # kuser_get_tls 22 | SKIP .* 'pc-update: .*' 'pc-update: 0xFFFF0FE0' 23 | # kuser_cmpxchg 24 | SKIP .* 'pc-update: .*' 'pc-update: 0xFFFF0FC0' 25 | # kuser_memory_barrier 26 | SKIP .* 'pc-update: .*' 'pc-update: 0xFFFF0FA0' 27 | # kuser_cmpxchg64 28 | SKIP .* 'pc-update: .*' 'pc-update: 0xFFFF0F60' 29 | 30 | 31 | # Last rules mean that every event should have a pair 32 | DENY .* '.*' '' 33 | DENY .* '' '.*' 34 | -------------------------------------------------------------------------------- /rules/x86: -------------------------------------------------------------------------------- 1 | 2 | # skipping modload and context switch events 3 | SKIP .* '.*: .* - .*' '' 4 | SKIP .* 'context-switch.*' '' 5 | 6 | # ignore all ours unmatched reads 7 | SKIP .* '' '.* => .*' 8 | 9 | # OR insn contains an unmatched read at left side, 10 | # e.g. when an argument is (imm -1) 11 | SKIP OR* '.* => .*' '' 12 | 13 | # XOR contains an unmatched read at left side when 14 | # operands are the same 15 | SKIP XOR* '.* => .*' '' 16 | 17 | # insn contains a conditional branch. As a result, in tracer, 18 | # if a condition is not satisfied then the same value 19 | # is written (the same as was read). 20 | SKIP CMPXCHG.* '.* <= .*' '' 21 | 22 | # LEAVE insn has additional read from RSP in our tracer 23 | SKIP LEAVE.* 'RSP => .*' '' 24 | 25 | # Our flags reads(writes) should be subset of tracer 26 | # reads(writes). But writes should be with same value 27 | SKIP .* '.F => .*' '' 28 | DENY .* '(.F) <= .*' '\1 <= .*' 29 | SKIP .* '.F <= .*' '' 30 | 31 | # Last rules mean that every event should have a pair 32 | DENY .* '.*' '' 33 | DENY .* '' '.*' 34 | -------------------------------------------------------------------------------- /lib/veri.mli: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Bap.Std 3 | open Regular.Std 4 | open Bap_traces.Std 5 | open Bap_future.Std 6 | 7 | module Disasm : sig 8 | module Dis = Disasm_expert.Basic 9 | open Dis 10 | type t = (asm, kinds) Dis.t 11 | end 12 | 13 | class context: Veri_stat.t -> Veri_policy.t -> Trace.t -> object('s) 14 | inherit Veri_traci.context 15 | method split : 's 16 | method merge : 's 17 | method other : 's option 18 | method save: 's -> 's 19 | method switch: 's 20 | method stat : Veri_stat.t 21 | method code : Chunk.t option 22 | method mode : Mode.t option 23 | method events : Value.Set.t 24 | method reports : Veri_report.t stream 25 | method register_event : Trace.event -> 's 26 | method notify_error: Veri_error.t -> 's 27 | method set_bil : bil -> 's 28 | method set_code : Chunk.t -> 's 29 | method set_mode : Mode.t -> 's 30 | method set_insn: string -> 's 31 | method drop_pc : 's 32 | end 33 | 34 | class ['a] t : arch -> object('s) 35 | constraint 'a = #context 36 | inherit ['a] Veri_traci.t 37 | end 38 | -------------------------------------------------------------------------------- /lib/veri_traci.mli: -------------------------------------------------------------------------------- 1 | open Bap.Std 2 | open Bap_traces.Std 3 | 4 | type 'a u = 'a Bil.Result.u [@@warning "-D"] 5 | type event = Trace.event 6 | 7 | class context : Trace.t -> object('s) 8 | inherit Bili.context [@@warning "-D"] 9 | method next_event: ('s * event) option 10 | method with_events: Trace.t -> 's 11 | end 12 | 13 | 14 | class ['a] t: arch -> object('s) 15 | constraint 'a = #context 16 | inherit ['a] Bili.t [@@warning "-D"] 17 | method eval_trace : Trace.t -> 'a u 18 | method eval_event : event -> 'a u 19 | method eval_memory_load : addr move -> 'a u 20 | method eval_memory_store : addr move -> 'a u 21 | method eval_register_read : var move -> 'a u 22 | method eval_register_write : var move -> 'a u 23 | method eval_exec : chunk -> 'a u 24 | method eval_pc_update : addr -> 'a u 25 | method eval_context_switch : int -> 'a u 26 | method eval_mode: Mode.t -> 'a u 27 | method eval_syscall : syscall -> 'a u 28 | method eval_exn : exn -> 'a u 29 | method eval_call : call -> 'a u 30 | method eval_return : return -> 'a u 31 | method eval_modload : modload -> 'a u 32 | end 33 | -------------------------------------------------------------------------------- /plugin/veri_out.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Text_block 3 | 4 | module Abs = Veri_stat.Abs 5 | module Rel = Veri_stat.Rel 6 | 7 | let make_iota max = 8 | let rec make acc n = 9 | if n < 0 then acc 10 | else make (n :: acc) (n - 1) in 11 | make [] (max - 1) 12 | 13 | let make_col title to_string vals = 14 | vcat ~align:`Center (text title :: List.map ~f:(fun x -> text (to_string x)) vals) 15 | 16 | let texts_col title vals = make_col title Fn.id vals 17 | let intgr_col title vals = make_col title (Printf.sprintf "%d") vals 18 | let float_col title vals = make_col title (Printf.sprintf "%.2f") vals 19 | 20 | let output stats path = 21 | let of_stats f = List.map ~f stats in 22 | let of_stats' f = List.map ~f:(fun x -> f (snd x)) stats in 23 | let out = Out_channel.create path in 24 | let cnter = intgr_col "#" (make_iota (List.length stats)) in 25 | let names = texts_col "file" (of_stats fst) in 26 | let total = intgr_col "total" (of_stats' Abs.total) in 27 | let as_percents = true in 28 | let prcnt = List.map 29 | ~f:(fun (name, f) -> float_col name (of_stats' f)) 30 | [ "successed, %", Rel.successed ~as_percents; 31 | "misexecuted, %", Rel.misexecuted ~as_percents; 32 | "overloaded, %", Rel.overloaded ~as_percents; 33 | "damaged, %", Rel.damaged ~as_percents; 34 | "undisasmed, %", Rel.undisasmed ~as_percents; 35 | "mislifted, %", Rel.mislifted ~as_percents; ] in 36 | let tab = hcat ~sep:(text " | ") ([cnter; names; total] @ prcnt) in 37 | Out_channel.output_string out (render tab); 38 | Out_channel.close out 39 | -------------------------------------------------------------------------------- /rules/x86_no_errors: -------------------------------------------------------------------------------- 1 | # we completle ignore the following because bil is either empty, 2 | # either contains unknown expressions or special statements 3 | 4 | # skipping modload events 5 | SKIP .* '.*: .* - .*' '' 6 | 7 | # skipping context switch events 8 | SKIP .* 'context-switch.*' '' 9 | 10 | SKIP NOOP. '' '' 11 | SKIP RDTSC '' '' 12 | SKIP SYSCALL.* '' '' 13 | SKIP CPUID '' '' 14 | SKIP XGETBV '' '' 15 | 16 | #this one doesn't perform any write operation in our lifter 17 | #SKIP FNSTCW16m '' '' 18 | 19 | #differences in ZF flag writing 20 | SKIP TZCNT64rr 'ZF <= .*' 'ZF <= .*' 21 | 22 | # SAR is suspected to be broken in our lifter, because of different 23 | # results with tracer 24 | SKIP SAR.* '' '' 25 | 26 | # XOR is suspected to be broken, because in case of same operands, 27 | # e.g. RAX and RAX, it reads nothing, just write zero to destination 28 | SKIP XOR.* '.* => .*' '' 29 | 30 | # There are a wrong flags reads in our lifter. 31 | SKIP SH(L|R).* '' '.F => .*' 32 | 33 | # CMOV in our lifter works a bit unstrict. It reads and writes the same value 34 | # if condition wasn't succeded. 35 | SKIP CMOV.* '' '.*' 36 | 37 | # insn contains a conditional branch. As a result, in tracer, 38 | # if a condition is not satisfied then the same value 39 | # is written (the same as was read). 40 | SKIP CMPXCHG.* '.* <= .*' '' 41 | 42 | # LEAVE insn has additional read from RSP in our tracer 43 | SKIP LEAVE.* 'RSP => .*' '' 44 | 45 | # Our flags reads(writes) should be subset of tracer 46 | # reads(writes). But writes should be with same value 47 | SKIP .* '.F => .*' '' 48 | DENY .* '(.F) <= .*' '\1 <= .*' 49 | SKIP .* '.F <= .*' '' 50 | 51 | # The last two rules mean that every event should have a pair 52 | DENY .* '.*' '' 53 | DENY .* '' '.*' 54 | -------------------------------------------------------------------------------- /lib/veri_report.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Bap.Std 3 | open Bap_traces.Std 4 | open Regular.Std 5 | 6 | type event = Trace.event [@@deriving bin_io, compare, sexp] 7 | type rule = Veri_rule.t [@@deriving bin_io, compare, sexp] 8 | type matched = Veri_policy.matched [@@deriving bin_io, compare, sexp] 9 | 10 | type t = { 11 | bil : bil; 12 | insn : string; 13 | code : string; 14 | mode : Mode.t option; 15 | left : event list; 16 | right: event list; 17 | data : (rule * matched) list; 18 | } [@@deriving bin_io, compare, fields, sexp] 19 | 20 | let create = Fields.create 21 | 22 | include Regular.Make(struct 23 | type nonrec t = t [@@deriving bin_io, compare, sexp] 24 | 25 | let compare = compare 26 | let hash = Hashtbl.hash 27 | let module_name = Some "Veri.Report" 28 | let version = "0.1" 29 | 30 | let pp_code fmt s = 31 | let pp fmt s = 32 | String.iter ~f:(fun c -> Format.fprintf fmt "%02X " (Char.to_int c)) s in 33 | Format.fprintf fmt "@[%a@]" pp s 34 | 35 | let pp_mode fmt = function 36 | | Some m -> Format.fprintf fmt "(%a)" Mode.pp m 37 | | None -> () 38 | 39 | let pp_evs fmt evs = 40 | List.iter ~f:(fun ev -> 41 | Format.(fprintf std_formatter "%a; " Value.pp ev)) evs 42 | 43 | let pp_data fmt (rule, matched) = 44 | let open Veri_policy in 45 | Format.fprintf fmt "%a\n%a" Veri_rule.pp rule Matched.pp matched 46 | 47 | let pp fmt t = 48 | let bil = Stmt.simpl t.bil in 49 | Format.fprintf fmt "@[%s %a%a@,left: %a@,right: %a@,%a@]@." 50 | t.insn pp_code t.code pp_mode t.mode pp_evs t.left pp_evs t.right Bil.pp bil; 51 | List.iter ~f:(pp_data fmt) t.data; 52 | Format.print_newline () 53 | 54 | end) 55 | -------------------------------------------------------------------------------- /tests/veri_policy_test.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open OUnit2 3 | open Bap.Std 4 | open Bap_future.Std 5 | open Bap_traces.Std 6 | open Event 7 | 8 | module Policy = Veri_policy 9 | module Rule = Veri_rule 10 | module Events = Value.Set 11 | 12 | (** this implies, that right reads should be subset of left reads and 13 | right writes should be subset of left writes *) 14 | let rule_with_skip = Rule.create_exn Rule.skip ~left:".F => .*" 15 | let rule_with_deny = Rule.create_exn Rule.deny ~left:"(.F) <= .*" ~right:"\\1 <= .*" 16 | let rule_with_skip' = Rule.create_exn Rule.skip ~left:".F <= .*" 17 | let policy = 18 | let add rule policy = Policy.add policy rule in 19 | add rule_with_skip Policy.empty |> add rule_with_deny |> add rule_with_skip' 20 | 21 | let make_flag var_name flag = 22 | let var = Var.create var_name (Type.Imm 1) in 23 | let data' = if flag then Word.b1 else Word.b0 in 24 | Value.create register_write (Move.({cell = var; data = data';})) 25 | 26 | let flag = make_flag "CF" true 27 | let flag' = make_flag "CF" false 28 | 29 | let events_equal x y = 30 | List.length x = List.length y && 31 | List.for_all x ~f:(fun e -> List.mem y e ~equal:Value.equal) 32 | 33 | let test_denied ctxt = 34 | let left = Events.of_list [make_flag "OF" true; flag; make_flag "SF" true] in 35 | let right = Events.of_list [make_flag "OF" true; flag'] in 36 | match Policy.denied policy "some insn" left right with 37 | | [] -> assert_failure "match result is empty" 38 | | (rule, (left', right')) :: [] -> 39 | assert_equal ~ctxt ~cmp:Rule.equal rule rule_with_deny; 40 | assert_equal ~cmp:events_equal ~ctxt [flag] left'; 41 | assert_equal ~cmp:events_equal ~ctxt [flag'] right' 42 | | res -> assert_failure "match result is unexpectable long" 43 | 44 | let suite () = 45 | "Veri rule test" >::: [ 46 | "denied" >:: test_denied; 47 | ] 48 | -------------------------------------------------------------------------------- /lib/veri_rule.mli: -------------------------------------------------------------------------------- 1 | (** rule = ACTION : INSN : EVENT : EVENT *) 2 | 3 | open Core_kernel[@@warning "-D"] 4 | open Regular.Std 5 | 6 | type t [@@deriving bin_io, compare, sexp] 7 | type action [@@deriving bin_io, compare, sexp] 8 | type field 9 | include Regular.S with type t := t 10 | 11 | (** [create ~insn ~left ~right action] - returns a rule, 12 | if all of fields {insn, left, right} either contains 13 | correct regular expression, either plain string, either 14 | are an empty strings. If some field is not given, it's 15 | assumed that an empty string fits well for this field. *) 16 | val create : 17 | ?insn:string -> ?left:string -> ?right:string -> action -> t Or_error.t 18 | 19 | exception Bad_field of string 20 | 21 | (** [create_exn ~insn ~left ~right action] - the same as above, but raises 22 | Bad_field exception if fields contains errors in regular expressions *) 23 | val create_exn : ?insn:string -> ?left:string -> ?right:string -> action -> t 24 | 25 | (** [of_string_err str] - return a rule, if string contains exactly 4 fields: 26 | - action (with only two possible values: SKIP | DENY) 27 | - instruction name or correct regular expression 28 | - one of the following: 29 | correct regular expression for left part and empty string for right part; 30 | empty string for left part and correct regular expression for right part; 31 | correct regular expression for both left and right parts. *) 32 | val of_string_err : string -> t Or_error.t 33 | 34 | val skip : action 35 | val deny : action 36 | 37 | val action : t -> action 38 | val insn : t -> field 39 | val left : t -> field 40 | val right : t -> field 41 | 42 | val is_empty : field -> bool 43 | 44 | (** [match_field t field str] - match a given string with a field. *) 45 | val match_field: t -> [`Insn | `Left | `Right | `Both] -> string -> bool 46 | -------------------------------------------------------------------------------- /rules/x86_qemu: -------------------------------------------------------------------------------- 1 | # we completle ignore the following because bil is either empty, 2 | # either contains unknown expressions or special statements 3 | 4 | # skipping modload events 5 | SKIP .* '.*: .* - .*' '' 6 | 7 | # skipping context switch events 8 | SKIP .* 'context-switch.*' '' 9 | 10 | # ignore all ours unmatched reads 11 | SKIP .* '' '.* => .*' 12 | 13 | # OR insn contains an unmatched read at left side, 14 | # e.g. when an argument is (imm -1) 15 | SKIP OR* '.* => .*' '' 16 | 17 | # XOR contains an unmatched read at left side when 18 | # operands are the same 19 | SKIP XOR* '.* => .*' '' 20 | 21 | # for some reasons qemu doesn't write to destination 22 | SKIP IMUL.* '' '.* <= .*' 23 | SKIP MUL.* '' '.* <= .*' 24 | SKIP DIV.* '' '.* <= .*' 25 | 26 | # skipping flags 27 | SKIP .* '.FLAGS.*' '' 28 | SKIP .* '' '.F => .*' 29 | SKIP .* '' '.F <= .*' 30 | 31 | # we can't rely on SHR8ri events, since in qemu there are two 32 | # sequential reads of source operand, e.g. RAX => 0x10; RAX => 0x1 33 | # so we can't figure out what exactly we should to shift. 34 | # And we have event mismatchig because of this, so we ignore this 35 | # instruction. 36 | SKIP SHR8ri '' '' 37 | 38 | # skip instructions, whose side effect depends on flags 39 | SKIP JE_1 .* .* 40 | SKIP JBE_1 .* .* 41 | SKIP JNE_1 .* .* 42 | SKIP JNE_4 .* .* 43 | 44 | # tracer produces wrong reads/writes when operand size 45 | # lesser then current mode bitwidth 46 | SKIP .* '(.*) <= 0x.+(.*)' '\1 <= \2' 47 | SKIP .* '(.*) => 0x.+(.*)' '\1 => \2' 48 | 49 | # qemu contains some addition readings even in write operations 50 | SKIP .* '.* => .*' '' 51 | 52 | # tracer produces extra zero writes/reads when operands size 53 | # lesser then current mode bitwidth, e.g. Mov8mi 54 | SKIP .* '.* => 0$' '' 55 | SKIP .* '.* <= 0$' '' 56 | 57 | # These rules mean that every event should have a pair 58 | DENY .* '.*' '' 59 | DENY .* '' '.*' 60 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: bap-veri 3 | Version: 0.2 4 | Synopsis: Bil verification tool 5 | Authors: BAP Team 6 | Maintainers: Ivan Gotovchits , 7 | Oleg Kamenkov 8 | License: MIT 9 | Copyrights: (C) 2016 Carnegie Mellon University 10 | Plugins: META (0.4) 11 | BuildTools: ocamlbuild 12 | BuildDepends: ppx_jane, core_kernel, bap, bap-traces, threads 13 | 14 | Library veri 15 | Path: lib 16 | FindLibName: bap-veri 17 | Modules: Veri, 18 | Veri_error, 19 | Veri_policy, 20 | Veri_report, 21 | Veri_rule, 22 | Veri_stat, 23 | Veri_tab, 24 | Veri_traci 25 | CompiledObject: best 26 | Install: true 27 | BuildDepends: bap-core-theory, pcre, graphlib, monads 28 | 29 | Library veri_plugin 30 | Path: plugin 31 | FindLibName: bap-plugin-veri 32 | InternalModules: Veri_bil, Veri_out 33 | CompiledObject: best 34 | Install: true 35 | BuildDepends: bap-main, bap-veri, bap-future, pcre, textutils_kernel.text_block, monads 36 | 37 | Library veri_test 38 | Path: tests 39 | Build$: flag(tests) 40 | Install: false 41 | CompiledObject: best 42 | Modules: Veri_test, 43 | Veri_policy_test, 44 | Veri_rule_test, 45 | Veri_stat_test 46 | BuildDepends: bap-veri, oUnit 47 | 48 | Executable run_tests 49 | Path: tests 50 | MainIs: run_tests.ml 51 | Install: false 52 | Build$: flag(tests) 53 | CompiledObject: best 54 | BuildDepends: monads, bap-main, veri_test, oUnit, findlib.dynload 55 | 56 | Test veri_test 57 | TestTools: run_tests 58 | Run$: flag(tests) 59 | Command: $run_tests -runner sequential 60 | -------------------------------------------------------------------------------- /lib/veri_stat.mli: -------------------------------------------------------------------------------- 1 | 2 | open Regular.Std 3 | type t [@@deriving bin_io, sexp] 4 | type stat = t [@@deriving bin_io, sexp] 5 | 6 | val empty : t 7 | val merge : t list -> t 8 | val notify : t -> Veri_error.t -> t 9 | val failbil : t -> string -> t 10 | val success : t -> string -> t 11 | 12 | val pp_summary: Format.formatter -> t -> unit 13 | 14 | include Regular.S with type t := t 15 | 16 | (** Terms: 17 | successed - instructions, that were successfuly lifted and evaluted 18 | without any divergence from trace at least once (or more); 19 | misexecuted - instructions, that were successfuly lifted and evaluted 20 | with divergence from trace at least once (or more); 21 | abs_successed - the same as successed but no divergences has occured 22 | abs_misexecuted - the same as misexecuted but haven't any successfully 23 | matches with trace at all; 24 | mislifted - instructions, that weren't recognized by lifter; 25 | overloaded - chunks that contains more that one instruction; 26 | damaged - chunks that failed to be represented as memory; 27 | undisasmed - chunks that were represented as memory, but failed to 28 | be disasmed; 29 | total - whole count of cases above *) 30 | 31 | (** absolute counts *) 32 | module Abs : sig 33 | type t = stat -> int 34 | val successed : t 35 | val abs_successed : t 36 | val misexecuted : t 37 | val abs_misexecuted : t 38 | val overloaded : t 39 | val damaged : t 40 | val undisasmed : t 41 | val mislifted : t 42 | val total : t 43 | end 44 | 45 | (** relative to total count *) 46 | module Rel : sig 47 | type t = ?as_percents:bool -> stat -> float 48 | val successed : t 49 | val abs_successed : t 50 | val misexecuted : t 51 | val abs_misexecuted : t 52 | val overloaded : t 53 | val damaged : t 54 | val undisasmed : t 55 | val mislifted : t 56 | end 57 | 58 | (** instruction names *) 59 | module Names : sig 60 | type t = stat -> string list 61 | val successed : t 62 | val abs_successed : t 63 | val misexecuted : t 64 | val abs_misexecuted : t 65 | val mislifted : t 66 | end 67 | -------------------------------------------------------------------------------- /lib/veri_tab.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | 3 | 4 | type t = { 5 | cols : int; 6 | rows : int; 7 | data : (string * string list) Int.Map.t; 8 | } 9 | 10 | let create headers = { 11 | cols = 0; 12 | rows = 0; 13 | data = 14 | List.foldi headers ~init:(Map.empty (module Int)) 15 | ~f:(fun i tab hd -> 16 | let hd = sprintf " %s " hd in 17 | Map.set tab ~key:i ~data:(hd,[])); 18 | } 19 | 20 | 21 | let add_row t data = { 22 | cols = max t.cols (List.length data); 23 | rows = t.rows + 1; 24 | data = 25 | List.foldi data ~init:t.data ~f:(fun i tab cell -> 26 | Map.change tab i ~f:(function 27 | | None -> None 28 | | Some (hd,cells) -> Some (hd, sprintf " %s " cell :: cells))); 29 | } 30 | 31 | let pp fmt t = 32 | let total, widths = 33 | Map.fold t.data ~init:(0,[]) ~f:(fun ~key:i ~data:(header,cells) (total,acc) -> 34 | let max_len = List.fold (header::cells) ~init:0 35 | ~f:(fun len x -> 36 | let len' = String.length x in 37 | if len' > len then len' else len) in 38 | total + max_len, (i,max_len) :: acc) in 39 | let col_width i = List.Assoc.find_exn widths i ~equal:Int.equal in 40 | let print_cell ?(term='|') i cell = 41 | let w = col_width i in 42 | let w' = String.length cell in 43 | let spaces = String.init (w - w') ~f:(fun _ -> ' ') in 44 | Format.fprintf fmt "%s%s%c" cell spaces term in 45 | let cell col_i row_j = 46 | let _, data = Map.find_exn t.data col_i in 47 | match List.nth (List.rev data) row_j with 48 | | None -> "-" 49 | | Some x -> x in 50 | let rows = List.init t.rows ~f:Fn.id in 51 | let cols = List.init t.cols ~f:Fn.id in 52 | let barrier = String.init (total + t.cols - 1) ~f:(fun _ -> '-') in 53 | Format.fprintf fmt "|%s|\n|" barrier; 54 | Map.iteri t.data ~f:(fun ~key:i ~data:(header,_) -> print_cell i header); 55 | Format.fprintf fmt "\n|"; 56 | Map.iteri t.data ~f:(fun ~key:i ~data:_ -> 57 | let line = String.init (col_width i) ~f:(fun _ -> '-') in 58 | let term = if i + 1 = t.cols then '|' else '+' in 59 | print_cell ~term i line); 60 | Format.fprintf fmt "\n|"; 61 | List.iter rows ~f:(fun row_i -> 62 | List.iter cols ~f:(fun col_i -> 63 | let cell = cell col_i row_i in 64 | print_cell col_i cell); 65 | Format.fprintf fmt "\n|"); 66 | Format.fprintf fmt "%s|\n%!" barrier 67 | -------------------------------------------------------------------------------- /tests/veri_rule_test.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open OUnit2 3 | 4 | module Rule = Veri_rule 5 | 6 | let assert_ok descr r = assert_bool descr (Result.is_ok r) 7 | let assert_er descr r = assert_bool descr (Result.is_error r) 8 | 9 | let test_create ctxt = 10 | let insn = "MOV32rr" in 11 | assert_ok "abs empty" (Rule.create Rule.skip); 12 | assert_ok "only insn" (Rule.create ~insn Rule.skip); 13 | assert_ok "only left part" (Rule.create ~left:insn Rule.skip); 14 | assert_ok "only right part" (Rule.create ~right:insn Rule.skip); 15 | assert_ok "left and right" (Rule.create ~left:insn ~right:insn Rule.skip); 16 | assert_ok "regexp on right" (Rule.create ~insn:".*" ~left:insn ~right:".F => .*" Rule.skip); 17 | assert_ok "regexp in insn" (Rule.create ~insn:".*" ~left:".F => .*" Rule.skip); 18 | assert_ok "backref regexp" (Rule.create ~insn:".*" ~left:"(.F) <= .*" ~right:"\\1 <= .*" Rule.skip); 19 | assert_er "error in regexp" (Rule.create ~insn:".*" ~right:"\\1 <= .*" Rule.skip) 20 | 21 | let test_create_exn ctxt = 22 | let f () = Rule.create_exn ~insn:".*" ~right:"\\1 <= .*" Rule.skip in 23 | assert_raises ~msg:"Bad field not raised!" 24 | (Rule.Bad_field "error in field \\1 <= .*") f 25 | 26 | let test_of_string ctxt = 27 | assert_ok "" (Rule.of_string_err "SKIP .* '.F => .*' ''"); 28 | assert_ok "" (Rule.of_string_err "DENY .* '(.F) <= .*' '\\1 <= .*'"); 29 | assert_ok "" (Rule.of_string_err "SKIP .* '.F <= .*' ''"); 30 | assert_er "" (Rule.of_string_err "SOME_ACTION .* '.F <= .*' ''") 31 | 32 | let test_match ctxt = 33 | let base_assert what descr rule field str = 34 | let res = Rule.match_field rule field str in 35 | match what with 36 | | `Expect_ok -> assert_bool descr res 37 | | `Expect_er -> assert_bool descr (not res) in 38 | let assert_match = base_assert `Expect_ok in 39 | let assert_mismatch = base_assert `Expect_er in 40 | assert_match "empty rule" (Rule.create_exn Rule.skip) `Insn "MOV32rr"; 41 | assert_mismatch "other insn" (Rule.create_exn Rule.skip ~insn:"MOV64rr") `Insn "MOV32rr"; 42 | assert_match "any insn" (Rule.create_exn Rule.skip ~insn:".*") `Insn "MOV32rr"; 43 | assert_match "any left" (Rule.create_exn Rule.skip ~left:".*") `Left "ESP <= 0xC0FFEE"; 44 | assert_match "any right" (Rule.create_exn Rule.skip ~right:".*") `Right "ESP <= 0xC0FFEE"; 45 | assert_match "empty field" (Rule.create_exn Rule.skip ~right:".*") `Left "ESP <= 0xC0FFEE"; 46 | assert_match "backref match" 47 | (Rule.create_exn Rule.skip ~left:"(.SP) <= 0xC0FFEE" ~right:"\\1 <= .*") 48 | `Both "ESP <= 0xC0FFEE ESP <= 0xBED"; 49 | assert_mismatch "backref mismatch" 50 | (Rule.create_exn Rule.skip ~left:"(.F) <= (.*)" ~right:"\\1 <= \\2") 51 | `Both "OF <= 0x1 OF <= 0x0" 52 | 53 | let suite () = 54 | "Veri rule test" >::: 55 | [ 56 | "create" >:: test_create; 57 | "create exn" >:: test_create_exn; 58 | "of_string" >:: test_of_string; 59 | "match" >:: test_match; 60 | ] 61 | -------------------------------------------------------------------------------- /lib/veri_traci.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Bap.Std 3 | open Bap_traces.Std 4 | open Monads.Std 5 | 6 | module SM = Monad.State 7 | open SM.Monad_infix 8 | 9 | type 'a u = 'a Bil.Result.u [@@warning "-D"] 10 | type event = Trace.event 11 | 12 | let stub = fun _ -> SM.return () 13 | 14 | class context trace = 15 | object(self:'s) 16 | inherit Bili.context [@@warning "-D"] 17 | val events = Trace.read_events trace 18 | method next_event = match Seq.next events with 19 | | None -> None 20 | | Some (ev,evs) -> Some ({}, ev) 21 | 22 | method with_events trace = {} 23 | end 24 | [@@warning "-D"] 25 | 26 | let data_size mv = 27 | Word.bitwidth (Move.data mv) |> Size.of_int_opt 28 | 29 | let mem_of_arch arch = 30 | let (module T : Target) = target_of_arch arch in 31 | T.CPU.mem 32 | 33 | class ['a] t arch = 34 | let mem_var = mem_of_arch arch in 35 | let mem = Bil.var mem_var in 36 | let endian = Arch.endian arch in 37 | object(self) 38 | constraint 'a = #context 39 | inherit ['a] Bili.t as super [@@warning "-D"] 40 | 41 | method eval_memory_store mv = 42 | match data_size mv with 43 | | None -> SM.return () 44 | | Some size -> 45 | let addr = Bil.int (Move.cell mv) in 46 | let data = Bil.int (Move.data mv) in 47 | let exp = Bil.store ~mem ~addr data endian size in 48 | self#eval_exp exp >>= fun r -> 49 | SM.update (fun c -> c#update mem_var r) 50 | 51 | method eval_register_write mv = 52 | self#eval_move (Move.cell mv) (Bil.int (Move.data mv)) 53 | 54 | method eval_pc_update addr = 55 | SM.update (fun c -> c#with_pc (Bil.Imm addr)) 56 | 57 | method eval_memory_load mv = 58 | match data_size mv with 59 | | None -> SM.return () 60 | | Some size -> 61 | let addr = Bil.int (Move.cell mv) in 62 | let exp = Bil.load ~mem ~addr endian size in 63 | self#eval_exp exp >>| ignore 64 | 65 | method eval_register_read mv = 66 | self#lookup (Move.cell mv) >>| ignore 67 | 68 | method eval_exn exn = 69 | self#eval_cpuexn (Exn.number exn) 70 | 71 | method eval_event ev = 72 | Value.Match.( 73 | select @@ 74 | case Event.memory_store self#eval_memory_store @@ 75 | case Event.memory_load self#eval_memory_load @@ 76 | case Event.register_read self#eval_register_read @@ 77 | case Event.register_write self#eval_register_write @@ 78 | case Event.code_exec self#eval_exec @@ 79 | case Event.mode self#eval_mode @@ 80 | case Event.pc_update self#eval_pc_update @@ 81 | case Event.context_switch self#eval_context_switch @@ 82 | case Event.syscall self#eval_syscall @@ 83 | case Event.exn self#eval_exn @@ 84 | case Event.call self#eval_call @@ 85 | case Event.return self#eval_return @@ 86 | case Event.modload self#eval_modload @@ 87 | default SM.return) ev 88 | 89 | method eval_trace trace : 'a u = 90 | SM.update (fun ctxt -> ctxt#with_events trace) >>= fun () -> self#run 91 | 92 | method private run : 'a u = 93 | SM.get () >>= fun ctxt -> 94 | match ctxt#next_event with 95 | | None -> SM.return () 96 | | Some (ctxt, ev) -> 97 | SM.put ctxt >>= fun () -> self#eval_event ev >>= fun () -> self#run 98 | 99 | method eval_exec: chunk -> 'a u = stub 100 | method eval_context_switch: int -> 'a u = stub 101 | method eval_mode: Mode.t -> 'a u = stub 102 | method eval_syscall: syscall -> 'a u = stub 103 | method eval_call: call -> 'a u = stub 104 | method eval_return: return -> 'a u = stub 105 | method eval_modload: modload -> 'a u = stub 106 | 107 | end 108 | -------------------------------------------------------------------------------- /lib/veri_rule.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Regular.Std 3 | 4 | type trial = Pcre.regexp 5 | let compare_trial (_ : trial) (_ : trial) = 0 (* TODO: this is wrong *) 6 | 7 | let empty = "" 8 | let trial_exn s = Pcre.regexp ~flags:[`ANCHORED] s 9 | let er s = Error (Error.of_string s) 10 | 11 | module Action = struct 12 | type t = Skip | Deny [@@deriving bin_io, compare, sexp] 13 | let skip = Skip 14 | let deny = Deny 15 | 16 | let to_string = function 17 | | Skip -> "SKIP" 18 | | Deny -> "DENY" 19 | 20 | let of_string_err = function 21 | | "SKIP" -> Ok Skip 22 | | "DENY" -> Ok Deny 23 | | s -> er (Printf.sprintf "only SKIP | DENY actions should be used: %s" s) 24 | end 25 | 26 | module Field = struct 27 | type t = trial * string [@@deriving compare] 28 | 29 | let create_exn s = trial_exn s, s 30 | 31 | let create_err s = 32 | try 33 | Ok (create_exn s) 34 | with Pcre.Error _ -> 35 | let s = Printf.sprintf "error in field %s" s in 36 | Error (Error.of_string s) 37 | 38 | let is_empty f = String.equal (snd f) empty 39 | end 40 | 41 | type action = Action.t [@@deriving bin_io, compare, sexp] 42 | type field = Field.t [@@deriving compare] 43 | 44 | type t = { 45 | action : action; 46 | insn : field; 47 | both : field; 48 | left : field; 49 | right : field; 50 | } [@@deriving fields, compare] 51 | 52 | exception Bad_field of string 53 | 54 | let skip = Action.skip 55 | let deny = Action.deny 56 | let is_empty = Field.is_empty 57 | 58 | let contains_backreference = 59 | let rex = Pcre.regexp "\\\\[1-9]" in 60 | fun s -> Pcre.pmatch ~rex s 61 | 62 | let right_field s = 63 | if contains_backreference s then 64 | Ok (trial_exn empty, s) 65 | else Field.create_err s 66 | 67 | let create ?insn ?left ?right action = 68 | let open Result in 69 | let of_opt = Option.value_map ~default:empty ~f:Fn.id in 70 | let both = String.concat ~sep:" " [of_opt left; of_opt right] in 71 | Field.create_err (of_opt insn) >>= fun insn -> 72 | Field.create_err both >>= fun both -> 73 | Field.create_err (of_opt left) >>= fun left -> 74 | right_field (of_opt right) >>= fun right -> 75 | Ok ({action; insn; both; left; right;}) 76 | 77 | let create_exn ?insn ?left ?right action = 78 | match create ?insn ?left ?right action with 79 | | Ok r -> r 80 | | Error s -> raise (Bad_field (Error.to_string_hum s)) 81 | 82 | let match_field t field s = 83 | let field' = match field with 84 | | `Insn -> t.insn 85 | | `Both -> t.both 86 | | `Left -> t.left 87 | | `Right -> t.right in 88 | Pcre.pmatch ~rex:(fst field') s 89 | 90 | module S = struct 91 | 92 | type nonrec t = t 93 | 94 | let to_string t = 95 | let contains_space s = String.exists ~f:(Char.equal ' ') s in 96 | let of_field f = 97 | if Field.is_empty f then "''" 98 | else if contains_space (snd f) then Printf.sprintf "'%s'" (snd f) 99 | else snd f in 100 | Printf.sprintf "%s %s %s %s" (Action.to_string t.action) 101 | (of_field t.insn) (of_field t.left) (of_field t.right) 102 | 103 | let rex = Pcre.regexp "'.*?'|\".*?\"|\\S+" 104 | let is_quote c = Char.equal c '\"' || Char.equal c '\'' 105 | let unquote s = String.strip ~drop:is_quote s 106 | 107 | (** Not_found could be raised here *) 108 | let fields_exn str = 109 | Pcre.exec_all ~rex str |> 110 | Array.fold ~init:[] ~f:(fun acc ar -> 111 | let subs = Pcre.get_substrings ar in 112 | acc @ Array.to_list subs) |> 113 | List.map ~f:unquote 114 | 115 | let fields_opt str = 116 | try 117 | match fields_exn str with 118 | | [action; insn; left; right] -> Some (action, insn, left, right) 119 | | _ -> None 120 | with _ -> None 121 | 122 | let fields_err str = 123 | match fields_opt str with 124 | | Some fields -> Ok fields 125 | | None -> 126 | er (Printf.sprintf "String %s doesn't match to rule grammar" str) 127 | 128 | let of_string_err s = 129 | let open Or_error in 130 | fields_err s >>= fun (action, insn, left, right) -> 131 | Action.of_string_err action >>= fun action' -> 132 | create ~insn ~left ~right action' 133 | 134 | let of_string str = ok_exn (of_string_err str) 135 | 136 | end 137 | 138 | let of_string_err = S.of_string_err 139 | 140 | include Sexpable.Of_stringable(S) 141 | include Binable.Of_stringable(S)[@@warning "-D"] 142 | include (S : Stringable with type t := t) 143 | 144 | include Regular.Make(struct 145 | type nonrec t = t [@@deriving bin_io, compare, sexp] 146 | let compare = compare 147 | let hash = Hashtbl.hash 148 | let module_name = Some "Veri_rule" 149 | let version = "0.1" 150 | 151 | let pp fmt t = Format.fprintf fmt "%s" (to_string t) 152 | end) 153 | -------------------------------------------------------------------------------- /tests/veri_stat_test.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open OUnit2 3 | open Veri_error 4 | 5 | module Stat = Veri_stat 6 | module Abs = Stat.Abs 7 | module Rel = Stat.Rel 8 | module Names = Stat.Names 9 | 10 | let repeat f n stat = 11 | let rec loop i stat = 12 | if i = n then stat 13 | else loop (i + 1) (f stat) in 14 | loop 0 stat 15 | 16 | let repeat' f data stat = 17 | let rec loop stat = function 18 | | [] -> stat 19 | | hd :: tl -> loop (f stat hd) tl in 20 | loop stat data 21 | 22 | let chunk_error = Error.of_string "spoiled chunk" 23 | let repeat_error n er stat = repeat (fun stat' -> Stat.notify stat' er) n stat 24 | let repeat_overloaded n stat = repeat_error n `Overloaded_chunk stat 25 | let repeat_damaged n stat = repeat_error n (`Damaged_chunk chunk_error) stat 26 | let repeat_undisasmed n stat = repeat_error n (`Disasm_error chunk_error) stat 27 | 28 | let add_unlifted = 29 | repeat' (fun stat' name -> Stat.notify stat' (`Lifter_error (name, chunk_error))) 30 | 31 | let add_failed = repeat' (fun stat' name -> Stat.failbil stat' name) 32 | let add_successed = repeat' (fun stat' name -> Stat.success stat' name) 33 | let mislifted_names = ["CDQ"; "CQO"; "LD_F80m"; "LD_Frr"; "ST_FP80m"] 34 | let successed_names = ["CMOVA64rr"; "CMOVAE32rr";] 35 | let abs_successed_names = ["ADD64rr"; "ADD64mr"; "ADD32rr"; "ADD32mr"; ] 36 | let abs_misexec_names = ["NOOPL"; "NOOPW"; "CMOVAE64rr";] 37 | 38 | (** since this both sets describes insns that were sometimes successed and 39 | sometimes not *) 40 | let misexec_names = successed_names 41 | 42 | let is_same xs xs' = 43 | List.length xs = List.length xs' && 44 | List.for_all ~f:(fun x' -> List.exists ~f:(fun x -> x = x') xs) xs' 45 | 46 | let overloaded_cnt = 8 47 | let damaged_cnt = 16 48 | let undisasmed_cnt = 32 49 | 50 | let stat = 51 | Stat.empty |> 52 | repeat_overloaded overloaded_cnt |> 53 | repeat_damaged damaged_cnt |> 54 | repeat_undisasmed undisasmed_cnt |> 55 | add_unlifted mislifted_names |> 56 | add_failed (misexec_names @ abs_misexec_names) |> 57 | add_successed (successed_names @ abs_successed_names) 58 | 59 | let test_abs ctxt = 60 | let abs_successed_cnt = List.length abs_successed_names in 61 | let successed_cnt = List.length (successed_names @ abs_successed_names) in 62 | let abs_misexec_cnt = List.length abs_misexec_names in 63 | let misexec_cnt = List.length (misexec_names @ abs_misexec_names) in 64 | let mislifted_cnt = List.length mislifted_names in 65 | let total = overloaded_cnt + damaged_cnt + undisasmed_cnt + 66 | successed_cnt + misexec_cnt + mislifted_cnt in 67 | assert_equal ~ctxt (Abs.successed stat) successed_cnt; 68 | assert_equal ~ctxt (Abs.abs_successed stat) abs_successed_cnt; 69 | assert_equal ~ctxt (Abs.misexecuted stat) misexec_cnt; 70 | assert_equal ~ctxt (Abs.abs_misexecuted stat) abs_misexec_cnt; 71 | assert_equal ~ctxt (Abs.overloaded stat) overloaded_cnt; 72 | assert_equal ~ctxt (Abs.damaged stat) damaged_cnt; 73 | assert_equal ~ctxt (Abs.undisasmed stat) undisasmed_cnt; 74 | assert_equal ~ctxt (Abs.mislifted stat) mislifted_cnt; 75 | assert_equal ~ctxt (Abs.total stat) total 76 | 77 | let test_rel ctxt = 78 | let assert_float descr x y = assert_bool descr (cmp_float x y) in 79 | let to_float n = float n /. float (Abs.total stat) in 80 | let to_float' xs = to_float (List.length xs) in 81 | assert_float "rel successed" 82 | (Rel.successed stat) (to_float' (abs_successed_names @ successed_names)); 83 | assert_float "rel misexecuted" 84 | (Rel.misexecuted stat) (to_float' (abs_misexec_names @ misexec_names)); 85 | assert_float "rel abs successed" 86 | (Rel.abs_successed stat) (to_float' abs_successed_names); 87 | assert_float "rel abs misexecuted" 88 | (Rel.abs_misexecuted stat) (to_float' abs_misexec_names); 89 | assert_float "rel overloaded" (Rel.overloaded stat) (to_float overloaded_cnt); 90 | assert_float "rel damaged" (Rel.damaged stat) (to_float damaged_cnt); 91 | assert_float "rel undisasmed" (Rel.undisasmed stat) (to_float undisasmed_cnt); 92 | assert_float "rel mislifted" (Rel.mislifted stat) (to_float' mislifted_names) 93 | 94 | let test_names ctxt = 95 | let successed = successed_names @ abs_successed_names in 96 | let misexecuted = misexec_names @ abs_misexec_names in 97 | assert_bool "successed names" (is_same (Names.successed stat) successed); 98 | assert_bool "abs successed names" 99 | (is_same (Names.abs_successed stat) abs_successed_names); 100 | assert_bool "misexecuted names" 101 | (is_same (Names.misexecuted stat) misexecuted); 102 | assert_bool "abs misexecuted names" 103 | (is_same (Names.abs_misexecuted stat) abs_misexec_names); 104 | assert_bool "mislifted names" (is_same (Names.mislifted stat) mislifted_names) 105 | 106 | let suite () = 107 | "Veri stat test" >::: 108 | [ 109 | "absolute" >:: test_abs; 110 | "relative" >:: test_rel; 111 | "names" >:: test_names; 112 | ] 113 | -------------------------------------------------------------------------------- /plugin/veri_bil.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Bap.Std 3 | open Bap_traces.Std 4 | open Bap_future.Std 5 | open Veri_policy 6 | open Monads.Std 7 | 8 | include Self() 9 | open Bap_main 10 | 11 | module Dis = Disasm_expert.Basic 12 | 13 | let read_rules fname = 14 | let comments = "#" in 15 | let is_sensible s = 16 | String.(s <> "") && not (String.is_prefix ~prefix:comments s) in 17 | let inc = In_channel.create fname in 18 | let strs = In_channel.input_lines inc in 19 | In_channel.close inc; 20 | List.map ~f:String.strip strs 21 | |> List.filter ~f:is_sensible 22 | |> List.map ~f:Veri_rule.of_string_err |> 23 | List.filter_map ~f:(function 24 | | Ok r -> Some r 25 | | Error er -> 26 | Format.(fprintf std_formatter "%s\n" (Error.to_string_hum er)); 27 | None) 28 | 29 | let string_of_error = function 30 | | `Protocol_error er -> 31 | Printf.sprintf "protocol error: %s" 32 | (Info.to_string_hum (Error.to_info er)) 33 | | `System_error er -> 34 | Printf.sprintf "system error: %s" (Caml_unix.error_message er) 35 | | `No_provider -> "no provider" 36 | | `Ambiguous_uri -> "ambiguous uri" 37 | 38 | let default_policy = 39 | let open Veri_rule in 40 | let p = Veri_policy.(add empty (create_exn ~insn:".*" ~left:".*" deny)) in 41 | Veri_policy.add p (create_exn ~insn:".*" ~right:".*" deny) 42 | 43 | let make_policy = function 44 | | None -> default_policy 45 | | Some file -> 46 | read_rules file |> 47 | List.fold ~f:Veri_policy.add ~init:Veri_policy.empty 48 | 49 | let errors_stream s = 50 | let hline = String.make 72 '=' in 51 | let pp_result fmt report = 52 | Format.fprintf fmt "%s@\n%a" hline Veri_report.pp report; 53 | Format.print_flush () in 54 | ignore(Stream.subscribe s (pp_result Format.std_formatter) : Stream.id) 55 | 56 | let eval_file file policy show_errs = 57 | let mk_er s = Error (Error.of_string s) in 58 | let uri = Uri.of_string ("file:" ^ file) in 59 | match Trace.load uri with 60 | | Error er -> 61 | Printf.sprintf "error during loading trace: %s\n" (string_of_error er) |> 62 | mk_er 63 | | Ok trace -> 64 | match Dict.find (Trace.meta trace) Meta.arch with 65 | | None -> mk_er "trace of unknown arch" 66 | | Some arch -> 67 | let stat = Veri_stat.empty in 68 | let ctxt = new Veri.context stat policy trace in 69 | let veri = new Veri.t arch in 70 | if show_errs then errors_stream ctxt#reports; 71 | let ctxt' = Monad.State.exec (veri#eval_trace trace) ctxt in 72 | Ok ctxt'#stat 73 | 74 | let read_dir path = 75 | let dir = Caml_unix.opendir path in 76 | let fullpath file = String.concat ~sep:"/" [path; file] in 77 | let next () = 78 | try 79 | Some (Caml_unix.readdir dir) 80 | with End_of_file -> None in 81 | let rec folddir acc = 82 | match next () with 83 | | Some file -> folddir (fullpath file :: acc) 84 | | None -> acc in 85 | let files = folddir [] in 86 | Caml_unix.closedir dir; 87 | files 88 | 89 | let main path rules out show_errs show_stat _ctxt = 90 | let files = 91 | if Caml.Sys.is_directory path then (read_dir path) 92 | else [path] in 93 | let policy = make_policy rules in 94 | let eval stats file = 95 | Format.(fprintf std_formatter "%s@." file); 96 | match eval_file file policy show_errs with 97 | | Error er -> 98 | Error.to_string_hum er |> 99 | Printf.eprintf "error in verification: %s"; 100 | stats 101 | | Ok stat' -> (Filename.basename file, stat') :: stats in 102 | let stats = List.fold ~init:[] ~f:eval files in 103 | let stat = Veri_stat.merge (List.map ~f:snd stats) in 104 | if show_stat then 105 | Veri_stat.pp Format.std_formatter stat; 106 | Format.(fprintf std_formatter "%a\n" Veri_stat.pp_summary stat); 107 | match out with 108 | | None -> Ok () 109 | | Some out -> Ok (Veri_out.output stats out) 110 | 111 | let input = 112 | Extension.Command.argument 113 | ~doc:"Input trace file or directory with trace files" 114 | Extension.Type.("FILE | DIR" %: path) 115 | 116 | let output = 117 | Extension.Command.parameter ~doc:"File to output results" 118 | Extension.Type.("FILE" %: some path) 119 | "output" 120 | 121 | let rules = 122 | Extension.Command.parameter ~doc:"File with policy description" 123 | Extension.Type.("FILE" %: some non_dir_file) 124 | "rules" 125 | 126 | let show_errors = 127 | Extension.Command.flag 128 | ~doc:"Show detailed information about BIL errors" 129 | "show-errors" 130 | 131 | let show_stat = 132 | Extension.Command.flag 133 | ~doc:"Show verification statistics" 134 | "show-stat" 135 | 136 | let man = 137 | {|Bil verification" 138 | Veri is a BIL verification tool and intend to verify BAP lifters 139 | and to find errors."; |} 140 | 141 | let features_used = [ 142 | "disassembler"; 143 | "lifter"; 144 | ] 145 | 146 | let _ = (Extension.Command.(begin 147 | declare ~doc:man "veri" 148 | ~requires:features_used 149 | (args $input $rules $output $show_errors $show_stat) 150 | end) @@ main : unit) 151 | -------------------------------------------------------------------------------- /tests/veri_test.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel 2 | open OUnit2 3 | open Bap.Std 4 | open Bap_future.Std 5 | open Bap_traces.Std 6 | open Event 7 | open Monads.Std 8 | 9 | module Dis = Disasm_expert.Basic 10 | 11 | let arch = `x86 12 | let size = 32 13 | 14 | let assert_false s = assert_bool s false 15 | 16 | let word_of_int x = Word.of_int ~width:size x 17 | 18 | let test_tool = 19 | Trace.register_tool (module struct 20 | let name = "test tool" 21 | let supports tag = true 22 | let probe uri = false 23 | end) 24 | 25 | let make_move cell' data' = Move.({cell = cell'; data = data';}) 26 | 27 | let make_reg var_name value = 28 | let var = Var.create var_name (Type.Imm size) in 29 | let dat = word_of_int value in 30 | make_move var dat 31 | 32 | let make_mem addr value = 33 | make_move (word_of_int addr) (word_of_int value) 34 | 35 | let make_chunk addr' data' = 36 | Chunk.({addr = word_of_int addr'; data = data';}) 37 | 38 | let make_event tag value = Value.create tag value 39 | 40 | let make_events_stream evs = 41 | let evs' = ref evs in 42 | let rec next () = match !evs' with 43 | | [] -> None 44 | | hd :: tl -> 45 | evs' := tl; 46 | Some (Ok hd) in 47 | next 48 | 49 | let make_trace code real_evs = 50 | let next = make_events_stream (code::real_evs) in 51 | let trace = Trace.create test_tool next in 52 | Trace.set_attr trace Meta.arch arch 53 | 54 | let is_equal_events evs evs' = 55 | let is_exists ev = List.exists ~f:(fun ev' -> Value.equal ev ev') evs' in 56 | List.length evs = List.length evs' && 57 | List.for_all ~f:is_exists evs 58 | 59 | let test_policy = 60 | let open Veri_policy in 61 | let rule = ok_exn (Veri_rule.create 62 | ~insn:" *" ~left:" *" Veri_rule.deny) in 63 | List.fold ~init:empty ~f:add (rule :: []) 64 | 65 | let eval_trace trace = 66 | Dis.with_disasm ~backend:"llvm" (Arch.to_string arch) ~f:(fun dis -> 67 | let dis = Dis.store_asm dis |> Dis.store_kinds in 68 | let stat = Veri_stat.empty in 69 | let ctxt = new Veri.context stat test_policy trace in 70 | let veri = new Veri.t arch dis in 71 | let hd = Stream.hd ctxt#reports in 72 | let _ctxt' = 73 | Monad.State.exec (veri#eval_trace trace) ctxt in 74 | Ok hd) 75 | 76 | let check_left_diff pref trace expected = 77 | match eval_trace trace with 78 | | Error er -> 79 | assert_false (Printf.sprintf "%s: %s" pref (Error.to_string_hum er)) 80 | | Ok hd -> 81 | match Future.peek hd with 82 | | None -> 83 | assert_false (Printf.sprintf "%s: no left match" pref) 84 | | Some r -> 85 | match Veri_report.data r with 86 | | [] -> assert_false (Printf.sprintf "%s: no left match" pref) 87 | | (rule,(left,_))::_ -> 88 | let s = Printf.sprintf "%s: diff equality check" pref in 89 | assert_bool s (is_equal_events expected left) 90 | 91 | (** MOV32rr: { EAX := low:32[ESP] } *) 92 | let test_reg ctxt = 93 | let code = make_event code_exec (make_chunk 0xF67DE0D0 "\x89\xE0") in 94 | let e0 = make_event register_read (make_reg "EFLAGS" 0x202) in 95 | let e1 = make_event register_read (make_reg "EAX" 0x0) in 96 | let e2 = make_event register_read (make_reg "ESP" 0xF6FFEE50) in 97 | let e3 = make_event register_write (make_reg "EAX" 0xF6FFEE50) in 98 | let e4 = make_event register_write (make_reg "EFLAGS" 0x202) in 99 | let e5 = make_event pc_update (word_of_int 0xF67DE0D2) in 100 | let real_evs = [e0;e1;e2;e3;e4;e5;] in 101 | let trace = make_trace code real_evs in 102 | let expected_diff = [e0; e1; e4;] in 103 | check_left_diff "test_reg" trace expected_diff 104 | 105 | (** MOV32mr: 106 | { 107 | mem32 := mem32 with 108 | [(pad:32[low:32[EBP]]) + 0xFFFFFFBC:32, el]:u32 <- low:32[EAX] 109 | } *) 110 | let test_mem_store ctxt = 111 | let code = make_event code_exec (make_chunk 0xF67E17D4 "\x89\x45\xBC") in 112 | let e0 = make_event register_read (make_reg "EFLAGS" 0x296) in 113 | let e1 = make_event register_read (make_reg "EBP" 0xF6FFEE48) in 114 | let e2 = make_event register_read (make_reg "EAX" 0xF6FFEE50) in 115 | let e3 = make_event memory_store (make_mem 0xF6FFEE04 0xF6FFEE50) in 116 | let e4 = make_event register_write (make_reg "EFLAGS" 0x296) in 117 | let e5 = make_event pc_update (word_of_int 0xF67E17D7) in 118 | let real_events = [e0;e1;e2;e3;e4;e5;] in 119 | let trace = make_trace code real_events in 120 | let expected_diff = [e0; e4;] in 121 | check_left_diff "test_mem_store" trace expected_diff 122 | 123 | (** MOV32rm : { EBX := mem32[low:32[ESP], el]:u32 }*) 124 | let test_mem_load ctxt = 125 | let code = make_event code_exec (make_chunk 0xF67F57A8 "\x8B\x1C\x24") in 126 | let e0 = make_event register_read (make_reg "EFLAGS" 0x282) in 127 | let e1 = make_event register_read (make_reg "ESP" 0xF6FFEDDC) in 128 | let e2 = make_event memory_load (make_mem 0xF6FFEDDC 0xF67E17CE) in 129 | let e3 = make_event register_write (make_reg "EBX" 0xF67E17CE) in 130 | let e4 = make_event register_write (make_reg "EFLAGS" 0x282) in 131 | let e5 = make_event pc_update (word_of_int 0xF67F57AB) in 132 | let real_evs = [e0;e1;e2;e3;e4;e5;] in 133 | let trace = make_trace code real_evs in 134 | let expected_diff = [e0; e4;] in 135 | check_left_diff "test_mem_load" trace expected_diff 136 | 137 | let suite () = 138 | "Veri test" >::: 139 | [ 140 | "reg test" >:: test_reg; 141 | "mem store test" >:: test_mem_store; 142 | "mem load test" >:: test_mem_load; 143 | ] 144 | -------------------------------------------------------------------------------- /lib/veri_policy.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Graph 3 | open Bap.Std 4 | open Bap_traces.Std 5 | open Regular.Std 6 | 7 | module Rule = Veri_rule 8 | 9 | type event = Trace.event [@@deriving bin_io, compare, sexp] 10 | type events = Value.Set.t 11 | type rule = Rule.t [@@deriving bin_io, compare, sexp] 12 | 13 | module Matched = struct 14 | type t = event list * event list [@@deriving bin_io, compare, sexp] 15 | 16 | include Regular.Make(struct 17 | type nonrec t = t [@@deriving bin_io, compare, sexp] 18 | let compare = compare 19 | let hash = Hashtbl.hash 20 | let module_name = Some "Veri_policy.Matched" 21 | let version = "0.1" 22 | let pp_ev fmt ev = Format.fprintf fmt "%a; " Value.pp ev 23 | 24 | let pp_events pref fmt = function 25 | | [] -> () 26 | | evs -> 27 | Format.fprintf fmt "%s: " pref; 28 | List.iter evs ~f:(pp_ev fmt); 29 | Format.print_newline () 30 | 31 | let pp fmt (evs, evs') = 32 | Format.fprintf fmt "%a%a" 33 | (pp_events "left") evs (pp_events "right") evs' 34 | 35 | end) 36 | end 37 | 38 | type matched = Matched.t [@@deriving bin_io, compare, sexp] 39 | type t = rule list [@@deriving bin_io, compare, sexp] 40 | 41 | let empty = [] 42 | let add t rule : t = rule :: t 43 | 44 | let string_of_events ev ev' = 45 | String.concat ~sep:" " [Value.pps () ev; Value.pps () ev'] 46 | 47 | let sat_events r ev ev' = 48 | Value.Typeid.equal (Value.typeid ev) (Value.typeid ev') && 49 | Rule.match_field r `Both (string_of_events ev ev') 50 | 51 | module G = struct 52 | type t = rule * event array * event array 53 | module V = struct 54 | type t = Source | Sink | Person of int | Task of int [@@deriving compare] 55 | let hash = Hashtbl.hash 56 | let equal x y = compare x y = 0 57 | end 58 | module E = struct 59 | type label = unit 60 | 61 | type t = {src : V.t; dst : V.t} [@@deriving fields] 62 | let make src dst = {src; dst} 63 | let label _ = () 64 | end 65 | type dir = Succ | Pred 66 | 67 | let iter dir f (rule, workers, jobs) v = 68 | match v,dir with 69 | | V.Source,Pred -> () 70 | | V.Source,Succ -> 71 | Array.iteri workers ~f:(fun i _ -> 72 | f @@ E.make V.Source (V.Person i)) 73 | | V.Sink,Pred -> 74 | Array.iteri jobs ~f:(fun i _ -> 75 | f @@ E.make (V.Task i) V.Sink) 76 | | V.Sink,Succ -> () 77 | | V.Person i as p,Pred -> 78 | f @@ E.make V.Source p 79 | | V.Person i as p,Succ -> 80 | Array.iteri jobs ~f:(fun j job -> 81 | if sat_events rule workers.(i) job 82 | then f (E.make p (V.Task j))) 83 | | V.Task j as t,Succ -> 84 | f @@ E.make t V.Sink 85 | | V.Task j as t,Pred -> 86 | Array.iteri workers ~f:(fun i worker -> 87 | if sat_events rule worker jobs.(j) 88 | then f (E.make (V.Person i) t)) 89 | 90 | let iter_succ_e = iter Succ 91 | let iter_pred_e = iter Pred 92 | end 93 | 94 | module F = struct 95 | type t = int 96 | type label = unit 97 | let max_capacity () = 1 98 | let min_capacity () = 0 99 | let flow () = min_capacity () 100 | let add = (+) 101 | let sub = (-) 102 | let zero = 0 103 | let compare = Int.compare 104 | end 105 | 106 | module FFMF = Flow.Ford_Fulkerson(G)(F) 107 | 108 | let single_match fmatch events = 109 | let f ev = fmatch (Value.pps () ev) in 110 | List.filter ~f (Set.to_list events) 111 | 112 | let match_right rule events = 113 | match single_match (Rule.match_field rule `Right) events with 114 | | [] -> None 115 | | ms -> Some ([], ms) 116 | 117 | let match_left rule events = 118 | match single_match (Rule.match_field rule `Left) events with 119 | | [] -> None 120 | | ms -> Some (ms,[]) 121 | 122 | let match_both rule left right = 123 | let workers = Set.to_array left in 124 | let jobs = Set.to_array right in 125 | let (flow,_) = FFMF.maxflow (rule, workers, jobs) G.V.Source G.V.Sink in 126 | Array.foldi workers ~init:([],[]) 127 | ~f:(fun i (acc, acc') w -> 128 | match Array.findi jobs ~f:(fun j e -> 129 | flow (G.E.make (G.V.Person i) (G.V.Task j)) <> 0) with 130 | | None -> acc, acc' 131 | | Some (_,e) -> w :: acc, e :: acc') |> function 132 | | [], [] -> None 133 | | ms -> Some ms 134 | 135 | let diff events events' = 136 | let left = Set.diff events events' in 137 | let right = Set.diff events' events in 138 | let to_str e = Value.pps () e in 139 | let is_unique other ev = 140 | not (Set.exists other ~f:(fun ev' -> String.equal (to_str ev) (to_str ev'))) in 141 | Set.filter ~f:(is_unique right) left, 142 | Set.filter ~f:(is_unique left) right 143 | 144 | let match_events rule insn events events' = 145 | match Rule.match_field rule `Insn insn with 146 | | false -> None 147 | | true -> 148 | let left, right = diff events events' in 149 | match Rule.(is_empty (left rule)), Rule.(is_empty (right rule)) with 150 | | true, true -> Some (Set.to_list events, Set.to_list events') 151 | | true, _ -> match_right rule right 152 | | _, true -> match_left rule left 153 | | _ -> match_both rule left right 154 | 155 | let remove what from = 156 | let eq x y = Value.compare x y = 0 in 157 | let not_exists e = not (List.exists what ~f:(fun e' -> eq e e')) in 158 | Set.filter ~f:not_exists from 159 | 160 | let remove_matched events events' (ms, ms') = 161 | remove ms events, remove ms' events' 162 | 163 | let denied rules insn events events' = 164 | let rec loop acc rules (evs,evs') = match rules with 165 | | [] -> acc 166 | | rule :: rls -> 167 | match match_events rule insn evs evs' with 168 | | None -> loop acc rls (evs,evs') 169 | | Some matched -> 170 | let acc' = 171 | if Veri_rule.compare_action (Rule.action rule) Rule.skip = 0 then acc 172 | else (rule, matched) :: acc in 173 | remove_matched evs evs' matched |> 174 | loop acc' rls in 175 | loop [] (List.rev rules) (events, events') 176 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # BAP Lifter Accuracy Verification Tool 2 | 3 | This tool uses trace files from [pintrace] or [qemu] to verify the lifters accuracy. For each instruction, the tracing tool records in the trace file all side effects, such as memory accesses, register updates, and so on. We call these effects the [trace events][trace-events]. The bap-veri tool reads the events from the trace file then disassembles and lifts each instruction (which is also stored in the trace file) and emulates them using a BIL interpreter that collects all side-effects in the form of a set of trace events. Ideally, the stored set and the emulated sets should coincide. In reality, the tracing tools have their own abstractions and could be less precise or more precise than BAP. For example, qemu doesn't really track changes in the status registers and instead generates a flag change event even if it wasn't changed. To address this, bap-veri uses [policy](#policy) files that contain simple rules describing which events shall be ignored and which events are crucial. 4 | 5 | Each instruction is compared independently starting from a clean state. Since BAP doesn't have access to the full image and execution enviroment, like the state of the heap or registers, we peek the values from the trace, e.g., if in the trace we see event like `RAX => 0x2A` we know that `RAX` contained `0x2A`. 6 | 7 | 8 | ## Installing 9 | 10 | To install the tool use opam, e.g., 11 | 12 | ``` 13 | opam install bap-veri 14 | ``` 15 | 16 | If you need the latest master version, do 17 | ``` 18 | opam pin add --dev-repo bap-veri 19 | ``` 20 | 21 | 22 | ## Running 23 | 24 | First of all, you will need to obtain a trace file. For that you need to build either of our tracing tools, [pin-trace] or [qemu]. Both tracing tools store their information using the [bap-frames] file format, so you need to build and install the [bap-frames] codec as well. If you installed bap from opam, e.g., with `opam install bap`, then you can just do 25 | ``` 26 | opam install bap-frames 27 | ``` 28 | 29 | Alternatively, you can build it from sources, see the [coreponding instructions](https://github.com/BinaryAnalysisPlatform/bap-frames#from-sources). 30 | 31 | Once you have everything ready, you can run `bap veri` as 32 | 33 | ``` 34 | bap veri --show-errors --show-stat 35 | ``` 36 | 37 | Notice that there's no need for the original binary or libraries, all the necessary information is stored in the binary. Before running `bap veri` you can use `bap --trace-dump ` to print the contents of the trace file in a human-readable format. 38 | 39 | You can also specify a policy file using `--rules `. If you don't know what it is, read the next section. 40 | 41 | ## Policy 42 | 43 | The policy file contains a list of rules, somewhat similar to the firewall rules. The rules are executed in order, the first that matches is applied. A rule contains four fields: `ACTION INSN TRACER_EVENT LIFTER_EVENT`: 44 | 45 | 1. The `ACTION` field is either `SKIP` or `DENY`. `DENY` means that we found an unacceptable inconsistency that should be reported as a problem. The `SKIP` action means that we can ignore this inconsistency. 46 | 2. The `INSN` field could contain an instruction name like `MOV64rr` or regular expression, like `MOV.*`, the rule will be applied only to instructions that match the INSN field. 47 | 3. The `TRACER_EVENT` field denotes a [tracing event][trace-events] generated by the tracing tool. It could be a string or a regular expression, or `''` that denotes a lack of event. The rule will be applied the tracer generated a matching event. 48 | 4. The `LIFTER_EVENT` field denotes a [tracing event][trace-events] generated during the emulation of a lifted instruction. It has the same format as the `TRACER_EVENT`. 49 | 50 | 51 | When bap-veri detects that the set of tracer events is not equal to the set of lifter events it will use the specified policy file to figure out what to do next. For each event in either set complements it will try to find the matching rule. Matching is performed on the textual representation of events (you can always use `bap --trace-dump ` to see how they look). Rules are written in a text file in which every line is either a rule, a comment, or an empty line. A comment line starts with `#` and is ignored. The rule must have exactly four fields separated with whitespaces. If the field contains a space it should be delimited with with single or double quotes, e.g., `"RAX => .*"`. If a field is empty (i.e., matches with an empty string or an absence of event), then use `''` or `""`. 52 | 53 | ### Examples 54 | 55 | Let's imagine that a tracer, unlike BAP, ignores accesses to the `ZF` register. To skip this inconsistency, we write the following rule 56 | ``` 57 | SKIP .* '' 'ZF -> .*' 58 | ``` 59 | 60 | It literally means, for any instruction, if there is an umatched read from `ZF` then skip it. 61 | 62 | The next two rules specify that tracer and lifter event sets must be equal. And this is the default policy, when no policy is specified. 63 | ``` 64 | DENY .* .* '' 65 | DENY .* '' .* 66 | ``` 67 | 68 | The rules match with every instruction and trigger whenever there is a `TRACER_EVENT` that doesn't has a matching `LIFTER_EVENT` (the first rule) or there is a `LIFTER_EVENT` that doesn't have a matching `LIFTER_EVENT. 69 | 70 | 71 | ### Backreferences 72 | 73 | It is also possible to use back references in regular expressions. A group is denoted with simple parentheses, e.g., and could be referenced by number (counting from 1) using `\` syntax, e.g., 74 | 75 | ``` 76 | DENY .* '(.F) <= .*' '\1 <= .*' 77 | ``` 78 | 79 | This rule captures any writes to a flag register, e.g., `ZF`, `PF`, etc, that write different values, e.g., it will match with, `ZF <= 0` vs. `ZF <= 1`. Keep in mind that rules are only applied to unmatched event, so if the events were already matching then they will not be even checked by the policy checker. 80 | 81 | # Developing 82 | 83 | If you want to modify the tool, then make sure that [bap][bap] is [installed][bap-install]. Note, that installing bap prebuilt binaries will not work. You need libraries and the toolchain. Also, make sure that you have installed other dependencies. You can look them in the [opam](./opam) file, or ask opam to do the work for you using `opam pin`, e.g., 84 | 85 | ``` 86 | opam pin add bap-veri --dev-repo 87 | opam install bap-veri --deps-only 88 | opam pin remove bap-veri 89 | ``` 90 | 91 | Now, when all the prerequisites are met, we can build and install bap-veri, 92 | 93 | ``` 94 | oasis setup 95 | make 96 | make install 97 | ``` 98 | 99 | Now you can change the code and repeat the last two steps. 100 | 101 | [trace-events]: https://binaryanalysisplatform.github.io/bap/api/master/bap-traces/Bap_traces/Std/index.html#trace-events 102 | [pintrace]: https://github.com/BinaryAnalysisPlatform/bap-pintraces 103 | [qemu]: https://github.com/BinaryAnalysisPlatform/qemu 104 | [bap]: https://github.com/BinaryAnalysisPlatform/bap 105 | [bap-install]: https://github.com/BinaryAnalysisPlatform/bap#from-sources 106 | [bap-frames]: https://github.com/BinaryAnalysisPlatform/bap-frames 107 | -------------------------------------------------------------------------------- /lib/veri_stat.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Regular.Std 3 | 4 | module Calls = String.Map 5 | 6 | type ok_er = int * int [@@deriving bin_io, compare, sexp] 7 | 8 | type t = { 9 | calls : ok_er Calls.t; 10 | errors: Veri_error.t list; 11 | } [@@deriving bin_io, compare, sexp] 12 | 13 | type stat = t [@@deriving bin_io, compare, sexp] 14 | 15 | let empty = { calls = Calls.empty; errors = []; } 16 | let errors t = t.errors 17 | let notify t er = {t with errors = er :: t.errors } 18 | 19 | let update t name ~ok ~er = 20 | {t with 21 | calls = 22 | Map.change t.calls name 23 | ~f:(function 24 | | None -> Some (ok, er) 25 | | Some (ok',er') -> Some (ok + ok', er + er')) } 26 | 27 | let failbil t name = update t name ~ok:0 ~er:1 28 | let success t name = update t name ~ok:1 ~er:0 29 | 30 | module Abs = struct 31 | 32 | type nonrec t = t -> int 33 | 34 | let fold_calls {calls} f = Map.fold ~f ~init:0 calls 35 | 36 | let errors_count t = 37 | let rec loop ((ovr, dmg, undis, misl) as acc) = function 38 | | [] -> acc 39 | | hd :: tl -> match hd with 40 | | `Overloaded_chunk -> loop (ovr + 1, dmg, undis, misl) tl 41 | | `Damaged_chunk _ -> loop (ovr, dmg + 1, undis, misl) tl 42 | | `Disasm_error _ -> loop (ovr, dmg, undis + 1, misl) tl 43 | | `Lifter_error _ -> loop (ovr, dmg, undis, misl + 1) tl in 44 | loop (0,0,0,0) t.errors 45 | 46 | let overloaded t = let x,_,_,_ = errors_count t in x 47 | let damaged t = let _,x,_,_ = errors_count t in x 48 | let undisasmed t = let _,_,x,_ = errors_count t in x 49 | let mislifted t = let _,_,_,x = errors_count t in x 50 | let successed t = fold_calls t (fun ~key ~data cnt -> cnt + fst data) 51 | let misexecuted t = fold_calls t (fun ~key ~data cnt -> cnt + snd data) 52 | 53 | let abs_successed t = 54 | fold_calls t (fun ~key ~data cnt -> 55 | if snd data <> 0 then cnt 56 | else cnt + fst data) 57 | 58 | let abs_misexecuted t = 59 | fold_calls t (fun ~key ~data cnt -> 60 | if fst data <> 0 then cnt 61 | else cnt + snd data) 62 | 63 | let total t = 64 | List.length t.errors + 65 | fold_calls t (fun ~key ~data cnt -> cnt + fst data + snd data) 66 | 67 | end 68 | 69 | module Rel = struct 70 | type t = ?as_percents:bool -> stat -> float 71 | 72 | let apply f b t = 73 | let r = float (f t) /. float (Abs.total t) in 74 | if b then r *. 100.0 75 | else r 76 | 77 | let ( @@ ) = apply 78 | 79 | let successed ?(as_percents=false) = Abs.successed @@ as_percents 80 | let abs_successed ?(as_percents=false) = Abs.abs_successed @@ as_percents 81 | let misexecuted ?(as_percents=false) = Abs.misexecuted @@ as_percents 82 | let abs_misexecuted ?(as_percents=false) = Abs.abs_misexecuted @@ as_percents 83 | let overloaded ?(as_percents=false) = Abs.overloaded @@ as_percents 84 | let damaged ?(as_percents=false) = Abs.damaged @@ as_percents 85 | let undisasmed ?(as_percents=false) = Abs.undisasmed @@ as_percents 86 | let mislifted ?(as_percents=false) = Abs.mislifted @@ as_percents 87 | end 88 | 89 | module Names = struct 90 | 91 | type nonrec t = t -> string list 92 | 93 | let fold_calls ~condition t = 94 | Map.fold ~f:(fun ~key ~data names -> 95 | if condition data then Set.add names key 96 | else names) ~init:String.Set.empty t.calls |> 97 | Set.to_list 98 | 99 | let successed = fold_calls ~condition:(fun data -> fst data <> 0) 100 | let abs_successed = fold_calls ~condition:(fun data -> snd data = 0) 101 | let misexecuted = fold_calls ~condition:(fun data -> snd data <> 0) 102 | let abs_misexecuted = fold_calls ~condition:(fun data -> fst data = 0) 103 | 104 | let mislifted t = 105 | List.fold_left ~init:String.Set.empty 106 | ~f:(fun names errs -> 107 | match errs with 108 | | `Lifter_error (insn,_) -> Set.add names insn 109 | | _ -> names) t.errors |> 110 | Set.to_list 111 | end 112 | 113 | let print_table : 114 | Format.formatter -> (string * ('a -> string)) list -> 'a list -> unit = 115 | fun fmt info rows -> 116 | let open Veri_tab in 117 | let headers, processors = 118 | List.map ~f:fst info, List.map ~f:snd info in 119 | List.foldi rows ~init:(create headers) 120 | ~f:(fun i tab row -> 121 | let cells = 122 | List.fold ~init:[] processors ~f:(fun acc p -> p row :: acc) in 123 | add_row tab @@ List.rev cells) |> 124 | pp fmt 125 | 126 | module Summary = struct 127 | 128 | type nonrec t = t [@@deriving bin_io, compare, sexp] 129 | 130 | type p = { 131 | name: string; 132 | rel : float; 133 | abs : int; 134 | } [@@deriving bin_io, sexp, compare] 135 | 136 | let of_stat s = 137 | let make name abs rel = {name; abs; rel;} in 138 | if Abs.total s = 0 then [] 139 | else 140 | let as_percents = true in 141 | [ make "overloaded" (Abs.overloaded s) (Rel.overloaded ~as_percents s); 142 | make "undisasmed" (Abs.undisasmed s) (Rel.undisasmed ~as_percents s); 143 | make "misexecuted" (Abs.misexecuted s) (Rel.misexecuted ~as_percents s); 144 | make "mislifted" (Abs.mislifted s) (Rel.mislifted ~as_percents s); 145 | make "damaged" (Abs.damaged s) (Rel.damaged ~as_percents s); 146 | make "successed" (Abs.successed s) (Rel.successed ~as_percents s);] 147 | 148 | let pp fmt t = match of_stat t with 149 | | [] -> Format.fprintf fmt "summary is unavailable\n" 150 | | ps -> 151 | print_table fmt 152 | ["", (fun x -> x.name); 153 | "rel", (fun x -> Printf.sprintf "%.2f%%" x.rel); 154 | "abs", (fun x -> Printf.sprintf "%d" x.abs);] 155 | ps 156 | 157 | end 158 | 159 | let merge ts = 160 | let (+) s s' = 161 | let errors = s.errors @ s'.errors in 162 | let calls = Map.fold ~init:s.calls s'.calls 163 | ~f:(fun ~key ~data calls -> 164 | Map.change calls key ~f:(function 165 | | None -> Some data 166 | | Some (ok,er) -> Some (fst data + ok, snd data + er))) in 167 | {errors; calls} in 168 | List.fold ~f:(+) ~init:empty ts 169 | 170 | let pp_summary = Summary.pp 171 | 172 | include Regular.Make(struct 173 | type nonrec t = t [@@deriving bin_io, compare, sexp] 174 | let compare = compare 175 | let hash = Hashtbl.hash 176 | let module_name = Some "Veri_stat" 177 | let version = "0.1" 178 | 179 | let pp_misexecuted fmt = function 180 | | [] -> () 181 | | mis -> 182 | Format.fprintf fmt "misexecuted \n"; 183 | print_table fmt 184 | [ "instruction", fst; 185 | "failed", (fun (_, (_,er)) -> Printf.sprintf "%d" er); 186 | "successful", (fun (_, (ok,_)) -> Printf.sprintf "%d" ok); ] 187 | mis 188 | 189 | let pp_mislifted fmt names = 190 | let max_row_len = 10 in 191 | let max_col_cnt = 5 in 192 | match names with 193 | | [] -> () 194 | | names when List.length names <= max_row_len -> 195 | let names' = "mislifted:" :: names in 196 | List.iter ~f:(Format.fprintf fmt "%s ") names'; 197 | Format.print_newline () 198 | | names -> 199 | let rows, row, _ = List.fold ~init:([], [], 0) 200 | ~f:(fun (acc, row, i) name -> 201 | if i < max_col_cnt then acc, name :: row, i + 1 202 | else row :: acc, name :: [], 1) names in 203 | let gaps = Array.create ~len:(max_col_cnt - List.length row) "-----" in 204 | let last = row @ Array.to_list gaps in 205 | let rows = List.rev (last :: rows) in 206 | let make_col i = "mislifted", (fun row -> List.nth_exn row i) in 207 | let cols = [ 208 | make_col 0; make_col 1; make_col 2; make_col 3; make_col 4; ] in 209 | print_table fmt cols rows 210 | 211 | let pp fmt t = 212 | let misexec = 213 | List.filter ~f:(fun (_,(_,er)) -> er <> 0) (Map.to_alist t.calls) in 214 | let mislift = Names.mislifted t in 215 | Format.fprintf fmt "%a\n%a\n" 216 | pp_misexecuted misexec pp_mislifted mislift 217 | 218 | end) 219 | -------------------------------------------------------------------------------- /lib/veri.ml: -------------------------------------------------------------------------------- 1 | open Core_kernel[@@warning "-D"] 2 | open Bap.Std 3 | open Regular.Std 4 | open Bap_traces.Std 5 | open Bap_future.Std 6 | open Bap_core_theory 7 | open Monads.Std 8 | 9 | module Dis = Disasm_expert.Basic 10 | 11 | module SM = Monad.State 12 | open SM.Monad_infix 13 | 14 | type event = Trace.event [@@deriving bin_io, compare, sexp] 15 | type 'a u = 'a Bil.Result.u [@@warning "-D"] 16 | type 'a r = 'a Bil.Result.r [@@warning "-D"] 17 | type 'a e = (event option, 'a) SM.t 18 | type error = Veri_error.t 19 | 20 | let create_move_event tag cell' data' = 21 | Value.create tag Move.({cell = cell'; data = data';}) 22 | 23 | let find cond tag evs = 24 | let open Option in 25 | List.find evs ~f:(fun ev -> match Value.get tag ev with 26 | | None -> false 27 | | Some mv -> cond mv) >>| fun ev -> Value.get_exn tag ev 28 | 29 | let create_mem_store = create_move_event Event.memory_store 30 | let create_mem_load = create_move_event Event.memory_load 31 | let create_reg_read = create_move_event Event.register_read 32 | let create_reg_write = create_move_event Event.register_write 33 | let value = Bil.Result.value [@warning "-D"] 34 | let same_value x y = 35 | Bil.Result.Id.equal (Bil.Result.id x) (Bil.Result.id y) 36 | [@@warning "-D"] 37 | 38 | module Disasm = struct 39 | module Dis = Disasm_expert.Basic 40 | open Dis 41 | type t = (asm, kinds) Dis.t 42 | 43 | let insn dis mem = 44 | match Dis.insn_of_mem dis mem with 45 | | Error er -> Error (`Disasm_error er) 46 | | Ok r -> match r with 47 | | _, Some _, `left _ -> Error `Overloaded_chunk 48 | | mem', insn, _ -> Ok (mem',insn) 49 | 50 | let insn_name = Dis.Insn.name 51 | end 52 | 53 | module Events = Value.Set 54 | 55 | class context stat policy trace = object(self:'s) 56 | inherit Veri_traci.context trace as super 57 | val events = Events.empty 58 | val stream = Stream.create () 59 | val error : error option = None 60 | val other : 's option = None 61 | val insn : string option = None 62 | val code : Chunk.t option = None 63 | val mode : Mode.t option = None 64 | val stat : Veri_stat.t = stat 65 | val bil : bil = [] 66 | 67 | method private make_report data = 68 | Veri_report.create ~bil ~data 69 | ~right:(Set.to_list self#events) 70 | ~left:(Set.to_list (Option.value_exn other)#events) 71 | ~insn:(Option.value_exn insn) 72 | ~code:(Option.value_exn code |> Chunk.data) 73 | ~mode 74 | 75 | method private finish_step stat = 76 | let s = {< other = None; error = None; insn = None; bil = []; 77 | stat = stat; events = Events.empty; code = None; >} in 78 | s#drop_pc 79 | 80 | method merge = 81 | match error with 82 | | Some er -> self#finish_step (Veri_stat.notify stat er) 83 | | None -> match insn with 84 | | None -> self#finish_step stat 85 | | Some name -> 86 | let other = Option.value_exn self#other in 87 | let events, events' = other#events, self#events in 88 | match Veri_policy.denied policy name events events' with 89 | | [] -> self#finish_step (Veri_stat.success stat name) 90 | | results -> 91 | let report = self#make_report results in 92 | Signal.send (snd stream) report; 93 | self#finish_step (Veri_stat.failbil stat name) 94 | 95 | method split = 96 | let s = {< other = Some self; events = Events.empty; >} in 97 | s#drop_pc 98 | 99 | method code = code 100 | method mode = mode 101 | method stat = stat 102 | method other = other 103 | method events = events 104 | method reports = fst stream 105 | method set_bil b = {< bil = b >} 106 | method set_code c = {< code = Some c >} 107 | method set_mode m = {< mode = Some m >} 108 | method set_insn s = {< insn = Some s >} 109 | method notify_error er = {< error = Some er >} 110 | method register_event ev = {< events = Set.add events ev; >} 111 | method save s = {< other = Some s >} 112 | method switch = (Option.value_exn other)#save self 113 | method drop_pc = self#with_pc Bil.Bot 114 | end 115 | 116 | type KB.conflict += Veri_error of Veri_error.t 117 | 118 | let trace_unit = KB.Symbol.intern "trace" Theory.Unit.cls 119 | 120 | let new_insn arch mode mem = 121 | let open KB.Syntax in 122 | let addr = Memory.min_addr mem in 123 | let* code = Theory.Label.for_addr (Word.to_bitvec addr) in 124 | let* unit = trace_unit in 125 | KB.sequence [ 126 | KB.provide Image.Spec.slot unit (Image.Spec.from_arch arch); 127 | KB.provide Theory.Label.unit code (Some unit); 128 | match mode with 129 | | Some mode -> KB.provide Mode.slot code mode 130 | | None -> KB.return () 131 | ] >>= fun () -> 132 | let* target = KB.collect Theory.Unit.target unit in 133 | let* coding = KB.collect Theory.Label.encoding code in 134 | let dis = Dis.lookup target coding |> Or_error.ok_exn in 135 | match Disasm.insn dis mem with 136 | | Error er -> KB.fail (Veri_error er) 137 | | Ok (mem, insn) -> 138 | KB.provide Memory.slot code (Some mem) >>= fun () -> 139 | KB.provide Dis.Insn.slot code insn >>= fun () -> 140 | KB.promising Theory.Label.unit ~promise:(fun _ -> !!(Some unit)) @@ fun () -> 141 | KB.collect Theory.Semantics.slot code >>| fun _ -> 142 | code 143 | 144 | let disasm_and_lift arch mode mem = 145 | let code = new_insn arch mode mem in 146 | match Toplevel.try_eval Theory.Semantics.slot code with 147 | | Error (Veri_error er) -> Error er 148 | | Error c -> 149 | let er = Error.of_string (Sexp.to_string (KB.sexp_of_conflict c)) in 150 | Error (`Disasm_error er) 151 | | Ok sema -> 152 | match Toplevel.eval Dis.Insn.slot code with 153 | | None -> Error (`Disasm_error (Error.of_string "nothing was disasmed")) 154 | | Some insn -> Ok (sema, insn) 155 | 156 | let target_info arch = 157 | let module Target = (val target_of_arch arch) in 158 | Target.CPU.mem 159 | 160 | let memory_of_chunk endian chunk = 161 | Bigstring.of_string (Chunk.data chunk) |> 162 | Memory.create endian (Chunk.addr chunk) 163 | 164 | let other_events c = match c#other with 165 | | None -> [] 166 | | Some c -> Set.to_list c#events 167 | 168 | let self_events c = Set.to_list c#events 169 | let same_var var mv = 170 | String.equal (Var.name var) (Var.name @@ Move.cell mv) 171 | 172 | let same_addr addr mv = Addr.equal addr (Move.cell mv) 173 | 174 | type find = [ `Addr of addr | `Var of var ] 175 | 176 | class ['a] t arch = 177 | let endian = Arch.endian arch in 178 | let mem_var = target_info arch in 179 | 180 | object(self) 181 | constraint 'a = #context 182 | inherit ['a] Veri_traci.t arch as super 183 | 184 | method private update_event ev = 185 | SM.update (fun c -> c#register_event ev) 186 | 187 | (** [find_value x] - return a value bound with [x] where 188 | [x] is either address or variable. In each variant of x 189 | an appropriative lookup order is applied. 190 | A register_read/memory_load event will be emited. *) 191 | method private find_value x = 192 | let find_data ctxt cond = function 193 | | `Write, tag -> find cond tag (self_events ctxt) 194 | | `Read, tag -> 195 | match find cond tag (self_events ctxt) with 196 | | None -> find cond tag (other_events ctxt) 197 | | x -> x in 198 | let find cond make_event tags = 199 | SM.get () >>= fun ctxt -> 200 | List.find_map ~f:(find_data ctxt cond) tags |> function 201 | | None -> SM.return None 202 | | Some mv -> 203 | self#update_event 204 | (make_event (Move.cell mv) (Move.data mv)) >>= fun () -> 205 | SM.return (Some (Move.data mv)) in 206 | match x with 207 | | `Var var -> 208 | find (same_var var) create_reg_read 209 | [ `Write, Event.register_write; `Read, Event.register_read ] 210 | | `Addr addr -> 211 | find (same_addr addr) create_mem_load 212 | [ `Write, Event.memory_store; `Read, Event.memory_load; ] 213 | 214 | method! lookup var = 215 | SM.get () >>= fun ctxt -> 216 | self#find_value (`Var var) >>= function 217 | | None -> super#lookup var 218 | | Some data -> self#eval_exp (Bil.int data) 219 | 220 | method! update var result = 221 | self#lookup var >>= fun old -> 222 | if same_value old result then SM.return () 223 | else super#update var result >>= fun () -> 224 | match value result with 225 | | Bil.Imm data -> 226 | if not (Var.is_virtual var) then 227 | self#update_event (create_reg_write var data) 228 | else SM.return () 229 | | Bil.Mem _ | Bil.Bot -> SM.return () 230 | 231 | method! eval_store ~mem ~addr data endian size = 232 | self#eval_exp addr >>= fun addr_r -> 233 | self#eval_exp data >>= fun data_r -> 234 | match value addr_r, value data_r with 235 | | Bil.Imm got_addr, Bil.Imm got_data -> 236 | self#update_event (create_mem_store got_addr got_data) >>= fun () -> 237 | super#eval_store ~mem ~addr data endian size 238 | | _ -> super#eval_store ~mem ~addr data endian size 239 | 240 | method! eval_load ~mem ~addr endian size = 241 | self#eval_exp addr >>= fun addr_res -> 242 | match value addr_res with 243 | | Bil.Bot | Bil.Mem _ -> super#eval_load ~mem ~addr endian size 244 | | Bil.Imm addr' -> 245 | self#find_value (`Addr addr') >>= function 246 | | Some data -> 247 | super#eval_store ~mem ~addr (Bil.int data) endian size >>= fun sr -> 248 | self#update mem_var sr >>= fun () -> 249 | super#eval_load ~mem ~addr endian size 250 | | None -> 251 | super#eval_load ~mem ~addr endian size >>= fun r -> 252 | match value r with 253 | | Bil.Imm data -> 254 | self#update_event (create_mem_load addr' data) >>= fun () -> 255 | SM.return r 256 | | _ -> SM.return r 257 | 258 | method private add_pc_update = 259 | SM.get () >>= fun ctxt -> 260 | match ctxt#pc with 261 | | Bil.Mem _ | Bil.Bot -> SM.return () 262 | | Bil.Imm pc -> 263 | let pc_ev = Value.create Event.pc_update pc in 264 | self#update_event pc_ev 265 | 266 | method! eval_jmp addr : 'a u = 267 | super#eval_jmp addr >>= fun () -> 268 | self#add_pc_update >>= fun () -> 269 | SM.update (fun c -> c#switch) >>= fun () -> 270 | self#add_pc_update >>= fun () -> 271 | SM.update (fun c -> c#switch) 272 | 273 | method! eval bil = 274 | super#eval (Stmt.normalize ~normalize_exp:true bil) 275 | 276 | method private eval_chunk chunk = 277 | self#update_event (Value.create Event.pc_update (Chunk.addr chunk)) >>= fun () -> 278 | match memory_of_chunk endian chunk with 279 | | Error er -> SM.update (fun c -> c#notify_error (`Damaged_chunk er)) 280 | | Ok mem -> SM.get () >>= fun ctxt -> 281 | match disasm_and_lift arch ctxt#mode mem with 282 | | Ok (sema, insn) -> 283 | let name = Disasm.insn_name insn in 284 | SM.update (fun c -> c#set_insn name) >>= fun () -> 285 | let bil = Insn.bil sema in 286 | SM.update (fun c -> c#set_bil bil) >>= fun () -> 287 | self#eval bil 288 | | Error er -> SM.update (fun c -> c#notify_error er) 289 | 290 | method! eval_memory_load mv = 291 | let addr = Bil.int @@ Move.cell mv in 292 | let data = Move.data mv in 293 | match Size.of_int_opt @@ Word.bitwidth data with 294 | | None -> SM.return () 295 | | Some size -> 296 | SM.get () >>= fun ctxt -> 297 | super#eval_store 298 | ~mem:(Bil.var mem_var) ~addr (Bil.int data) endian size >>= fun r -> 299 | SM.put ctxt >>= fun () -> 300 | super#update mem_var r >>= fun () -> 301 | super#eval_memory_load mv 302 | 303 | method! eval_pc_update addr = 304 | super#eval_pc_update addr >>= fun () -> 305 | self#verify_frame 306 | 307 | method! eval_exec code = 308 | super#eval_exec code >>= fun () -> 309 | SM.update (fun c -> c#set_code code) 310 | 311 | method! eval_mode mode = 312 | super#eval_mode mode >>= fun () -> 313 | SM.update (fun c -> c#set_mode mode) 314 | 315 | method! eval_event ev = 316 | super#eval_event ev >>= fun () -> 317 | Value.Match.( 318 | select @@ 319 | case Event.code_exec (fun _ -> SM.return ()) @@ 320 | case Event.mode (fun _ -> SM.return ()) @@ 321 | case Event.memory_store (fun _ -> SM.return ()) @@ 322 | case Event.memory_load (fun _ -> SM.return ()) @@ 323 | default (fun () -> self#update_event ev)) ev 324 | 325 | method private verify_frame : 'a u = 326 | SM.get () >>= fun ctxt -> 327 | match ctxt#code with 328 | | None -> SM.return () 329 | | Some code -> 330 | SM.update (fun c -> c#split) >>= fun () -> 331 | self#eval_chunk code >>= fun () -> 332 | SM.update (fun c -> c#merge) >>= fun () -> 333 | SM.return () 334 | 335 | method! eval_trace trace = 336 | super#eval_trace trace >>= fun () -> self#verify_frame 337 | 338 | method! eval_while ~cond ~body = 339 | super#eval_exp cond >>| value >>= function 340 | | Imm r when Word.(r = b1) -> self#eval body 341 | | _ -> SM.return () 342 | end 343 | --------------------------------------------------------------------------------