adds riscv32 and riscv64 support

Makefile

@@ -55,7 +55,7 @@ testsuite:
 	git clone https://github.com/BinaryAnalysisPlatform/bap-testsuite.git testsuite
 
 check: testsuite
-	make REVISION=3eb55ac2b5085445 -C testsuite
+	make REVISION=eaa6b5e -C testsuite
 
 .PHONY: indent check-style status-clean
 

lib/bap_riscv/bap_riscv_target.ml

@@ -0,0 +1,81 @@
+open Core_kernel
+open Bap_core_theory
+
+let package = "bap"
+
+type r64 and r32 and r8
+
+type 'a bitv = 'a Theory.Bitv.t Theory.Value.sort
+
+let r64 : r64 bitv = Theory.Bitv.define 64
+let r32 : r32 bitv = Theory.Bitv.define 32
+let r8  : r8  bitv = Theory.Bitv.define 8
+
+let reg t n = Theory.Var.define t n
+let untyped = List.map ~f:Theory.Var.forget
+let (@<) xs ys = untyped xs @ untyped ys
+
+
+let regs = [
+  "zero";
+  "ra";
+  "sp";
+  "gp";
+  "tp";
+  "t0"; "t1"; "t2";
+  "s0"; "s1";
+  "a0"; "a1"; "a2"; "a3"; "a4"; "a5"; "a6"; "a7";
+  "s2"; "s3"; "s4"; "s5"; "s6"; "s7"; "s8"; "s9"; "s10"; "s11";
+  "t3"; "t4"; "t5"; "t6"
+]
+
+let array t = List.map regs ~f:(reg t)
+let vars p t = List.init 32 ~f:(fun i -> reg t (sprintf "%c%d" p  i))
+
+let parent = Theory.Target.declare ~package "riscv"
+    ~endianness:Theory.Endianness.le
+
+let select xs ~mask =
+  let mask = Set.of_list (module Int) mask in
+  List.filteri xs ~f:(fun i _ -> Set.mem mask i)
+
+let (--) x y = List.range x (y+1)
+
+let riscv t =
+  let mems = Theory.Mem.define t r8 in
+  let mem = reg mems "mem" in
+  let pc = reg t "PC" in
+  let ints = untyped@@vars 'X' t in
+  let flts = untyped@@vars 'F' t in
+  let vars = ints @< flts @< [pc] @< [mem] in
+  let bits = Theory.Bitv.size t in
+  let name = sprintf "riscv%d" bits in
+  let x i = select ints ~mask:i in
+  let f i = select flts ~mask:i in
+  Theory.Target.declare ~package name ~parent
+    ~bits
+    ~code:mem
+    ~data:mem
+    ~vars
+    ~regs:Theory.Role.Register.[
+        [general; integer], ints;
+        [general; floating], flts;
+        [constant; zero; pseudo], x[0];
+        [pseudo], untyped@@[pc];
+        [function_argument], x(10--17) @ f(10--17);
+        [function_return], x(10--12) @ f(10--12);
+        [link], x[1];
+        [stack_pointer], x[2];
+        [thread], x[3];
+        [caller_saved], x[1] @ x(5--7) @ x(10--17) @ x(28--31) @
+                        f(0--7) @ f(10--17) @ f(28--31);
+        [callee_saved], x[2] @ x(8--9) @ x(18--27) @
+                        f(8--9) @ f(18--27);
+
+      ]
+
+let riscv64 = riscv r64
+let riscv32 = riscv r32
+
+let llvm64 = Theory.Language.declare ~package "llvm-riscv64"
+let llvm32 = Theory.Language.declare ~package "llvm-riscv32"

lib/bap_riscv/bap_riscv_target.mli

@@ -0,0 +1,12 @@
+open Bap_core_theory
+
+
+type r64 and r32 and r8
+
+type 'a bitv = 'a Theory.Bitv.t Theory.Value.sort
+
+val parent  : Theory.Target.t
+val riscv32 : Theory.Target.t
+val riscv64 : Theory.Target.t
+val llvm32 : Theory.Language.t
+val llvm64 : Theory.Language.t

oasis/riscv

