diff --git a/lib/dune b/lib/dune index 9a95d98..323131d 100644 --- a/lib/dune +++ b/lib/dune @@ -1,12 +1,19 @@ (library (name miou_solo5) (public_name miou-solo5) + (modules miou_solo5) + (libraries jsonm logs miou) (wrapped false) - (libraries logs miou) (foreign_stubs (language c) (names stubs))) +(rule + (target miou_solo5.ml) + (deps miou_solo5.solo5.ml miou_solo5.default.ml) + (action + (copy miou_solo5.%{context_name}.ml %{target}))) + (rule (target stubs.c) (deps stubs.solo5.c stubs.default.c) diff --git a/lib/miou_solo5.default.ml b/lib/miou_solo5.default.ml new file mode 100644 index 0000000..1befc59 --- /dev/null +++ b/lib/miou_solo5.default.ml @@ -0,0 +1,124 @@ +type bigstring = + (char, Bigarray.int8_unsigned_elt, Bigarray.c_layout) Bigarray.Array1.t + +module Json = struct + type value = [ `Null | `Bool of bool | `String of string | `Float of float ] + type t = [ value | `A of t list | `O of (string * t) list ] + + module Stack = struct + type stack = + | In_array of t list * stack + | In_object of (string * t) list * stack + | Empty + end + + let encode ?minify ?(size_chunk = 0x800) ~output t = + let encoder = Jsonm.encoder ?minify `Manual in + let buf = Bytes.create size_chunk in + let rec encode k stack value = + match Jsonm.encode encoder value with + | `Ok -> k stack + | `Partial -> + let len = Bytes.length buf - Jsonm.Manual.dst_rem encoder in + output (Bytes.sub_string buf 0 len); + Jsonm.Manual.dst encoder buf 0 (Bytes.length buf); + encode k stack `Await + and value k v stack = + match v with + | #value as v -> encode (continue k) stack (`Lexeme v) + | `O ms -> encode (obj k ms) stack (`Lexeme `Os) + | `A vs -> encode (arr k vs) stack (`Lexeme `As) + and obj k ms stack = + match ms with + | (n, v) :: ms -> + let stack = Stack.In_object (ms, stack) in + encode (value k v) stack (`Lexeme (`Name n)) + | [] -> encode (continue k) stack (`Lexeme `Oe) + and arr k vs stack = + match vs with + | v :: vs -> + let stack = Stack.In_array (vs, stack) in + value k v stack + | [] -> encode (continue k) stack (`Lexeme `Ae) + and continue k = function + | Stack.In_array (vs, stack) -> arr k vs stack + | Stack.In_object (ms, stack) -> obj k ms stack + | Stack.Empty as stack -> encode k stack `End + in + Jsonm.Manual.dst encoder buf 0 (Bytes.length buf); + value (Fun.const ()) t Stack.Empty +end + +let to_json = function + | `Block name -> + `O [ "name", `String name; "type", `String "BLOCK_BASIC" ] + | `Net name -> + `O [ "name", `String name; "type", `String "NET_BASIC" ] + +module Net = struct + type t = int + type mac = string + type cfg = { mac: mac; mtu: int } + + let connect _name = assert false + let read_bigstring _t ?off:_ ?len:_ _bstr = assert false + let read_bytes _t ?off:_ ?len:_ _buf = assert false + let write_bigstring _t ?off:_ ?len:_ _bstr = assert false + let write_string _t ?off:_ ?len:_ _str = assert false +end + +module Block = struct + type t = { handle: int; pagesize: int } + + let pagesize _ = assert false + let connect _name = assert false + let atomic_read _t ~off:_ _bstr = assert false + let atomic_write _t ~off:_ _bstr = assert false + let read _t ~off:_ _bstr = assert false + let write _t ~off:_ _bstr = assert false +end + +external clock_monotonic : unit -> (int[@untagged]) + = "unimplemented" "miou_solo5_clock_monotonic" +[@@noalloc] + +external clock_wall : unit -> (int[@untagged]) + = "unimplemented" "miou_solo5_clock_wall" +[@@noalloc] + +let sleep _ = assert false + +type 'a arg = + | Args : ('k, 'res) devices -> 'a arg + | Block : string -> Block.t arg + | Net : string -> (Net.t * Net.cfg) 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 arg = Args [ arg ] +let map _fn args = Args args +let dft _v arg = Args [ arg ] +let const _ = Args [] + +type t = [ `Block of string | `Net of string ] + +let collect devices = + let rec go : type k res. t list -> (k, res) devices -> t list = fun acc -> function + | [] -> List.rev acc + | Block name :: rest -> go (`Block name :: acc) rest + | Net name :: rest -> go (`Net name :: acc) rest + | Args vs :: rest -> go (go acc vs) rest in + go [] devices + +let run ?g:_ args _fn = + let devices = collect args in + let v = + `O List.[ "type", `String "solo5.manifest" + ; "version", `Float 1.0 + ; "devices", `A (List.map to_json devices) ] in + let output str = output_string stdout str in + Json.encode ~output v; exit 0 diff --git a/lib/miou_solo5.ml b/lib/miou_solo5.solo5.ml similarity index 100% rename from lib/miou_solo5.ml rename to lib/miou_solo5.solo5.ml diff --git a/lib/stubs.default.c b/lib/stubs.default.c index e69de29..0cc8e61 100644 --- a/lib/stubs.default.c +++ b/lib/stubs.default.c @@ -0,0 +1,21 @@ +#include + +#ifndef __unused +# if defined(_MSC_VER) && _MSC_VER >= 1500 +# define __unused(x) __pragma( warning (push) ) \ + __pragma( warning (disable:4189 ) ) \ + x \ + __pragma( warning (pop)) +# else +# define __unused(x) x __attribute__((unused)) +# endif +#endif +#define __unit() value __unused(unit) + +intnat miou_solo5_clock_monotonic(__unit ()) { + return 0; +} + +intnat miou_solo5_clock_wall(__unit ()) { + return 0; +} diff --git a/test/block.json b/test/block.json deleted file mode 100644 index ce3ba2d..0000000 --- a/test/block.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "type": "solo5.manifest", - "version": 1, - "devices": [ { "name": "simple", "type": "BLOCK_BASIC" } ] -} diff --git a/test/block.ml b/test/block.ml index 12bddc6..f86dede 100644 --- a/test/block.ml +++ b/test/block.ml @@ -1,27 +1,47 @@ -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 - let res = Bytes.create len in - for i = 0 to len - 1 do - Bytes.set res i (unsafe_get_char v i) - done; - Bytes.unsafe_to_string res - -let () = - Miou_solo5.(run [ block "simple" ]) @@ fun blk () -> +let cachet_of_block ~cachesize blk () = + let map blk ~pos len = + let bstr = Bigarray.(Array1.create char c_layout len) in + Miou_solo5.Block.read blk ~off:pos bstr; bstr in let pagesize = Miou_solo5.Block.pagesize blk in - let bstr = Bigarray.(Array1.create char c_layout pagesize) in + Cachet.make ~cachesize ~pagesize ~map blk + +let cachet ~cachesize name = + let open Miou_solo5 in + map (cachet_of_block ~cachesize) [ block name ] + +let run cachesize = + Miou_solo5.(run [ cachet ~cachesize "simple" ]) @@ fun blk () -> + let pagesize = Cachet.pagesize blk in let prm = Miou.async @@ fun () -> + let bstr = Bigarray.(Array1.create char c_layout pagesize) in + let blk = Cachet.fd blk in Miou_solo5.Block.atomic_read blk ~off:0 bstr; - let str = bigstring_to_string bstr in + let bstr = Cachet.Bstr.of_bigstring bstr in + let str = Cachet.Bstr.to_string bstr in let hash = Digest.string str in Fmt.pr "%08x: %s\n%!" 0 (Digest.to_hex hash) in - Miou_solo5.Block.read blk ~off:pagesize bstr; - let str = bigstring_to_string bstr in + let str = Cachet.get_string blk pagesize ~len:pagesize in let hash = Digest.string str in Fmt.pr "%08x: %s\n%!" pagesize (Digest.to_hex hash); Miou.await_exn prm + +open Cmdliner + +let cachesize = + let doc = "The size of the cache (must be a power of two)." in + let open Arg in + value & opt int 0x100 & info [ "cachesize" ] ~doc ~docv:"NUMBER" + +let term = + let open Term in + const run $ cachesize + +let cmd = + let doc = "A simple unikernel to read a block device." in + let man = [] in + let info = Cmd.info "blk" ~doc ~man in + Cmd.v info term + +let () = Cmd.(exit @@ eval cmd) diff --git a/test/dune b/test/dune index eecdc6d..9a871a8 100644 --- a/test/dune +++ b/test/dune @@ -3,8 +3,6 @@ (modules sleep) (modes native) (link_flags :standard -cclib "-z solo5-abi=hvt") - (enabled_if - (= %{context_name} "solo5")) (libraries miou-solo5) (foreign_stubs (language c) @@ -15,8 +13,6 @@ (modules schedule) (modes native) (link_flags :standard -cclib "-z solo5-abi=hvt") - (enabled_if - (= %{context_name} "solo5")) (libraries miou-solo5) (foreign_stubs (language c) @@ -27,31 +23,83 @@ (modules block) (modes native) (link_flags :standard -cclib "-z solo5-abi=hvt") - (enabled_if - (= %{context_name} "solo5")) - (libraries miou-solo5 fmt hxd.core hxd.string) + (libraries miou-solo5 cmdliner fmt cachet hxd.core hxd.string) (foreign_stubs (language c) (names manifest.block))) (rule (targets manifest.sleep.c) - (deps none.json) + (deps sleep.json) + (enabled_if + (= %{context_name} "solo5")) (action - (run solo5-elftool gen-manifest none.json manifest.sleep.c))) + (run solo5-elftool gen-manifest sleep.json manifest.sleep.c))) + +(rule + (targets sleep.json) + (enabled_if + (= %{context_name} "solo5")) + (action + (with-stdout-to + sleep.json + (run %{exe:sleep.exe})))) + +(rule + (targets manifest.sleep.c) + (enabled_if + (= %{context_name} "default")) + (action + (write-file manifest.sleep.c ""))) (rule (targets manifest.schedule.c) - (deps none.json) + (deps schedule.json) + (enabled_if + (= %{context_name} "solo5")) (action - (run solo5-elftool gen-manifest none.json manifest.schedule.c))) + (run solo5-elftool gen-manifest schedule.json manifest.schedule.c))) + +(rule + (targets schedule.json) + (enabled_if + (= %{context_name} "solo5")) + (action + (with-stdout-to + schedule.json + (run %{exe:schedule.exe})))) + +(rule + (targets manifest.schedule.c) + (enabled_if + (= %{context_name} "default")) + (action + (write-file manifest.schedule.c ""))) (rule (targets manifest.block.c) (deps block.json) + (enabled_if + (= %{context_name} "solo5")) (action (run solo5-elftool gen-manifest block.json manifest.block.c))) +(rule + (targets block.json) + (enabled_if + (= %{context_name} "solo5")) + (action + (with-stdout-to + block.json + (run %{exe:block.exe})))) + +(rule + (targets manifest.block.c) + (enabled_if + (= %{context_name} "default")) + (action + (write-file manifest.block.c ""))) + (cram (enabled_if (= %{context_name} "solo5"))