Merge remote-tracking branch 'origin/master'

dinosaure · Nov 7, 2019 · 375c092 · 375c092
2 parents 90e3be9 + 15119aa
commit 375c092
Show file tree

Hide file tree

Showing 11 changed files with 128 additions and 15 deletions.
diff --git a/bin/caravan.ml b/bin/caravan.ml
@@ -1067,19 +1067,23 @@ let craft_new_data_section t ~name:sect_name sh_size =
   | Zero _ -> Fmt.invalid_arg "Invalid last section of last PT_LOAD segment"
   | Section { shdr= n_last; _ } ->
     let last = List.nth t.sht n_last in
-    let vpad =
+    let _vpad =
       if Int64.(rem (last.sh_addr + last.sh_size) (size_of_addr ~ehdr:t.hdr)) <> 0L
       then let open Int64 in (size_of_addr ~ehdr:t.hdr) - (rem (last.sh_addr + last.sh_size) (size_of_addr ~ehdr:t.hdr))
       else 0L in
-    let ppad =
+    let _ppad =
       if Int64.(rem (last.sh_offset + last.sh_size) last.sh_addralign) <> 0L
       then let open Int64 in last.sh_addralign - (rem (last.sh_offset + last.sh_size) last.sh_addralign)
       else 0L in
     (* XXX(dinosaure): even if [sh_size] should be equal to 0, (it's a .bss
        section), we fixed it on the previous pass. *)
