Allow clock to be configured in Uring.wait

lib/uring/include/discover.ml

@@ -2,7 +2,9 @@ module C = Configurator.V1
 
 let () =
   C.main ~name:"discover" (fun c ->
-      C.C_define.import c ~c_flags:["-D_GNU_SOURCE"] ~includes:["fcntl.h"; "poll.h"; "sys/uio.h"] C.C_define.Type.[
+    C.C_define.import c ~c_flags:["-D_GNU_SOURCE"]
+      ~includes:["fcntl.h"; "poll.h"; "sys/uio.h"; "linux/time_types.h"]
+      C.C_define.Type.[
           "POLLIN", Int;
           "POLLOUT", Int;
           "POLLERR", Int;
@@ -31,10 +33,16 @@ let () =
           "AT_FDCWD", Int;
 
           "sizeof(struct iovec)", Int;
+          "sizeof(struct __kernel_timespec)", Int;
         ]
       |> List.map (function
           | name, C.C_define.Value.Int v ->
-            let name = if name = "sizeof(struct iovec)" then "sizeof_iovec" else name in
+            let name = 
+              match name with
+              | "sizeof(struct iovec)" -> "sizeof_iovec"
+              | "sizeof(struct __kernel_timespec)" -> "sizeof_kernel_timespec"
+              | nm -> nm 
+            in
             Printf.sprintf "let %s = 0x%x" (String.lowercase_ascii name) v
           | _ -> assert false
         )

lib/uring/uring.ml

@@ -194,6 +194,8 @@ end
 
 type 'a job = 'a Heap.entry
 
+type clock = Boottime | Realtime
+
 module Uring = struct
   type t
 
@@ -209,6 +211,7 @@ module Uring = struct
 
   type offset = Optint.Int63.t
   external submit_nop : t -> id -> bool = "ocaml_uring_submit_nop" [@@noalloc]
+  external submit_timeout : t -> id -> Sketch.ptr -> clock -> bool -> bool = "ocaml_uring_submit_timeout" [@@noalloc]
   external submit_poll_add : t -> Unix.file_descr -> id -> Poll_mask.t -> bool = "ocaml_uring_submit_poll_add" [@@noalloc]
   external submit_read : t -> Unix.file_descr -> id -> Cstruct.t -> offset -> bool = "ocaml_uring_submit_read" [@@noalloc]
   external submit_write : t -> Unix.file_descr -> id -> Cstruct.t -> offset -> bool = "ocaml_uring_submit_write" [@@noalloc]
@@ -334,6 +337,13 @@ let with_id t fn a = with_id_full t fn a ~extra_data:()
 let noop t user_data =
   with_id t (fun id -> Uring.submit_nop t.uring id) user_data
 
+external set_timespec: Sketch.ptr -> int64 -> unit = "ocaml_uring_set_timespec" [@@noalloc]
+
+let timeout ?(absolute = false) t clock timeout_ns user_data =
+  let timespec_ptr = Sketch.alloc t.sketch Config.sizeof_kernel_timespec in
+  set_timespec timespec_ptr timeout_ns;
+  with_id t (fun id -> Uring.submit_timeout t.uring id timespec_ptr clock absolute) user_data
+
 let at_fdcwd : Unix.file_descr = Obj.magic Config.at_fdcwd
 
 let openat2 t ~access ~flags ~perm ~resolve ?(fd=at_fdcwd) path user_data =

lib/uring/uring.mli

@@ -67,6 +67,19 @@ val noop : 'a t -> 'a -> 'a job option
 (** [noop t d] submits a no-op operation to uring [t]. The user data [d] will be
     returned by {!wait} or {!peek} upon completion. *)
 
+(** {2 Timeout} *)
+
+type clock = Boottime | Realtime
+(** Represents Linux clocks. [Boottime] and [Realtime] represents OS clocks CLOCK_BOOTTIME
+    and CLOCK_REALTIME respectively. *)
+
+val timeout: ?absolute:bool -> 'a t -> clock -> int64 -> 'a -> 'a job option
+(** [timeout t clock ns d] submits a timeout request to uring [t].
+
+    [absolute] denotes how [clock] and [ns] relate to one another. Default value is [false]
+
+    [ns] is the timeout time in nanoseconds *)
+
 module type FLAGS = sig
   type t = private int
   (** A set of flags. *)

lib/uring/uring_stubs.c

@@ -49,6 +49,8 @@
 #endif
 
 #define Ring_val(v) *((struct io_uring**)Data_custom_val(v))
+#define Sketch_ptr_val(vsp) (Caml_ba_data_val(Field(vsp, 0)) + Long_val(Field(vsp, 1)))
+#define Sketch_ptr_len_val(vsp) Long_val(Field(vsp, 2))
 
 // Note that this does not free the ring data. You must not allow this to be
 // GC'd until the ring has been released by calling ocaml_uring_exit.
@@ -146,6 +148,39 @@ ocaml_uring_sq_ready(value v_uring) {
   return (Int_val(io_uring_sq_ready(ring)));
 }
 
+void /* noalloc */
+ocaml_uring_set_timespec(value v_sketch_ptr, value v_timeout)
+{
+  struct __kernel_timespec *t = Sketch_ptr_val(v_sketch_ptr);
+  t->tv_sec = 0;
+  t->tv_nsec = Int64_val(v_timeout);
+}
+
+#define Val_boottime Val_int(0)
+
+value /* noalloc */
+ocaml_uring_submit_timeout(value v_uring, value v_id, value v_sketch_ptr, value v_clock, value v_absolute)
+{
+  struct __kernel_timespec *t = Sketch_ptr_val(v_sketch_ptr);
+  struct io_uring* ring = Ring_val(v_uring);
+  struct io_uring_sqe* sqe;
+  int flags;
+
+  if (v_clock == Val_boottime)
+    flags = IORING_TIMEOUT_BOOTTIME;
+  else
+    flags = IORING_TIMEOUT_REALTIME;
+
+  if(Bool_val(v_absolute))
+    flags |= IORING_TIMEOUT_ABS;
+
+  sqe = io_uring_get_sqe(ring);
+  if (!sqe) return Val_false;
+  io_uring_prep_timeout(sqe, t, 0, flags);
+  io_uring_sqe_set_data(sqe, (void *)Long_val(v_id));
+  return Val_true;
+}
+
 struct open_how_data {
   struct open_how how;
   char path[];
@@ -224,9 +259,6 @@ ocaml_uring_submit_poll_add(value v_uring, value v_fd, value v_id, value v_poll_
   return (Val_true);
 }
 
-#define Sketch_ptr_val(vsp) (Caml_ba_data_val(Field(vsp, 0)) + Long_val(Field(vsp, 1)))
-#define Sketch_ptr_len_val(vsp) Long_val(Field(vsp, 2))
-
 void /* noalloc */
 ocaml_uring_set_iovec(value v_sketch_ptr, value v_csl)
 {

tests/main.md

@@ -748,3 +748,42 @@ val b : Cstruct.t = {Cstruct.buffer = <abstr>; off = 0; len = 1}
 # Uring.exit t;;
 - : unit = ()
 ```
+
+## Timeout
+
+Timeout should return (-ETIME). This is defined in https://github.com/torvalds/linux/blob/master/include/uapi/asm-generic/errno.h#L45
+
+```ocaml
+# let t = Uring.create ~queue_depth:1 ();;
+val t : '_weak13 Uring.t = <abstr>
+
+# let ns1 = Int64.(mul 10L 1_000_000L) in
+  Uring.(timeout t Boottime ns1 `Timeout);;
+- : _[> `Timeout ] Uring.job option = Some <abstr>
+
+# Uring.submit t;;
+- : int = 1
+
+# let `Timeout, timeout = consume t;;
+val timeout : int = -62
+
+# let ns = 
+    ((Unix.gettimeofday () +. 0.01) *. 1e9)
+    |> Int64.of_float
+  in
+  Uring.(timeout ~absolute:true t Realtime ns `Timeout);;
+- : [ `Timeout ] Uring.job option = Some <abstr>
+
+# let `Timeout, timeout = consume t;;
+val timeout : int = -62
+
+# let ns1 = Int64.(mul 10L 1_000_000L) in
+  Uring.(timeout ~absolute:true t Boottime ns1 `Timeout);;
+- : [ `Timeout ] Uring.job option = Some <abstr>
+
+# let `Timeout, timeout = consume t;;
+val timeout : int = -62
+
+# Uring.exit t;;
+- : unit = ()
+```