package mopsa

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

Source file hook.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
(****************************************************************************)
(*                                                                          *)
(* 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/>.    *)
(*                                                                          *)
(****************************************************************************)

(** Hooks are modules that can observe the execution of the transfer
    functions without modifying their output. They can be used however to enrich the
    analysis by adding information to the context.
*)

open Ast.Stmt
open Ast.Expr
open Lattice
open Flow
open Context
open Post
open Eval
open Route
open Manager
open Ast.Semantic
open Mopsa_utils


module type HOOK =
sig
  val name : string
  val init : 'a ctx -> 'a ctx
  val on_before_exec : route -> stmt -> ('a,'a) man -> 'a flow -> 'a ctx option
  val on_after_exec : route -> stmt -> ('a,'a) man -> 'a flow -> 'a post -> 'a ctx option
  val on_before_eval : route -> semantic -> expr -> ('a,'a) man -> 'a flow -> 'a ctx option
  val on_after_eval : route -> semantic -> expr -> ('a,'a) man -> 'a flow -> 'a eval -> 'a ctx option
  val on_finish : ('a,'a) man -> 'a flow -> unit
end


module type STATELESS_HOOK =
sig
  val name : string
  val init : 'a ctx -> unit
  val on_before_exec : route -> stmt -> ('a,'a) man  -> 'a flow -> unit
  val on_after_exec : route -> stmt -> ('a,'a) man -> 'a flow -> 'a post -> unit
  val on_before_eval : route -> semantic -> expr -> ('a,'a) man -> 'a flow -> unit
  val on_after_eval : route -> semantic -> expr -> ('a,'a) man -> 'a flow -> 'a eval -> unit
  val on_finish : ('a,'a) man -> 'a flow -> unit
end

module MakeStatefulHook(Hook:STATELESS_HOOK) : HOOK =
struct
  let name = Hook.name

  let init ctx =
    Hook.init ctx;
    ctx

  let on_before_exec route stmt man flow =
    Hook.on_before_exec route stmt man flow;
    None

  let on_after_exec route stmt man flow post =
    Hook.on_after_exec route stmt man flow post;
    None

  let on_before_eval route semantic exp man flow =
    Hook.on_before_eval route semantic exp man flow;
    None

  let on_after_eval route semantic exp man flow eval =
    Hook.on_after_eval route semantic exp man flow eval;
    None

  let on_finish = Hook.on_finish

end


(** Registered hooks *)
let hooks : (string,(module HOOK)) Hashtbl.t = Hashtbl.create 16

(** Active hooks *)
let active_hooks : (string,(module HOOK)) Hashtbl.t = Hashtbl.create 16

(** Initialized hooks *)
let initialized_hooks : (string,(module HOOK)) Hashtbl.t = Hashtbl.create 16


(** Register a new hook *)
let register_hook hook =
  let module H = (val hook : HOOK) in
  Hashtbl.add hooks H.name hook


(** Register a new stateless hook *)
let register_stateless_hook hook =
  let module H = (val hook : STATELESS_HOOK) in
  Hashtbl.add hooks H.name (module MakeStatefulHook(H))

(** Check whether a hook exists *)
let mem_hook name : bool =
  Hashtbl.mem hooks name

(** Find a hook by name *)
let find_hook (name:string) : (module HOOK) =
  Hashtbl.find hooks name

let list_hooks () : (module HOOK) list =
  Hashtbl.fold (fun _ h l -> h::l) hooks []


(** Initialize internals *)
let init () = ()



(** Initialize an active hook *)
let init_hook hook ctx =
  if Hashtbl.mem initialized_hooks hook then ctx else
  if not (Hashtbl.mem active_hooks hook) then Exceptions.panic "Inactive hook %s cannot be initialized" hook
  else
    let h = find_hook hook in
    let module H = (val h : HOOK) in
    let () = Hashtbl.add initialized_hooks hook (module H) in
    H.init ctx

let is_hook_active n : bool =
  Hashtbl.mem active_hooks n

(** Initialize all active hooks *)
let init_active_hooks ctx =
  Hashtbl.fold (fun name hook ctx ->
      init_hook name ctx
    ) active_hooks ctx


(** Activate a registered hook *)
let activate_hook name =
  let module H = (val find_hook name) in
  Hashtbl.add active_hooks name (module H)


(** Deactivate an active hook *)
let deactivate_hook name man flow =
  if not (Hashtbl.mem active_hooks name) then ()
  else
    let h = Hashtbl.find active_hooks name in
    let module H = (val h : HOOK) in
    H.on_finish man flow;
    Hashtbl.remove active_hooks name;
    Hashtbl.remove initialized_hooks name



(** Fire [on_before_exec] event *)
let on_before_exec route stmt man flow =
  Hashtbl.fold (fun name hook acc ->
      let flow =
        match acc with
        | None -> flow
        | Some ctx -> Flow.set_ctx ctx flow in
      let module H = (val hook : HOOK) in
      match H.on_before_exec route stmt man flow with
      | None -> acc
      | x -> x
    ) active_hooks None

(** Fire [on_after_exec] event *)
let on_after_exec route stmt man flow post =
  Hashtbl.fold (fun name hook acc ->
      let post =
        match acc with
        | None -> post
        | Some ctx -> Cases.set_ctx ctx post in
      let module H = (val hook : HOOK) in
      match H.on_after_exec route stmt man flow post with
      | None -> acc
      | x -> x
    ) active_hooks None


(** Fire [on_before_eval] event *)
let on_before_eval route semantic exp man flow =
  Hashtbl.fold (fun name hook acc ->
      let flow =
        match acc with
        | None -> flow
        | Some ctx -> Flow.set_ctx ctx flow in
      let module H = (val hook : HOOK) in
      match H.on_before_eval route semantic exp man flow with
      | None -> acc
      | x -> x
    ) active_hooks None


(** Fire [on_after_eval] event *)
let on_after_eval route semantic exp man flow evl =
  Hashtbl.fold (fun name hook acc ->
      let evl =
        match acc with
        | None -> evl
        | Some ctx -> Cases.set_ctx ctx evl in
      let module H = (val hook : HOOK) in
      match H.on_after_eval route semantic exp man flow evl with
      | None -> acc
      | x -> x
    ) active_hooks None


let on_finish man flow =
  Hashtbl.iter (fun name hook ->
      deactivate_hook name man flow
    ) active_hooks
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