From ab5201cdac0ed80d1d87e5916f99e15c6fe2d076 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Mon, 24 Jan 2022 20:46:22 +0100 Subject: [PATCH 1/2] Replace OS by Xen_os --- lib/back/blkback.ml | 42 +++++++++++++++++++++--------------------- lib/core/blkproto.ml | 6 +++--- lib/core/blkproto.mli | 2 +- lib/front/blkfront.ml | 28 ++++++++++++++-------------- 4 files changed, 39 insertions(+), 39 deletions(-) diff --git a/lib/back/blkback.ml b/lib/back/blkback.ml index ad590f5..bb7747c 100644 --- a/lib/back/blkback.ml +++ b/lib/back/blkback.ml @@ -32,7 +32,7 @@ type event val program_start: event (** represents an event which 'fired' when the program started *) -val after: OS.Eventchn.t -> event -> event Lwt.t +val after: Xen_os.Eventchn.t -> event -> event Lwt.t (** [next channel event] blocks until the system receives an event newer than [event] on channel [channel]. If an event is received while we aren't looking then this will be remembered and the @@ -44,7 +44,7 @@ end open Lwt open Blkproto -module Gntref = OS.Xen.Gntref +module Gntref = Xen_os.Xen.Gntref type ops = { read : int64 -> Cstruct.t list -> unit Lwt.t; @@ -61,8 +61,8 @@ type stats = { type ('a, 'b) t = { domid: int; - xe: OS.Eventchn.handle; - evtchn: OS.Eventchn.t; + xe: Xen_os.Eventchn.handle; + evtchn: Xen_os.Eventchn.t; ring: ('a, 'b) Ring.Rpc.Back.t; ops : ops; parse_req : Cstruct.t -> Req.t; @@ -112,7 +112,7 @@ end let service_thread t stats = let grants_of_segments = List.map (fun seg -> { - OS.Xen.Import.domid = t.domid; + Xen_os.Xen.Import.domid = t.domid; ref = seg.Req.gref; }) in @@ -124,34 +124,34 @@ let service_thread t stats = can form the second batch. *) (* 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 (grant_table : (Xen_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 %s" @@ OS.Xen.Gntref.to_string gref); + Log.err (fun f -> f "FATAL: failed to find mapped grant reference %s" @@ Xen_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 OS.Xen.Import.mapv grants ~writable with + begin match Xen_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 *) | Ok x -> - let buf = Io_page.to_cstruct @@ OS.Xen.Import.Local_mapping.to_buf x in + let buf = Io_page.to_cstruct @@ Xen_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 + Hashtbl.add grant_table import.Xen_os.Xen.Import.ref region ) grants in Some x end in let maybe_unmap mapping = try - Opt.iter OS.Xen.Import.Local_mapping.unmap_exn mapping + Opt.iter Xen_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 +169,7 @@ let service_thread t stats = match req.segs with | Indirect grefs -> let grefs = List.map (fun g -> - { OS.Xen.Import.domid = t.domid; ref = Gntref.of_int32 g } + { Xen_os.Xen.Import.domid = t.domid; ref = Gntref.of_int32 g } ) (Array.to_list grefs) in indirect_grants := grefs @ (!indirect_grants) @@ -182,7 +182,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 (OS.Xen.Gntref.of_int32 gref) in + let page = lookup_mapping (Xen_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 _ -> @@ -271,7 +271,7 @@ let service_thread t stats = maybe_unmap indirect_grants_mapping; (* Make the responses visible to the frontend *) let notify = Ring.Rpc.Back.push_responses_and_check_notify t.ring in - if notify then OS.Eventchn.notify t.xe t.evtchn; + if notify then Xen_os.Eventchn.notify t.xe t.evtchn; return () in let open Lwt.Infix in A.after t.evtchn after @@ -280,21 +280,21 @@ let service_thread t stats = loop_forever A.program_start let init xe domid ring_info ops = - let evtchn = OS.Eventchn.bind_interdomain xe domid ring_info.RingInfo.event_channel in + let evtchn = Xen_os.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 -> - { OS.Xen.Import.domid = domid; ref = Gntref.of_int32 r }) + { Xen_os.Xen.Import.domid = domid; ref = Gntref.of_int32 r }) [ ring_info.RingInfo.ref ] in - match OS.Xen.Import.mapv ~writable:true grants with + match Xen_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); + Log.err (fun f -> f "Xen_os.Xen.Import.mapv failed during initialization: %s" s); failwith "Gnttab.mapv failed" | Ok mapping -> - let buf = OS.Xen.Import.Local_mapping.to_buf mapping in + let buf = Xen_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 @@ -307,7 +307,7 @@ let init xe domid ring_info ops = 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 () = OS.Xen.Import.Local_mapping.unmap_exn mapping in () + let () = Xen_os.Xen.Import.Local_mapping.unmap_exn mapping in () ); th, stats @@ -397,7 +397,7 @@ let run ?(max_indirect_segments=256) t name (domid,devid) = let open Mirage_block in make () >>= fun client -> - let xe = OS.Eventchn.init () in + let xe = Xen_os.Eventchn.init () in mk_backend_path client name (domid,devid) >>= fun backend_path -> diff --git a/lib/core/blkproto.ml b/lib/core/blkproto.ml index ccb781a..21512cc 100644 --- a/lib/core/blkproto.ml +++ b/lib/core/blkproto.ml @@ -216,7 +216,7 @@ module Req = struct let segments_per_request = 11 type seg = { - gref: OS.Xen.Gntref.t; + gref: Xen_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 = OS.Xen.Gntref.of_int32 @@ get_segment_gref seg; + gref = Xen_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 (OS.Xen.Gntref.to_int32 seg.gref); + set_segment_gref buf (Xen_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/core/blkproto.mli b/lib/core/blkproto.mli index bd823e2..9268fdf 100644 --- a/lib/core/blkproto.mli +++ b/lib/core/blkproto.mli @@ -57,7 +57,7 @@ end module Req : sig type seg = { - gref : OS.Xen.Gntref.t; + gref : Xen_os.Xen.Gntref.t; first_sector : int; last_sector : int; } diff --git a/lib/front/blkfront.ml b/lib/front/blkfront.ml index d689de0..107534f 100644 --- a/lib/front/blkfront.ml +++ b/lib/front/blkfront.ml @@ -19,7 +19,7 @@ open Lwt open Printf open Mirage_block open Blkproto -open OS +open Xen_os let src = Logs.Src.create "blkfront" ~doc:"Mirage Xen blkfront" @@ -30,7 +30,7 @@ type transport = { backend: string; ring: (Res.t,int64) Ring.Rpc.Front.t; client: (Res.t,int64) Lwt_ring.Front.t; - gnts: OS.Xen.Gntref.t list; + gnts: Xen_os.Xen.Gntref.t list; evtchn: Eventchn.t; max_indirect_segments: int; info: info; @@ -57,9 +57,9 @@ let alloc ~order (num,domid) = let pages = Io_page.to_pages buf in let open Lwt.Infix in - OS.Xen.Export.get_n (List.length pages) >>= fun gnts -> + Xen_os.Xen.Export.get_n (List.length pages) >>= fun gnts -> List.iter (fun (gnt, page) -> - OS.Xen.Export.grant_access ~domid ~writable:true gnt page) + Xen_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 @@ -131,10 +131,10 @@ let plug (id:id) = let rfs = snd (List.fold_left (fun (i, acc) g -> (i + 1), - ((sprintf "ring-ref%d" i, OS.Xen.Gntref.to_string g) :: acc) + ((sprintf "ring-ref%d" i, Xen_os.Xen.Gntref.to_string g) :: acc) ) (0, []) gnts) in if ring_page_order = 0 - then [ "ring-ref", OS.Xen.Gntref.to_string (List.hd gnts) ] (* backwards compat *) + then [ "ring-ref", Xen_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; @@ -233,7 +233,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:OS.Xen.Gntref.t array) fn = +let with_segs t ~start_offset ~end_offset (rs:Xen_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 @@ -252,9 +252,9 @@ let with_segs t ~start_offset ~end_offset (rs:OS.Xen.Gntref.t array) fn = * anyway. *) let indirect_page = Io_page.get 1 in Req.Proto_64.write_segments segs (Io_page.to_cstruct indirect_page); - 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 |]) + Xen_os.Xen.Export.with_ref (fun indirect_ref -> + Xen_os.Xen.Export.with_grant ~domid:t.t.backend_id ~writable:false indirect_ref indirect_page (fun () -> + fn (Req.Indirect [| Xen_os.Xen.Gntref.to_int32 indirect_ref |]) ) ) ) @@ -270,14 +270,14 @@ let single_request_into op t start_sector ?(start_offset=0) ?(end_offset=7) page let rec retry () = Lwt.catch (fun () -> - OS.Xen.Export.with_refs len + Xen_os.Xen.Export.with_refs len (fun rs -> - OS.Xen.Export.with_grants ~domid:t.t.backend_id ~writable:(op = Req.Read) rs pages + Xen_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_int32 @@ OS.Xen.Gntref.to_int32 rs.(0) in + let id = Int64.of_int32 @@ Xen_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,7 +322,7 @@ let disconnect t = 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 + Lwt_list.iter_s (fun ref -> Xen_os.Xen.Export.end_access ~release_ref:true ref) t.t.gnts type error = [ Mirage_block.error | `Exn of exn ] From aa0fab1c782a45c4701f1eda1317d159810ba370 Mon Sep 17 00:00:00 2001 From: Romain Calascibetta Date: Tue, 25 Jan 2022 11:38:49 +0100 Subject: [PATCH 2/2] Add pin-depends on mirage-xen and transitive deps --- mirage-block-xen.opam | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/mirage-block-xen.opam b/mirage-block-xen.opam index c1bf50c..d781692 100644 --- a/mirage-block-xen.opam +++ b/mirage-block-xen.opam @@ -41,4 +41,9 @@ library which enables high-throughput, low-latency data transfers over shared memory on both x86 and ARM architectures, using the standard Xen RPC and event channel semantics. """ - +pin-depends:[ + [ "mirage-xen.dev" "git+https://github.com/dinosaure/mirage-xen.git#b7b5eaebead17a864b53085b60351a1648ba05b1" ] + [ "mirage-runtime.4.0.0" "git+https://github.com/mirage/mirage.git#59101cd795e741982a0a4580c113072339e1389b" ] + [ "functoria-runtime.4.0.0" "git+https://github.com/mirage/mirage.git#59101cd795e741982a0a4580c113072339e1389b" ] + [ "functoria.4.0.0" "git+https://github.com/mirage/mirage.git#59101cd795e741982a0a4580c113072339e1389b" ] +]