implements the superset disassembler

lib/bap/bap.mli

@@ -6040,6 +6040,19 @@ module Std : sig
           unlifted instructions.  *)
       val errors : t -> error list
     end
+
+    module SupersetDisasm : sig
+      type 'a t
+      val raw_superset : 
+        ?backend:string -> data:'a -> 
+        ?f:(mem * Basic.full_insn option -> 'a t -> 'a t) -> 
+        string -> 'a t
+      val trimmed_superset : 
+        data:'a ->  ?f:('a t -> mem -> Basic.full_insn option -> (addr option * edge) list -> 'a t) list -> 
+        backend:string -> string -> 'a t
+      val converged_superset : unit t -> unit t
+    end
+
   end
 
   (** Assembly instruction.

lib/bap_disasm/abstract_ssa.ml

@@ -0,0 +1,50 @@
+open Bap_types.Std
+open Bap_image_std
+open Core_kernel.Std
+
+let stmt_def_vars =
+  object(self)
+    inherit [Exp.Set.t] Stmt.visitor
+    method enter_move def use accu =
+      if not Var.(is_virtual def) then
+        Set.add accu Exp.(Bil.Var def)
+      else accu
+  end
+
+let stmt_use_vars =
+  object(self)
+    inherit [Exp.Set.t] Stmt.visitor
+    method enter_move def use accu =
+      Set.add accu use
+  end
+
+
+let stmt_def_freevars =
+  object(self)
+    inherit [Var.Set.t] Stmt.visitor
+    method enter_move def use accu =
+      if not Var.(is_virtual def) then
+        Set.add accu def
+      else accu
+  end
+
+let stmt_use_freevars =
+  object(self)
+    inherit [Var.Set.t] Stmt.visitor
+    method enter_move def use accu =
+      let free_vars = 
+        Set.filter ~f:(fun v -> not Var.(is_virtual v)) (Exp.free_vars use)
+      in Set.union accu free_vars
+  end
+
+let def_ssa bil =
+  stmt_def_vars#run bil Exp.Set.empty
+
+let use_ssa bil =
+  stmt_use_vars#run bil Exp.Set.empty 
+
+let def_freevars bil =
+  stmt_def_freevars#run bil Var.Set.empty
+
+let use_freevars bil =
+  stmt_use_freevars#run bil Var.Set.empty 

lib/bap_disasm/bap_disasm_std.ml

@@ -13,6 +13,7 @@ module Disasm_expert = struct
   type nonrec lifter = lifter
   module Basic = Bap_disasm_basic
   module Recursive = Bap_disasm_rec
+  module SupersetDisasm = Bap_disasm_superset
   module Linear = Bap_disasm_linear_sweep
   module Kind = Bap_insn_kind
   module Insn = Bap_disasm_basic.Insn

lib/bap_disasm/bap_disasm_superset.ml

@@ -0,0 +1,4 @@
+type 'a t = 'a Superset.t
+let raw_superset = Superset.superset_disasm_of_file
+let trimmed_superset = Trim.trimmed_disasm_of_file
+let converged_superset s = Trim.Default.trim Features.(apply_featurepmap Features.default_features s)

lib/bap_disasm/builder.ml

@@ -0,0 +1,10 @@
+open Core_kernel.Std
+open Bap.Std
+open Superset
+open Trim
+
+module Builder
+    (Superset : Superset_intf)
+    (Reducer : Reducer) = struct
+
+end

lib/bap_disasm/cfg_dot_layout.ml

@@ -0,0 +1,114 @@
+open Core_kernel.Std
+open Bap_types.Std
+open Bap_image_std
+open Graphlib.Std
+
+type colored_superset = Superset_risg.t * Addr.Hash_set.t String.Map.t
+         * Superset.elem Addr.Map.t
+
+module Make(T : sig val instance : colored_superset end) = struct
+  open T
+  module Dottable = struct
+    type t = colored_superset
+
+    module V = struct
+      type t = Superset_risg.G.V.t
+    end
+
+    module E = struct
+      type t = Superset_risg.G.E.t
+      let src (s,_) = s
+      let dst (_,d) = d
+    end
+
+    let iter_vertex f (g, _, _) =
+      Superset_risg.G.iter_vertex f g
+
+    let iter_edges_e f (g, _, _) =
+      Superset_risg.G.iter_edges_e f g
+
+    let graph_attributes _ = [
+        `Fontsize 14;
+      ]
+    let default_vertex_attributes gr = [
+        `Shape `Box; 
+        (*`Height 1.0*.Memory.(length mem);*)
+        `Fontsize 14;
+        `Fontcolor 0x666699;
+        `Fontname "Monospace";
+        `Width 1.0
+      ]
+
+    let red = 0xff0000
+    let green = 0x009900
+    let yellow = 0xffff00
+    let blue = 0x0000ff
+    let orange = 0xff6600
+    let purple = 0x660066
+    let brown = 0x663300
+    let cyan = 0x0099cc
+
+    let vertex_name name =
+      let fmt = Format.str_formatter in
+      Addr.(pp_generic ~prefix:`none ~suffix:`none ~format:`dec
+              fmt name);
+      Format.flush_str_formatter ()
+
+    let vertex_attributes v =
+      let default_attrs =
+        [
+          `Label ((vertex_name v));
+        ] in
+      let g, colors, insn_map = instance in
+      let contains name =
+        match Map.find colors name with
+        | Some(s) ->
+           Hash_set.mem s v
+        | None -> false in
+      let find_update default_attrs name color =
+        if contains name then
+          `Color color :: default_attrs
+        else default_attrs in
+      let default_attrs =
+        find_update default_attrs "False Negatives" red in
+      let default_attrs =
+        find_update default_attrs "True Positives" green in
+      let default_attrs =
+        find_update default_attrs "False Positives" yellow in
+      let default_attrs =
+        match List.hd default_attrs with
+        | Some (`Color _) -> 
+           default_attrs
+        | _ -> `Color 0X660000 :: default_attrs  in
+      match Map.find insn_map v with
+      | Some(mem,insn) ->
+         let len = float_of_int Memory.(length mem) in
+         `Height (1.0 *. len) ::
+           default_attrs
+      | None -> default_attrs
+
+
+    let get_subgraph _ = None
+    let default_edge_attributes _ = [
+        `Penwidth 1.0;
+        `Arrowsize 0.5;
+        `Headport `N;
+        `Tailport `S;
+        `Labelfloat true;
+      ]
+
+    let edge_attributes (src,dst) =
+      (*let color,weight = match kind,arity with
+        | `Fall,`Many -> 0x660000, 4
+        | `Fall,`Mono -> 0x000066, 8
+        | `Cond,_ -> 0x006600, 2
+        | `Jump,_ -> 0x000066, 2 in*)
+      [
+        (*`Color color;*)
+        (*`Weight weight;*)
+      ]
+  end
+  module Dot = Graph.Graphviz.Dot(Dottable)
+
+  include Dot
+end

lib/bap_disasm/common.ml

@@ -0,0 +1,14 @@
+open Bap_types.Std
+open Bap_image_std
+open Core_kernel.Std
+
+let img_of_filename filename = 
+  let img, errs = Image.create filename |> ok_exn in
+  List.iter errs ~f:(fun err ->
+      (Error.pp Format.std_formatter err);
+    );
+  img
+
+let create_memory arch min_addr data =
+  let data = Bigstring.of_string data in
+  Memory.create (Arch.endian arch) min_addr data