An example of a BAP/Primus component that evaluates assignments and jump targets.

primus_evaluator_example.ml

(** 

MAKEFILE:

plugin = primus_evaluator_example

all: clean build install

build:
        bapbuild -pkg bap-primus -tags 'warn(A)' $(plugin).plugin

install:
        bapbundle install $(plugin).plugin

clean:
        bapbundle remove $(plugin).plugin
        bapbuild -clean
        rm -rf $(plugin).plugin

RUN IT:
    bap /path/to/exe --pass=run --run-argv=main,5

*)

open Core_kernel
open Bap.Std
open Bap_primus.Std
include Self()

module Bap_arg = Bap.Std.Arg

module Evaluator(Machine : Primus.Machine.S) = struct
  module Eval = Primus.Interpreter.Make(Machine)
  module Env = Primus.Env.Make(Machine)
  module Value = Primus.Value.Make(Machine)
  open Machine.Syntax

  let pos_tid = Primus.Pos.tid
  let string_of_tid = Tid.to_string

  let def_lhs t = Var.name (Def.lhs t)
  let def_rhs t = Exp.to_string (Def.rhs t)

  let print_sub_term t =
    Printf.printf "\nSUB------------------\n--> %s%!" (Sub.to_string t)

  let print_arg_term t =
    Printf.printf "--> %s%!" (Bap_arg.to_string t)

  let print_def_term t =
    Printf.printf "--> %s%!" (Def.to_string t)

  let print_jmp_term t =
    Printf.printf "--> %s%!" (Jmp.to_string t)

  let handle_arg t =
    let lhs = Bap_arg.lhs t in
    let rhs = Bap_arg.rhs t in
    let lhs_name = Var.name lhs in
    let lhs_index = Var.index lhs in
    let lhs_str = Printf.sprintf "%s.%d" lhs_name lhs_index in

    let intent_str =
      match Bap_arg.intent t with
      | None -> Printf.sprintf "unknown if meant for input or output"
      | Some x ->
        begin
          let intent = match x with
          | In -> Printf.sprintf "input"
          | Out -> Printf.sprintf "output"
          | Both -> Printf.sprintf "input and output"
          in
          Printf.sprintf "meant for %s" intent
        end
      in
    Format.printf "    --> %s's intent: %s\n%!" lhs_str intent_str;

    Eval.exp rhs >>= fun new_v ->
    let new_value_w = Value.to_word new_v in
    let new_value_str = Format.asprintf "%a" Word.pp_bin new_value_w in
    Format.printf "    --> %s has value: %s\n%!" lhs_str new_value_str;

    Machine.return ()

  let handle_assignment t =
    let lhs = Def.lhs t in
    let rhs = Def.rhs t in
    let lhs_name = Var.name lhs in
    let lhs_index = Var.index lhs in
    let lhs_str = Printf.sprintf "%s.%d" lhs_name lhs_index in

    Eval.exp rhs >>= fun new_v ->
    let new_value_w = Value.to_word new_v in
    let new_value_str = Format.asprintf "%a" Word.pp_bin new_value_w in
    Format.printf "    --> %s will get new value: %s\n%!" lhs_str new_value_str;

    Machine.return ()

  let handle_jmp t =
    let cond = Jmp.cond t in
    let cond_str = Exp.to_string cond in
    Format.printf "    --> Jump condition: %s\n%!" cond_str;
    match Jmp.kind t with
    | Goto l ->
      begin
        Format.printf "    --> Jump type: goto\n%!";
        match l with
        | Direct tid ->
          begin
            Printf.printf "    --> Direct to: %s\n%!" (Tid.to_string tid);
            Machine.return ()
          end
        | Indirect exp ->
          begin
            Printf.printf "    --> Indirect to: %s\n%!" (Exp.to_string exp);
            Eval.exp exp >>= fun target ->
            let target_w = Value.to_word target in
            let target_str = Format.asprintf "%a" Word.pp_bin target_w in
            Format.printf "    --> Target evaluates to: %s\n%!" target_str;
            Machine.return ()
          end
      end
    | Call c ->
      begin
        Format.printf "    --> Jump type: call\n%!";
        match Call.target c with
        | Direct tid ->
          begin
            Printf.printf "    --> Direct to: %s\n%!" (Tid.to_string tid);
            Machine.return ()
          end
        | Indirect exp ->
          begin
            Printf.printf "    --> Indirect to: %s\n%!" (Exp.to_string exp);
            Eval.exp exp >>= fun target ->
            let target_w = Value.to_word target in
            let target_str = Format.asprintf "%a" Word.pp_bin target_w in
            Format.printf "    --> Target evaluates to: %s\n%!" target_str;
            Machine.return ()
          end
      end
    | Ret l ->
      begin
        Format.printf "    --> Jump type: return\n%!";
        match l with
        | Direct tid ->
          begin
            Printf.printf "    --> Direct to: %s\n%!" (Tid.to_string tid);
            Machine.return ()
          end
        | Indirect exp ->
          begin
            Printf.printf "    --> Indirect to: %s\n%!" (Exp.to_string exp);
            Eval.exp exp >>= fun target ->
            let target_w = Value.to_word target in
            let target_str = Format.asprintf "%a" Word.pp_bin target_w in
            Format.printf "    --> Target evaluates to: %s\n%!" target_str;
            Machine.return ()
          end
      end
    | Int _ ->
      begin
        Format.printf "    --> Jump type: interrupt\n%!";
        Machine.return ()
      end

  (** Called when Primus enters a position. *)
  let enter_pos t =
    let open Primus.Pos in
    match t with
    | Top _ -> Machine.return ()
    | Sub {me; _} ->
      begin
        print_sub_term me;
        Machine.return ()
      end
    | Arg {me; _} -> 
      begin
        print_arg_term me;
        handle_arg me
      end
    | Blk _ -> Machine.return ()
    | Phi _ -> Machine.return ()
    | Def {me; _} ->
      begin
        print_def_term me;
        handle_assignment me
      end
    | Jmp {me; _} ->
      begin
        print_jmp_term me;
        handle_jmp me
      end

  (** Called when Primus is done. *)
  let all_done () =
    Printf.printf "\n-------------------- Primus finished.\n%!";
    Machine.return ()

  (** Register handlers for Primus events. *)
  let init () =
    Printf.printf "-------------------- Starting Primus trace.\n\n%!";
    Machine.sequence [
      Primus.Interpreter.enter_pos >>> enter_pos;
      Primus.Machine.finished >>> all_done;
    ]

end

(** Register the component with Primus. *)
let main _ =
  Primus.Machine.add_component (module Evaluator)

let () = Config.when_ready main