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
open Common_
type out =
[ `Stdout
| `Stderr
| `File of string
]
type event =
| E_write_buf of Buf.t
| E_tick
type state = {
buf_pool: Buf_pool.t;
oc: out_channel;
events: event B_queue.t;
}
let with_out_ (out : out) f =
let oc, must_close =
match out with
| `Stdout -> stdout, false
| `Stderr -> stderr, false
| `File path -> open_out path, true
in
if must_close then (
let finally () = close_out_noerr oc in
Fun.protect ~finally (fun () -> f oc)
) else
f oc
let handle_ev (self : state) (ev : event) : unit =
match ev with
| E_tick -> flush self.oc
| E_write_buf buf ->
output self.oc buf.buf 0 buf.offset;
Buf_pool.recycle self.buf_pool buf
let bg_loop (self : state) : unit =
let continue = ref true in
while !continue do
match B_queue.pop_all self.events with
| exception B_queue.Closed -> continue := false
| evs -> List.iter (handle_ev self) evs
done
let bg_thread ~buf_pool ~out ~(events : event B_queue.t) () : unit =
let@ oc = with_out_ out in
let st = { oc; buf_pool; events } in
bg_loop st
(** Thread that simply regularly "ticks", sending events to
the background thread so it has a chance to write to the file,
and call [f()] *)
let tick_thread events : unit =
try
while true do
Thread.delay 0.5;
B_queue.push events E_tick
done
with B_queue.Closed -> ()