1 |
external dump_heap_c: unit -> unit = "heap_dump" |
external dump_heap_c: unit -> unit = "heap_dump" |
2 |
external set_tag : 'a -> int -> unit = "heap_set_tag" |
external set_tag : 'a -> int -> unit = "heap_set_tag" |
3 |
|
|
4 |
|
(* open CommonGlobals *) |
5 |
|
(* open CommonTypes *) |
6 |
|
|
7 |
let memstat_functions = ref [] |
let memstat_functions = ref [] |
8 |
|
|
9 |
let add_memstat m f = memstat_functions := (m,f) :: !memstat_functions |
let add_memstat m f = memstat_functions := (m,f) :: !memstat_functions |
10 |
|
|
11 |
let print_memstats (level : int) buf = |
let print_memstats (level : int) buf output_type = |
12 |
let level = if level < 0 then begin |
let level = if level < 0 then begin |
13 |
Gc.compact (); -level |
Gc.compact (); -level |
14 |
end else level in |
end else level in |
15 |
|
|
16 |
|
if output_type = true then |
17 |
|
begin |
18 |
|
Printf.bprintf buf "\\<div class=results\\>"; |
19 |
|
(* |
20 |
|
html_mods_table_header buf "memstatsTable" "memstats" []; |
21 |
|
html_mods_td buf [ |
22 |
|
("", "srh", "Memory Debug Stats"); ]; |
23 |
|
*) |
24 |
|
Printf.bprintf buf "\\<div class=\\\"results\\\"\\> |
25 |
|
\\<table id=\\\"memstatsTable\\\" name=\\\"memstatsTable\\\" class=\\\"results\\\" cellspacing=0 cellpadding=0\\> |
26 |
|
\\<tr\\>\\<td class=\\\"srh\\\" \\>Memory Debug Stats\\</td\\>"; |
27 |
|
Printf.bprintf buf "\\</tr\\>\\</table\\>\\</div\\>\n" |
28 |
|
end |
29 |
|
else |
30 |
Printf.bprintf buf "Memory Debug Stats:\n"; |
Printf.bprintf buf "Memory Debug Stats:\n"; |
31 |
let list = List.rev !memstat_functions in |
let memstat_list = List.rev !memstat_functions in |
32 |
List.iter (fun (m,f) -> |
if output_type = true then |
33 |
Printf.bprintf buf "\n----------------------------------\n"; |
begin |
34 |
Printf.bprintf buf " Module %s:\n" m ; |
let split_string c str = |
35 |
Printf.bprintf buf "----------------------------------\n"; |
let rec aux s acc = |
36 |
f level buf) list; |
try let ind=String.index s c in |
37 |
|
aux (String.sub s (ind+1) ((String.length s) - ind -1 )) |
38 |
dump_heap_c () |
((String.sub s 0 ind)::acc) |
39 |
|
with Not_found -> List.rev (s::acc) |
40 |
|
in aux str []; in |
41 |
|
let split_lines = split_string '\n' in |
42 |
|
|
43 |
|
List.iter (fun (m,f) -> |
44 |
|
(* |
45 |
|
html_mods_table_header buf "memstatsTable" "memstats" [ |
46 |
|
( "0", "srh", "Module", m ); ]; |
47 |
|
*) |
48 |
|
Printf.bprintf buf "\\<div class=\\\"results\\\"\n\\>\\<table id=\\\"memstatsTable\\\" name=\\\"memstatsTable\\\" class=\\\"results\\\" cellspacing=0 cellpadding=0 |
49 |
|
\\>\\<tr\\>\\<td class=\\\"srh\\\" \\>Module %s\\</td\\>\\</tr\\>" m; |
50 |
|
let buftmp = Buffer.create 100 in |
51 |
|
f level buftmp; |
52 |
|
let listtmp = split_lines (Buffer.contents buftmp) in |
53 |
|
(List.iter (fun s -> |
54 |
|
(* |
55 |
|
html_mods_td buf [ |
56 |
|
("", "srh", s); ]; |
57 |
|
*) |
58 |
|
Printf.bprintf buf "\\<tr class=\\\"dl-1\\\"\\>\\<td class=\\\"sr\\\"\\>"; |
59 |
|
Printf.bprintf buf "%s" s; |
60 |
|
Printf.bprintf buf "\\</td\\>\\</tr\\>"; |
61 |
|
) listtmp); |
62 |
|
|
63 |
|
Printf.bprintf buf "\\</table\\>\\</div\\>\n"; |
64 |
|
) memstat_list; |
65 |
|
|
66 |
|
Printf.bprintf buf "\\</div\\>\n"; |
67 |
|
dump_heap_c () |
68 |
|
end |
69 |
|
else |
70 |
|
begin |
71 |
|
List.iter (fun (m,f) -> |
72 |
|
Printf.bprintf buf "\n----------------------------------\n"; |
73 |
|
Printf.bprintf buf " Module %s:\n" m ; |
74 |
|
Printf.bprintf buf "----------------------------------\n"; |
75 |
|
f level buf) memstat_list; |
76 |
|
|
77 |
|
dump_heap_c () |
78 |
|
end; |