.

lib/miou_solo5.ml

@@ -44,12 +44,8 @@ let bigstring_blit_from_string src ~src_off dst ~dst_off ~len =
     bigstring_set_uint8 dst (dst_off + i) v
   done
 
-external miou_solo5_net_acquire :
-     string
-  -> bytes
-  -> bytes
-  -> bytes
-  -> int = "unimplemented" "miou_solo5_net_acquire"
+external miou_solo5_net_acquire : string -> bytes -> bytes -> bytes -> int
+  = "unimplemented" "miou_solo5_net_acquire"
 [@@noalloc]
 
 external miou_solo5_net_read :
@@ -69,12 +65,8 @@ external miou_solo5_net_write :
   -> (int[@untagged]) = "unimplemented" "miou_solo5_net_write"
 [@@noalloc]
 
-external miou_solo5_block_acquire :
-     string
-  -> bytes
-  -> bytes
-  -> bytes
-  -> int = "unimplemented" "miou_solo5_block_acquire"
+external miou_solo5_block_acquire : string -> bytes -> bytes -> bytes -> int
+  = "unimplemented" "miou_solo5_block_acquire"
 [@@noalloc]
 
 external miou_solo5_block_read :
@@ -114,7 +106,8 @@ module Block_direct = struct
         let _len = Int64.to_int (Bytes.get_int64_ne _len 0) in
         let pagesize = Int64.to_int (Bytes.get_int64_ne pagesize 0) in
         Ok { handle; pagesize }
-    | errno -> error_msgf "Impossible to connect the block-device %s (%d)" name errno
+    | errno ->
+        error_msgf "Impossible to connect the block-device %s (%d)" name errno
 
   let unsafe_read t ~off bstr =
     match miou_solo5_block_read t.handle off t.pagesize bstr with
@@ -279,9 +272,9 @@ module Net = struct
           | 0 ->
               let len = Int64.to_int (unsafe_get_int64_ne read_size 0) in
               bigstring_blit_to_bytes bstr ~src_off:0 buf ~dst_off ~len;
-            if len > 0 then go (dst_off + len) (dst_len - len) else dst_off - off
-          | 1 ->
-            blocking_read t; go dst_off dst_len
+              if len > 0 then go (dst_off + len) (dst_len - len)
+              else dst_off - off
+          | 1 -> blocking_read t; go dst_off dst_len
           | 2 -> invalid_arg "Miou_solo5.Net.read"
           | _ -> assert false (* UNSPEC *)
         end
@@ -384,8 +377,7 @@ let rec sleeper () =
   | { cancelled= true; _ } ->
       Heapq.delete_min_exn domain.sleepers;
       sleeper ()
-  | { time; _ } ->
-      Some time
+  | { time; _ } -> Some time
 
 let in_the_past t = t == 0 || t <= clock_monotonic ()
 
@@ -512,29 +504,59 @@ let select ~block cancelled_syscalls =
 
 let events _domain = { Miou.interrupt= ignore; select; finaliser= ignore }
 
-type 'a device =
-  | Net : string -> (Net.t * Net.cfg) device
-  | Block : string -> Block.t device
+type 'a arg =
+  | Net : string -> (Net.t * Net.cfg) arg
+  | Block : string -> Block.t arg
+  | Map : ('f, 'a) devices * 'f -> 'a arg
+  | Opt : 'a arg -> 'a option arg
+  | Dft : 'a * 'a arg -> 'a arg
+  | Const : 'a -> 'a arg
+
+and ('k, 'res) devices =
+  | [] : (unit -> 'res, 'res) devices
+  | ( :: ) : 'a arg * ('k, 'res) devices -> ('a -> 'k, 'res) devices
 
 let net name = Net name
 let block name = Block name
+let opt value = Opt value
+let map fn args = Map (args, fn)
+let dft v arg = Dft (v, arg)
+let const v = Const v
 
-type ('k, 'res) devices =
-  | [] : (unit -> 'res, 'res) devices
-  | ( :: ) : 'a device * ('k, 'res) devices -> ('a -> 'k, 'res) devices
+let rec ctor : type a. a arg -> a = function
+  | Net device -> begin
+      match Net.connect device with
+      | Ok (t, cfg) -> (t, cfg)
+      | Error (`Msg msg) -> failwithf "%s." msg
+    end
+  | Block device -> begin
+      match Block.connect device with
+      | Ok t -> t
+      | Error (`Msg msg) -> failwithf "%s." msg
+    end
+  | Opt arg -> begin
+      match go (fun fn -> fn ()) [ arg ] (fun v () -> Some v) with
+      | v -> v
+      | exception _ -> None
+    end
+  | Const v -> v
+  | Dft (v, arg) -> begin
+      match go (fun fn -> fn ()) [ arg ] (fun v () -> v) with
+      | v' -> v'
+      | exception _ -> v
+    end
+  | Map (args, fn) -> go (fun fn -> fn ()) args fn
 
-let rec go : type k res. ((unit -> res) -> res) -> (k, res) devices -> k -> res
-  = fun run -> function
+and go : type k res. ((unit -> res) -> res) -> (k, res) devices -> k -> res =
+ fun run -> function
   | [] -> fun fn -> run fn