-    let last_sh_size = Int64.(last.sh_size + (rem last.sh_size last.sh_addralign)) in
-    let sh_addr = let open Int64 in last.sh_addr + last.sh_size + vpad in
-    let sh_offset = let open Int64 in last.sh_offset + last_sh_size + ppad in
+    let last_sh_size =
+      Int64.(last.sh_size + (rem last.sh_size last.sh_addralign)) in
+    let lpad =
+      let open Int64 in
+      phdr.p_filesz - (last.sh_offset - phdr.p_offset) - last_sh_size in
+    let sh_addr = let open Int64 in last.sh_addr + last.sh_size (* + vpad *) in
+    let sh_offset = let open Int64 in last.sh_offset + last_sh_size + lpad in
     let sh_name, _, _ = inject_shstr_name ~name:sect_name t in
     let shdr =
       { sh_name
@@ -1383,18 +1387,30 @@ let setup style_renderer log_level cwd =
     | Ok () -> `Ok ()
     | Error err -> `Error (false, Fmt.strf "%a" Rresult.R.pp_msg err)
 
+let copy ~src ~dst =
+  Bos.OS.File.with_output dst
+  @@ fun output -> Bos.OS.File.with_input src
+  @@ fun input ->
+  let rec transmit () = match input () with
+    | None -> output None
+    | v -> output v ; transmit () in
+  transmit
+
 let run () a_out provision result =
   let fiber =
     fiber0 a_out
-    >>= fun (a_out, _) -> fiber1 a_out provision
+    >>= fun (a_out, _) -> copy ~src:a_out ~dst:(Fpath.v "a.out.bss") () |> Rresult.R.join |> Us.inj
+    >>= fun () -> fiber1 a_out provision
     >>= fun (a_out, _, (vaddr, len)) -> fiber2 a_out vaddr (Int64.of_int len)
     >>= fun a_out ->
     let res = Bos.OS.Path.move ~force:true a_out result in
     Unix.unix.return res in
   Us.prj fiber |> function
   | Ok () ->
     Fmt.pr "[%a] output ELF binary <%a>.\n%!" Fmt.(styled `Green string) "x" Fpath.pp result ; `Ok ()
-  | Error err -> `Error (false, Fmt.strf "%a" (pp_error ~pp_source) err)
+  | Error err ->
+    Fmt.epr "[%a] %a.\n%!" Fmt.(styled `Red string) "ERROR" (pp_error ~pp_source) err ;
+    `Error (false, Fmt.strf "%a" (pp_error ~pp_source) err)
 
 open Cmdliner
 

diff --git a/example/ex01.ml b/example/ex01.ml
@@ -6,4 +6,7 @@ let () =
   let len = Provision.length p in
   let buf = Bytes.create len in
   Provision.load_bytes p ~src_off:0 buf ~dst_off:0 ~len ;
-  Fmt.pr "@[<hov>%a@]\n%!" (Hxd_string.pp Hxd.O.default) (Bytes.unsafe_to_string buf)
+  let map = Provision.map_bigstring p ~off:0 ~len in
+  let res = Bytes.unsafe_to_string buf in
+  assert (String.equal (Bigstringaf.to_string map) res) ;
+  Fmt.pr "@[<hov>%a@]\n%!" (Hxd_string.pp Hxd.O.default) res
diff --git a/lib/load.c b/lib/load.c
@@ -27,3 +27,22 @@ caml_load_vaddr_into_bigstring(value v_vaddr, value v_buf, value v_off, value v_
 
   return Val_unit;
 }
+
+#include <caml/memory.h>
+#include <caml/bigarray.h>
+
+CAMLprim value
+caml_map_vaddr(value v_vaddr, value v_len)
+{
+  CAMLparam2(v_vaddr, v_len);
+  CAMLlocal1(res);
+
+  intnat dim[CAML_BA_MAX_NUM_DIMS];
+  uint64_t vaddr = Int64_val (v_vaddr);
+  int len = Long_val(v_len);
+
+  dim[0] = len;
+  res = caml_ba_alloc(CAML_BA_UINT8 | CAML_BA_C_LAYOUT | CAML_BA_EXTERNAL, 1, (uint8_t *) vaddr, dim);
+
+  CAMLreturn(res);
+}
diff --git a/lib/provision.ml b/lib/provision.ml
@@ -7,10 +7,12 @@ let string_get_int64_be =
   else fun buf off -> swap64 (string_get_int64 buf off)
 
 external load_bytes : int64 -> bytes -> int -> int -> unit
-  = "caml_load_vaddr_into_bytes"
+  = "caml_load_vaddr_into_bytes" [@@noalloc]
 
 external load_bigstring : int64 -> Bigstringaf.t -> int -> int -> unit
-  = "caml_load_vaddr_into_bigstring"
+  = "caml_load_vaddr_into_bigstring" [@@noalloc]
+
+external map_bigstring : int64 -> int -> Bigstringaf.t = "caml_map_vaddr"
 
 type t = string
 
@@ -43,3 +45,13 @@ let load_bigstring t ~src_off buf ~dst_off ~len =
 
   let offset = Int64.add (string_get_int64_be t 10) (Int64.of_int src_off) in
   load_bigstring offset buf dst_off len
+
+let map_bigstring t ~off ~len =
+  let src_len = string_get_int64 t 18 |> Int64.to_int in
+
+  if len < 0 then Fmt.invalid_arg "len must be positive (%d)" len ;
+  if off < 0 || src_len - off < len
+  then Fmt.invalid_arg "Invalid source bounds (off: %d, src_len: %d)" off src_len ;
+
+  let offset = Int64.add (string_get_int64_be t 10) (Int64.of_int off) in
+  map_bigstring offset len
diff --git a/lib/provision.mli b/lib/provision.mli
@@ -5,3 +5,4 @@ val unsafe_of_string : string -> t
 
 val load_bytes : t -> src_off:int -> bytes -> dst_off:int -> len:int -> unit
 val load_bigstring : t -> src_off:int -> Bigstringaf.t -> dst_off:int -> len:int -> unit
+val map_bigstring : t -> off:int -> len:int -> Bigstringaf.t
diff --git a/mirage/_tags b/mirage/_tags
@@ -0,0 +1,2 @@
+<*.cm{o,x}> and not <config.cm{o,x}>: ccopt(-no-pie)
+<*.native> and not <config.native>: ccopt(-no-pie)
diff --git a/mirage/dune b/mirage/dune
@@ -0,0 +1,45 @@
+(rule
+ (targets filled)
+ (deps (:unikernel _tags config.ml unikernel.ml))
+ (locks mirage-lock)
+ (action (progn
+          (run mirage configure -t unix)
+	  (run mirage build))))
+
+(rule
+ (targets filled.hvt)
+ (deps (:unikernel _tags config.ml unikernel.ml))
+ (locks mirage-lock)
+ (action (progn
+          (run mirage configure -t hvt)
+	  (run mirage build))))
+
+(rule
+ (targets filled.exe)
+ (deps (:provision provision) (:filled filled))
+ (locks mirage-lock)
+ (action (run %{exe:../bin/caravan.exe} -i %{filled} -p %{provision} %{targets})))
+
+(rule
+ (targets filled.c.hvt)
+ (deps (:provision provision) (:filled filled.hvt))
+ (locks mirage-lock)
+ (action (run %{exe:../bin/caravan.exe} -i %{filled} -p %{provision} %{targets})))
+
+(rule (with-stdout-to result.hvt.output (run solo5-hvt %{exe:filled.c.hvt})))
+
+(rule (with-stdout-to result.unix.output (run %{exe:filled.exe})))
+
+(alias
+ (name runtest)
+ (package caravan)
+ (locks mirage-lock)
+ (deps (:output result.unix.output) (:expected result.unix.expected))
+ (action (run diff -uw %{output} %{expected})))
+
+(alias
+ (name runtest)
+ (package caravan)
+ (locks mirage-lock)
+ (deps (:output result.hvt.output) (:expected result.hvt.expected))
+ (action (run diff -uw %{output} %{expected})))
diff --git a/mirage/mirage-lock b/mirage/mirage-lock
diff --git a/mirage/result.hvt.expected b/mirage/result.hvt.expected
@@ -0,0 +1,13 @@
+            |      ___|
+  __|  _ \  |  _ \ __ \
+\__ \ (   | | (   |  ) |
+____/\___/ _|\___/____/
+Solo5: Bindings version v0.6.2
+Solo5: Memory map: 512 MB addressable:
+Solo5:   reserved @ (0x0 - 0xfffff)
+Solo5:       text @ (0x100000 - 0x1e8fff)
+Solo5:     rodata @ (0x1e9000 - 0x21efff)
+Solo5:       data @ (0x21f000 - 0x2c6fff)
+Solo5:       heap >= 0x2c7000 < stack < 0x20000000
+9f4e47215a247af1c3d24f7aa33560d637e9389b
+Solo5: solo5_exit(0) called
diff --git a/mirage/result.unix.expected b/mirage/result.unix.expected
@@ -0,0 +1 @@
+9f4e47215a247af1c3d24f7aa33560d637e9389b
diff --git a/mirage/unikernel.ml b/mirage/unikernel.ml
@@ -1,6 +1,4 @@
-module type PROVISION = sig
-  val provision : Provision.t
-end
+module type PROVISION = sig end
 
 module Make (P : PROVISION) (Console : Mirage_types_lwt.CONSOLE)
 = struct
@@ -10,7 +8,10 @@ module Make (P : PROVISION) (Console : Mirage_types_lwt.CONSOLE)
     let len = Provision.length provision in
     let res = Bytes.create len in
     Provision.load_bytes provision ~src_off:0 res ~dst_off:0 ~len ;
-    match Digestif.SHA1.of_hex_opt (Bytes.to_string res) with
+    let res = Bytes.unsafe_to_string res in
+    let map = Provision.map_bigstring provision ~off:0 ~len in
+    assert (String.equal (Bigstringaf.to_string map) res) ;
+    match Digestif.SHA1.of_hex_opt res with
     | Some hash -> log console "%a%!" Digestif.SHA1.pp hash
-    | None -> log console ">>> Invalid provision %S (length: %d)%!" (Bytes.unsafe_to_string res) len
+    | None -> log console ">>> Invalid provision %S (length: %d)%!" res len
 end