eio.mock: auto-advancing mock clock

README.md

@@ -982,16 +982,24 @@ The standard environment provides a [clock][Eio.Time] with the usual POSIX time:
 ```ocaml
 # Eio_main.run @@ fun env ->
   let clock = Eio.Stdenv.clock env in
-  traceln "The time is now %f" (Eio.Time.now clock);
-  Eio.Time.sleep clock 1.0;
   traceln "The time is now %f" (Eio.Time.now clock);;
 +The time is now 1623940778.270336
-+The time is now 1623940779.270336
 - : unit = ()
 ```
 
-You might like to replace this clock with a mock for tests.
-In fact, this README does just that! See [doc/prelude.ml](doc/prelude.ml) for the fake clock used in the example above.
+The mock backend provides a mock clock that advances automatically where there is nothing left to do:
+
+```ocaml
+# Eio_mock.Backend.run_full @@ fun env ->
+  let clock = Eio.Stdenv.clock env in
+  traceln "Sleeping for five seconds...";
+  Eio.Time.sleep clock 5.0;
+  traceln "Resumed";;
++Sleeping for five seconds...
++mock time is now 5
++Resumed
+- : unit = ()
+```
 
 ## Multicore Support
 

doc/prelude.ml

@@ -4,30 +4,16 @@
 module Eio_main = struct
   open Eio.Std
 
-  let now = ref 1623940778.27033591
-
   module Fake_clock = struct
     type time = float
