diff --git a/lib/miou_solo5.ml b/lib/miou_solo5.ml index 4af19a0..48d8f8e 100644 --- a/lib/miou_solo5.ml +++ b/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 @@ -190,11 +183,11 @@ end type elt = { time: int; syscall: Miou.syscall; mutable cancelled: bool } module Heapq = Miou.Pqueue.Make (struct - type t = elt + type t = elt - let dummy = { time= 0; syscall= Obj.magic (); cancelled= false } - let compare { time= a; _ } { time= b; _ } = Int.compare a b - end) + let dummy = { time= 0; syscall= Obj.magic (); cancelled= false } + let compare { time= a; _ } { time= b; _ } = Int.compare a b +end) type action = Rd of arguments | Wr of arguments @@ -228,7 +221,7 @@ let blocking_read fd = module Net = struct type t = int type mac = string - type cfg = { mac : mac; mtu : int } + type cfg = { mac: mac; mtu: int } let connect name = let handle = Bytes.make 8 '\000' in @@ -277,11 +270,11 @@ module Net = struct let result = miou_solo5_net_read t bstr off len read_size in match result with | 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 + 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 | 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 diff --git a/lib/miou_solo5.mli b/lib/miou_solo5.mli index b1f4147..214677d 100644 --- a/lib/miou_solo5.mli +++ b/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.} @@ -83,20 +83,19 @@ have more than a single core. Parallel tasks are therefore {b unavailable} \- in other words, the user should {b not} use [Miou.call] but only [Miou.async]. - + 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 @@ -108,33 +107,33 @@ module Net : sig type mac = private string (** The type of the hardware addres (MAC) of an ethernet interface. *) - type cfg = { mac : mac; mtu : int } + type cfg = { mac: mac; mtu: int } 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 diff --git a/test/block.ml b/test/block.ml index aa38c5b..12bddc6 100644 --- a/test/block.ml +++ 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 diff --git a/test/dune b/test/dune index dc1b315..eecdc6d 100644 --- a/test/dune +++ b/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)) diff --git a/test/schedule.ml b/test/schedule.ml index bbd8c1e..631fada 100644 --- a/test/schedule.ml +++ b/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 diff --git a/test/sleep.ml b/test/sleep.ml index 7a98fba..95fcd03 100644 --- a/test/sleep.ml +++ b/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;