Source file affect_unix__mtime.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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
(*---------------------------------------------------------------------------
   Copyright (c) 2026 The affect programmers. All rights reserved.
   SPDX-License-Identifier: ISC
  ---------------------------------------------------------------------------*)

type uint64 = int64

module Span = struct
  (* N.B. this is a cut and paste from More.Mtime *)

  (* Time spans are by a nanosecond magnitude stored in an unsigned 64-bit
     integer. Allows to represent spans for ~584.5 Julian years. *)

  type t = uint64
  let zero = 0L
  let one = 1L
  let max_span = -1L

  let equal = Int64.equal
  let compare = Int64.unsigned_compare
  let is_shorter s ~than = compare s than < 0
  let is_longer s ~than = compare s than > 0

  let add = Int64.add
  let abs_sub s0 s1 =
    if compare s0 s1 < 0 then Int64.sub s1 s0 else Int64.sub s0 s1

  let sat_sub s0 s1 =
    if compare s0 s1 <= 0 then zero else Int64.sub s0 s1

  (* Durations *)

  let ( * ) n span = Int64.mul (Int64.of_int n) span
  let ( / ) span n = Int64.unsigned_div span (Int64.of_int n)
  let ( + ) = add
  let ( - ) = sat_sub
  let ns   =                      1L
  let us   =                  1_000L
  let ms   =              1_000_000L
  let s    =          1_000_000_000L
  let min  =         60_000_000_000L
  let hour =       3600_000_000_000L
  let day  =      86400_000_000_000L
  let year = 31_557_600_000_000_000L

  (* Conversions *)

  let to_uint64_ns s = s
  let of_uint64_ns ns = ns

  let max_float_int = 9007199254740992. (* 2^53. *)
  let int64_min_int_float = Int64.to_float Int64.min_int
  let int64_max_int_float = Int64.to_float Int64.max_int

  let of_float_ns sf =
    if sf < 0. || sf >= max_float_int || not (Float.is_finite sf)
    then None else Some (Int64.of_float sf)

  let to_float_ns s =
    if Int64.compare 0L s <= 0 then Int64.to_float s else
    int64_max_int_float +. (-. int64_min_int_float +. Int64.to_float s)

  let to_float_s s = 1e-9 *. to_float_ns s
  let of_float_s s = of_float_ns (s *. 1e9)

  let units = [|"ns"; "μs"; "ms"; "s"|]
  let pp ppf ns =
    let u = ref ns in
    let rem_u = ref 0L in
    let i = ref 0 in
    while (Int64.compare !u 1000L >= 0 && !i < 3) do
      rem_u := Int64.rem !u 1000L;
      u := Int64.(div !u 1000L);
      incr i;
    done;
    if !i = 0 then Format.fprintf ppf "%Luns" !u else
    let frac = Int64.div !rem_u 100L (* first decimal digit *) in
    Format.fprintf ppf "%Lu.%Lu%s" !u frac units.(!i)

  let pp_ns ppf s = Format.fprintf ppf "%Luns" s
end

(* Counters *)

type counter = Affect_unix__timeline.mtime_ns
let counter () = Affect_unix__timeline.mtime_now_ns ()
let count c = Int64.sub (Affect_unix__timeline.mtime_now_ns ()) c

let program_startup = counter ()
let elapsed () = count program_startup

(* Timestamps *)

type t = uint64
let now = Affect_unix__timeline.mtime_now_ns
let min_stamp = 0L
let max_stamp = -1L

(* Predicates *)

let equal = Int64.equal
let compare = Affect_unix__timeline.mtime_compare
let is_earlier t ~than = compare t than < 0
let is_later t ~than = compare t than > 0

(* Arithmetic *)

let span t0 t1 =
  if compare t0 t1 < 0 then Int64.sub t1 t0 else Int64.sub t0 t1

let add_span t span =
  let sum = Int64.add t span in
  if compare t sum <= 0 then Some sum else None

let sub_span t span =
  if compare t span < 0 then None else Some (Int64.sub t span)

(* Converting *)

let to_uint64_ns t = t
let of_uint64_ns ns = ns
let pp ppf s = Format.fprintf ppf "%Lu" s

(* Waiting *)

open Affect
open Affect.Action.Private

let wait_for_poll start span tag ~continue =
  if count start >= span
  then Some (continue (Action.Result.Value tag))
  else None

let wait_for_block start span tag ~blocked =
  if count start >= span then
    Action.Blocked.synced_unblock ~candidate:(Action.Result.Value tag) blocked
  else
  let timeline = Affect_unix__timeline.get_domain_local () in
  let deadline = Span.add start span in
  let blocked = Action.Blocked.Value.make tag blocked in
  Affect_unix__timeline.add_mtime_deadline timeline deadline blocked

let wait_for_key = Action.Meta.Key.make ~pp_value:Span.pp ()
let wait_for_meta span =
  let bindings = Action.Meta.[Binding (wait_for_key, span)] in
  Action.Meta.make ~name:"Mtime.wait_for" ~bindings ()

let wait_for' span tag =
  let start_wait span tag () =
    let start = counter () in
    let poll = wait_for_poll start span tag in
    let block = wait_for_block start span tag in
    Action.Primitive.make ~meta:(wait_for_meta span) ~poll ~block
  in
  Action.guard (start_wait span tag)

let wait_for span = Action.invoke (wait_for' span ())
let observe_wait_for span =
  let globally = counter () in
  Action.invoke (wait_for' span ());
  count globally