package mopsa

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

Source file logs.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
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
(****************************************************************************)
(*                                                                          *)
(* This file is part of MOPSA, a Modular Open Platform for Static Analysis. *)
(*                                                                          *)
(* Copyright (C) 2017-2019 The MOPSA Project.                               *)
(*                                                                          *)
(* This program is free software: 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, either version 3 of the License, or     *)
(* (at your option) any later version.                                      *)
(*                                                                          *)
(* This program 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.                      *)
(*                                                                          *)
(* You should have received a copy of the GNU Lesser General Public License *)
(* along with this program.  If not, see <http://www.gnu.org/licenses/>.    *)
(*                                                                          *)
(****************************************************************************)

(** Hook for displaying analysis logs as a tree *)

open Mopsa
open Format
open Core.All


(** Logs options *)
module type OPTIONS =
sig
  val name  : string
  val short : bool
end

module Hook(Options:OPTIONS) =
struct

  (** {2 Hook header} *)
  (** *************** *)

  let name = Options.name


  (** {2 Initialization} *)
  (** ****************** *)

  (* We use a stack for keeping the duration of exec and eval *)
  let stack = Stack.create ()

  let init ctx = Stack.clear stack


  (** {2 Indentation} *)
  (** *************** *)

  let color level s =
    let code = (level mod 16) * 16 + 10 in
    if !Debug.print_color then
      Printf.sprintf "\027[1;38;5;%dm%s\027[0m" code s
    else
      s

  type symbol =
    | BEGIN
    | END
    | MSG


  (** Symbol of a new entry *)
  let symbol_to_string symbol level =
    match symbol with
    | BEGIN -> color level "+"
    | END -> color level "o"
    | MSG -> color level "*"


  let is_end_symbol = function
    | END -> true
    | _ -> false


  (** Tabulation *)
  let tab level = color level "|"

  let cur_level () = max (Stack.length stack) 0

  (** Indent a message by adding tabs at the beginning of each line *)
  let indent ~symbol fmt =
    (* Get the formatted message as a string *)
    Format.kasprintf (fun str ->
        (* Split the message into lines *)
        let lines = String.split_on_char '\n' str in
        let level = cur_level () in
        match lines with
        | [] -> ()
        | first :: others ->

          (* The first line is prefixed with the entry symbol *)
          let first' = (symbol_to_string symbol level) ^ " " ^ first in

          (* The other lines are prefixed with the indent symbol *)
          let others' =
            if not (is_end_symbol symbol) then
              List.map (fun line -> (tab level) ^ " " ^ line) others
            else
              List.map (fun line -> "  " ^ line) others
          in

          (* Add the margin *)
          let margin = List.init level (fun i -> (tab i) ^ " ") |>
                       String.concat ""
          in
          let lines' = List.map (fun line ->
              margin ^ line
            ) (first' :: others')
          in

          printf "%a@."
            (pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@\n") pp_print_string)
            lines'
      ) fmt


  let reach loc =
    indent "reaching %a" pp_range loc ~symbol:MSG

  let pp_S fmt stmt =
    fprintf fmt "@[<v 3>S [| %a@] |]" pp_stmt stmt

  let pp_E semantic fmt exp =
    fprintf fmt "@[<v 3>E [| %a : %a@] |]%a"
      pp_expr exp
      pp_typ exp.etyp
      (fun fmt s ->
         if is_any_semantic s then () else fprintf fmt "<%a>" pp_semantic s
      ) semantic

  let pp_route_if_any fmt route =
    if compare_route route toplevel = 0 then
      ()
    else
      fprintf fmt " in %a" pp_route route

  let get_timing () =
    try Sys.time () -. Stack.pop stack
    with Stack.Empty -> Float.nan


  (** {2 Events handlers} *)
  (** ******************* *)

  let on_before_exec route stmt man flow =
    reach stmt.srange;
    if Options.short then
      indent "%a%a"
        pp_S stmt
        pp_route_if_any route
        ~symbol:BEGIN
    else
      indent "%a%a@,input @[%a@]"
        pp_S stmt
        pp_route_if_any route
        (format (Flow.print man.lattice.print)) flow
        ~symbol:BEGIN
    ;
    Stack.push (Sys.time ()) stack


  let on_after_exec route stmt man flow post =
    let time = get_timing () in
    let nb = Cases.cardinal post in
    if Options.short then
      indent "%a%a done [%.4fs, %d case%a]"
        pp_S stmt
        pp_route_if_any route
        time
        nb Debug.plurial_int nb
        ~symbol:END
    else
      indent "%a%a done [%.4fs, %d case%a]@ output: @[%a@]"
        pp_S stmt
        pp_route_if_any route
        time
        nb Debug.plurial_int nb
        (Cases.print
           (fun fmt _ flow ->
              format (Flow.print man.lattice.print) fmt flow
           )
        ) post
        ~symbol:END


  let on_before_eval route semantic exp man flow =
    if Options.short then
      indent "%a%a"
        (pp_E semantic) exp
        pp_route_if_any route
        ~symbol:BEGIN
    else
      indent "%a%a@,input: @[%a@]"
        (pp_E semantic) exp
        pp_route_if_any route
        (format (Flow.print man.lattice.print)) flow
        ~symbol:BEGIN
    ;
      Stack.push (Sys.time ()) stack

  let on_after_eval route semantic exp man flow evl =
    let time = get_timing () in
    let pp_evl fmt evl =
      Cases.print_result (
        fun fmt e flow ->
          Format.fprintf fmt "%a : %a%a"
            pp_expr e
            pp_typ e.etyp
            (fun fmt trans ->
               if SemanticMap.is_empty trans then ()
               else
                 fprintf fmt " ‖ %a"
                   (pp_print_list
                      ~pp_sep:(fun fmt () -> fprintf fmt " ‖ ")
                      (fun fmt (s,e) -> fprintf fmt "%a ⇝ %a : %a" pp_semantic s pp_expr e pp_typ e.etyp)
                   ) (SemanticMap.bindings trans)
            ) e.etrans
      ) fmt evl
    in
    let nb = Cases.cardinal evl in
    if Options.short then
      indent "%a = %a%a done [%.4fs, %d case%a]"
        (pp_E semantic) exp
        pp_evl evl
        pp_route_if_any route
        time
        nb Debug.plurial_int nb
        ~symbol:END
    else
      indent "%a%a done [%.4fs, %d case%a]@ output: @[%a]"
        (pp_E semantic) exp
        pp_route_if_any route
        time
        nb Debug.plurial_int nb
        pp_evl evl
        ~symbol:END

  let on_finish man flow =
    Stack.clear stack

end

let () =
  Core.Hook.register_stateless_hook (module Hook(struct let name = "logs" let short = false end));
  Core.Hook.register_stateless_hook (module Hook(struct let name = "short-logs" let short = true end))
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct