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
(**
Counters for regions, for super-simple profiling support.
Useful for debugging combinatoric algorithms
or other algorithms with known complexity,
such as search, sorting, etc.
*)
open Source
module Value = Mo_values.Value
module T = Mo_types.Type
type t = {
label : ((region * string), int) Hashtbl.t ;
region : (region, int) Hashtbl.t ;
}
let dump_count = ref 0
let zeros () = {
label = Hashtbl.create 100 ;
region = Hashtbl.create 100 ;
}
let bump_region c reg =
if !ProfilerFlags.profile then
match Hashtbl.find_opt c.region reg with
Some n -> Hashtbl.replace c.region reg (n + 1)
| None -> Hashtbl.replace c.region reg 1
let bump_label c reg lab =
if !ProfilerFlags.profile then
match Hashtbl.find_opt c.label (reg, lab) with
Some n -> Hashtbl.replace c.label (reg, lab) (n + 1)
| None -> Hashtbl.replace c.label (reg, lab) 1
(* lexicographic on (left.file, left.line, left.column, right.line, right.column) *)
let region_order rega regb =
if rega.left.file = regb.left.file then
if rega.left.line = regb.left.line then
if rega.left.column = regb.left.column then
if rega.right.line = regb.right.line then
compare rega.right.column regb.right.column
else
compare rega.right.line regb.right.line
else
compare rega.left.column regb.left.column
else
compare rega.left.line regb.left.line
else
compare rega.left.file regb.left.file
let label_order laba labb =
compare laba labb
let dump (c:t) (ve: Value.value Value.Env.t) =
if !ProfilerFlags.profile then
if !ProfilerFlags.profile_verbose then (
Printf.printf "{\n" ;
Value.Env.iter (fun fn fv ->
Printf.printf " %s = %s;\n"
fn (Value.string_of_val 0 T.Non fv)
)
ve ;
Printf.printf "}\n"
) ;
let dump_count = begin
let d = !dump_count in
dump_count := d + 1;
d
end
in
(* Include all labeled regions in the final table: *)
let labeled_counts =
Hashtbl.fold (
fun (reg, label) count counts ->
((reg, Some label), count) :: counts)
c.label []
in
(* Include all other regions in the final table: *)
let all_region_counts =
Hashtbl.fold (
fun reg count counts ->
((reg, None), count) :: counts)
c.region labeled_counts
in
let sorted_counts =
List.sort (
(* Final ordering:
- counts; bigger first; this is the main ordering constraint.
- labels; labeled expressions before unlabeled
- regions; earlier/outer regions before later/enclosed ones
*)
fun
((rega, laba), x)
((regb, labb), y)
->
let diff = x - y in
if diff <> 0 then -diff else
match (laba, labb) with
(Some _, None) -> -1
| (None, Some _) -> 1
| (Some _, Some _) -> label_order laba labb
| (None, None) -> region_order rega regb
) all_region_counts
in
let file = open_out (!ProfilerFlags.profile_file) in
let (suffix, flds) =
(* the suffix of the line consists of field values for each field in `profile_field_names`: *)
List.fold_right
(fun var (line, flds) ->
match Value.Env.find_opt var ve with
None -> (Printf.sprintf "%s, #err" line, (var :: flds))
| Some v -> (Printf.sprintf "%s, %s" line (Value.string_of_val 0 T.Non v), var :: flds)
) !ProfilerFlags.profile_field_names ("", [])
in
Printf.fprintf file "# column: source region\n" ;
Printf.fprintf file "# column: source region count\n" ;
List.iter (fun fld -> Printf.fprintf file "# column: --profile-field: %s\n" fld)
(List.rev flds) ;
let lab_total = ref 0 in
let unlab_total = ref 0 in
List.iter (fun ((region, labop), region_count) ->
assert (dump_count = 0);
(match labop with
None -> unlab_total := !unlab_total + region_count
| Some x -> lab_total := !lab_total + region_count
);
) sorted_counts;
Printf.fprintf file "# count total (unlabeled): %d\n" !unlab_total ;
Printf.fprintf file "# ... labeled: %d\n" !lab_total ;
List.iter (fun ((region, labop), region_count) ->
assert (dump_count = 0);
Printf.fprintf file "%s\"%s\", %s, %d%s\n"
(!ProfilerFlags.profile_line_prefix)
(string_of_region region)
(match labop with
None -> "null"
| Some x -> Printf.sprintf "?\"%s\"" x
)
region_count
suffix
) sorted_counts;
close_out file