Commit 982051af authored by Keir Fraser's avatar Keir Fraser

ocaml: Add XS bindings.

Signed-off-by: default avatarVincent Hanquez <vincent.hanquez@eu.citrix.com>
parent f93ce9d3
version = "@VERSION@"
description = "Eventchn interface extension"
archive(byte) = "eventchn.cma"
archive(native) = "eventchn.cmxa"
TOPLEVEL=../..
include $(TOPLEVEL)/common.make
OBJS = eventchn
INTF = $(foreach obj, $(OBJS),$(obj).cmi)
LIBS = eventchn.cma eventchn.cmxa
all: $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
libs: $(LIBS)
eventchn_OBJS = $(OBJS)
eventchn_C_OBJS = eventchn_stubs
OCAML_LIBRARY = eventchn
.PHONY: install
install: $(LIBS) META
ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore eventchn META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove eventchn
include $(TOPLEVEL)/Makefile.rules
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
exception Error of string
external init: unit -> Unix.file_descr = "stub_eventchn_init"
external notify: Unix.file_descr -> int -> unit = "stub_eventchn_notify"
external bind_interdomain: Unix.file_descr -> int -> int -> int = "stub_eventchn_bind_interdomain"
external bind_virq: Unix.file_descr -> int = "stub_eventchn_bind_virq"
external unbind: Unix.file_descr -> int -> unit = "stub_eventchn_unbind"
external read_port: Unix.file_descr -> int = "stub_eventchn_read_port"
external write_port: Unix.file_descr -> int -> unit = "stub_eventchn_write_port"
let _ = Callback.register_exception "eventchn.error" (Error "register_callback")
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
exception Error of string
external init : unit -> Unix.file_descr = "stub_eventchn_init"
external notify : Unix.file_descr -> int -> unit = "stub_eventchn_notify"
external bind_interdomain : Unix.file_descr -> int -> int -> int
= "stub_eventchn_bind_interdomain"
external bind_virq : Unix.file_descr -> int = "stub_eventchn_bind_virq"
external unbind : Unix.file_descr -> int -> unit = "stub_eventchn_unbind"
external read_port : Unix.file_descr -> int = "stub_eventchn_read_port"
external write_port : Unix.file_descr -> int -> unit
= "stub_eventchn_write_port"
/*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*/
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <unistd.h>
#include <errno.h>
#include <stdint.h>
#include <sys/ioctl.h>
#define __XEN_TOOLS__
#include <xen/sysctl.h>
#if XEN_SYSCTL_INTERFACE_VERSION < 4
#include <xen/linux/evtchn.h>
#else
#include <xen/xen.h>
#include <xen/sys/evtchn.h>
#endif
#include <xenctrl.h>
#define CAML_NAME_SPACE
#include <caml/mlvalues.h>
#include <caml/memory.h>
#include <caml/alloc.h>
#include <caml/custom.h>
#include <caml/callback.h>
#include <caml/fail.h>
#define EVENTCHN_PATH "/dev/xen/eventchn"
static int eventchn_major = 10;
static int eventchn_minor = 61;
static int do_ioctl(int handle, int cmd, void *arg)
{
return ioctl(handle, cmd, arg);
}
static int do_read_port(int handle, evtchn_port_t *port)
{
return (read(handle, port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
}
static int do_write_port(int handle, evtchn_port_t port)
{
return (write(handle, &port, sizeof(evtchn_port_t)) != sizeof(evtchn_port_t));
}
int eventchn_do_open(void)
{
int fd;
fd = open(EVENTCHN_PATH, O_RDWR);
if (fd == -1 && errno == ENOENT) {
mkdir("/dev/xen", 0640);
mknod(EVENTCHN_PATH, S_IFCHR | 0640, makedev(eventchn_major, eventchn_minor));
fd = open(EVENTCHN_PATH, O_RDWR);
}
return fd;
}
CAMLprim value stub_eventchn_init(value unit)
{
CAMLparam1(unit);
int fd = eventchn_do_open();
if (fd == -1)
caml_failwith("open failed");
CAMLreturn(Val_int(fd));
}
CAMLprim value stub_eventchn_notify(value fd, value port)
{
CAMLparam2(fd, port);
struct ioctl_evtchn_notify notify;
int rc;
notify.port = Int_val(port);
rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_NOTIFY, &notify);
if (rc == -1)
caml_failwith("ioctl notify failed");
CAMLreturn(Val_unit);
}
CAMLprim value stub_eventchn_bind_interdomain(value fd, value domid,
value remote_port)
{
CAMLparam3(fd, domid, remote_port);
CAMLlocal1(port);
struct ioctl_evtchn_bind_interdomain bind;
int rc;
bind.remote_domain = Int_val(domid);
bind.remote_port = Int_val(remote_port);
rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_INTERDOMAIN, &bind);
if (rc == -1)
caml_failwith("ioctl bind_interdomain failed");
port = Val_int(rc);
CAMLreturn(port);
}
CAMLprim value stub_eventchn_bind_virq(value fd)
{
CAMLparam1(fd);
CAMLlocal1(port);
struct ioctl_evtchn_bind_virq bind;
int rc;
bind.virq = VIRQ_DOM_EXC;
rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_BIND_VIRQ, &bind);
if (rc == -1)
caml_failwith("ioctl bind_virq failed");
port = Val_int(rc);
CAMLreturn(port);
}
CAMLprim value stub_eventchn_unbind(value fd, value port)
{
CAMLparam2(fd, port);
struct ioctl_evtchn_unbind unbind;
int rc;
unbind.port = Int_val(port);
rc = do_ioctl(Int_val(fd), IOCTL_EVTCHN_UNBIND, &unbind);
if (rc == -1)
caml_failwith("ioctl unbind failed");
CAMLreturn(Val_unit);
}
CAMLprim value stub_eventchn_read_port(value fd)
{
CAMLparam1(fd);
CAMLlocal1(result);
evtchn_port_t port;
if (do_read_port(Int_val(fd), &port))
caml_failwith("read port failed");
result = Val_int(port);
CAMLreturn(result);
}
CAMLprim value stub_eventchn_write_port(value fd, value _port)
{
CAMLparam2(fd, _port);
evtchn_port_t port;
port = Int_val(_port);
if (do_write_port(Int_val(fd), port))
caml_failwith("write port failed");
CAMLreturn(Val_unit);
}
version = "@VERSION@"
description = "XenBus Interface"
archive(byte) = "xb.cma"
archive(native) = "xb.cmxa"
TOPLEVEL=../..
include $(TOPLEVEL)/common.make
CFLAGS += -I../mmap
OCAMLINCLUDE += -I ../mmap
.NOTPARALLEL:
# Ocaml is such a PITA!
PREINTF = op.cmi partial.cmi packet.cmi
PREOBJS = op partial packet xs_ring
PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx)
OBJS = op partial packet xs_ring xb
INTF = op.cmi packet.cmi xb.cmi
LIBS = xb.cma xb.cmxa
ALL_OCAML_OBJS = $(OBJS) $(PREOJBS)
all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS)
bins: $(PROGRAMS)
libs: $(LIBS)
xb_OBJS = $(OBJS)
xb_C_OBJS = xs_ring_stubs xb_stubs
OCAML_LIBRARY = xb
%.mli: %.ml
$(E) " MLI $@"
$(Q)$(OCAMLC) -i $< $o
.PHONY: install
install: $(LIBS) META
ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xb META $(INTF) $(LIBS) *.a *.so *.cmx
.PHONY: uninstall
uninstall:
ocamlfind remove xb
include $(TOPLEVEL)/Makefile.rules
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
type operation = Debug | Directory | Read | Getperms |
Watch | Unwatch | Transaction_start |
Transaction_end | Introduce | Release |
Getdomainpath | Write | Mkdir | Rm |
Setperms | Watchevent | Error | Isintroduced |
Resume | Set_target
| Restrict
(* There are two sets of XB operations: the one coming from open-source and *)
(* the one coming from our private patch queue. These operations *)
(* in two differents arrays for make easier the forward compatibility *)
let operation_c_mapping =
[| Debug; Directory; Read; Getperms;
Watch; Unwatch; Transaction_start;
Transaction_end; Introduce; Release;
Getdomainpath; Write; Mkdir; Rm;
Setperms; Watchevent; Error; Isintroduced;
Resume; Set_target |]
let size = Array.length operation_c_mapping
(* [offset_pq] has to be the same as in <xen/io/xs_wire.h> *)
let offset_pq = size
let operation_c_mapping_pq =
[| Restrict |]
let size_pq = Array.length operation_c_mapping_pq
let array_search el a =
let len = Array.length a in
let rec search i =
if i > len then raise Not_found;
if a.(i) = el then i else search (i + 1) in
search 0
let of_cval i =
if i >= 0 && i < size
then operation_c_mapping.(i)
else if i >= offset_pq && i < offset_pq + size_pq
then operation_c_mapping_pq.(i-offset_pq)
else raise Not_found
let to_cval op =
try
array_search op operation_c_mapping
with _ -> offset_pq + array_search op operation_c_mapping_pq
let to_string ty =
match ty with
| Debug -> "DEBUG"
| Directory -> "DIRECTORY"
| Read -> "READ"
| Getperms -> "GET_PERMS"
| Watch -> "WATCH"
| Unwatch -> "UNWATCH"
| Transaction_start -> "TRANSACTION_START"
| Transaction_end -> "TRANSACTION_END"
| Introduce -> "INTRODUCE"
| Release -> "RELEASE"
| Getdomainpath -> "GET_DOMAIN_PATH"
| Write -> "WRITE"
| Mkdir -> "MKDIR"
| Rm -> "RM"
| Setperms -> "SET_PERMS"
| Watchevent -> "WATCH_EVENT"
| Error -> "ERROR"
| Isintroduced -> "IS_INTRODUCED"
| Resume -> "RESUME"
| Set_target -> "SET_TARGET"
| Restrict -> "RESTRICT"
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
type t =
{
tid: int;
rid: int;
ty: Op.operation;
data: string;
}
exception Error of string
exception DataError of string
external string_of_header: int -> int -> int -> int -> string = "stub_string_of_header"
let create tid rid ty data = { tid = tid; rid = rid; ty = ty; data = data; }
let of_partialpkt ppkt =
create ppkt.Partial.tid ppkt.Partial.rid ppkt.Partial.ty (Buffer.contents ppkt.Partial.buf)
let to_string pkt =
let header = string_of_header pkt.tid pkt.rid (Op.to_cval pkt.ty) (String.length pkt.data) in
header ^ pkt.data
let unpack pkt =
pkt.tid, pkt.rid, pkt.ty, pkt.data
let get_tid pkt = pkt.tid
let get_ty pkt = pkt.ty
let get_data pkt =
let l = String.length pkt.data in
if l > 0 && pkt.data.[l - 1] = '\000' then
String.sub pkt.data 0 (l - 1)
else
pkt.data
let get_rid pkt = pkt.rid
\ No newline at end of file
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
type pkt =
{
tid: int;
rid: int;
ty: Op.operation;
len: int;
buf: Buffer.t;
}
external header_size: unit -> int = "stub_header_size"
external header_of_string_internal: string -> int * int * int * int
= "stub_header_of_string"
let of_string s =
let tid, rid, opint, dlen = header_of_string_internal s in
{
tid = tid;
rid = rid;
ty = (Op.of_cval opint);
len = dlen;
buf = Buffer.create dlen;
}
let append pkt s sz =
Buffer.add_string pkt.buf (String.sub s 0 sz)
let to_complete pkt =
pkt.len - (Buffer.length pkt.buf)
(*
* Copyright (C) 2006-2007 XenSource Ltd.
* Copyright (C) 2008 Citrix Ltd.
* Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU Lesser General Public License as published
* by the Free Software Foundation; version 2.1 only. with the special
* exception on linking described in file LICENSE.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU Lesser General Public License for more details.
*)
module Op = struct include Op end
module Packet = struct include Packet end
exception End_of_file
exception Eagain
exception Noent
exception Invalid
type backend_mmap =
{
mmap: Mmap.mmap_interface; (* mmaped interface = xs_ring *)
eventchn_notify: unit -> unit; (* function to notify through eventchn *)
mutable work_again: bool;
}
type backend_fd =
{
fd: Unix.file_descr;
}
type backend = Fd of backend_fd | Mmap of backend_mmap
type partial_buf = HaveHdr of Partial.pkt | NoHdr of int * string
type t =
{
backend: backend;
pkt_in: Packet.t Queue.t;
pkt_out: Packet.t Queue.t;
mutable partial_in: partial_buf;
mutable partial_out: string;
}
let init_partial_in () = NoHdr
(Partial.header_size (), String.make (Partial.header_size()) '\000')
let queue con pkt = Queue.push pkt con.pkt_out
let read_fd back con s len =
let rd = Unix.read back.fd s 0 len in
if rd = 0 then
raise End_of_file;
rd
let read_mmap back con s len =
let rd = Xs_ring.read back.mmap s len in
back.work_again <- (rd > 0);
if rd > 0 then
back.eventchn_notify ();
rd
let read con s len =
match con.backend with
| Fd backfd -> read_fd backfd con s len
| Mmap backmmap -> read_mmap backmmap con s len
let write_fd back con s len =
Unix.write back.fd s 0 len
let write_mmap back con s len =
let ws = Xs_ring.write back.mmap s len in
if ws > 0 then
back.eventchn_notify ();
ws
let write con s len =
match con.backend with
| Fd backfd -> write_fd backfd con s len
| Mmap backmmap -> write_mmap backmmap con s len
let output con =
(* get the output string from a string_of(packet) or partial_out *)
let s = if String.length con.partial_out > 0 then
con.partial_out
else if Queue.length con.pkt_out > 0 then
Packet.to_string (Queue.pop con.pkt_out)
else
"" in
(* send data from s, and save the unsent data to partial_out *)
if s <> "" then (
let len = String.length s in
let sz = write con s len in
let left = String.sub s sz (len - sz) in
con.partial_out <- left
);
(* after sending one packet, partial is empty *)
con.partial_out = ""
let input con =
let newpacket = ref false in
let to_read =
match con.partial_in with
| HaveHdr partial_pkt -> Partial.to_complete partial_pkt
| NoHdr (i, buf) -> i in
(* try to get more data from input stream *)
let s = String.make to_read '\000' in
let sz = if to_read > 0 then read con s to_read else 0 in
(
match con.partial_in with
| HaveHdr partial_pkt ->
(* we complete the data *)
if sz > 0 then
Partial.append partial_pkt s sz;
if Partial.to_complete partial_pkt = 0 then (
let pkt = Packet.of_partialpkt partial_pkt in
con.partial_in <- init_partial_in ();
Queue.push pkt con.pkt_in;
newpacket := true
)
| NoHdr (i, buf) ->
(* we complete the partial header *)
if sz > 0 then
String.blit s 0 buf (Partial.header_size () - i) sz;
con.partial_in <- if sz = i then
HaveHdr (Partial.of_string buf) else NoHdr (i - sz, buf)
);
!newpacket
let newcon backend = {
backend = backend;
pkt_in = Queue.create ();
pkt_out = Queue.create ();
partial_in = init_partial_in ();
partial_out = "";
}
let open_fd fd = newcon (Fd { fd = fd; })
let open_mmap mmap notifyfct =
newcon (Mmap {
mmap = mmap;
eventchn_notify = notifyfct;
work_again = false; })
let close con =
match con.backend with
| Fd backend -> Unix.close backend.fd
| Mmap backend -> Mmap.unmap backend.mmap
let is_fd con =
match con.backend with
| Fd _ -> true
| Mmap _ -> false
let is_mmap con = not (is_fd con)
let output_len con = Queue.length con.pkt_out
let has_new_output con = Queue.length con.pkt_out > 0
let has_old_output con = String.length con.partial_out > 0
let has_output con = has_new_output con || has_old_output con
let peek_output con = Queue.peek con.pkt_out
let input_len con = Queue.length con.pkt_in
let has_in_packet con = Queue.length con.pkt_in > 0
let get_in_packet con = Queue.pop con.pkt_in
let has_more_input con =
match con.backend with
| Fd _ -> false
| Mmap backend -> backend.work_again
let is_selectable con =
match con.backend with
| Fd _ -> true
| Mmap _ -> false
let get_fd con =
match con.backend with
| Fd backend -> backend.fd
| Mmap _ -> raise (Failure "get_fd")
module Op:
sig
type operation = Op.operation =
| Debug
| Directory
| Read
| Getperms
| Watch
| Unwatch
| Transaction_start
| Transaction_end
| Introduce
| Release
| Getdomainpath
| Write
| Mkdir
| Rm
| Setperms
| Watchevent
| Error
| Isintroduced
| Resume
| Set_target
| Restrict
val to_string : operation -> string
end
module Packet:
sig
type t
exception Error of string
exception DataError of string
val create : int -> int -> Op.operation -> string -> t
val unpack : t -> int * int * Op.operation * string
val get_tid : t -> int
val get_ty : t -> Op.operation
val get_data : t -> string
val get_rid: t -> int
end