@@ -45,16 +45,18 @@ module Gnttab = struct
ref: gntref;
}
+ external unmap_exn : interface -> Xenmmap.mmap_interface -> unit = "stub_gnttab_unmap"
+
+ external map_fresh_exn: interface -> gntref -> domid -> bool -> Xenmmap.mmap_interface = "stub_gnttab_map_fresh"
+
module Local_mapping = struct
type t = Xenmmap.mmap_interface
- let to_pages t = t
+ let to_pages interface t =
+ Xenmmap.make t ~unmap:(unmap_exn interface)
end
- external unmap_exn : interface -> Local_mapping.t -> unit = "stub_gnttab_unmap"
-
- external map_fresh_exn: interface -> gntref -> domid -> bool -> Local_mapping.t = "stub_gnttab_map_fresh"
-
let map_exn interface grant writable =
- map_fresh_exn interface grant.ref grant.domid writable
+ map_fresh_exn interface grant.ref grant.domid writable
+
end
@@ -53,6 +53,7 @@ module Gnttab : sig
ref: gntref;
(** id which identifies the specific export in the foreign domain *)
}
+
(** A foreign domain must explicitly "grant" us memory and send us the
"reference". The pair of (foreign domain id, reference) uniquely
identifies the block of memory. This pair ("grant") is transmitted
@@ -63,7 +64,7 @@ module Gnttab : sig
type t
(** Abstract type representing a locally-mapped shared memory page *)
- val to_pages: t -> Xenmmap.mmap_interface
+ val to_pages: interface -> t -> Xenmmap.t
end
val map_exn : interface -> grant -> bool -> Local_mapping.t
@@ -15,17 +15,27 @@
*)
type mmap_interface
+type t = mmap_interface * (mmap_interface -> unit)
+
type mmap_prot_flag = RDONLY | WRONLY | RDWR
type mmap_map_flag = SHARED | PRIVATE
(* mmap: fd -> prot_flag -> map_flag -> length -> offset -> interface *)
-external mmap: Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
+external mmap': Unix.file_descr -> mmap_prot_flag -> mmap_map_flag
-> int -> int -> mmap_interface = "stub_mmap_init"
-external unmap: mmap_interface -> unit = "stub_mmap_final"
(* read: interface -> start -> length -> data *)
external read: mmap_interface -> int -> int -> string = "stub_mmap_read"
(* write: interface -> data -> start -> length -> unit *)
external write: mmap_interface -> string -> int -> int -> unit = "stub_mmap_write"
(* getpagesize: unit -> size of page *)
+external unmap': mmap_interface -> unit = "stub_mmap_final"
+(* getpagesize: unit -> size of page *)
+let make ?(unmap=unmap') interface = interface, unmap
external getpagesize: unit -> int = "stub_mmap_getpagesize"
+
+let to_interface (intf, _) = intf
+let mmap fd prot_flag map_flag length offset =
+ let map = mmap' fd prot_flag map_flag length offset in
+ make map ~unmap:unmap'
+let unmap (map, do_unmap) = do_unmap map
@@ -14,15 +14,20 @@
* GNU Lesser General Public License for more details.
*)
+type t
type mmap_interface
type mmap_prot_flag = RDONLY | WRONLY | RDWR
type mmap_map_flag = SHARED | PRIVATE
-external mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int
- -> mmap_interface = "stub_mmap_init"
-external unmap : mmap_interface -> unit = "stub_mmap_final"
external read : mmap_interface -> int -> int -> string = "stub_mmap_read"
external write : mmap_interface -> string -> int -> int -> unit
= "stub_mmap_write"
+val mmap : Unix.file_descr -> mmap_prot_flag -> mmap_map_flag -> int -> int -> t
+val unmap : t -> unit
+
+val make: ?unmap:(mmap_interface -> unit) -> mmap_interface -> t
+
+val to_interface: t -> mmap_interface
+
external getpagesize : unit -> int = "stub_mmap_getpagesize"
@@ -28,7 +28,7 @@ let _ =
type backend_mmap =
{
- mmap: Xenmmap.mmap_interface; (* mmaped interface = xs_ring *)
+ mmap: Xenmmap.t; (* mmaped interface = xs_ring *)
eventchn_notify: unit -> unit; (* function to notify through eventchn *)
mutable work_again: bool;
}
@@ -59,7 +59,7 @@ let reconnect t = match t.backend with
(* should never happen, so close the connection *)
raise End_of_file
| Xenmmap backend ->
- Xs_ring.close backend.mmap;
+ Xs_ring.close Xenmmap.(to_interface backend.mmap);
backend.eventchn_notify ();
(* Clear our old connection state *)
Queue.clear t.pkt_in;
@@ -77,7 +77,7 @@ let read_fd back _con b len =
let read_mmap back _con b len =
let s = Bytes.make len '\000' in
- let rd = Xs_ring.read back.mmap s len in
+ let rd = Xs_ring.read Xenmmap.(to_interface back.mmap) s len in
Bytes.blit s 0 b 0 rd;
back.work_again <- (rd > 0);
if rd > 0 then
@@ -93,7 +93,7 @@ let write_fd back _con b len =
Unix.write_substring back.fd b 0 len
let write_mmap back _con s len =
- let ws = Xs_ring.write_substring back.mmap s len in
+ let ws = Xs_ring.write_substring Xenmmap.(to_interface back.mmap) s len in
if ws > 0 then
back.eventchn_notify ();
ws
@@ -167,7 +167,7 @@ let open_fd fd = newcon (Fd { fd = fd; })
let open_mmap mmap notifyfct =
(* Advertise XENSTORE_SERVER_FEATURE_RECONNECTION *)
- Xs_ring.set_server_features mmap (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection);
+ Xs_ring.set_server_features (Xenmmap.to_interface mmap) (Xs_ring.Server_features.singleton Xs_ring.Server_feature.Reconnection);
newcon (Xenmmap {
mmap = mmap;
eventchn_notify = notifyfct;
@@ -59,7 +59,7 @@ exception Noent
exception Invalid
exception Reconnect
type backend_mmap = {
- mmap : Xenmmap.mmap_interface;
+ mmap : Xenmmap.t;
eventchn_notify : unit -> unit;
mutable work_again : bool;
}
@@ -86,7 +86,7 @@ val output : t -> bool
val input : t -> bool
val newcon : backend -> t
val open_fd : Unix.file_descr -> t
-val open_mmap : Xenmmap.mmap_interface -> (unit -> unit) -> t
+val open_mmap : Xenmmap.t -> (unit -> unit) -> t
val close : t -> unit
val is_fd : t -> bool
val is_mmap : t -> bool
@@ -265,9 +265,11 @@ external domain_set_memmap_limit: handle -> domid -> int64 -> unit
external domain_memory_increase_reservation: handle -> domid -> int64 -> unit
= "stub_xc_domain_memory_increase_reservation"
-external map_foreign_range: handle -> domid -> int
+external map_foreign_range': handle -> domid -> int
-> nativeint -> Xenmmap.mmap_interface
- = "stub_map_foreign_range"
+ = "stub_map_foreign_range"
+let map_foreign_range handle domid port mfn =
+ Xenmmap.make (map_foreign_range' handle domid port mfn)
external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
= "stub_xc_domain_assign_device"
@@ -202,9 +202,8 @@ external domain_set_memmap_limit : handle -> domid -> int64 -> unit
external domain_memory_increase_reservation :
handle -> domid -> int64 -> unit
= "stub_xc_domain_memory_increase_reservation"
-external map_foreign_range :
- handle -> domid -> int -> nativeint -> Xenmmap.mmap_interface
- = "stub_map_foreign_range"
+val map_foreign_range :
+ handle -> domid -> int -> nativeint -> Xenmmap.t
external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit
= "stub_xc_domain_assign_device"
@@ -23,7 +23,7 @@ type t =
{
id: Xenctrl.domid;
mfn: nativeint;
- interface: Xenmmap.mmap_interface;
+ interface: Xenmmap.t;
eventchn: Event.t;
mutable remote_port: int;
mutable port: Xeneventchn.t option;
Xenmmap.mmap_interface is created from multiple places: * via mmap(), which needs to be unmap()-ed * xc_map_foreign_range * xengnttab_map_grant_ref Signed-off-by: Edwin Török <edvin.torok@citrix.com> --- tools/ocaml/libs/mmap/gnt.ml | 14 ++++++++------ tools/ocaml/libs/mmap/gnt.mli | 3 ++- tools/ocaml/libs/mmap/xenmmap.ml | 14 ++++++++++++-- tools/ocaml/libs/mmap/xenmmap.mli | 11 ++++++++--- tools/ocaml/libs/xb/xb.ml | 10 +++++----- tools/ocaml/libs/xb/xb.mli | 4 ++-- tools/ocaml/libs/xc/xenctrl.ml | 6 ++++-- tools/ocaml/libs/xc/xenctrl.mli | 5 ++--- tools/ocaml/xenstored/domain.ml | 2 +- 9 files changed, 44 insertions(+), 25 deletions(-)