.

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)

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

lib/stubs.default.c

@@ -0,0 +1,21 @@
+#include <caml/memory.h>
+
+#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;
+}

test/block.json

@@ -1,5 +0,0 @@
-{
-  "type": "solo5.manifest",
-  "version": 1,
-  "devices": [ { "name": "simple", "type": "BLOCK_BASIC" } ]
-}

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)

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"))