improves disassembler performance

lib/bap_disasm/bap_disasm_basic.ml

@@ -658,10 +658,7 @@ let with_disasm ?debug_level ?cpu ?backend triple ~f =
   create ?debug_level ?cpu ?backend triple >>= fun dis ->
   f dis >>| fun res -> close dis; res
 
-let switch : ('a,'k,'s,'r) state -> ('a,'k) t -> ('a,'k,'s,'r) state = fun s dis ->
-  let s = {s with dis} in
-  reset_predicates s s.current.preds;
-  s
+let switch s dis = {s with dis}
 
 let run ?backlog ?(stop_on=[]) ?invalid ?stopped ?hit dis ~return ~init mem =
   let state =

lib/bap_disasm/bap_disasm_calls.ml

@@ -158,6 +158,17 @@ let belongs {parents} ~entry:parent addr =
   | Top -> false
   | Set parents -> Set.mem parents parent
 
+let entry {parents; entries} addr =
+  match Solution.get parents addr with
+  | Top -> addr
+  | Set parents ->
+    let entries = Set.inter parents entries in
+    match Set.to_list entries with
+    | [] -> addr
+    | [parent] -> parent
+    | _ -> assert false
+
+
 let siblings {parents} x y =
   Addr.equal x y ||
   match Solution.get parents x, Solution.get parents y with

lib/bap_disasm/bap_disasm_calls.mli

@@ -10,6 +10,7 @@ val empty : t
 val equal : t -> t -> bool
 val update : t -> Driver.state -> t KB.t
 val belongs : t -> entry:addr -> addr -> bool
+val entry : t -> addr -> addr
 val entries : t -> Set.M(Addr).t
 val siblings : t -> addr -> addr -> bool
 val domain : t KB.domain

lib/bap_disasm/bap_disasm_symtab.ml

@@ -117,23 +117,32 @@ let insert_call ?(implicit=false) symtab block data =
     ecalls = Map.set symtab.ecalls ~key ~data
   }
 
-
 let explicit_callee {ecalls} = Map.find ecalls
 let implicit_callee {icalls} = Map.find icalls
 let callee tab src = match explicit_callee tab src with
   | Some dst -> Some dst
   | None -> implicit_callee tab src
 
+let update_graph calls graphs node f =
+  let addr = Block.addr node in
+  let entry = Callgraph.entry calls addr in
+  let start = Option.some_if (Addr.equal addr entry) node in
+  Map.update graphs entry ~f:(function
+      | None -> start,f Cfg.empty
+      | Some (entry,cfg) -> Option.first_some entry start, f cfg)
 
+let add_node calls graphs node =
+  update_graph calls graphs node @@
+  Cfg.Node.insert node
 
-let (<--) = fun g f -> match g with
-  | None -> None
-  | Some (e,g) -> Some (e, f g)
+let add_edge calls graphs edge =
+  update_graph calls graphs (Cfg.Edge.src edge) @@
+  Cfg.Edge.insert edge
 
-let build_cfg disasm calls entry =
-  Disasm.explore disasm ~entry ~init:None
-    ~follow:(fun dst ->
-        KB.return (Callgraph.belongs calls ~entry dst))
+let collect_graphs disasm calls =
+  Disasm.explore disasm
+    ~init:(empty,Map.empty (module Addr))
+    ~entries:(Set.to_sequence@@Disasm.subroutines disasm)
     ~block:(fun mem insns ->
         Disasm.execution_order insns >>= fun insns ->
         KB.List.filter_map insns ~f:(fun label ->
@@ -142,57 +151,31 @@ let build_cfg disasm calls entry =
             | None -> None
             | Some mem -> Some (mem, s)) >>| fun insns ->
         Block.create mem insns)
