package binsec

  1. Overview
  2. Docs
package binsec
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file instr_cfg.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
(**************************************************************************)
(*  This file is part of BINSEC.                                          *)
(*                                                                        *)
(*  Copyright (C) 2016-2026                                               *)
(*    CEA (Commissariat à l'énergie atomique et aux énergies              *)
(*         alternatives)                                                  *)
(*                                                                        *)
(*  you can redistribute it and/or modify it under the terms of the GNU   *)
(*  Lesser General Public License as published by the Free Software       *)
(*  Foundation, version 2.1.                                              *)
(*                                                                        *)
(*  It is distributed in the hope that it will be useful,                 *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU Lesser General Public License for more details.                   *)
(*                                                                        *)
(*  See the GNU Lesser General Public License version 2.1                 *)
(*  for more details (enclosed in the file licenses/LGPLv2.1).            *)
(*                                                                        *)
(**************************************************************************)

module Key = Virtual_address

module Value = struct
  type t = Instruction.t

  let hash (i : t) = Virtual_address.hash i.Instruction.address
  let equal i1 i2 = i1 = i2
end

module type S = sig
  include Cfg.S

  val ordered_iter_vertex :
    compare:(vertex -> vertex -> int) -> (vertex -> unit) -> t -> unit

  val iter_vertex_by_address : (vertex -> unit) -> t -> unit

  val output_graph :
    out_channel -> t -> entry:vertex -> Virtual_address.t list -> unit

  val dump : filename:string -> t -> unit
end

module Make (H : Hashtbl.HashedType) = struct
  module G = Cfg.Make (Key) (Value) (H)
  include G

  type block = {
    leader : V.t;
    block : V.t list;
    succs : V.t list;
    preds : V.t list;
  }

  module D = Graph.Imperative.Digraph.ConcreteBidirectional (struct
    type t = block

    let compare b1 b2 = V.compare b1.leader b2.leader
    let hash b = V.hash b.leader
    let equal b1 b2 = V.equal b1.leader b2.leader
  end)

  module L = Graph.Leaderlist.Make (G)
  module H = Hashtbl.Make (V)

  let get_pred t v = match pred t v with [ v ] -> Some v | _ -> None
  let get_succ t v = match succ t v with [ v ] -> Some v | _ -> None

  let rec compare_preds_succs g v pred succ =
    match (pred, succ) with
    | None, None -> assert false
    | Some _, None -> -1
    | None, Some _ -> 1
    | Some p, Some s ->
        if V.equal v p then -1
        else if V.equal v s then 1
        else compare_preds_succs g v (get_pred g p) (get_succ g s)

  let compare_vertex g v1 v2 =
    if G.V.equal v1 v2 then 0
    else compare_preds_succs g v1 (get_pred g v2) (get_succ g v2)

  let rec diff lst1 lst2 acc =
    match (lst1, lst2) with
    | ls, [] -> List.rev_append ls acc
    | [], _ -> acc
    | a1 :: ls1, a2 :: ls2 ->
        if G.V.compare a1 a2 < 0 then diff ls1 lst2 (a1 :: acc)
        else if G.V.compare a1 a2 > 0 then diff lst1 ls2 acc
        else diff ls1 ls2 acc

  let diff lst1 lst2 = List.rev (diff lst1 lst2 [])

  let build_block g block =
    let succs, preds =
      List.fold_left
        (fun (succs, preds) v ->
          ( List.fold_left (fun l e -> e :: l) succs (succ g v),
            List.fold_left (fun l e -> e :: l) preds (pred g v) ))
        ([], []) block
    in
    let block = List.sort_uniq V.compare block in
    let succs = diff (List.sort_uniq V.compare succs) block in
    let preds = diff (List.sort_uniq V.compare preds) block in
    let block = List.sort_uniq (compare_vertex g) block in
    { leader = List.hd block; block; succs; preds }

  let build_block_graph cfg entry =
    let blocks = List.map (build_block cfg) (L.leader_lists cfg entry) in
    let htbl = H.create 17 in
    List.iter (fun b -> List.iter (fun v -> H.add htbl v b) b.block) blocks;
    let t = D.create () in
    List.iter
      (fun block ->
        let vertex = D.V.create block in
        D.add_vertex t vertex;
        List.iter
          (fun succ -> D.add_edge t vertex (H.find htbl succ))
          block.succs;
        List.iter
          (fun pred -> D.add_edge t (H.find htbl pred) vertex)
          block.preds)
      blocks;
    t

  let html_block callees block =
    let open Format in
    let align = "align=\"left\"" in
    let border = "border=\"1\"" in
    let open Colors in
    let color1 = asprintf "bgcolor=\"%a\"" pp FlatUI.greensea in
    let color2 = asprintf "bgcolor=\"%a\"" pp FlatUI.silver in
    let pp_mnemonic ppf vert =
      match V.inst vert with
      | None -> ()
      | Some inst ->
          let a = Instruction.address inst in
          let m = Instruction.mnemonic inst in
          if List.mem a callees then
            fprintf ppf "<font color=\"%a\">%a</font>" pp FlatUI.alizarin
              Mnemonic.pp m
          else Mnemonic.pp ppf m
    in
    block.block
    |> List.map (fun vert ->
           asprintf "<tr><td %s %s>%a</td><td %s %s %s>%a</td></tr>" border
             color1 Virtual_address.pp (V.addr vert) border color2 align
             pp_mnemonic vert)
    |> String.concat "\n"
    |> sprintf "<table border=\"0\" cellspacing=\"0\">\n%s\n</table>"

  let output_graph c g ~entry ca =
    let g = build_block_graph g entry in
    let module Dot = struct
      include Graph.Graphviz.Dot (struct
        include D

        let graph_attributes _ = []
        let default_vertex_attributes _ = [ `Shape `Plaintext ]
        let vertex_name b = Printf.sprintf "%i" (Hashtbl.hash b)
        let vertex_attributes b = [ `HtmlLabel (html_block ca b) ]
        let get_subgraph _ = None
        let default_edge_attributes _ = []
        let edge_attributes _ = [ `Minlen 1 ]
      end)
    end in
    Dot.output_graph c g

  let dump_oc oc g =
    let module Dot = Graph.Graphviz.Dot (struct
      include G

      let graph_attributes _ = []
      let default_vertex_attributes _ = []

      let vertex_name v =
        Format.asprintf "\"%a %a\"" Virtual_address.pp (V.addr v)
          (fun ppf v ->
            let open Format in
            match V.inst v with
            | None -> pp_print_string ppf ""
            | Some i -> fprintf ppf "%a" Mnemonic.pp (Instruction.mnemonic i))
          v

      let vertex_attributes _ = []
      let get_subgraph _ = None
      let default_edge_attributes _ = []
      let edge_attributes _ = []
    end) in
    Dot.output_graph oc g

  let dump ~filename g =
    let oc = open_out_bin filename in
    dump_oc oc g;
    close_out oc

  let ordered_iter_vertex ~compare (f : vertex -> unit) g =
    (* It is way better to use arrays (and even lists) than trees *)
    let dummy_v = G.V.of_addr (Virtual_address.create 0) in
    let a = Array.make (G.nb_vertex g) dummy_v in
    let i = ref 0 in
    iter_vertex
      (fun v ->
        a.(!i) <- v;
        incr i)
      g;
    Array.sort compare a;
    Array.iter f a

  let iter_vertex_by_address = ordered_iter_vertex ~compare:G.V.compare
end

module S = struct
  type t = string

  let hash s = Hashtbl.hash s
  let equal s1 s2 = s1 = s2
end

module F = Make (S)
include F