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
|
(* TEST
include systhreads;
hassysthreads;
{
bytecode;
}{
native;
}
*)
let cnt = ref 0
let alloc_thread = 50000
let (rd1, wr1) = Unix.pipe ()
let (rd2, wr2) = Unix.pipe ()
let main_thread = Thread.self ()
let cb_main = ref 0 and cb_other = ref 0
let stopped = ref false
let alloc_callback alloc =
if !stopped then
None
else begin
let t = Thread.self () in
if t == main_thread then begin
assert (alloc.Gc.Memprof.size < 10 || alloc.Gc.Memprof.size mod 2 = 0);
let do_stop = !cb_main >= alloc_thread in
if do_stop then stopped := true;
incr cb_main;
assert (Unix.write wr2 (Bytes.make 1 'a') 0 1 = 1);
if not do_stop then
assert (Unix.read rd1 (Bytes.make 1 'a') 0 1 = 1)
end else begin
assert (alloc.Gc.Memprof.size < 10 || alloc.Gc.Memprof.size mod 2 = 1);
let do_stop = !cb_other >= alloc_thread in
if do_stop then stopped := true;
incr cb_other;
assert (Unix.write wr1 (Bytes.make 1 'a') 0 1 = 1);
if not do_stop then
assert (Unix.read rd2 (Bytes.make 1 'a') 0 1 = 1)
end;
Some ()
end
let mut = Mutex.create ()
let () = Mutex.lock mut
let rec go alloc_num tid =
Mutex.lock mut;
Mutex.unlock mut;
if alloc_num < alloc_thread then begin
let len = 2 * (Random.int 200 + 1) + tid in
Sys.opaque_identity (Array.make len 0) |> ignore;
go (alloc_num + 1) tid
end else begin
cnt := !cnt + 1;
if !cnt < 2 then begin
Gc.minor (); (* check for callbacks *)
Thread.yield ();
go alloc_num tid
end else begin
Gc.minor () (* check for callbacks *)
end
end
let () =
let t = Thread.create (fun () -> go 0 1) () in
let _:Gc.Memprof.t =
Gc.Memprof.(start ~callstack_size:10 ~sampling_rate:1.
{ null_tracker with
alloc_minor = alloc_callback;
alloc_major = alloc_callback }) in
Mutex.unlock mut;
go 0 0;
Thread.join t;
Gc.Memprof.stop ();
assert (!cb_main >= alloc_thread);
assert (!cb_other >= alloc_thread);
assert (abs (!cb_main - !cb_other) <= 1)
|