-  | Net device :: devices ->
-    begin match Net.connect device with
-    | Ok (t, cfg) -> fun f -> let r = f (t, cfg) in go run devices r
-    | Error (`Msg msg) -> failwithf "%s." msg end
-  | Block device :: devices ->
-    begin match Block.connect device with
-    | Ok t -> fun f -> let r = f t in go run devices r
-    | Error (`Msg msg) -> failwithf "%s." msg end
+  | arg :: devices ->
+      let v = ctor arg in
+      fun f ->
+        let r = f v in
+        go run devices r
 
 let run ?g devices fn =
-  let run fn = Miou.run ~events ~domains:0 ?g fn in
+  Miou.run ~events ~domains:0 ?g @@ fun () ->
+  let run fn = fn () in
   go run devices fn

lib/miou_solo5.mli

@@ -37,8 +37,8 @@
     other tasks if reading failed in the first place. It is at the next
     iteration of the scheduler (after it has executed at least one other task)
     that [Miou_solo5] will ask the tender if a packet has just arrived. If this
-    is the case, the scheduler will resume the read task, otherwise it will
-    keep it in a suspended state until the next iteration.
+    is the case, the scheduler will resume the read task, otherwise it will keep
+    it in a suspended state until the next iteration.
 
     {2 Block devices.}
 
@@ -73,8 +73,8 @@
     later date without the current time at which the operation is carried out
     having any effect on the result. For example, scheduling reads on a block
     device that is read-only is probably more interesting than using atomic
-    reads (whether the read is done at time [T0] or [T1], the result remains
-    the same).
+    reads (whether the read is done at time [T0] or [T1], the result remains the
+    same).
 
     {2 The scheduler.}
 
@@ -87,16 +87,15 @@
     Finally, the scheduler works in such a way that scheduled read/write
     operations on a block device are relegated to the lowest priority tasks.
     However, this does not mean that [Miou_solo5] is a scheduler that tries to
-    complete as many tasks as possible before reaching an I/O operation (such
-    as waiting for a packet - {!val:Net.read} - or reading/writing a block
-    device). Miou and [Miou_solo5] aim to increase the availability of an
-    application: in other words, as soon as there is an opportunity to execute a
-    task other than the current one, Miou will take it.
+    complete as many tasks as possible before reaching an I/O operation (such as
+    waiting for a packet - {!val:Net.read} - or reading/writing a block device).
+    Miou and [Miou_solo5] aim to increase the availability of an application: in
+    other words, as soon as there is an opportunity to execute a task other than
+    the current one, Miou will take it.
 
-    In this case, all the operations (except atomic ones) present in this
-    module give Miou the opportunity to suspend the current task and execute
-    another task.
-*)
+    In this case, all the operations (except atomic ones) present in this module
+    give Miou the opportunity to suspend the current task and execute another
+    task. *)
 
 type bigstring =
   (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t
@@ -113,28 +112,28 @@ module Net : sig
   val read_bigstring : t -> ?off:int -> ?len:int -> bigstring -> int
   (** [read_bigstring t ?off ?len bstr] reads [len] (defaults to
       [Bigarray.Array1.dim bstr - off]) bytes from the net device [t], storing
-      them in byte sequence [bstr], starting at position [off] (defaults to
-      [0]) in [bstr]. Return the number of bytes actually read.
+      them in byte sequence [bstr], starting at position [off] (defaults to [0])
+      in [bstr]. Return the number of bytes actually read.
 
       [read_bigstring] attempts an initial read. If it fails, we give the
       scheduler the opportunity to execute another task. The current task will
       be resumed as soon as bytes are available in the given net-device [t].
 
-      @raise Invalid_argument if [off] and [len] do not designate a valid range
-      of [bstr]. *)
+      @raise Invalid_argument
+        if [off] and [len] do not designate a valid range of [bstr]. *)
 
   val read_bytes : t -> ?off:int -> ?len:int -> bytes -> int
   (** [read_bytes] is {!val:read_bigstring} but for [bytes]. However, this
       function uses an internal buffer (of a fixed size) which transmits the
       bytes from the net-device to the [byte] given by the user. If the [byte]
-      given by the user is larger than the internal buffer, several actual
-      reads are made.
+      given by the user is larger than the internal buffer, several actual reads
+      are made.
 
       This means that a single [read_bytes] can give the scheduler several
       opportunities to execute other tasks.
 
-      @raise Invalid_argument if [off] and [len] do not designate a valid range
-      of [bstr]. *)
+      @raise Invalid_argument
+        if [off] and [len] do not designate a valid range of [bstr]. *)
 
   val write_bigstring : t -> ?off:int -> ?len:int -> bigstring -> unit
   val write_string : t -> ?off:int -> ?len:int -> string -> unit
@@ -183,13 +182,16 @@ external clock_wall : unit -> (int[@untagged])
 val sleep : int -> unit
 (** [sleep ns] blocks (suspends) the current task for [ns] nanoseconds. *)
 
