Minimal MIPS lifter for BAP

mips.ml

open Core_kernel.Std
open Bap.Std
open Or_error.Monad_infix

module Insn = Disasm_expert.Basic.Insn

module Mips = struct
  (** Defines the register map *)
  module CPU = struct
    let mem = Var.create "mem" @@ mem32_t `r8
    let reg name = Var.create name reg32_t
    let regs pref = Array.init ~f:(fun i -> reg @@ sprintf "%s%d" pref i)
    let zero = reg "zero"
    let at = reg "at"
    let v = regs "v" 4
    let a = regs "a" 4
    let t = regs "t" 10
    let s = regs "s" 8
    let k = regs "k" 2
    let gp = reg "gp"
    let sp = reg "sp"
    let fp = reg "fp"
    let ra = reg "ra"

    let gprs = Array.concat [
        v; a; t; s; k;
        [|zero; at; gp; sp; fp; ra |] ;
      ]

    let gpr = Array.to_list gprs |> Var.Set.of_list

    let reg_of_name name =
      let name = String.lowercase name in
      Array.find gprs ~f:(fun reg ->
      Var.name reg = name)

    (* the problem is that MIPS doesn't have flags at all,
       but we can just pretend that they are. They will not
       be used.  *)
    let flag n = Var.create n bool_t
    let zf = flag "zf"
    let cf = flag "cf"
    let vf = flag "vf"
    let nf = flag "nf"
    let never _ = false
    let is_reg = Set.mem gpr
    let is_flag = never
    let is_zf = never
    let is_cf = never
    let is_vf = never
    let is_nf = never
    let is_sp v = Var.same v sp
    let is_bp v = Var.same v fp
    let is_mem v = Var.same v mem
  end

  (** simplify an expression by applying constant folding *)
  let simpl = Bil.fixpoint Bil.fold_consts

  (** [reg op] is [Ok reg] if operand is a register with the same
      name as reg *)
  let reg = function
    | Op.Imm _ | Op.Fmm _ -> Or_error.errorf "expected register"
    | Op.Reg reg ->
      let name = Reg.name reg in
      match CPU.reg_of_name name with
      | None -> invalid_argf "unknown register %s" name ()
      | Some reg -> Ok reg


  (** [r_type f d s t] uses lifter [f] for an r-type instruction with
      arguments [d], [s], and [t]. TODO: add shift, and the rest.  *)
  let r_type f d s t = match reg d, reg s, reg t with
    | Ok d, Ok s, Ok t -> Ok (simpl (f d s t))
    | e1,e2,e3 -> Or_error.errorf "invalid instruction"

  (** [!$reg] lifts [reg] into a Bil expression, substitution a zero
      register with zero value (a smart version of [Bil.Var]. *)
  let (!$) reg =
    if Var.equal reg CPU.zero
    then Bil.int (Word.zero 32)
    else Bil.var reg


  (** {2 Instruction semantics}  *)

  let addu r0 r1 r2 = Bil.[
      r0 := !$r1 + !$r2;
    ]

  (** [lift mem insn] dispatches instructions to corresponding lifters. *)
  let lift mem insn = match Insn.name insn, Insn.ops insn with
    | "ADDu", [|r0;r1;r2|] -> r_type addu r0 r1 r2
    | _ -> Ok [Bil.special (Insn.asm insn)]
end

let () = register_target `mips (module Mips)

Compile:

bapbuild mips.plugin

Install:

bapbundle install mips.plugin

Test:

$ bap-mc --show-bil --arch=mips '\x00\x40\x08\x21'

Expect:

{
  at := v0
}