From 7ac853d3fba934298b0d16f211db84773ee589be Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 12 Nov 2013 21:47:18 +0000 Subject: [PATCH 01/12] Depend on mirage-types; add stub implementation of BLOCK_DEVICE Note the 'read' and 'write' functions simply return `Error Unknown Signed-off-by: David Scott --- _oasis | 2 +- lib/blkfront.ml | 54 ++++++++++++++++++++++++++++-------------------- lib/blkfront.mli | 5 +++-- 3 files changed, 36 insertions(+), 25 deletions(-) diff --git a/_oasis b/_oasis index a68b648..193ffe8 100644 --- a/_oasis +++ b/_oasis @@ -29,7 +29,7 @@ Library blkfront Findlibparent: xenblock Findlibname: front Modules: Blkfront - BuildDepends: lwt, lwt.syntax, cstruct, cstruct.syntax, mirage, shared-memory-ring, shared-memory-ring.lwt, xenblock + BuildDepends: lwt, lwt.syntax, cstruct, cstruct.syntax, mirage, mirage-types, shared-memory-ring, shared-memory-ring.lwt, xenblock Library blkback Build$: flag(blkback) diff --git a/lib/blkfront.ml b/lib/blkfront.ml index d309205..3d4502c 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -21,12 +21,14 @@ open OS open Blkproto open Gnt -type features = { - barrier: bool; - removable: bool; - sector_size: int64; (* stored as int64 for convenient division *) - sectors: int64; - readwrite: bool; +type 'a io = 'a Lwt.t + +type page_aligned_buffer = Io_page.t + +type info = { + read_write: bool; + sector_size: int; + size_sectors: int64; } type transport = { @@ -36,7 +38,7 @@ type transport = { client: (Res.t,int64) Lwt_ring.Front.t; gnts: Gnt.gntref list; evtchn: Eventchn.t; - features: features; + info: info; } type t = { @@ -44,6 +46,8 @@ type t = { mutable t: transport } +let get_info t = return (t.t.info) + type id = string exception IO_error of string @@ -129,21 +133,19 @@ let plug (id:id) = lwt state = read h (sprintf "%s/state" backend) in if Device_state.(of_string state = Connected) then return () else fail Xs_protocol.Eagain )) in - (* Read backend features *) - lwt features = + (* Read backend info *) + lwt info = lwt state = backend_read (Device_state.of_string) Device_state.Unknown "state" in printf "state=%s\n%!" (Device_state.prettyprint state); - lwt barrier = backend_read ((=) "1") false "feature-barrier" in - lwt removable = backend_read ((=) "1") false "removable" in - lwt sectors = backend_read Int64.of_string (-1L) "sectors" in - lwt sector_size = backend_read Int64.of_string 0L "sector-size" in - lwt readwrite = backend_read (fun x -> x = "w") false "mode" in - return { barrier; removable; sector_size; sectors; readwrite } + lwt size_sectors = backend_read Int64.of_string (-1L) "sectors" in + lwt sector_size = backend_read int_of_string 0 "sector-size" in + lwt read_write = backend_read (fun x -> x = "w") false "mode" in + return { sector_size; size_sectors; read_write } in - printf "Blkfront features: barrier=%b removable=%b sector_size=%Lu sectors=%Lu\n%!" - features.barrier features.removable features.sector_size features.sectors; + printf "Blkfront info: sector_size=%u sectors=%Lu\n%!" + info.sector_size info.size_sectors; Eventchn.unmask h evtchn; - let t = { backend_id; backend; ring; client; gnts; evtchn; features } in + let t = { backend_id; backend; ring; client; gnts; evtchn; info } in (* Start the background poll thread *) let _ = poll t in return t @@ -170,8 +172,8 @@ let enumerate () = Offset is in bytes, which must be sector-aligned Page must be an Io_page *) let rec write_page t offset page = - let sector = Int64.div offset t.t.features.sector_size in - if not t.t.features.readwrite + let sector = Int64.(div offset (of_int t.t.info.sector_size)) in + if not t.t.info.read_write then fail (IO_error "read-only") else try_lwt @@ -338,8 +340,8 @@ let create ~id : Devices.blkif Lwt.t = method read_512 = read_512 dev method write_page = write_page dev method sector_size = 4096 - method size = Int64.mul dev.t.features.sectors dev.t.features.sector_size - method readwrite = dev.t.features.readwrite + method size = Int64.(mul dev.t.info.size_sectors (of_int dev.t.info.sector_size)) + method readwrite = dev.t.info.read_write method ppname = sprintf "Xen.blkif:%s" id method destroy = unplug id end) @@ -373,6 +375,14 @@ let register () = ) ids in Lwt_list.iter_s (Lwt_mvar.put plug_mvar) vbds +type error = Unknown + +let read t sector_start buffers = + return (`Error Unknown) + +let write t sector_start buffers = + return (`Error Unknown) + let _ = printf "Blkif: add resume hook\n%!"; Sched.add_resume_hook resume diff --git a/lib/blkfront.mli b/lib/blkfront.mli index f49f3b9..f2ddc9e 100644 --- a/lib/blkfront.mli +++ b/lib/blkfront.mli @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) open OS - +(* type features = { barrier : bool; removable : bool; @@ -22,8 +22,9 @@ type features = { sectors : int64; readwrite: bool; } +*) +include V1.BLOCK_DEVICE -type t type id = string exception IO_error of string val create : id:id -> Devices.blkif Lwt.t From 1f5280b368577d53949f066d0f51302da1918f15 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 16 Nov 2013 13:09:25 +0000 Subject: [PATCH 02/12] Update following V1.BLOCK error type change We now return Error Is_read_only for an attempt to write to a read/only device, and Error Unimplemented otherwise. Signed-off-by: David Scott --- lib/blkfront.ml | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/lib/blkfront.ml b/lib/blkfront.ml index 3d4502c..39586a0 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -375,13 +375,18 @@ let register () = ) ids in Lwt_list.iter_s (Lwt_mvar.put plug_mvar) vbds -type error = Unknown +type error = +| Unknown of string +| Unimplemented +| Is_read_only let read t sector_start buffers = - return (`Error Unknown) + return (`Error Unimplemented) let write t sector_start buffers = - return (`Error Unknown) + if not t.t.info.read_write + then return (`Error Is_read_only) + else return (`Error Unimplemented) let _ = printf "Blkif: add resume hook\n%!"; From e48e56f61a30a18814f94bf01d1a82a5d6272b94 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 16 Nov 2013 17:14:16 +0000 Subject: [PATCH 03/12] Flesh out V1.BLOCK read, write Note we advertise a minimum sector size of 4KiB (ie a page) to ensure the read/write start_sector is page-aligned as well as sector-aligned. More and more disks are using 4kiB sectors natively, and this simplifies the logic. Signed-off-by: David Scott --- lib/blkfront.ml | 316 ++++++++++++++++++++++++++---------------------- 1 file changed, 170 insertions(+), 146 deletions(-) diff --git a/lib/blkfront.ml b/lib/blkfront.ml index 39586a0..6e17771 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -46,8 +46,6 @@ type t = { mutable t: transport } -let get_info t = return (t.t.info) - type id = string exception IO_error of string @@ -168,152 +166,139 @@ let enumerate () = Console.log (sprintf "Blkif.enumerate caught exception: %s" (Printexc.to_string e)); return [] -(* Write a single page to disk. +(** [single_request_into op t start_sector start_offset end_offset pages] + issues a single request [op], starting at [start_sector] and using + the memory [pages] as either the target of data (if [op] is Read) or the + source of data (if [op] is Write). If the sector size is less than a page + then [start_offset] and [end_offset] can be used to start and finish the + data on sub-page sector boundaries in the first and last pages. *) +let single_request_into op t start_sector ?(start_offset=0) ?(end_offset=7) pages = + let len = List.length pages in + let rec retry () = + try_lwt + Gntshr.with_refs len + (fun rs -> + Gntshr.with_grants ~domid:t.t.backend_id ~writeable:(op = Req.Read) rs pages + (fun () -> + let segs = Array.mapi + (fun i rf -> + let first_sector = match i with + | 0 -> start_offset + | _ -> 0 in + 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 } + ) (Array.of_list rs) in + let id = Int64.of_int (List.hd rs) in + let sector = Int64.(add start_sector (of_int start_offset)) in + let req = Req.({ op=Some op; handle=t.vdev; id; sector; segs }) in + lwt res = Lwt_ring.Front.push_request_and_wait t.t.client + (fun () -> Eventchn.notify h t.t.evtchn) + (Req.Proto_64.write_request req) in + let open Res in + match res.st with + | Some Error -> fail (IO_error "read") + | Some Not_supported -> fail (IO_error "unsupported") + | None -> fail (IO_error "unknown error") + | Some OK -> return () + ) + ) + with + | Lwt_ring.Shutdown -> retry () + | exn -> fail exn in + retry () + +(* THIS FUNCTION IS DEPRECATED. Use 'write' instead. + + Write a single page to disk. Offset is in bytes, which must be sector-aligned Page must be an Io_page *) let rec write_page t offset page = let sector = Int64.(div offset (of_int t.t.info.sector_size)) in if not t.t.info.read_write then fail (IO_error "read-only") - else - try_lwt - Gntshr.with_ref - (fun r -> - Gntshr.with_grant ~domid:t.t.backend_id ~writeable:false r page - (fun () -> - let gref = Int32.of_int r in - let id = Int64.of_int32 gref in - let segs =[| { Req.gref; first_sector=0; last_sector=7 } |] in - let req = Req.({op=Some Req.Write; handle=t.vdev; id; sector; segs}) in - lwt res = Lwt_ring.Front.push_request_and_wait t.t.client - (fun () -> Eventchn.notify h t.t.evtchn) - (Req.Proto_64.write_request req) in - let open Res in - Res.(match res.st with - | Some Error -> fail (IO_error "write") - | Some Not_supported -> fail (IO_error "unsupported") - | None -> fail (IO_error "unknown error") - | Some OK -> return ()) - ) - ) - with - | Lwt_ring.Shutdown -> write_page t offset page - | exn -> fail exn - -module Single_request = struct - (** A large request must be broken down into a series of smaller page-aligned requests: *) - type t = { - start_sector: int64; (* page-aligned sector to start reading from *) - start_offset: int; (* sector offset into the page of our data *) - end_sector: int64; (* last page-aligned sector to read *) - end_offset: int; (* sector offset into the page of our data *) - } - - (** Number of pages required to issue this request *) - let npages_of t = Int64.(to_int (div (sub t.end_sector t.start_sector) 8L)) - - let to_string t = - sprintf "(%Lu, %u) -> (%Lu, %u)" t.start_sector t.start_offset t.end_sector t.end_offset - - (* Transforms a large read of [num_sectors] starting at [sector] into a Lwt_stream - of single_requests, where each request will fit on the ring. *) - let stream_of sector num_sectors = - let from (sector, num_sectors) = - assert (sector >= 0L); - assert (num_sectors > 0L); - (* Round down the starting sector in order to get a page aligned sector *) - let start_sector = Int64.(mul 8L (div sector 8L)) in - let start_offset = Int64.(to_int (sub sector start_sector)) in - (* Round up the ending sector to the page boundary *) - let end_sector = Int64.(mul 8L (div (add (add sector num_sectors) 7L) 8L)) in - (* Calculate number of sectors needed *) - let total_sectors_needed = Int64.(sub end_sector start_sector) in - (* Maximum of 11 segments per request; 1 page (8 sectors) per segment so: *) - let total_sectors_possible = min 88L total_sectors_needed in - let possible_end_sector = Int64.add start_sector total_sectors_possible in - let end_offset = min 7 (Int64.(to_int (sub 7L (sub possible_end_sector (add sector num_sectors))))) in - - let first = { start_sector; start_offset; end_sector = possible_end_sector; end_offset } in - if total_sectors_possible < total_sectors_needed - then - let num_sectors = Int64.(sub num_sectors (sub total_sectors_possible (of_int start_offset))) in - first, Some ((Int64.add start_sector total_sectors_possible), num_sectors) - else - first, None in - let state = ref (Some (sector, num_sectors)) in - Lwt_stream.from - (fun () -> - match !state with - | None -> return None - | Some x -> - let item, state' = from x in - state := state'; - return (Some item) - ) -end - -(* Issues a single request to read from [start_sector + start_offset] to [end_sector - end_offset] - where: [start_sector] and [end_sector] are page-aligned; and the total number of pages will fit - in a single request. *) -let read_single_request t r = - let open Single_request in - let len = npages_of r in - if len > 11 then - fail (Failure (sprintf "len > 11 %s" (Single_request.to_string r))) - else - let pages = Io_page.(to_pages (get len)) in - let rec single_attempt () = - try_lwt - Gntshr.with_refs len - (fun rs -> - Gntshr.with_grants ~domid:t.t.backend_id ~writeable:true rs pages - (fun () -> - let segs = Array.mapi - (fun i rf -> - let first_sector = match i with - |0 -> r.start_offset - |_ -> 0 in - let last_sector = match i with - |n when n == len-1 -> r.end_offset - |_ -> 7 in - let gref = Int32.of_int rf in - { Req.gref; first_sector; last_sector } - ) (Array.of_list rs) in - let id = Int64.of_int (List.hd rs) in - let sector = Int64.(add r.start_sector (of_int r.start_offset)) in - let req = Req.({ op=Some Read; handle=t.vdev; id; sector; segs }) in - lwt res = Lwt_ring.Front.push_request_and_wait t.t.client - (fun () -> Eventchn.notify h t.t.evtchn) - (Req.Proto_64.write_request req) in - let open Res in - match res.st with - | Some Error -> fail (IO_error "read") - | Some Not_supported -> fail (IO_error "unsupported") - | None -> fail (IO_error "unknown error") - | Some OK -> - (* Get the pages, and convert them into Istring views *) - return (Lwt_stream.of_list (List.rev (snd (List.fold_left - (fun (i, acc) page -> - let start_offset = match i with - |0 -> r.start_offset * 512 - |_ -> 0 in - let end_offset = match i with - |n when n = len-1 -> (r.end_offset + 1) * 512 - |_ -> 4096 in - let bytes = end_offset - start_offset in - let subpage = Cstruct.sub (Io_page.to_cstruct page) start_offset bytes in - i + 1, subpage :: acc - ) (0, []) pages - )))) - ) - ) - with | Lwt_ring.Shutdown -> single_attempt () - | exn -> fail exn in - single_attempt () - -(* Reads [num_sectors] starting at [sector], returning a stream of Io_page.ts *) + else single_request_into Req.Write t sector [ page ] + + +(* THIS FUNCTION IS DEPRECATED. Use 'read' instead. + + Reads [num_sectors] starting at [sector], returning a stream of Io_page.ts *) let read_512 t sector num_sectors = + let module Single_request = struct + (** A large request must be broken down into a series of smaller page-aligned requests: *) + type t = { + start_sector: int64; (* page-aligned sector to start reading from *) + start_offset: int; (* sector offset into the page of our data *) + end_sector: int64; (* last page-aligned sector to read *) + end_offset: int; (* sector offset into the page of our data *) + } + + (** Number of pages required to issue this request *) + let npages_of t = Int64.(to_int (div (sub t.end_sector t.start_sector) 8L)) + + let to_string t = + sprintf "(%Lu, %u) -> (%Lu, %u)" t.start_sector t.start_offset t.end_sector t.end_offset + + (* Transforms a large read of [num_sectors] starting at [sector] into a Lwt_stream + of single_requests, where each request will fit on the ring. *) + let stream_of sector num_sectors = + let from (sector, num_sectors) = + assert (sector >= 0L); + assert (num_sectors > 0L); + (* Round down the starting sector in order to get a page aligned sector *) + let start_sector = Int64.(mul 8L (div sector 8L)) in + let start_offset = Int64.(to_int (sub sector start_sector)) in + (* Round up the ending sector to the page boundary *) + let end_sector = Int64.(mul 8L (div (add (add sector num_sectors) 7L) 8L)) in + (* Calculate number of sectors needed *) + let total_sectors_needed = Int64.(sub end_sector start_sector) in + (* Maximum of 11 segments per request; 1 page (8 sectors) per segment so: *) + let total_sectors_possible = min 88L total_sectors_needed in + let possible_end_sector = Int64.add start_sector total_sectors_possible in + let end_offset = min 7 (Int64.(to_int (sub 7L (sub possible_end_sector (add sector num_sectors))))) in + + let first = { start_sector; start_offset; end_sector = possible_end_sector; end_offset } in + if total_sectors_possible < total_sectors_needed + then + let num_sectors = Int64.(sub num_sectors (sub total_sectors_possible (of_int start_offset))) in + first, Some ((Int64.add start_sector total_sectors_possible), num_sectors) + else + first, None in + let state = ref (Some (sector, num_sectors)) in + Lwt_stream.from + (fun () -> + match !state with + | None -> return None + | Some x -> + let item, state' = from x in + state := state'; + return (Some item) + ) + + let list_of sector num_sectors = + Lwt_stream.to_list (stream_of sector num_sectors) + end in let requests = Single_request.stream_of sector num_sectors in + let read_single_request t r = + let open Single_request in + let len = npages_of r in + let pages = Io_page.(to_pages (get len)) in + lwt () = single_request_into Req.Read t r.start_sector ~start_offset:r.start_offset ~end_offset:r.end_offset pages in + return (Lwt_stream.of_list (List.rev (snd (List.fold_left + (fun (i, acc) page -> + let start_offset = match i with + |0 -> r.start_offset * 512 + |_ -> 0 in + let end_offset = match i with + |n when n = len-1 -> (r.end_offset + 1) * 512 + |_ -> 4096 in + let bytes = end_offset - start_offset in + let subpage = Cstruct.sub (Io_page.to_cstruct page) start_offset bytes in + i + 1, subpage :: acc + ) (0, []) pages + )))) in Lwt_stream.(concat (map_s (read_single_request t) requests)) let resume t = @@ -380,13 +365,52 @@ type error = | Unimplemented | Is_read_only -let read t sector_start buffers = - return (`Error Unimplemented) +(* [take xs n] returns [(taken, remaining)] where [taken] is as many + elements of [xs] as possible, up to [n], and [remaining] is any + that are left over. *) +let take xs n = + let rec loop taken remaining n = match n, remaining with + | 0, _ + | _, [] -> List.rev taken, remaining + | n, x :: xs -> loop (x :: taken) xs (n - 1) in + loop [] xs n + +(* Upgrade sector_size to be at least a page to guarantee read/write + is page-aligned as well as sector-aligned. 4k sector size disks + are becoming more common, so we might as well be ready. *) +let minimum_sector_size = 4096 + +let get_sector_size t = + min t.t.info.sector_size minimum_sector_size + +let sector t x = + if t.t.info.sector_size >= 4096 + then x + else Int64.(div (mul x (of_int t.t.info.sector_size)) (of_int minimum_sector_size)) + +let get_info t = + let info = { t.t.info with sector_size = get_sector_size t } in + return info + +let rec multiple_requests_into op t start_sector = function + | [] -> return () + | remaining -> + let pages, remaining = take remaining 11 in (* 11 segments per request *) + lwt () = single_request_into op t start_sector pages in + let start_sector = Int64.(add start_sector (of_int (11 * 4096 / t.t.info.sector_size))) in + multiple_requests_into op t start_sector remaining + +let read t start_sector pages = + try_lwt + lwt () = multiple_requests_into Req.Read t (sector t start_sector) pages in + return (`Ok ()) + with e -> return (`Error (Unknown (Printexc.to_string e))) -let write t sector_start buffers = - if not t.t.info.read_write - then return (`Error Is_read_only) - else return (`Error Unimplemented) +let write t start_sector pages = + try_lwt + lwt () = multiple_requests_into Req.Write t (sector t start_sector) pages in + return (`Ok ()) + with e -> return (`Error (Unknown (Printexc.to_string e))) let _ = printf "Blkif: add resume hook\n%!"; From 6e0a5c58b488ec8066f826fa27a9fdfe820b6d56 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 16 Nov 2013 22:00:14 +0000 Subject: [PATCH 04/12] Add a basic 'connect' function Signed-off-by: David Scott --- lib/blkfront.ml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/blkfront.ml b/lib/blkfront.ml index 6e17771..f31e02a 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -400,6 +400,8 @@ let rec multiple_requests_into op t start_sector = function let start_sector = Int64.(add start_sector (of_int (11 * 4096 / t.t.info.sector_size))) in multiple_requests_into op t start_sector remaining +let connect id = return (`Ok (Hashtbl.find devices id)) (* XXX: make this block and wait *) + let read t start_sector pages = try_lwt lwt () = multiple_requests_into Req.Read t (sector t start_sector) pages in From 15adc4869d0668af1243895479bad08da55e5ac7 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 16 Nov 2013 22:07:20 +0000 Subject: [PATCH 05/12] Register the blkfront as the "local" block driver Also use the mirage-platform's Block.S signature, which is the mirage-type V1.BLOCK_DEVICE with abstract types instantiated. Signed-off-by: David Scott --- _oasis | 2 +- lib/blkfront.mli | 2 +- lib/blkfront_init.ml | 19 +++++++++++++++++++ 3 files changed, 21 insertions(+), 2 deletions(-) create mode 100644 lib/blkfront_init.ml diff --git a/_oasis b/_oasis index 193ffe8..8ee9b3d 100644 --- a/_oasis +++ b/_oasis @@ -28,7 +28,7 @@ Library blkfront Path: lib Findlibparent: xenblock Findlibname: front - Modules: Blkfront + Modules: Blkfront, Blkfront_init BuildDepends: lwt, lwt.syntax, cstruct, cstruct.syntax, mirage, mirage-types, shared-memory-ring, shared-memory-ring.lwt, xenblock Library blkback diff --git a/lib/blkfront.mli b/lib/blkfront.mli index f2ddc9e..722e6b6 100644 --- a/lib/blkfront.mli +++ b/lib/blkfront.mli @@ -23,7 +23,7 @@ type features = { readwrite: bool; } *) -include V1.BLOCK_DEVICE +include Block.S type id = string exception IO_error of string diff --git a/lib/blkfront_init.ml b/lib/blkfront_init.ml new file mode 100644 index 0000000..d9d25ae --- /dev/null +++ b/lib/blkfront_init.ml @@ -0,0 +1,19 @@ +(* + * Copyright (c) 2011 Anil Madhavapeddy + * Copyright (c) 2012 Citrix Systems Inc + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +let _ = + OS.Block.register "local" (module Blkfront: OS.Block.S) From b43cacf0711eafe0592f9bf7881b9054714cf5dd Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 17 Nov 2013 11:52:27 +0000 Subject: [PATCH 06/12] blkfront: make 'connect' block properly This is necessary because devices are plugged asynchronously. We still need a device naming scheme: currently xen devices have funny names like '51712' '51768' etc. This 'pair of Hashtbl.ts with Lwt_sequence.ts full of waiters' seems like a common pattern. Perhaps it should be factored out. Signed-off-by: David Scott --- lib/blkfront.ml | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/lib/blkfront.ml b/lib/blkfront.ml index f31e02a..8eae730 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -52,6 +52,8 @@ exception IO_error of string (** Set of active block devices *) let devices : (id, t) Hashtbl.t = Hashtbl.create 1 +let devices_waiters : (id, t Lwt.u Lwt_sequence.t) Hashtbl.t = Hashtbl.create 1 + let h = Eventchn.init () (* Allocate a ring, given the vdev and backend domid *) @@ -319,6 +321,10 @@ let create ~id : Devices.blkif Lwt.t = let dev = { vdev = int_of_string id; t = trans } in Hashtbl.add devices id dev; + if Hashtbl.mem devices_waiters id then begin + Lwt_sequence.iter_l (fun u -> Lwt.wakeup_later u dev) (Hashtbl.find devices_waiters id); + Hashtbl.remove devices_waiters id + end; printf "Xen.Blkif: success\n%!"; return (object method id = id @@ -400,7 +406,19 @@ let rec multiple_requests_into op t start_sector = function let start_sector = Int64.(add start_sector (of_int (11 * 4096 / t.t.info.sector_size))) in multiple_requests_into op t start_sector remaining -let connect id = return (`Ok (Hashtbl.find devices id)) (* XXX: make this block and wait *) +let connect id = + if Hashtbl.mem devices id + then return (`Ok (Hashtbl.find devices id)) + else + let t, u = Lwt.task () in + let seq = + if Hashtbl.mem devices_waiters id + then Hashtbl.find devices_waiters id + else Lwt_sequence.create () in + let (_: t Lwt.u Lwt_sequence.node) = Lwt_sequence.add_r u seq in + Hashtbl.replace devices_waiters id seq; + lwt dev = t in + return (`Ok dev) let read t start_sector pages = try_lwt From 2ac986a2d1df13a1c5bdfe959ad775a446311ce9 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 17 Nov 2013 22:21:23 +0000 Subject: [PATCH 07/12] Blkfront_init.register () is the only registration function needed Signed-off-by: David Scott --- lib/blkfront_init.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/lib/blkfront_init.ml b/lib/blkfront_init.ml index d9d25ae..4dbaa13 100644 --- a/lib/blkfront_init.ml +++ b/lib/blkfront_init.ml @@ -15,5 +15,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -let _ = - OS.Block.register "local" (module Blkfront: OS.Block.S) +let register () = + OS.Block.register "local" (module Blkfront: OS.Block.S); + Blkfront.register () From 795b53bca5fc5c8f76778856396edd56688616f4 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sun, 17 Nov 2013 22:21:52 +0000 Subject: [PATCH 08/12] Update after page_aligned_buffer := Cstruct.t change Signed-off-by: David Scott --- lib/blkfront.ml | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/lib/blkfront.ml b/lib/blkfront.ml index 8eae730..e473550 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -420,13 +420,30 @@ let connect id = lwt dev = t in return (`Ok dev) +exception Buffer_is_not_page_aligned +exception Buffer_is_more_than_one_page +let to_iopage x = + if x.Cstruct.off <> 0 then raise Buffer_is_not_page_aligned; + if x.Cstruct.len > 4096 then raise Buffer_is_more_than_one_page; + x.Cstruct.buffer + +let to_iopages x = + try return (List.map to_iopage x) + with e -> fail e + +let ( >>= ) x f = match x with + | `Error _ -> x + | `Ok x -> f x + let read t start_sector pages = + lwt pages = to_iopages pages in try_lwt lwt () = multiple_requests_into Req.Read t (sector t start_sector) pages in return (`Ok ()) with e -> return (`Error (Unknown (Printexc.to_string e))) let write t start_sector pages = + lwt pages = to_iopages pages in try_lwt lwt () = multiple_requests_into Req.Write t (sector t start_sector) pages in return (`Ok ()) From 9c19ec200da4e481f4a89078f629187d2db10d24 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 19 Nov 2013 21:20:22 +0000 Subject: [PATCH 09/12] blkfront: fix sector/offset calculations in new BLOCK interface Signed-off-by: David Scott --- lib/blkfront.ml | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/lib/blkfront.ml b/lib/blkfront.ml index e473550..6222698 100644 --- a/lib/blkfront.ml +++ b/lib/blkfront.ml @@ -387,15 +387,17 @@ let take xs n = let minimum_sector_size = 4096 let get_sector_size t = - min t.t.info.sector_size minimum_sector_size + max t.t.info.sector_size minimum_sector_size let sector t x = if t.t.info.sector_size >= 4096 then x - else Int64.(div (mul x (of_int t.t.info.sector_size)) (of_int minimum_sector_size)) + else Int64.(div (mul x (of_int minimum_sector_size)) (of_int t.t.info.sector_size)) let get_info t = - let info = { t.t.info with sector_size = get_sector_size t } in + let sector_size = get_sector_size t in + let size_sectors = Int64.(div t.t.info.size_sectors (of_int (sector_size / t.t.info.sector_size))) in + let info = { t.t.info with sector_size; size_sectors } in return info let rec multiple_requests_into op t start_sector = function From c574b10d0bab310bc9df8bb0ed50724b7cb9544a Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 19 Nov 2013 21:22:35 +0000 Subject: [PATCH 10/12] Remove commented-out dead code Signed-off-by: David Scott --- lib/blkfront.mli | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/lib/blkfront.mli b/lib/blkfront.mli index 722e6b6..189b286 100644 --- a/lib/blkfront.mli +++ b/lib/blkfront.mli @@ -14,17 +14,11 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) open OS -(* -type features = { - barrier : bool; - removable : bool; - sector_size : int64; - sectors : int64; - readwrite: bool; -} -*) + include Block.S +(** {2} Legacy interface *) + type id = string exception IO_error of string val create : id:id -> Devices.blkif Lwt.t From 9b457b6640561cff4437f65256cd69ece907bcd4 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 19 Nov 2013 21:22:51 +0000 Subject: [PATCH 11/12] Update CHANGES Signed-off-by: David Scott --- CHANGES | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES b/CHANGES index cf73af6..93684b8 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,6 @@ +trunk (unreleased) +* implement new mirage-types BLOCK interface + 0.2.5 (10-Nov-2013) * fix build against cstruct.0.8.0 * blkfront write_page only needs to grant read access to From df3223cf6b39430fb81f148f2ec0fe430c6fcab9 Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 19 Nov 2013 21:22:55 +0000 Subject: [PATCH 12/12] Regenerate OASIS Signed-off-by: David Scott --- _tags | 3 ++- lib/META | 4 ++-- lib/blkfront.mllib | 3 ++- setup.ml | 8 ++++---- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/_tags b/_tags index 5f7ce23..5a33cd1 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 7bd900b7024f84f0fb74d6e39d9969bc) +# DO NOT EDIT (digest: fa8d6474a1a5bb6911b0fb034ee12cc9) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -17,6 +17,7 @@ "lib/xenblock.cmxs": use_xenblock # Library blkfront "lib/blkfront.cmxs": use_blkfront +: pkg_mirage-types # Library blkback "lib/blkback.cmxs": use_blkback : use_xenblock diff --git a/lib/META b/lib/META index 93527a9..a02910a 100644 --- a/lib/META +++ b/lib/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 5d19f3e579effe5987b622cdcaef96db) +# DO NOT EDIT (digest: 29112410a7cdc0a8cf0173c510bb7667) version = "0.2.4" description = "Xen block frontend and backend driver implementation" requires = "cstruct cstruct.syntax" @@ -12,7 +12,7 @@ package "front" ( version = "0.2.4" description = "Xen block frontend and backend driver implementation" requires = - "lwt lwt.syntax cstruct cstruct.syntax mirage shared-memory-ring shared-memory-ring.lwt xenblock" + "lwt lwt.syntax cstruct cstruct.syntax mirage mirage-types shared-memory-ring shared-memory-ring.lwt xenblock" archive(byte) = "blkfront.cma" archive(byte, plugin) = "blkfront.cma" archive(native) = "blkfront.cmxa" diff --git a/lib/blkfront.mllib b/lib/blkfront.mllib index 5e98dd6..a248237 100644 --- a/lib/blkfront.mllib +++ b/lib/blkfront.mllib @@ -1,4 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 2d16726a1926756d424db957c9d78408) +# DO NOT EDIT (digest: f7fed72d781df4577f6248f09fbc53cc) Blkfront +Blkfront_init # OASIS_STOP diff --git a/setup.ml b/setup.ml index bc88bab..3a0b225 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.3.1 *) (* OASIS_START *) -(* DO NOT EDIT (digest: 6af0e1b9f7666ba467fd3a471e1f6253) *) +(* DO NOT EDIT (digest: 648c6d14cec373e3874d25bae73710e1) *) (* Regenerated by OASIS v0.3.0 Visit http://oasis.forge.ocamlcore.org for more information and @@ -5707,6 +5707,7 @@ let setup_t = FindlibPackage ("cstruct", None); FindlibPackage ("cstruct.syntax", None); FindlibPackage ("mirage", None); + FindlibPackage ("mirage-types", None); FindlibPackage ("shared-memory-ring", None); FindlibPackage ("shared-memory-ring.lwt", None); InternalLibrary "xenblock" @@ -5722,7 +5723,7 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])]; }, { - lib_modules = ["Blkfront"]; + lib_modules = ["Blkfront"; "Blkfront_init"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "xenblock"; @@ -5781,8 +5782,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.3.0"; - oasis_digest = - Some "=\t\151\233\225\215\185\163H/\249\255\023\213\027\182"; + oasis_digest = Some "zC\011\183\163\002\230\200\132vGuz8 \n"; oasis_exec = None; oasis_setup_args = []; setup_update = false;