From f9367d0dafa775c673bff37ac5097ca66f52388c Mon Sep 17 00:00:00 2001 From: Mindy Date: Mon, 25 Mar 2019 22:00:18 -0500 Subject: [PATCH 1/6] port to new grant interface provided by mirage-xen bonus: `disconnect` is now implemented! --- lib/blkback.ml | 63 +++++++++++++++++++++------------------ lib/blkfront.ml | 68 +++++++++++++++++++++++++++++++------------ lib/dune | 6 ++-- mirage-block-xen.opam | 2 +- 4 files changed, 88 insertions(+), 51 deletions(-) diff --git a/lib/blkback.ml b/lib/blkback.ml index 58bda42..bfb9bbc 100644 --- a/lib/blkback.ml +++ b/lib/blkback.ml @@ -43,7 +43,7 @@ end open Lwt open Blkproto -open Gnt +module Gntref = OS.Xen.Gntref type ops = { read : int64 -> Cstruct.t list -> unit Lwt.t; @@ -51,7 +51,7 @@ type ops = { } 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; @@ -118,8 +117,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 = Gntref.of_int32 seg.Req.gref; }) in let rec loop_forever after = @@ -129,30 +128,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 (4096 * i) 4096 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 +173,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 +187,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 _ -> @@ -220,7 +227,7 @@ let service_thread t stats = | Some ((Req.Read | Req.Write) as op) -> (try let bufs = List.map (fun seg -> - let page = lookup_mapping seg.Req.gref in + let page = lookup_mapping (OS.Xen.Gntref.of_int32 seg.Req.gref) in let frag = Cstruct.sub page (seg.Req.first_sector * 512) ((seg.Req.last_sector - seg.Req.first_sector + 1) * 512) in frag) segs in add acc request.Req.id op request.Req.sector bufs @@ -277,7 +284,7 @@ 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 @@ -285,26 +292,27 @@ let init xg xe domid ring_info ops = | 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 +402,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 +475,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 diff --git a/lib/blkfront.ml b/lib/blkfront.ml index fccccc0..c461d58 100644 --- a/lib/blkfront.ml +++ b/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,7 +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 + let gref = OS.Xen.Gntref.to_int32 rf in { Req.gref; first_sector; last_sector } ) rs in if len <= 11 then ( @@ -257,9 +257,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 +275,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 +322,39 @@ let resume () = resume v ) devs -let disconnect _id = - Log.err (fun f -> f "Blkfront: disconnect not implement yet"); - return () +let disconnect (t:t) : unit Lwt.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 -> + (* first, set the frontend state to Closing. *) + Xs.(immediate xs (fun h -> write h (frontend_node "state") + Device_state.(to_string Closing))) >>= fun () -> + (* wait for the backend to set its state to Closing or Closed. *) + 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 () -> + (* set frontend state to Closed *) + Xs.(immediate xs (fun h -> write h (frontend_node "state") + Device_state.(to_string Closed))) >>= fun () -> + (* wait for backend to set its state to Closed (or higher, which we don't recognize) *) + 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 () -> + (* set frontend state to Initialising *) + Xs.(immediate xs (fun h -> write h (frontend_node "state") + Device_state.(to_string Initialising))) >>= fun () -> + (* wait for the backend to set its state to something >= Closed. *) + 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 () -> + (* finally, remove the tree. *) + Xs.(immediate xs (fun h -> rm h (sprintf "device/vbd/%d" t.vdev))) >>= fun () -> + (* and end access to all the grants. *) + 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 ] diff --git a/lib/dune b/lib/dune index a0b1d97..0507d58 100644 --- a/lib/dune +++ b/lib/dune @@ -13,7 +13,7 @@ (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 @@ -21,6 +21,6 @@ (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)) diff --git a/mirage-block-xen.opam b/mirage-block-xen.opam index f3a77c5..490c489 100644 --- a/mirage-block-xen.opam +++ b/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: [ From 21c0450dc98a1ab728e2afd747bab1fe7f8d2483 Mon Sep 17 00:00:00 2001 From: Mindy Date: Tue, 26 Mar 2019 13:29:39 -0500 Subject: [PATCH 2/6] remove unused convenience functions from Opt module --- lib/blkback.ml | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/lib/blkback.ml b/lib/blkback.ml index bfb9bbc..fc4771c 100644 --- a/lib/blkback.ml +++ b/lib/blkback.ml @@ -70,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 @@ -145,7 +139,7 @@ let service_thread t stats = 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 *) | Ok x -> - let buf = Io_page.to_cstruct (OS.Xen.Import.Local_mapping.to_buf x) in + 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 (4096 * i) 4096 in From 27e17770bfa38dc4257871f0bddc98f521cc9344 Mon Sep 17 00:00:00 2001 From: Mindy Date: Tue, 26 Mar 2019 13:30:02 -0500 Subject: [PATCH 3/6] refer to page_size instead of magic number 4096 --- lib/blkback.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/blkback.ml b/lib/blkback.ml index fc4771c..471d5e0 100644 --- a/lib/blkback.ml +++ b/lib/blkback.ml @@ -142,7 +142,7 @@ let service_thread t stats = 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 (4096 * i) 4096 in + let region = Cstruct.sub buf (page_size * i) page_size in Hashtbl.add grant_table import.OS.Xen.Import.ref region ) grants in From dda6c13f82127a6c7f44226bd9963f9dbd2e04ce Mon Sep 17 00:00:00 2001 From: Mindy Date: Mon, 1 Apr 2019 19:24:56 -0500 Subject: [PATCH 4/6] update CHANGES for v1.6.1 --- CHANGES.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 1a16f22..8b9233d 100644 --- a/CHANGES.md +++ b/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) From 3f1d93bc538e5731e149e85e15074435c3ccdab4 Mon Sep 17 00:00:00 2001 From: Mindy Date: Wed, 3 Apr 2019 13:03:39 -0500 Subject: [PATCH 5/6] deal directly with OS.Xen.Gntref.t's in a few more places Replace some code which deals with grant references as int32's - we can use Gntref.t there and only deal with int32s when setting values in cstructs. --- lib/blkback.ml | 4 ++-- lib/blkfront.ml | 3 +-- lib/blkproto.ml | 6 +++--- lib/blkproto.mli | 2 +- lib/dune | 2 +- 5 files changed, 8 insertions(+), 9 deletions(-) diff --git a/lib/blkback.ml b/lib/blkback.ml index 471d5e0..5a5085d 100644 --- a/lib/blkback.ml +++ b/lib/blkback.ml @@ -112,7 +112,7 @@ let service_thread t stats = let grants_of_segments = List.map (fun seg -> { OS.Xen.Import.domid = t.domid; - ref = Gntref.of_int32 seg.Req.gref; + ref = seg.Req.gref; }) in let rec loop_forever after = @@ -221,7 +221,7 @@ let service_thread t stats = | Some ((Req.Read | Req.Write) as op) -> (try let bufs = List.map (fun seg -> - let page = lookup_mapping (OS.Xen.Gntref.of_int32 seg.Req.gref) in + let page = lookup_mapping seg.Req.gref in let frag = Cstruct.sub page (seg.Req.first_sector * 512) ((seg.Req.last_sector - seg.Req.first_sector + 1) * 512) in frag) segs in add acc request.Req.id op request.Req.sector bufs diff --git a/lib/blkfront.ml b/lib/blkfront.ml index c461d58..4098ac9 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -246,8 +246,7 @@ let with_segs t ~start_offset ~end_offset (rs:OS.Xen.Gntref.t array) fn = let last_sector = match i with | n when n == len-1 -> end_offset | _ -> 7 in - let gref = OS.Xen.Gntref.to_int32 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) diff --git a/lib/blkproto.ml b/lib/blkproto.ml index ac6285d..055afd4 100644 --- a/lib/blkproto.ml +++ b/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 diff --git a/lib/blkproto.mli b/lib/blkproto.mli index 05f2b65..bd823e2 100644 --- a/lib/blkproto.mli +++ b/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; } diff --git a/lib/dune b/lib/dune index 0507d58..2ecc702 100644 --- a/lib/dune +++ b/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))) From 2189d76ad9674dad05d10b086521c0d323027186 Mon Sep 17 00:00:00 2001 From: Mindy Date: Wed, 3 Apr 2019 13:09:54 -0500 Subject: [PATCH 6/6] don't delete tree in disconnect --- lib/blkfront.ml | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/lib/blkfront.ml b/lib/blkfront.ml index 4098ac9..3141d64 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -321,38 +321,29 @@ let resume () = resume v ) devs -let disconnect (t:t) : unit Lwt.t = +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 -> - (* first, set the frontend state to Closing. *) Xs.(immediate xs (fun h -> write h (frontend_node "state") Device_state.(to_string Closing))) >>= fun () -> - (* wait for the backend to set its state to Closing or Closed. *) 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 () -> - (* set frontend state to Closed *) Xs.(immediate xs (fun h -> write h (frontend_node "state") Device_state.(to_string Closed))) >>= fun () -> - (* wait for backend to set its state to Closed (or higher, which we don't recognize) *) 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 () -> - (* set frontend state to Initialising *) Xs.(immediate xs (fun h -> write h (frontend_node "state") Device_state.(to_string Initialising))) >>= fun () -> - (* wait for the backend to set its state to something >= Closed. *) 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 () -> - (* finally, remove the tree. *) - Xs.(immediate xs (fun h -> rm h (sprintf "device/vbd/%d" t.vdev))) >>= fun () -> - (* and end access to all the grants. *) 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 ]