Merge pull request #79 from yomimono/new-gnt-iface

 port to new grant interface provided by mirage-xen

CHANGES.md

@@ -1,3 +1,8 @@
+## 1.6.1 (2019-04-02):
+* use new grant API from mirage-xen (@yomimono, @talex5)
+* several code cleanups and removals (@yomimono, @emillon)
+* remove ppx_cstruct direct dependency (@TheLortex)
+
 ## 1.6.0 (2019-01-11):
 * Port to dune from jbuilder (@avsm)
 

lib/blkback.ml

@@ -43,15 +43,15 @@ end
 
 open Lwt
 open Blkproto
-open Gnt
+module Gntref = OS.Xen.Gntref
 
 type ops = {
   read : int64 -> Cstruct.t list -> unit Lwt.t;
   write : int64 -> Cstruct.t list -> unit Lwt.t;
 }
 
 type stats = {
-  ring_utilisation: int array; (* one entry per leval, last entry includes all larger levels *)
+  ring_utilisation: int array; (* one entry per level, last entry includes all larger levels *)
   segments_per_request: int array; (* one entry per number of segments *)
   mutable total_requests: int;
   mutable total_ok: int;
@@ -60,7 +60,6 @@ type stats = {
 
 type ('a, 'b) t = {
   domid:  int;
-  xg:     Gnttab.interface;
   xe:     Eventchn.handle;
   evtchn: Eventchn.t;
   ring:   ('a, 'b) Ring.Rpc.Back.t;
@@ -71,15 +70,9 @@ type ('a, 'b) t = {
 let page_size = 4096
 
 module Opt = struct
-  let map f = function
-    | None -> None
-    | Some x -> Some (f x)
   let iter f = function
     | None -> ()
     | Some x -> f x
-  let default d = function
-    | None -> d
-    | Some x -> x
 end
 
 module Request = struct
@@ -118,8 +111,8 @@ end
 let service_thread t stats =
 
   let grants_of_segments = List.map (fun seg -> {
-    Gnttab.domid = t.domid;
-    ref = Int32.to_int seg.Req.gref;
+    OS.Xen.Import.domid = t.domid;
+    ref = seg.Req.gref;
   }) in
 
   let rec loop_forever after =
@@ -129,30 +122,35 @@ let service_thread t stats =
        the indirect descriptors which must be mapped before we
        can form the second batch. *)
 
-    (* a convenience table of grantref -> page Cstruct.t *)
-    let grant_table = Hashtbl.create 16 in
+    (* values in this grant table should be Cstruct.t's that can be converted to Io_page.t's *)
+    let (grant_table : (OS.Xen.Gntref.t, Cstruct.t) Hashtbl.t) = Hashtbl.create 16 in
 
     let lookup_mapping gref =
       if not(Hashtbl.mem grant_table gref) then begin
-        Log.err (fun f -> f "FATAL: failed to find mapped grant reference %ld" gref);
+        Log.err (fun f -> f "FATAL: failed to find mapped grant reference %s" @@ OS.Xen.Gntref.to_string gref);
         failwith "failed to find mapped grant reference"
       end else Hashtbl.find grant_table gref in
 
     let maybe_mapv writable = function
       | [] -> None (* nothing to do *)
       | grants ->
-        begin match Gnttab.mapv t.xg grants writable with
-          | None ->
-            Log.err (fun f -> f "FATAL: failed to map batch of %d grant references" (List.length grants));
+        begin match OS.Xen.Import.mapv grants ~writable with
+          | Error (`Msg s) ->
+            Log.err (fun f -> f "FATAL: failed to map batch of %d grant references: %s" (List.length grants) s);
             failwith "Failed to map grants" (* TODO: handle this error cleanly *)
-          | Some x ->
-            let buf = Io_page.to_cstruct (Gnttab.Local_mapping.to_buf x) in
-            let _ = List.fold_left (fun i gref -> Hashtbl.add grant_table (Int32.of_int gref.Gnttab.ref) (Cstruct.sub buf (4096 * i) 4096); i + 1) 0 grants in
+          | Ok x ->
+            let buf = Io_page.to_cstruct @@ OS.Xen.Import.Local_mapping.to_buf x in
+            let () =
+              List.iteri (fun i import ->
+                  let region = Cstruct.sub buf (page_size * i) page_size in
+                  Hashtbl.add grant_table import.OS.Xen.Import.ref region
+               ) grants
+            in
             Some x
         end in
     let maybe_unmap mapping =
       try
-        Opt.iter (Gnttab.unmap_exn t.xg) mapping
+        Opt.iter OS.Xen.Import.Local_mapping.unmap_exn mapping
       with e ->
         Log.err (fun f -> f "FATAL: failed to unmap grant references (frontend will be confused (%s)" (Printexc.to_string e)) in
 
@@ -169,7 +167,10 @@ let service_thread t stats =
          q := req :: !q;
          match req.segs with
          | Indirect grefs ->
-           let grefs = List.map (fun g -> { Gnttab.domid = t.domid; ref = Int32.to_int g }) (Array.to_list grefs) in
+           let grefs = List.map (fun g ->
+               { OS.Xen.Import.domid = t.domid; ref = Gntref.of_int32 g }
+             ) (Array.to_list grefs)
+           in
            indirect_grants := grefs @ (!indirect_grants)
          | Direct _ -> ()
       );
@@ -180,7 +181,7 @@ let service_thread t stats =
     let q = List.map (fun req -> match req.Req.segs with
       | Req.Direct _ -> req
       | Req.Indirect [| gref |] ->
-        let page = lookup_mapping gref in
+        let page = lookup_mapping (OS.Xen.Gntref.of_int32 gref) in
         let segs = Blkproto.Req.get_segments page req.Req.nr_segs in
         { req with Req.segs = Req.Direct segs }
       | Req.Indirect _ ->
@@ -277,34 +278,35 @@ let service_thread t stats =
     loop_forever next in
   loop_forever A.program_start
 
-let init xg xe domid ring_info ops =
+let init xe domid ring_info ops =
   let evtchn = Eventchn.bind_interdomain xe domid ring_info.RingInfo.event_channel in
   let parse_req, idx_size = match ring_info.RingInfo.protocol with
     | Protocol.X86_64 -> Req.Proto_64.read_request, Req.Proto_64.total_size
     | Protocol.X86_32 -> Req.Proto_32.read_request, Req.Proto_32.total_size
     | Protocol.Native -> Req.Proto_64.read_request, Req.Proto_64.total_size
   in
   let grants = List.map (fun r ->
-      { Gnttab.domid = domid; ref = Int32.to_int r })
+      { OS.Xen.Import.domid = domid; ref = Gntref.of_int32 r })
       [ ring_info.RingInfo.ref ] in
-  match Gnttab.mapv xg grants true with
-  | None ->
+  match OS.Xen.Import.mapv ~writable:true grants with
+  | Error (`Msg s) ->
+    Log.err (fun f -> f "OS.Xen.Import.mapv failed during initialization: %s" s);
     failwith "Gnttab.mapv failed"
-  | Some mapping ->
-    let buf = Gnttab.Local_mapping.to_buf mapping in
+  | Ok mapping ->
+    let buf = OS.Xen.Import.Local_mapping.to_buf mapping in
     let ring = Ring.Rpc.of_buf ~buf:(Io_page.to_cstruct buf) ~idx_size ~name:"blkback" in
     let ring = Ring.Rpc.Back.init ~sring:ring in
     let ring_utilisation = Array.make (Ring.Rpc.Back.nr_ents ring + 1) 0 in
     let segments_per_request = Array.make (Blkproto.max_segments_per_request + 1) 0 in
     let total_requests = 0 and total_ok = 0 and total_error = 0 in
     let stats = { ring_utilisation; segments_per_request; total_requests; total_ok; total_error } in
-    let t = { domid; xg; xe; evtchn; ops; parse_req; ring } in
+    let t = { domid; xe; evtchn; ops; parse_req; ring } in
     let th = service_thread t stats in
     on_cancel th (fun () ->
       let counter = ref 0 in
       Ring.Rpc.Back.ack_requests ring (fun _ -> incr counter);
       if !counter <> 0 then Log.err (fun f-> f "FATAL: before unmapping, there were %d outstanding requests on the ring. Events lost?" !(counter));
-      let () = Gnttab.unmap_exn xg mapping in ()
+      let () = OS.Xen.Import.Local_mapping.unmap_exn mapping in ()
     );
     th, stats
 
@@ -394,7 +396,6 @@ let run ?(max_indirect_segments=256) t name (domid,devid) =
   let open Mirage_block in
   make ()
   >>= fun client ->
-  let xg = Gnttab.interface_open () in
   let xe = Eventchn.init () in
 
   mk_backend_path client name (domid,devid)
@@ -468,7 +469,7 @@ let run ?(max_indirect_segments=256) t name (domid,devid) =
         ) (fun e ->
           Log.err (fun f -> f "blkback: write exception: %s, offset=%Ld" (Printexc.to_string e) ofs);
           Lwt.fail e) in
-    let be_thread, stats = init xg xe domid ring_info {
+    let be_thread, stats = init xe domid ring_info {
       read = device_read;
       write = device_write;
     } in

lib/blkfront.ml

@@ -19,7 +19,6 @@ open Lwt
 open Printf
 open Mirage_block
 open Blkproto
-open Gnt
 open OS
 
 let src = Logs.Src.create "blkfront" ~doc:"Mirage Xen blkfront"
@@ -35,7 +34,7 @@ type transport = {
   backend: string;
   ring: (Res.t,int64) Ring.Rpc.Front.t;
   client: (Res.t,int64) Lwt_ring.Front.t;
-  gnts: Gnt.gntref list;
+  gnts: OS.Xen.Gntref.t list;
   evtchn: Eventchn.t;
   max_indirect_segments: int;
   info: info;
@@ -62,10 +61,9 @@ let alloc ~order (num,domid) =
 
   let pages = Io_page.to_pages buf in
   let open Lwt.Infix in
-  Gntshr.get_n (List.length pages)
-  >>= fun gnts ->
+  OS.Xen.Export.get_n (List.length pages) >>= fun gnts ->
   List.iter (fun (gnt, page) ->
-      Gntshr.grant_access ~domid ~writable:true gnt page)
+      OS.Xen.Export.grant_access ~domid ~writable:true gnt page)
     (List.combine gnts pages);
 
   let sring = Ring.Rpc.of_buf ~buf:(Io_page.to_cstruct buf) ~idx_size ~name in
@@ -134,11 +132,13 @@ let plug (id:id) =
   let port = Eventchn.to_int evtchn in
   let ring_info =
     (* The new protocol writes (ring-refN = G) where N=0,1,2 *)
-    let rfs = snd(List.fold_left (fun (i, acc) g ->
-        i + 1, ((sprintf "ring-ref%d" i, string_of_int g) :: acc)
+    let rfs = snd
+        (List.fold_left (fun (i, acc) g ->
+             (i + 1),
+             ((sprintf "ring-ref%d" i, OS.Xen.Gntref.to_string g) :: acc)
       ) (0, []) gnts) in
     if ring_page_order = 0
-    then [ "ring-ref", string_of_int (List.hd gnts) ] (* backwards compat *)
+    then [ "ring-ref", OS.Xen.Gntref.to_string (List.hd gnts) ] (* backwards compat *)
     else [ "ring-page-order", string_of_int ring_page_order ] @ rfs in
   let info = [
     "event-channel", string_of_int port;
@@ -237,7 +237,7 @@ let params_to_frontend_ids ids =
     ) [] ids
 
 (** Create a Direct request if we have 11 or fewer requests, else an Indirect request. *)
-let with_segs t ~start_offset ~end_offset rs fn =
+let with_segs t ~start_offset ~end_offset (rs:OS.Xen.Gntref.t array) fn =
   let len = Array.length rs in
   let segs = Array.mapi (fun i rf ->
       let first_sector = match i with
@@ -246,8 +246,7 @@ let with_segs t ~start_offset ~end_offset rs fn =
       let last_sector = match i with
         | n when n == len-1 -> end_offset
         | _ -> 7 in
-      let gref = Int32.of_int rf in
-      { Req.gref; first_sector; last_sector }
+      { Req.gref = rf; first_sector; last_sector }
     ) rs in
   if len <= 11 then (
     fn (Req.Direct segs)
@@ -257,9 +256,9 @@ let with_segs t ~start_offset ~end_offset rs fn =
      * anyway. *)
     let indirect_page = Io_page.get 1 in
     Req.Proto_64.write_segments segs (Io_page.to_cstruct indirect_page);
-    Gntshr.with_ref (fun indirect_ref ->
-      Gntshr.with_grant ~domid:t.t.backend_id ~writable:false indirect_ref indirect_page (fun () ->
-        fn (Req.Indirect [| Int32.of_int indirect_ref |])
+    OS.Xen.Export.with_ref (fun indirect_ref ->
+      OS.Xen.Export.with_grant ~domid:t.t.backend_id ~writable:false indirect_ref indirect_page (fun () ->
+        fn (Req.Indirect [| OS.Xen.Gntref.to_int32 indirect_ref |])
       )
     )
   )
@@ -275,14 +274,14 @@ let single_request_into op t start_sector ?(start_offset=0) ?(end_offset=7) page
   let rec retry () =
     Lwt.catch
       (fun () ->
-      Gntshr.with_refs len
+      OS.Xen.Export.with_refs len
         (fun rs ->
-           Gntshr.with_grants ~domid:t.t.backend_id ~writable:(op = Req.Read) rs pages
+           OS.Xen.Export.with_grants ~domid:t.t.backend_id ~writable:(op = Req.Read) rs pages
              (fun () ->
                 let rs = Array.of_list rs in
                 let nr_segs = Array.length rs in
                 with_segs t ~start_offset ~end_offset rs (fun segs ->
-                  let id = Int64.of_int rs.(0) in
+                  let id = Int64.of_int32 @@ OS.Xen.Gntref.to_int32 rs.(0) in
                   let sector = Int64.(add start_sector (of_int start_offset)) in
                   let req = Req.({ op=Some op; handle=t.vdev; id; sector; nr_segs; segs }) in
                   let open Lwt.Infix in
@@ -322,9 +321,30 @@ let resume () =
     resume v
   ) devs
 
-let disconnect _id =
-  Log.err (fun f -> f "Blkfront: disconnect not implement yet");
-  return ()
+let disconnect t =
+  let open Lwt.Infix in
+  let frontend_node = sprintf "device/vbd/%d/%s" t.vdev in
+  let backend_state = sprintf "%s/state" t.t.backend in
+  Xs.make () >>= fun xs ->
+  Xs.(immediate xs (fun h -> write h (frontend_node "state")
+                       Device_state.(to_string Closing))) >>= fun () ->
+  Xs.(wait xs (fun h -> read h backend_state >>= fun state ->
+      match Device_state.of_string state with
+      | Closing | Closed -> Lwt.return_unit
+      | _ -> fail Xs_protocol.Eagain)) >>= fun () ->
+  Xs.(immediate xs (fun h -> write h (frontend_node "state")
+                       Device_state.(to_string Closed))) >>= fun () ->
+  Xs.(wait xs (fun h -> read h backend_state >>= fun state ->
+      match Device_state.of_string state with
+      | Closed -> Lwt.return_unit
+      | _ -> fail Xs_protocol.Eagain)) >>= fun () ->
+  Xs.(immediate xs (fun h -> write h (frontend_node "state")
+                       Device_state.(to_string Initialising))) >>= fun () ->
+  Xs.(wait xs (fun h -> read h backend_state >>= fun state ->
+      match Device_state.of_string state with
+      | InitWait | Initialised | Connected | Closing -> Lwt.return_unit
+      | _ -> fail Xs_protocol.Eagain)) >>= fun () ->
+  Lwt_list.iter_s (fun ref -> OS.Xen.Export.end_access ~release_ref:true ref) t.t.gnts
 
 type error = [ Mirage_block.error | `Exn of exn ]
 

lib/blkproto.ml

@@ -216,7 +216,7 @@ module Req = struct
   let segments_per_request = 11
 
   type seg = {
-    gref: int32;
+    gref: OS.Xen.Gntref.t;
     first_sector: int;
     last_sector: int;
   }
@@ -249,7 +249,7 @@ module Req = struct
   let get_segments payload nr_segs =
     Array.init nr_segs (fun i ->
       let seg = Cstruct.shift payload (i * sizeof_segment) in {
-        gref = get_segment_gref seg;
+        gref = OS.Xen.Gntref.of_int32 @@ get_segment_gref seg;
         first_sector = get_segment_first_sector seg;
         last_sector = get_segment_last_sector seg;
       })
@@ -294,7 +294,7 @@ module Req = struct
     let write_segments segs buffer =
       Array.iteri (fun i seg ->
         let buf = Cstruct.shift buffer (i * sizeof_segment) in
-        set_segment_gref buf seg.gref;
+        set_segment_gref buf (OS.Xen.Gntref.to_int32 seg.gref);
         set_segment_first_sector buf seg.first_sector;
         set_segment_last_sector buf seg.last_sector
       ) segs

lib/blkproto.mli

@@ -57,7 +57,7 @@ end
 
 module Req : sig
   type seg = {
-    gref : int32;
+    gref : OS.Xen.Gntref.t;
     first_sector : int;
     last_sector : int;
   }

lib/dune

@@ -2,7 +2,7 @@
  (name mirage_block_xen)
  (public_name mirage-block-xen)
  (modules Blkproto Device_number)
- (libraries cstruct io-page)
+ (libraries cstruct io-page mirage-xen)
  (wrapped false)
  (preprocess
   (pps ppx_cstruct)))
@@ -13,14 +13,14 @@
  (modules Blkfront Block)
  (libraries logs stringext lwt cstruct mirage-block-lwt io-page
    io-page-xen shared-memory-ring shared-memory-ring-lwt mirage-block-xen
-   xen-evtchn xen-gnt mirage-xen)
+   xen-evtchn mirage-xen)
  (wrapped false))
 
 (library
  (name mirage_block_xen_back)
  (public_name mirage-block-xen.back)
  (modules Blkback Block_request)
  (libraries logs lwt cstruct io-page shared-memory-ring
-   shared-memory-ring-lwt mirage-block-xen xen-evtchn xen-gnt xenstore
-   xenstore.client mirage-block-lwt rresult)
+   shared-memory-ring-lwt mirage-block-xen xen-evtchn xenstore
+   xenstore.client mirage-block-lwt rresult mirage-xen)
  (wrapped false))

mirage-block-xen.opam

@@ -19,7 +19,7 @@ depends: [
   "mirage-block-lwt" {>= "1.0.0"}
   "ipaddr"
   "io-page-xen" {>= "2.0.0"}
-  "mirage-xen" {>= "1.0.1"}
+  "mirage-xen" {>= "3.3.0"}
   "rresult"
 ]
 build: [