package goblint

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

Source file goblint_timing.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
include Goblint_timing_intf

(** Dummy options used for initialization before {!S.start} is called. *)
let dummy_options: options = {
  cputime = false;
  walltime = false;
  allocated = false;
  count = false;
  tef = false;
}

(** TEF process ID for the next {!Make}.
    We give each timing hierarchy a separate PID in TEF such that they'd be rendered as separate tracks. *)
let next_tef_pid = ref 0

module Make (Name: Name): S =
struct
  let enabled = ref false
  let options = ref dummy_options
  let tef_pid =
    let tef_pid = !next_tef_pid in
    incr next_tef_pid;
    tef_pid

  let create_tree name =
    {
      name = name;
      cputime = 0.0;
      walltime = 0.0;
      allocated = 0.0;
      count = 0;
      children = [];
    }

  let root = create_tree Name.name

  (** A currently active timing frame in the stack. *)
  type frame = {
    tree: tree; (** Tree node, where the measurement results will be accumulated. *)
    start_cputime: float; (** CPU time at the beginning of the frame. *)
    start_walltime: float; (** Wall time at the beginning of the frame. *)
    start_allocated: float; (** Allocated memory at the beginning of the frame. *)
    (* No need for count, because it always gets incremented by 1. *)
  }

  let current_cputime (): float =
    let {Unix.tms_utime; tms_stime; tms_cutime; tms_cstime} = Unix.times () in
    (* Sum CPU time from userspace and kernel, including child processes.
       This way we account for preprocessor executions. *)
    tms_utime +. tms_stime +. tms_cutime +. tms_cstime

  let current_walltime (): float =
    Unix.gettimeofday ()

  let current_allocated = Gc.allocated_bytes

  let create_frame tree =
    {
      tree;
      start_cputime = if !options.cputime then current_cputime () else 0.0;
      start_walltime = if !options.walltime then current_walltime () else 0.0;
      start_allocated = if !options.allocated then current_allocated () else 0.0;
    }

  (** Stack of currently active timing frames. *)
  let current: frame Stack.t = Stack.create ()

  let reset () =
    (* Reset tree. *)
    root.cputime <- 0.0;
    root.walltime <- 0.0;
    root.allocated <- 0.0;
    root.count <- 0;
    root.children <- [];
    (* Reset frames. *)
    if not (Stack.is_empty current) then ( (* If ever started. In case reset before first start. *)
      Stack.clear current;
      Stack.push (create_frame root) current
    )

  let start options' =
    options := options';
    if !options.tef then (
      (* Override TEF process and thread name for track rendering. *)
      Catapult.Tracing.emit ~pid:tef_pid "thread_name" ~cat:["__firefox_profiler_hack__"] ~args:[("name", `String Name.name)] Catapult.Event_type.M;
      (* First event must have category, otherwise Firefox Profiler refuses to open. *)
      Catapult.Tracing.emit ~pid:tef_pid "process_name" ~args:[("name", `String Name.name)] Catapult.Event_type.M
    );
    enabled := true;
    if Stack.is_empty current then (* If never started. *)
      Stack.push (create_frame root) current

  let stop () =
    enabled := false

  let enter ?args name =
    (* Find the right tree. *)
    let tree: tree =
      let {tree; _} = Stack.top current in
      let rec loop = function
        | child :: _ when child.name = name -> child
        | _ :: children' -> loop children'
        | [] ->
          (* Not found, create new. *)
          let tree' = create_tree name in
          tree.children <- tree' :: tree.children;
          tree'
      in
      loop tree.children
    in
    Stack.push (create_frame tree) current;
    if !options.tef then
      Catapult.Tracing.begin' ~pid:tef_pid ?args name

  (** Add current frame measurements to tree node accumulators. *)
  let add_frame_to_tree frame tree =
    if !options.cputime then (
      let diff = current_cputime () -. frame.start_cputime in
      tree.cputime <- tree.cputime +. diff
    );
    if !options.walltime then (
      let diff = current_walltime () -. frame.start_walltime in
      tree.walltime <- tree.walltime +. diff
    );
    if !options.allocated then (
      let diff = current_allocated () -. frame.start_allocated in
      tree.allocated <- tree.allocated +. diff
    );
    if !options.count then
      tree.count <- tree.count + 1

  let exit name =
    let {tree; _} as frame = Stack.pop current in
    assert (tree.name = name);
    add_frame_to_tree frame tree;
    if !options.tef then
      Catapult.Tracing.exit' ~pid:tef_pid name

  let wrap ?args name f x =
    enter ?args name;
    match f x with
    | r ->
      exit name;
      r
    | exception e ->
      exit name;
      raise e

  (* Shortcutting measurement functions to avoid any work when disabled. *)

  let enter ?args name =
    if !enabled then
      enter ?args name

  let exit name =
    if !enabled then
      exit name

  let wrap ?args name f x =
    if !enabled then
      wrap ?args name f x
    else
      f x

  (** Root tree with current (entered but not yet exited) frame resources added.
      This allows printing with in-progress resources also accounted for. *)
  let root_with_current () =
    let rec tree_with_current current_rev tree =
      match current_rev with
      | frame :: current_rev' when tree == frame.tree ->
        let tree' = {tree with name = tree.name} in (* new physical copy to avoid mutating original tree *)
        add_frame_to_tree frame tree';
        let children = List.map (tree_with_current current_rev') tree.children in
        {tree' with children}
      | _ :: current_rev'
      | ([] as current_rev') ->
        tree (* no need to recurse, current doesn't go into subtree *)
    in
    (* Folding the stack also reverses it such that the root frame is at the beginning. *)
    let current_rev = Stack.fold (fun acc frame -> frame :: acc) [] current in
    tree_with_current current_rev root

  let rec pp_tree ppf node =
    Format.fprintf ppf "@[<v 2>%-25s      " node.name;
    if !options.cputime then
      Format.fprintf ppf "%9.3fs" node.cputime;
    if !options.walltime then
      Format.fprintf ppf "%10.3fs" node.walltime;
    if !options.allocated then
      Format.fprintf ppf "%10.2fMB" (node.allocated /. 1_000_000.0); (* TODO: or should it be 1024-based (MiB)? *)
    if !options.count then
      Format.fprintf ppf "%7d×" node.count;
    (* cut also before first child *)
    List.iter (Format.fprintf ppf "@,%a" pp_tree) (List.rev node.children);
    Format.fprintf ppf "@]"

  let pp_header ppf =
    Format.fprintf ppf "%-25s      " "";
    if !options.cputime then
      Format.fprintf ppf "   cputime";
    if !options.walltime then
      Format.fprintf ppf "   walltime";
    if !options.allocated then
      Format.fprintf ppf "   allocated";
    if !options.count then
      Format.fprintf ppf "   count";
    Format.fprintf ppf "@\n"

  let print ppf =
    pp_header ppf;
    pp_tree ppf (root_with_current ());
    Format.fprintf ppf "@\n"
end

let setup_tef filename =
  Catapult_file.set_file filename;
  Catapult_file.enable ();
  Catapult_file.setup ()

let teardown_tef () =
  Catapult_file.teardown ()
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