Source file clock.ml

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
open Eio.Std

module type S = sig
  type time

  type t = <
    time Eio.Time.clock_base;
    advance : unit;
    set_time : time -> unit;
  >

  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 Eio.Time.clock_base;
    advance : unit;
    set_time : T.t -> unit;
  >

  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)

  let make () =
    object (self)
      inherit [T.t] Eio.Time.clock_base

      val mutable now = T.zero
      val mutable q = Q.empty

      method now = now

      method sleep_until time =
        if T.compare time now <= 0 then Fiber.yield ()
        else (
          let p, r = Promise.create () in
          let k = object end in
          q <- Q.add k { time; resolver = r } q;
          try
            Promise.await p
          with Eio.Cancel.Cancelled _ as ex ->
            q <- Q.remove k q;
            raise ex
        )

      method set_time time =
        let rec drain () =
          match Q.min q with
          | Some (_, v) when T.compare v.time time <= 0 ->
            Promise.resolve v.resolver ();
            q <- Option.get (Q.rest q);
            drain ()
          | _ -> ()
        in
        drain ();
        now <- time;
        traceln "mock time is now %a" T.pp now

      method advance =
        match Q.min q with
        | None -> invalid_arg "No further events scheduled on mock clock"
        | Some (_, v) -> self#set_time v.time
    end

    let set_time (t:t) time = t#set_time time
    let advance (t:t) = t#advance
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)