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
open Eio.Std
type 'time ty = [`Mock | 'time Eio.Time.clock_ty]
module type S = sig
type time
type t = time ty r
val make : unit -> t
val advance : t -> unit
val set_time : t -> time -> unit
end
module type TIME = sig
type t
val zero : t
val compare : t -> t -> int
val pp : t Fmt.t
end
module Make(T : TIME) : S with type time := T.t = struct
type t = T.t ty r
module Key = struct
type t = < >
let compare = compare
end
module Job = struct
type t = {
time : T.t;
resolver : unit Promise.u;
}
let compare a b = T.compare a.time b.time
end
module Q = Psq.Make(Key)(Job)
module Impl = struct
type time = T.t
type t = {
mutable now : T.t;
mutable q : Q.t;
}
let make () =
{
now = T.zero;
q = Q.empty;
}
let now t = t.now
let sleep_until t time =
if T.compare time t.now <= 0 then Fiber.yield ()
else (
let p, r = Promise.create () in
let k = object end in
t.q <- Q.add k { time; resolver = r } t.q;
try
Promise.await p
with Eio.Cancel.Cancelled _ as ex ->
t.q <- Q.remove k t.q;
raise ex
)
let set_time t time =
let rec drain () =
match Q.min t.q with
| Some (_, v) when T.compare v.time time <= 0 ->
Promise.resolve v.resolver ();
t.q <- Option.get (Q.rest t.q);
drain ()
| _ -> ()
in
drain ();
t.now <- time;
traceln "mock time is now %a" T.pp t.now
let advance t =
match Q.min t.q with
| None -> invalid_arg "No further events scheduled on mock clock"
| Some (_, v) -> set_time t v.time
type (_, _, _) Eio.Resource.pi += Raw : ('t, 't -> t, T.t ty) Eio.Resource.pi
let raw (Eio.Resource.T (t, ops)) = Eio.Resource.get ops Raw t
end
let handler =
Eio.Resource.handler (
H (Impl.Raw, Fun.id) ::
Eio.Resource.bindings (Eio.Time.Pi.clock (module Impl));
)
let make () =
Eio.Resource.T (Impl.make (), handler)
let set_time t v = Impl.set_time (Impl.raw t) v
let advance t = Impl.advance (Impl.raw t)
end
module Old_time = struct
type t = float
let compare = Float.compare
let pp f x = Fmt.pf f "%g" x
let zero = 0.0
end
module Mono_time = struct
type t = Mtime.t
let compare = Mtime.compare
let zero = Mtime.of_uint64_ns 0L
let pp f t =
let s = Int64.to_float (Mtime.to_uint64_ns t) /. 1e9 in
Fmt.pf f "%g" s
end
module Mono = Make(Mono_time)
include Make(Old_time)