@@ -0,0 +1,24 @@
+Flag riscv
+ Description: Build Riscv lifter
+ Default: false
+
+Library "bap-riscv"
+ Build$:           flag(everything) || flag(riscv)
+ XMETADescription: common definitions for Riscv targets
+ Path: lib/bap_riscv
+ BuildDepends: core_kernel, bap-knowledge, bap-core-theory
+ FindlibName: bap-riscv
+ Modules: Bap_riscv_target
+
+Library riscv_plugin
+  XMETADescription: provide Riscv target
+  Path:             plugins/riscv
+  Build$:           flag(everything) || flag(riscv)
+  BuildDepends:     core_kernel, ppx_bap, ogre,
+                    bap-core-theory, bap-knowledge, bap-main,
+                    bap, bap-riscv, bap-c, bap-abi, bap-api,
+                    monads
+  FindlibName:      bap-plugin-riscv
+  InternalModules:  Riscv_main
+  DataFiles:        semantics/*.lisp ($datadir/bap/primus/semantics)
+  XMETAExtraLines:  tags="riscv, riscv64, riscv32"

plugins/primus_lisp/site-lisp/libc-init.lisp

@@ -17,6 +17,12 @@
               (logand main 0xfffffffe) ; to handle thumb jumps
               argc argv)))
 
+(defun riscv-reset-LR-to-prevent-infinite-loop (main argv base other)
+  (declare (context (target riscv))
+           (advice :before __libc_start_main)
+           (visibility :private))
+  (set X1 0))
+
 
 (defun setup-stack-canary ()
   (declare (context (abi "sysv"))

plugins/riscv/.merlin

@@ -0,0 +1,2 @@
+B ../../lib/bap_riscv
+REC

plugins/riscv/riscv_main.ml

@@ -0,0 +1,134 @@
+open Base
+open Bap_main
+open Bap.Std
+open Bap_core_theory
+open KB.Syntax
+module CT = Theory
+
+include Bap_main.Loggers()
+
+module Target = Bap_riscv_target
+module Dis = Disasm_expert.Basic
+
+let provides = [
+  "riscv";
+  "riscv64";
+  "riscv32";
+]
+
+
+let provide_decoding () =
+  KB.promise CT.Label.encoding @@ fun label ->
+  CT.Label.target label >>| fun t ->
+  if CT.Target.belongs Target.parent t
+  then if Theory.Target.belongs Target.riscv64 t
+    then Target.llvm64
+    else Target.llvm32
+  else CT.Language.unknown
+
+
+let enable_llvm encoding triple =
+  Dis.register encoding @@ fun _ ->
+  Dis.create ~attrs:"+a,+c,+d,+m" ~backend:"llvm" triple
+
+let enable_loader () =
+  let request_arch doc =
+    let open Ogre.Syntax in
+    match Ogre.eval (Ogre.request Image.Scheme.arch) doc with
+    | Error _ -> assert false
+    | Ok arch -> arch in
+  KB.promise CT.Unit.target @@ fun unit ->
+  KB.collect Image.Spec.slot unit >>| request_arch >>| function
+  | Some "riscv64" -> Target.riscv64
+  | Some "riscv32" -> Target.riscv32
+  | _ -> CT.Target.unknown
+
+module Abi = struct
+  open Bap_c.Std
+  open Bap.Std
+  open Monads.Std
+  open Monad.Option.Syntax
+  open Monad.Option.Let
+
+  let name = "riscv"            (* is there an official name? *)
+
+  let (.:()) file num = match Set.nth file num with
+    | None -> failwith "a wrong number of registers"
+    | Some v -> Var.reify v
+
+  let (.%()) file num = Bil.var file.:(num)
+
+  let is_floating = function
+    | `Basic {C.Type.Spec.t=#C.Type.real} -> true
+    | _ -> false
+
+  (* even x = x if x is even otherwise x+1 *)
+  let even x = x + x land 1
+
+  let data_model t =
+    let bits = Theory.Target.bits t in
+    new C.Size.base (if bits = 32 then `ILP32 else `LP64)
+
+  let insert_args t _sub _attrs {C.Type.Proto.return; args} =
+    let bits = Theory.Target.bits t in
+    let a = Theory.Target.regs t ~roles:Theory.Role.Register.[
+        integer; function_argument;
+      ] in
+    let fa = Theory.Target.regs t ~roles:Theory.Role.Register.[
+        floating; function_argument;
+      ] in
+    let regs = Set.length a in
+    let mem = Bil.var @@ Var.reify @@ Theory.Target.data t in
+    let* sp = Theory.Target.reg t Theory.Role.Register.stack_pointer >>| Var.reify in
+    let size = data_model t in
+    let stack t n =
+      size#bits t >>= Size.of_int_opt >>| fun sz ->
+      C.Abi.data size t,
+      Bil.load ~mem LittleEndian sz
+        ~addr:Bil.(var sp + int (Word.of_int ~width:bits n)) in
+    let param t n =
+      if n > regs then stack t (n - regs)
+      else
+        size#bits t >>= fun s ->
+        Monad.Option.guard (s <= 2 * bits) >>| fun () ->
+        C.Abi.data size t, match is_floating return,s <= bits with
+        | true,true -> fa.%(n)
+        | true,false -> Bil.concat fa.%(even n) fa.%(even n + 1)
+        | false,true -> a.%(n)
+        | false,false -> Bil.concat a.%(even n) a.%(even n + 1) in
+    let return = param return 0 in
+    let+ (_,params) = Monad.Option.List.fold args
+        ~init:(0,[]) ~f:(fun (used,pars) (_name,arg) ->
+            size#bits arg >>= fun argsz ->
+            param arg used >>| fun par ->
+            let used = if argsz <= bits then used + 1
+              else used + 2 + used land 1 in
+            used,par::pars) in
+    {C.Abi.return; params = List.rev params; hidden=[]}
+
+  let apply_headers proj =
+    let t = Project.target proj in
+    if Theory.Target.belongs Target.parent t then
+      let abi = C.Abi.{
+          insert_args = insert_args t;
+          apply_attrs = fun _ x -> x;
+        } in
+      C.Abi.register name abi;
+      let size = data_model t in
+      let apply_headers = C.Abi.create_api_processor size abi in
+      Bap_api.process apply_headers;
+      Project.set proj Bap_abi.name name
+    else proj
+end
+
+
+let main _ctxt =
+  enable_llvm Target.llvm64 "riscv64";
+  enable_llvm Target.llvm32 "riscv32";
+  enable_loader ();
+  provide_decoding ();
+  Bap_abi.register_pass Abi.apply_headers;
+  Ok ()
+
+let () = Bap_main.Extension.declare main
+    ~provides