Source file time.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
open Std

exception Timeout

type 'a clock_ty = [`Clock of 'a]
type 'a clock_base = 'a r constraint 'a = [> _ clock_ty]

module Pi = struct
  module type CLOCK = sig
    type t
    type time
    val now : t -> time
    val sleep_until : t -> time -> unit
  end

  type (_, _, _) Resource.pi +=
    | Clock : ('t, (module CLOCK with type t = 't and type time = 'time), [> 'time clock_ty]) Resource.pi

  let clock (type t time) (module X : CLOCK with type t = t and type time = time) =
    Resource.handler [ H (Clock, (module X)) ]
end

type 'a clock = ([> float clock_ty] as 'a) r

let now (type time) (t : [> time clock_ty] r) =
  let Resource.T (t, ops) = t in
  let module X = (val (Resource.get ops Pi.Clock)) in
  X.now t

let sleep_until (type time) (t : [> time clock_ty] r) time =
  let Resource.T (t, ops) = t in
  let module X = (val (Resource.get ops Pi.Clock)) in
  X.sleep_until t time

let sleep t d = sleep_until t (now t +. d)

module Mono = struct
  type ty = Mtime.t clock_ty
  type 'a t = ([> ty] as 'a) r

  let now = now
  let sleep_until = sleep_until

  let sleep_span t span =
    match Mtime.add_span (now t) span with
    | Some time -> sleep_until t time
    | None -> Fiber.await_cancel ()

  (* Converting floats via int64 is tricky when things overflow or go negative.
     Since we don't need to wait for more than 100 years, limit it to this: *)
  let too_many_ns = 0x8000000000000000.

  let span_of_s s =
    if s >= 0.0 then (
      let ns = s *. 1e9 in
      if ns >= too_many_ns then Mtime.Span.max_span
      else Mtime.Span.of_uint64_ns (Int64.of_float ns)
    ) else Mtime.Span.zero      (* Also happens for NaN and negative infinity *)

  let sleep t s =
    sleep_span t (span_of_s s)
end

let with_timeout t d = Fiber.first (fun () -> sleep t d; Error `Timeout)
let with_timeout_exn t d = Fiber.first (fun () -> sleep t d; raise Timeout)

module Timeout = struct
  type t =
    | Timeout of Mono.ty r * Mtime.Span.t
    | Unlimited

  let none = Unlimited
  let v clock time = Timeout ((clock :> Mono.ty r), time)

  let seconds clock time =
    v clock (Mono.span_of_s time)

  let run t fn =
    match t with
    | Unlimited -> fn ()
    | Timeout (clock, d) ->
      Fiber.first (fun () -> Mono.sleep_span clock d; Error `Timeout) fn

  let run_exn t fn =
    match t with
    | Unlimited -> fn ()
    | Timeout (clock, d) ->
      Fiber.first (fun () -> Mono.sleep_span clock d; raise Timeout) fn

  let sleep t =
    match t with
    | Unlimited -> Fiber.await_cancel ()
    | Timeout (clock, d) -> Mono.sleep_span clock d

  let pp_duration f d =
    if d >= 0.001 && d < 0.1 then
      Fmt.pf f "%.2gms" (d *. 1000.)
    else if d < 120. then
      Fmt.pf f "%.2gs" d
    else
      Fmt.pf f "%.2gm" (d /. 60.)

  let pp f = function
    | Unlimited -> Fmt.string f "(no timeout)"
    | Timeout (_clock, d) ->
      let d = Mtime.Span.to_float_ns d /. 1e9 in
      pp_duration f d
end