-    type t = time Eio.Time.clock_ty r  (* The real clock *)
-
-    let make real_clock = (real_clock :> t)
-
-    let sleep_until real_clock time =
-      (* The fake times are all in the past, so we just ask to wait until the
-         fake time is due and it will happen immediately. If we wait for
-         multiple times, they'll get woken in the right order. At the moment,
-         the scheduler only checks for expired timers when the run-queue is
-         empty, so this is a convenient way to wait for the system to be idle.
-         TODO: This is no longer true (since #213). *)
-      Eio.Time.sleep_until real_clock time;
-      now := max !now time
-
-    let now _ = !now
+    type t = unit
+    let sleep_until () _time = failwith "No sleeping in tests!"
+    let now _ = 1623940778.27033591
   end
 
   let fake_clock =
     let handler = Eio.Time.Pi.clock (module Fake_clock) in
-    fun real_clock -> Eio.Resource.T (Fake_clock.make real_clock, handler)
+    Eio.Resource.T ((), handler)
 
   let run fn =
     (* To avoid non-deterministic output, we run the examples a single domain. *)
@@ -41,7 +27,7 @@ module Eio_main = struct
       method cwd         = env#cwd
       method process_mgr = env#process_mgr
       method domain_mgr  = fake_domain_mgr
-      method clock       = fake_clock env#clock
+      method clock       = fake_clock
     end
 end
 

lib_eio/mock/backend.ml

@@ -6,22 +6,57 @@ exception Deadlock_detected
 (* The scheduler could just return [unit], but this is clearer. *)
 type exit = Exit_scheduler
 
+type stdenv = <
+  clock : Clock.t;
+  mono_clock : Clock.Mono.t;
+  debug : Eio.Debug.t;
+  backend_id: string;
+>
+
 type t = {
   (* Suspended fibers waiting to run again.
      [Lf_queue] is like [Stdlib.Queue], but is thread-safe (lock-free) and
      allows pushing items to the head too, which we need. *)
   run_q : (unit -> exit) Lf_queue.t;
+
+  mono_clock : Clock.Mono.t;
 }
 
+module Wall_clock = struct
+  type t = Clock.Mono.t
+  type time = float
+
+  let wall_of_mtime m = Int64.to_float (Mtime.to_uint64_ns m) /. 1e9
+  let wall_to_mtime w = Mtime.of_uint64_ns (Int64.of_float (w *. 1e9))
+
+  let now t = wall_of_mtime (Eio.Time.Mono.now t)
+  let sleep_until t time = Eio.Time.Mono.sleep_until t (wall_to_mtime time)
+end
+
+let wall_clock =
+  let handler = Eio.Time.Pi.clock (module Wall_clock) in
+  fun mono_clock -> Eio.Resource.T (mono_clock, handler)
+
 (* Resume the next runnable fiber, if any. *)
-let schedule t : exit =
+let rec schedule t : exit =
   match Lf_queue.pop t.run_q with
   | Some f -> f ()
-  | None -> Exit_scheduler      (* Finished (or deadlocked) *)
+  | None ->
+    (* Nothing is runnable. Try advancing the clock. *)
+    if Clock.Mono.try_advance t.mono_clock then schedule t
+    else Exit_scheduler      (* Finished (or deadlocked) *)
 
 (* Run [main] in an Eio main loop. *)
-let run main =
-  let t = { run_q = Lf_queue.create () } in
+let run_full main =
+  let mono_clock = Clock.Mono.make () in
+  let clock = wall_clock mono_clock in
+  let stdenv = object (_ : stdenv)
+    method clock = clock
+    method mono_clock = mono_clock
+    method debug = Eio.Private.Debug.v
+    method backend_id = "mock"
+  end in
+  let t = { run_q = Lf_queue.create (); mono_clock } in
   let rec fork ~new_fiber:fiber fn =
     (* Create a new fiber and run [fn] in it. *)
     Effect.Deep.match_with fn ()
@@ -67,7 +102,10 @@ let run main =
     Domain_local_await.using
       ~prepare_for_await:Eio.Private.Dla.prepare_for_await
       ~while_running:(fun () ->
-        fork ~new_fiber (fun () -> result := Some (main ()))) in
+        fork ~new_fiber (fun () -> result := Some (main stdenv))) in
   match !result with
   | None -> raise Deadlock_detected
   | Some x -> x
+
+let run fn =
+  run_full (fun _ -> fn ())

lib_eio/mock/backend.mli

@@ -10,3 +10,16 @@ exception Deadlock_detected
 val run : (unit -> 'a) -> 'a
 (** [run fn] runs an event loop and then calls [fn env] within it.
     @raise Deadlock_detected if the run queue becomes empty but [fn] hasn't returned. *)
+
+type stdenv = <
+  clock : Clock.t;
+  mono_clock : Clock.Mono.t;
+  debug : Eio.Debug.t;
+  backend_id: string;
+>
+
+val run_full : (stdenv -> 'a) -> 'a
+(** [run_full] is like {!run} but also provides a mock environment.
+
+    The mock monotonic clock it provides advances automatically when there is nothing left to do.
+    The mock wall clock is linked directly to the monotonic time. *)

lib_eio/mock/clock.ml

@@ -9,6 +9,7 @@ module type S = sig
 
   val make : unit -> t
   val advance : t -> unit
+  val try_advance : t -> bool
   val set_time : t -> time -> unit
 end
 
@@ -80,10 +81,10 @@ module Make(T : TIME) : S with type time := T.t = struct
       t.now <- time;
       traceln "mock time is now %a" T.pp t.now
 
-    let advance t =
+    let try_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
+      | None -> false
+      | Some (_, v) -> set_time t v.time; true
 
     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
@@ -99,7 +100,12 @@ module Make(T : TIME) : S with type time := T.t = struct
     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)
+
+  let try_advance t = Impl.try_advance (Impl.raw t)
+
+  let advance t =
+    if not (try_advance t) then
+      invalid_arg "No further events scheduled on mock clock"
 end
 
 module Old_time = struct

lib_eio/mock/clock.mli

@@ -1,3 +1,6 @@
+(** Note that {!Backend.run_full} provides mock clocks
+    that advance automatically when there is nothing left to do. *)
+
 open Eio.Std
 
 type 'time ty = [`Mock | 'time Eio.Time.clock_ty]
@@ -16,6 +19,9 @@ module type S = sig
   (** [advance t] sets the time to the next scheduled event (adding any due fibers to the run queue).
       @raise Invalid_argument if nothing is scheduled. *)
 
+  val try_advance : t -> bool
+  (** Like {!advance}, but returns [false] instead of raising an exception. *)
+
   val set_time : t -> time -> unit
   (** [set_time t time] sets the time to [time] (adding any due fibers to the run queue). *)
 end

tests/network.md

@@ -683,22 +683,16 @@ Eio.Io Net Connection_failure Refused _,
 First attempt times out:
 
 ```ocaml
-# Eio_mock.Backend.run @@ fun () ->
-  let clock = Eio_mock.Clock.Mono.make () in
+# Eio_mock.Backend.run_full @@ fun env ->
+  let clock = env#mono_clock in
   let timeout = Eio.Time.Timeout.seconds clock 10. in
   Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]];
   let mock_flow = Eio_mock.Flow.make "flow" in
   Eio_mock.Net.on_connect net [`Run Fiber.await_cancel; `Return mock_flow];
-  Fiber.both
-    (fun () ->
-       Eio.Net.with_tcp_connect ~timeout ~host:"www.example.com" ~service:"http" net (fun conn ->
-          let req = "GET / HTTP/1.1\r\nHost:www.example.com:80\r\n\r\n" in
-          Eio.Flow.copy_string req conn
-       )
-    )
-    (fun () ->
-       Eio_mock.Clock.Mono.advance clock
-     );;
+  Eio.Net.with_tcp_connect ~timeout ~host:"www.example.com" ~service:"http" net (fun conn ->
+     let req = "GET / HTTP/1.1\r\nHost:www.example.com:80\r\n\r\n" in
+     Eio.Flow.copy_string req conn
+  )
 +mock-net: getaddrinfo ~service:http www.example.com
 +mock-net: connect to tcp:127.0.0.1:80
 +mock time is now 10
@@ -713,23 +707,14 @@ First attempt times out:
 Both attempts time out:
 
 ```ocaml
-# Eio_mock.Backend.run @@ fun () ->
-  let clock = Eio_mock.Clock.Mono.make () in
+# Eio_mock.Backend.run_full @@ fun env ->
+  let clock = env#mono_clock in
   let timeout = Eio.Time.Timeout.seconds clock 10. in
   Eio_mock.Net.on_getaddrinfo net [`Return [addr1; addr2]];
   Eio_mock.Net.on_connect net [`Run Fiber.await_cancel; `Run Fiber.await_cancel];
-  Fiber.both
-    (fun () ->
-       Eio.Net.with_tcp_connect ~timeout ~host:"www.example.com" ~service:"http" net (fun _ ->
-          assert false
-       )
-    )
-    (fun () ->
-       Eio_mock.Clock.Mono.advance clock;
-       Fiber.yield ();
-       Fiber.yield ();
-       Eio_mock.Clock.Mono.advance clock
-     );;
+  Eio.Net.with_tcp_connect ~timeout ~host:"www.example.com" ~service:"http" net (fun _ ->
+    assert false
+  )
 +mock-net: getaddrinfo ~service:http www.example.com
 +mock-net: connect to tcp:127.0.0.1:80
 +mock time is now 10