-    ~node:(fun n g ->
-        KB.return @@
-        if Addr.equal (Block.addr n) entry
-        then Some (n,Cfg.Node.insert n Cfg.empty)
-        else g <-- Cfg.Node.insert n)
-    ~edge:(fun src dst g ->
+    ~node:(fun n (tab,graphs) ->
+        KB.return (tab, add_node calls graphs n))
+    ~edge:(fun src dst (tab,graphs) ->
         let msrc = Block.memory src
-        and mdst = Block.memory dst in
+        and from = Block.addr src
+        and dest = Block.addr dst in
         let next = Addr.succ (Memory.max_addr msrc) in
-        let kind = if Addr.equal next (Memory.min_addr mdst)
-          then `Fall else `Jump in
-        let edge = Cfg.Edge.create src dst kind in
-        KB.return (g <-- Cfg.Edge.insert edge))
-
-
-let build_symbol disasm calls start =
-  build_cfg disasm calls start >>= function
-  | None -> failwith "Broken CFG, try bap --cache-clean"
-  | Some (entry,graph) ->
-    Symbolizer.get_name start >>| fun name ->
-    name,entry,graph
-
-let create_intra disasm calls =
-  Callgraph.entries calls |>
-  Set.to_sequence |>
-  KB.Seq.fold ~init:empty ~f:(fun symtab entry ->
-      build_symbol disasm calls entry >>| fun fn ->
-      add_symbol symtab fn)
-
-let create_inter disasm calls init =
-  Disasm.explore disasm
-    ~init
-    ~entries:(Set.to_sequence@@Disasm.subroutines disasm)
-    ~block:(fun mem _ -> KB.return mem)
-    ~node:(fun _ s -> KB.return s)
-    ~edge:(fun src dst s ->
-        let src = Memory.min_addr src
-        and dst = Memory.min_addr dst
-        and next = Addr.succ (Memory.max_addr src) in
-        if Callgraph.siblings calls src dst
-        then KB.return s
+        if Callgraph.siblings calls (Block.addr src) dest
+        then
+          let kind = if Addr.equal next dest then `Fall else `Jump in
+          let edge = Cfg.Edge.create src dst kind in
+          KB.return (tab,add_edge calls graphs edge)
         else
-          Symbolizer.get_name dst >>| fun name ->
-          if Addr.equal next dst
-          then {s with icalls = Map.set s.icalls src name}
-          else {s with ecalls = Map.set s.ecalls src name})
-
+          Symbolizer.get_name (Block.addr dst) >>| fun name ->
+          if Addr.equal next dest
+          then {tab with icalls = Map.set tab.icalls from name},graphs
+          else {tab with ecalls = Map.set tab.ecalls from name},graphs)
 
 let create disasm calls =
-  create_intra disasm calls >>=
-  create_inter disasm calls
+  let* (init,graphs) = collect_graphs disasm calls in
+  Map.to_sequence graphs |>
+  KB.Seq.fold ~init ~f:(fun tab (addr,(entry,cfg)) ->
+      let+ name = Symbolizer.get_name addr in
+      let entry = Option.value_exn entry in
+      add_symbol tab (name,entry,cfg))
 
 let result = Toplevel.var "symtab"
 

lib/bap_disasm/disasm.cpp

@@ -148,7 +148,6 @@ class disassembler {
 
     void push_pred(bap_disasm_insn_p_type p) {
         preds.push_back(p);
-        sort(preds.begin(), preds.end());
     }
 
     void clear_preds() {

lib/bap_types/bap_bitvector.ml

@@ -47,6 +47,7 @@ module Packed : sig
 
   val hash : t -> int
   val compare : t -> t -> int
+  val nsucc : t -> int -> t
 
   val lift1 : t -> (Bitvec.t -> Bitvec.t Bitvec.m) -> t
   val lift2 : t -> t -> (Bitvec.t -> Bitvec.t -> Bitvec.t Bitvec.m) -> t
@@ -95,6 +96,11 @@ end = struct
     {packed=Z.(x lsl metasize lor meta)}
   [@@inline]
 
+  let nsucc x n =
+    let w = bitwidth x in
+    let x = payload x in
+    pack Bitvec.(to_bigint (nsucc x n mod modulus w)) w
+
   let create ?(signed=false) x w =
     let m = Bitvec.modulus w in
     let x = Bitvec.(bigint x mod m) in
@@ -107,18 +113,21 @@ end = struct
     let x = payload x in
     pack Bitvec.(to_bigint (f x mod modulus w)) w
   [@@inline]
+  [@@specialize]
 
   let lift2 x y f =
     let w = bitwidth x in
     let x = payload x and y = payload y in
     pack Bitvec.(to_bigint (f x y mod modulus w)) w
   [@@inline]
+  [@@specialize]
 
   let lift3 x y z f =
     let w = bitwidth x in
     let x = payload x and y = payload y and z = payload z in
     pack Bitvec.(to_bigint (f x y z mod modulus w)) w
   [@@inline]
+  [@@specialize]
 
   module Stringable = struct
     type t = packed