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
|
(* TEST
include systhreads;
hassysthreads;
{
bytecode;
}{
native;
}
*)
(* A few triggers, to control timing of events between threads.
`await a` will wait until after `set a` has been called. *)
let t2_begin = Atomic.make false
let t2_promoting = Atomic.make false
let t2_finish_promote = Atomic.make false
let t2_done = Atomic.make false
let t2_quit = Atomic.make false
(* `await a` waits for the trigger `a` *)
let await a =
while not (Atomic.get a) do Thread.yield () done
(* `set a` pulls the trigger `a` *)
let set a =
Atomic.set a true
(* no-alloc printing to stdout *)
let say msg =
Unix.write_substring Unix.stdout msg 0 (String.length msg)
|> ignore
(*
The intended sequence of events in this test is as follows:
- thread 1 spawns thread 2 to run thread_fn.
- thread 2 starts thread_fn, waits for t2_begin.
- thread 1 starts a profile, sampling at 100%, which logs allocations and
has a complex "promote" callback which hands control flow back and
forth between threads.
- thread 1 allocates a large object (creating tracking entry 0), then
sets t2_begin and awaits t2_promoting. The alloc_major callback is run at
some point here, so tracking entry 0 now has no pending callbacks.
- thread 2 wakes on t2_begin.
- thread 2 allocates a small object, a ref cell, on the minor heap. This
creates tracking entry 1, and runs the alloc_minor callback.
- thread 2 commands a minor collection.
- In the minor collection, the small object is promoted. Tracking entry 1 is
now marked as promoted and having a runnable callback.
- The promotion callback runs (thread 2 runs this, because thread 1
is still waiting for t2_promoting). In the promotion callback, t2_promoting
is set, and then t2_finish_promote is awaited.
- thread 1 wakes on t2_promoting, clears its root, and sets off a full
major collection which should collect thread 1's large block. The
after-major-GC function runs, marking tracking entry 0 as deallocated.
- thread 1 then sets t2_finish_promote and awaits t2_done.
- thread 2 wakes on t2_finish_promote, finishes its promotion callback, then
returns to its main flow of control, clearing the reference to its small
block, setting t2_done and awaiting t2_quit.
- thread 1 wakes on t2:done, does another full collection, which should
free the small block from thread 2 and mark its tracking entry for a dealloc
callback. Then it stops the profile, sets t2_quit, and joins thread 2.
- thread 2 wakes on t2_quit and exits.
- thread 1 joins thread 2 and exits.
Note that the implementation of threads in the bytecode backend
performs some allocations of its own. TODO: update these to use
CAML_DONT_TRACK to avoid statmemprof. For now, I have tweaked the test
so that it doesn't track minor allocations of sizes larger than 1.
*)
let static_ref = ref 0
let global = ref static_ref
let thread_fn () =
await t2_begin;
say "T2: alloc\n";
global := ref 0;
say "T2: minor GC\n";
Gc.minor ();
global := static_ref;
say "T2: done\n";
set t2_done;
await t2_quit
let big = ref [| |]
let fill_big () = big := Array.make 1000 42
[@@inline never] (* Prevent flambda to move the allocated array in a global
root (see #9978). *)
let empty_big () = big := [| |]
[@@inline never]
let () =
let th = Thread.create thread_fn () in
let _:Gc.Memprof.t = Gc.Memprof.(start ~sampling_rate:1.
{ null_tracker with
alloc_minor = (fun info -> say " minor alloc\n"; Some ());
alloc_major = (fun _ -> say " major alloc\n"; Some "major block\n");
promote = (fun () ->
say " promoting...\n";
set t2_promoting;
await t2_finish_promote;
say " ...done promoting\n";
Some "promoted block\n");
dealloc_major = (fun msg ->
say " major dealloc: "; say msg)})
in
say "T1: alloc\n";
fill_big ();
set t2_begin;
await t2_promoting;
say "T1: major GC\n";
empty_big ();
Gc.full_major ();
set t2_finish_promote;
await t2_done;
say "T1: major GC\n";
Gc.full_major ();
say "T1: done\n";
Gc.Memprof.stop ();
set t2_quit;
Thread.join th
|
