package mopsa

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

Source file marker.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
(****************************************************************************)
(*                                                                          *)
(* This file is part of MOPSA, a Modular Open Platform for Static Analysis. *)
(*                                                                          *)
(* Copyright (C) 2017-2021 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/>.    *)
(*                                                                          *)
(****************************************************************************)

(** Trace markers *)

open Ast.Stmt
open Ast.Visitor
open Mopsa_utils

type marker = ..

type marker_info = {
  marker_name : string;
  marker_print_name : (marker -> string) -> marker -> string;
  marker_print : (Format.formatter -> marker -> unit) -> Format.formatter -> marker -> unit;
  marker_compare : (marker -> marker -> int) -> marker -> marker -> int;
}

let compare_marker_chain =
  ref (fun m1 m2 -> Stdlib.compare m1 m2)

let pp_marker_chain  =
  ref (fun fmt mk -> Exceptions.panic "marker not registered")

let name_marker_chain =
  ref (fun m -> Exceptions.panic "marker not registered")

let compare_marker m1 m2 = !compare_marker_chain m1 m2
let pp_marker fmt m = !pp_marker_chain fmt m
let get_marker_name m = !name_marker_chain m

let all_markers = ref []

let register_marker info =
  pp_marker_chain := info.marker_print !pp_marker_chain;
  compare_marker_chain := info.marker_compare !compare_marker_chain;
  name_marker_chain := info.marker_print_name !name_marker_chain;
  all_markers := info.marker_name :: !all_markers

type stmt_kind +=
  | S_add_marker of marker

let mk_add_marker m range =
  mk_stmt (S_add_marker m) range

let opt_enabled_markers = ref []

let enable_marker name =
  opt_enabled_markers := name :: !opt_enabled_markers

let disable_marker name =
  opt_enabled_markers := List.filter (fun name' -> name' <> name) !opt_enabled_markers

let is_marker_enabled m =
  match !opt_enabled_markers with
  | [] -> true
  | l ->
    let name = get_marker_name m in
    List.exists (fun name' -> String.equal name name') !opt_enabled_markers

let available_markers () = !all_markers

let () = register_stmt_with_visitor {
    print = (fun next fmt stmt ->
        match skind stmt with
        | S_add_marker m ->
          Format.fprintf fmt "add-marker(%a)" pp_marker m
        | _ ->
          next fmt stmt
      );
    compare = (fun next s1 s2 ->
        match skind s1, skind s2 with
        | S_add_marker m1, S_add_marker m2 ->
          compare_marker m1 m2
        | _ ->
          next s1 s2
      );
    visit = (fun next stmt ->
        match skind stmt with
        | S_add_marker _ -> leaf stmt
        | _ -> next stmt
      );
  }
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