-type 'a device
-
-val net : string -> (Net.t * Net.cfg) device
-val block : string -> Block.t device
+type 'a arg
 
 type ('k, 'res) devices =
   | [] : (unit -> 'res, 'res) devices
-  | ( :: ) : 'a device * ('k, 'res) devices -> ('a -> 'k, 'res) devices
+  | ( :: ) : 'a arg * ('k, 'res) devices -> ('a -> 'k, 'res) devices
 
+val net : string -> (Net.t * Net.cfg) arg
+val block : string -> Block.t arg
+val opt : 'a arg -> 'a option arg
+val map : 'f -> ('f, 'a) devices -> 'a arg
+val dft : 'a -> 'a arg -> 'a arg
+val const : 'a -> 'a arg
 val run : ?g:Random.State.t -> ('a, 'b) devices -> 'a -> 'b

test/block.ml

@@ -1,4 +1,5 @@
-external unsafe_get_char : Miou_solo5.bigstring -> int -> char = "%caml_ba_ref_1"
+external unsafe_get_char : Miou_solo5.bigstring -> int -> char
+  = "%caml_ba_ref_1"
 
 let bigstring_to_string v =
   let len = Bigarray.Array1.dim v in
@@ -8,10 +9,12 @@ let bigstring_to_string v =
   done;
   Bytes.unsafe_to_string res
 
-let () = Miou_solo5.(run [ block "simple" ]) @@ fun blk () ->
+let () =
+  Miou_solo5.(run [ block "simple" ]) @@ fun blk () ->
   let pagesize = Miou_solo5.Block.pagesize blk in
   let bstr = Bigarray.(Array1.create char c_layout pagesize) in
-  let prm = Miou.async @@ fun () ->
+  let prm =
+    Miou.async @@ fun () ->
     Miou_solo5.Block.atomic_read blk ~off:0 bstr;
     let str = bigstring_to_string bstr in
     let hash = Digest.string str in

test/dune

@@ -3,43 +3,56 @@
  (modules sleep)
  (modes native)
  (link_flags :standard -cclib "-z solo5-abi=hvt")
- (enabled_if (= %{context_name} "solo5"))
+ (enabled_if
+  (= %{context_name} "solo5"))
  (libraries miou-solo5)
- (foreign_stubs (language c) (names manifest.sleep)))
+ (foreign_stubs
+  (language c)
+  (names manifest.sleep)))
 
 (executable
  (name schedule)
  (modules schedule)
  (modes native)
  (link_flags :standard -cclib "-z solo5-abi=hvt")
- (enabled_if (= %{context_name} "solo5"))
+ (enabled_if
+  (= %{context_name} "solo5"))
  (libraries miou-solo5)
- (foreign_stubs (language c) (names manifest.schedule)))
+ (foreign_stubs
+  (language c)
+  (names manifest.schedule)))
 
 (executable
  (name block)
  (modules block)
  (modes native)
  (link_flags :standard -cclib "-z solo5-abi=hvt")
- (enabled_if (= %{context_name} "solo5"))
+ (enabled_if
+  (= %{context_name} "solo5"))
  (libraries miou-solo5 fmt hxd.core hxd.string)
- (foreign_stubs (language c) (names manifest.block)))
+ (foreign_stubs
+  (language c)
+  (names manifest.block)))
 
 (rule
  (targets manifest.sleep.c)
  (deps none.json)
- (action (run solo5-elftool gen-manifest none.json manifest.sleep.c)))
+ (action
+  (run solo5-elftool gen-manifest none.json manifest.sleep.c)))
 
 (rule
  (targets manifest.schedule.c)
  (deps none.json)
- (action (run solo5-elftool gen-manifest none.json manifest.schedule.c)))
+ (action
+  (run solo5-elftool gen-manifest none.json manifest.schedule.c)))
 
 (rule
  (targets manifest.block.c)
  (deps block.json)
- (action (run solo5-elftool gen-manifest block.json manifest.block.c)))
+ (action
+  (run solo5-elftool gen-manifest block.json manifest.block.c)))
 
 (cram
- (enabled_if (= %{context_name} "solo5"))
+ (enabled_if
+  (= %{context_name} "solo5"))
  (deps sleep.exe schedule.exe block.exe simple.txt))

test/schedule.ml

@@ -1,5 +1,4 @@
-let () = Miou_solo5.run [] @@ fun () ->
-  let prm = Miou.async @@ fun () ->
-    print_endline "World" in
-  print_endline "Hello";
-  Miou.await_exn prm
+let () =
+  Miou_solo5.run [] @@ fun () ->
+  let prm = Miou.async @@ fun () -> print_endline "World" in
+  print_endline "Hello"; Miou.await_exn prm

test/sleep.ml

@@ -1,6 +1,7 @@
 let _1s = 1_000_000_000
 
-let () = Miou_solo5.run [] @@ fun () ->
+let () =
+  Miou_solo5.run [] @@ fun () ->
   Miou_solo5.sleep _1s;
   print_endline "Hello";
   Miou_solo5.sleep _1s;