|
| 1 | +open Core_kernel |
| 2 | +open Bap.Std |
| 3 | +open Bap_core_theory |
| 4 | +open Bap_knowledge |
| 5 | + |
| 6 | +include Self () |
| 7 | + |
| 8 | +open KB.Syntax |
| 9 | + |
| 10 | +type groups = int Tid.Map.t |
| 11 | +type names = String.Set.t Int.Map.t |
| 12 | + |
| 13 | +type t = { |
| 14 | + groups : groups; |
| 15 | + names : names; |
| 16 | + next : int; |
| 17 | + stubs : Tid.Set.t; |
| 18 | +} |
| 19 | + |
| 20 | +let tids = Knowledge.Domain.mapping (module Tid) "tids" |
| 21 | + ~equal:Tid.equal |
| 22 | + ~inspect:sexp_of_tid |
| 23 | + |
| 24 | +let slot = Knowledge.Class.property |
| 25 | + Theory.Program.cls "stubs" tids |
| 26 | + ~persistent:(Knowledge.Persistent.of_binable (module struct |
| 27 | + type t = tid Tid.Map.t |
| 28 | + [@@deriving bin_io] |
| 29 | + end)) |
| 30 | + ~public:true |
| 31 | + ~desc:"The mapping from stubs to real symbols" |
| 32 | + |
| 33 | +let cls = Knowledge.Slot.cls slot |
| 34 | + |
| 35 | +let empty = { |
| 36 | + groups = Map.empty (module Tid); |
| 37 | + names = Map.empty (module Int); |
| 38 | + stubs = Set.empty (module Tid); |
| 39 | + next = 0; |
| 40 | +} |
| 41 | + |
| 42 | +let is_stub sub = |
| 43 | + KB.collect (Value.Tag.slot Sub.stub) (Term.tid sub) >>= function |
| 44 | + | None -> KB.return false |
| 45 | + | Some () -> KB.return true |
| 46 | + |
| 47 | +let aliases_of_sub s = KB.collect Theory.Label.aliases (Term.tid s) |
| 48 | + |
| 49 | +let update_stubs t sub = |
| 50 | + is_stub sub >>| fun is_stub -> |
| 51 | + if is_stub |
| 52 | + then { t with stubs = Set.add t.stubs (Term.tid sub) } |
| 53 | + else t |
| 54 | + |
| 55 | +let find_groups names aliases = |
| 56 | + Map.fold names ~init:[] |
| 57 | + ~f:(fun ~key:group ~data:aliases' groups -> |
| 58 | + if Set.(is_empty @@ inter aliases aliases') |
| 59 | + then groups |
| 60 | + else group :: groups) |
| 61 | + |
| 62 | +let unite_names t groups = |
| 63 | + List.fold groups ~init:(Set.empty (module String)) |
| 64 | + ~f:(fun als id -> |
| 65 | + Set.union als (Map.find_exn t.names id)) |
| 66 | + |
| 67 | +let pick_representative = function |
| 68 | + | [] -> assert false |
| 69 | + | groups -> |
| 70 | + List.min_elt groups ~compare:Int.compare |> |
| 71 | + Option.value_exn |
| 72 | + |
| 73 | +let redirect t ~from ~to_ = |
| 74 | + Map.map t.groups ~f:(fun id -> |
| 75 | + if List.mem from id ~equal:Int.equal |
| 76 | + then to_ |
| 77 | + else id) |
| 78 | + |
| 79 | +let add t sub = |
| 80 | + update_stubs t sub >>= fun t -> |
| 81 | + aliases_of_sub sub >>| fun aliases -> |
| 82 | + match find_groups t.names aliases with |
| 83 | + | [] -> |
| 84 | + let groups = Map.add_exn t.groups (Term.tid sub) t.next in |
| 85 | + let names = Map.add_exn t.names t.next aliases in |
| 86 | + { t with groups; names; next = t.next + 1 } |
| 87 | + | [id] -> |
| 88 | + let groups = Map.add_exn t.groups (Term.tid sub) id in |
| 89 | + let names = Map.update t.names id ~f:(function |
| 90 | + | None -> assert false |
| 91 | + | Some als' -> Set.union aliases als') in |
| 92 | + { t with names; groups } |
| 93 | + | groups -> |
| 94 | + let grp = pick_representative groups in |
| 95 | + let aliases = Set.union aliases (unite_names t groups) in |
| 96 | + let names = List.fold groups ~init:t.names ~f:Map.remove in |
| 97 | + let names = Map.add_exn names grp aliases in |
| 98 | + let groups = redirect t ~from:groups ~to_:grp in |
| 99 | + {t with names; groups;} |
| 100 | + |
| 101 | +let collect_by_group_id groups = |
| 102 | + Map.fold groups ~init:Int.Map.empty |
| 103 | + ~f:(fun ~key:tid ~data:id xs -> |
| 104 | + Map.update xs id ~f:(function |
| 105 | + | None -> [tid] |
| 106 | + | Some tids -> tid :: tids )) |
| 107 | + |
| 108 | +let unambiguous_pairs stubs xs = |
| 109 | + let is_stub tid = Set.mem stubs tid in |
| 110 | + Map.fold xs ~init:(Map.empty (module Tid)) |
| 111 | + ~f:(fun ~key:_group_id ~data:tids pairs -> |
| 112 | + match tids with |
| 113 | + | [x; y] -> |
| 114 | + begin |
| 115 | + match is_stub x, is_stub y with |
| 116 | + | true, false -> Map.add_exn pairs x y |
| 117 | + | false, true -> Map.add_exn pairs y x |
| 118 | + | _ -> pairs |
| 119 | + end |
| 120 | + | _ -> pairs) |
| 121 | + |
| 122 | +let find_pairs t = |
| 123 | + collect_by_group_id t.groups |> |
| 124 | + unambiguous_pairs t.stubs |
| 125 | + |
| 126 | +let resolve prog = |
| 127 | + Knowledge.Seq.fold ~init:empty |
| 128 | + (Term.to_sequence sub_t prog) ~f:add >>| |
| 129 | + find_pairs |
| 130 | + |
| 131 | +let provide prog = |
| 132 | + Knowledge.Object.create cls >>= fun obj -> |
| 133 | + resolve prog >>= fun links -> |
| 134 | + KB.provide slot obj links >>= fun () -> |
| 135 | + KB.return obj |
| 136 | + |
| 137 | +let run prog = |
| 138 | + match Knowledge.run cls (provide prog) (Toplevel.current ()) with |
| 139 | + | Ok (v,_) -> Knowledge.Value.get slot v |
| 140 | + | Error cnf -> |
| 141 | + error "%a\n" Knowledge.Conflict.pp cnf; |
| 142 | + Map.empty (module Tid) |
0 commit comments