diff --git a/tools/ocaml/libs/eventchn/META.in b/tools/ocaml/libs/eventchn/META.in new file mode 100644 index 0000000..f3e01aa --- /dev/null +++ b/tools/ocaml/libs/eventchn/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "Eventchn interface extension" +archive(byte) = "eventchn.cma" +archive(native) = "eventchn.cmxa" diff --git a/tools/ocaml/libs/eventchn/Makefile b/tools/ocaml/libs/eventchn/Makefile new file mode 100644 index 0000000..9d6ef31 --- /dev/null +++ b/tools/ocaml/libs/eventchn/Makefile @@ -0,0 +1,28 @@ +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 + diff --git a/tools/ocaml/libs/eventchn/eventchn.ml b/tools/ocaml/libs/eventchn/eventchn.ml new file mode 100644 index 0000000..c4a7fa3 --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn.ml @@ -0,0 +1,27 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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") diff --git a/tools/ocaml/libs/eventchn/eventchn.mli b/tools/ocaml/libs/eventchn/eventchn.mli new file mode 100644 index 0000000..7088700 --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn.mli @@ -0,0 +1,26 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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" diff --git a/tools/ocaml/libs/eventchn/eventchn_stubs.c b/tools/ocaml/libs/eventchn/eventchn_stubs.c new file mode 100644 index 0000000..ab61b0a --- /dev/null +++ b/tools/ocaml/libs/eventchn/eventchn_stubs.c @@ -0,0 +1,173 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 +#include +#include +#include +#include +#include + +#include + +#define __XEN_TOOLS__ + +#include + +#if XEN_SYSCTL_INTERFACE_VERSION < 4 +#include +#else +#include +#include +#endif + +#include + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include +#include + +#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, ¬ify); + 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); +} diff --git a/tools/ocaml/libs/log/META.in b/tools/ocaml/libs/log/META.in new file mode 100644 index 0000000..5c3646a --- /dev/null +++ b/tools/ocaml/libs/log/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "Log - logging library" +archive(byte) = "log.cma" +archive(native) = "log.cmxa" diff --git a/tools/ocaml/libs/log/Makefile b/tools/ocaml/libs/log/Makefile new file mode 100644 index 0000000..d16f72a --- /dev/null +++ b/tools/ocaml/libs/log/Makefile @@ -0,0 +1,43 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +OCAMLINCLUDE += -I ../stdext + +OBJS = syslog log logs +INTF = log.cmi logs.cmi syslog.cmi +LIBS = log.cma log.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +log.cmxa: libsyslog_stubs.a $(foreach obj,$(OBJS),$(obj).cmx) + $(call mk-caml-lib-native, $@, -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmx)) + +log.cma: $(foreach obj,$(OBJS),$(obj).cmo) + $(call mk-caml-lib-bytecode, $@, -dllib dllsyslog_stubs.so -cclib -lsyslog_stubs, $(foreach obj,$(OBJS),$(obj).cmo)) + +syslog_stubs.a: syslog_stubs.o + $(call mk-caml-stubs, $@, $+) + +libsyslog_stubs.a: syslog_stubs.o + $(call mk-caml-lib-stubs, $@, $+) + +logs.mli : logs.ml + $(OCAMLC) -i $(OCAMLCFLAGS) $< > $@ + +syslog.mli : syslog.ml + $(OCAMLC) -i $< > $@ + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore log META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove log + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/log/log.ml b/tools/ocaml/libs/log/log.ml new file mode 100644 index 0000000..4f42759 --- /dev/null +++ b/tools/ocaml/libs/log/log.ml @@ -0,0 +1,258 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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. + *) + +open Printf + +exception Unknown_level of string + +type stream_type = Stderr | Stdout | File of string + +type stream_log = { + ty : stream_type; + channel : out_channel option ref; +} + +type level = Debug | Info | Warn | Error + +type output = + | Stream of stream_log + | String of string list ref + | Syslog of string + | Nil + +let int_of_level l = + match l with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3 + +let string_of_level l = + match l with Debug -> "debug" | Info -> "info" + | Warn -> "warn" | Error -> "error" + +let level_of_string s = + match s with + | "debug" -> Debug + | "info" -> Info + | "warn" -> Warn + | "error" -> Error + | _ -> raise (Unknown_level s) + +let mkdir_safe dir perm = + try Unix.mkdir dir perm with _ -> () + +let mkdir_rec dir perm = + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name = "/" || p_name = "." then + () + else ( + p_mkdir p_name; + mkdir_safe dir perm + ) in + p_mkdir dir + +type t = { output: output; mutable level: level; } + +let make output level = { output = output; level = level; } + +let make_stream ty channel = + Stream {ty=ty; channel=ref channel; } + +(** open a syslog logger *) +let opensyslog k level = + make (Syslog k) level + +(** open a stderr logger *) +let openerr level = + if (Unix.stat "/dev/stderr").Unix.st_kind <> Unix.S_CHR then + failwith "/dev/stderr is not a valid character device"; + make (make_stream Stderr (Some (open_out "/dev/stderr"))) level + +let openout level = + if (Unix.stat "/dev/stdout").Unix.st_kind <> Unix.S_CHR then + failwith "/dev/stdout is not a valid character device"; + make (make_stream Stdout (Some (open_out "/dev/stdout"))) level + + +(** open a stream logger - returning the channel. *) +(* This needs to be separated from 'openfile' so we can reopen later *) +let doopenfile filename = + if Filename.is_relative filename then + None + else ( + try + mkdir_rec (Filename.dirname filename) 0o700; + Some (open_out_gen [ Open_append; Open_creat ] 0o600 filename) + with _ -> None + ) + +(** open a stream logger - returning the output type *) +let openfile filename level = + make (make_stream (File filename) (doopenfile filename)) level + +(** open a nil logger *) +let opennil () = + make Nil Error + +(** open a string logger *) +let openstring level = + make (String (ref [""])) level + +(** try to reopen a logger *) +let reopen t = + match t.output with + | Nil -> t + | Syslog k -> Syslog.close (); opensyslog k t.level + | Stream s -> ( + match (s.ty,!(s.channel)) with + | (File filename, Some c) -> close_out c; s.channel := (try doopenfile filename with _ -> None); t + | _ -> t) + | String _ -> t + +(** close a logger *) +let close t = + match t.output with + | Nil -> () + | Syslog k -> Syslog.close (); + | Stream s -> ( + match !(s.channel) with + | Some c -> close_out c; s.channel := None + | None -> ()) + | String _ -> () + +(** create a string representating the parameters of the logger *) +let string_of_logger t = + match t.output with + | Nil -> "nil" + | Syslog k -> sprintf "syslog:%s" k + | String _ -> "string" + | Stream s -> + begin + match s.ty with + | File f -> sprintf "file:%s" f + | Stderr -> "stderr" + | Stdout -> "stdout" + end + +(** parse a string to a logger *) +let logger_of_string s : t = + match s with + | "nil" -> opennil () + | "stderr" -> openerr Debug + | "stdout" -> openout Debug + | "string" -> openstring Debug + | _ -> + let split_in_2 s = + try + let i = String.index s ':' in + String.sub s 0 (i), + String.sub s (i + 1) (String.length s - i - 1) + with _ -> + failwith "logger format error: expecting string:string" + in + let k, s = split_in_2 s in + match k with + | "syslog" -> opensyslog s Debug + | "file" -> openfile s Debug + | _ -> failwith "unknown logger type" + +let validate s = + match s with + | "nil" -> () + | "stderr" -> () + | "stdout" -> () + | "string" -> () + | _ -> + let split_in_2 s = + try + let i = String.index s ':' in + String.sub s 0 (i), + String.sub s (i + 1) (String.length s - i - 1) + with _ -> + failwith "logger format error: expecting string:string" + in + let k, s = split_in_2 s in + match k with + | "syslog" -> () + | "file" -> ( + try + let st = Unix.stat s in + if st.Unix.st_kind <> Unix.S_REG then + failwith "logger file is a directory"; + () + with Unix.Unix_error (Unix.ENOENT, _, _) -> () + ) + | _ -> failwith "unknown logger" + +(** change a logger level to level *) +let set t level = t.level <- level + +let gettimestring () = + let time = Unix.gettimeofday () in + let tm = Unix.localtime time in + let msec = time -. (floor time) in + sprintf "%d%.2d%.2d %.2d:%.2d:%.2d.%.3d|" (1900 + tm.Unix.tm_year) + (tm.Unix.tm_mon + 1) tm.Unix.tm_mday + tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec + (int_of_float (1000.0 *. msec)) + +(*let extra_hook = ref (fun x -> x)*) + +let output t ?(key="") ?(extra="") priority (message: string) = + let construct_string withtime = + (*let key = if key = "" then [] else [ key ] in + let extra = if extra = "" then [] else [ extra ] in + let items = + (if withtime then [ gettimestring () ] else []) + @ [ sprintf "%5s" (string_of_level priority) ] @ extra @ key @ [ message ] in +(* let items = !extra_hook items in*) + String.concat " " items*) + Printf.sprintf "[%s%s|%s] %s" + (if withtime then gettimestring () else "") (string_of_level priority) extra message + in + (* Keep track of how much we write out to streams, so that we can *) + (* log-rotate at appropriate times *) + let write_to_stream stream = + let string = (construct_string true) in + try + fprintf stream "%s\n%!" string + with _ -> () (* Trap exception when we fail to write log *) + in + + if String.length message > 0 then + match t.output with + | Syslog k -> + let sys_prio = match priority with + | Debug -> Syslog.Debug + | Info -> Syslog.Info + | Warn -> Syslog.Warning + | Error -> Syslog.Err in + Syslog.log Syslog.Daemon sys_prio ((construct_string false) ^ "\n") + | Stream s -> ( + match !(s.channel) with + | Some c -> write_to_stream c + | None -> ()) + | Nil -> () + | String s -> (s := (construct_string true)::!s) + +let log t level (fmt: ('a, unit, string, unit) format4): 'a = + let b = (int_of_level t.level) <= (int_of_level level) in + (* ksprintf is the preferred name for kprintf, but the former + * is not available in OCaml 3.08.3 *) + Printf.kprintf (if b then output t level else (fun _ -> ())) fmt + +let debug t (fmt: ('a , unit, string, unit) format4) = log t Debug fmt +let info t (fmt: ('a , unit, string, unit) format4) = log t Info fmt +let warn t (fmt: ('a , unit, string, unit) format4) = log t Warn fmt +let error t (fmt: ('a , unit, string, unit) format4) = log t Error fmt diff --git a/tools/ocaml/libs/log/log.mli b/tools/ocaml/libs/log/log.mli new file mode 100644 index 0000000..36c5a6b --- /dev/null +++ b/tools/ocaml/libs/log/log.mli @@ -0,0 +1,55 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 Unknown_level of string +type level = Debug | Info | Warn | Error + +type stream_type = Stderr | Stdout | File of string +type stream_log = { + ty : stream_type; + channel : out_channel option ref; +} +type output = + Stream of stream_log + | String of string list ref + | Syslog of string + | Nil +val int_of_level : level -> int +val string_of_level : level -> string +val level_of_string : string -> level +val mkdir_safe : string -> Unix.file_perm -> unit +val mkdir_rec : string -> Unix.file_perm -> unit +type t = { output : output; mutable level : level; } +val make : output -> level -> t +val opensyslog : string -> level -> t +val openerr : level -> t +val openout : level -> t +val openfile : string -> level -> t +val opennil : unit -> t +val openstring : level -> t +val reopen : t -> t +val close : t -> unit +val string_of_logger : t -> string +val logger_of_string : string -> t +val validate : string -> unit +val set : t -> level -> unit +val gettimestring : unit -> string +val output : t -> ?key:string -> ?extra:string -> level -> string -> unit +val log : t -> level -> ('a, unit, string, unit) format4 -> 'a +val debug : t -> ('a, unit, string, unit) format4 -> 'a +val info : t -> ('a, unit, string, unit) format4 -> 'a +val warn : t -> ('a, unit, string, unit) format4 -> 'a +val error : t -> ('a, unit, string, unit) format4 -> 'a diff --git a/tools/ocaml/libs/log/logs.ml b/tools/ocaml/libs/log/logs.ml new file mode 100644 index 0000000..2a40896 --- /dev/null +++ b/tools/ocaml/libs/log/logs.ml @@ -0,0 +1,197 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 keylogger = +{ + mutable debug: string list; + mutable info: string list; + mutable warn: string list; + mutable error: string list; + no_default: bool; +} + +(* map all logger strings into a logger *) +let __all_loggers = Hashtbl.create 10 + +(* default logger that everything that doesn't have a key in __lop_mapping get send *) +let __default_logger = { debug = []; info = []; warn = []; error = []; no_default = false } + +(* + * This describe the mapping between a name to a keylogger. + * a keylogger contains a list of logger string per level of debugging. + * Example: "xenops", debug -> [ "stderr"; "/var/log/xensource.log" ] + * "xapi", error -> [] + * "xapi", debug -> [ "/var/log/xensource.log" ] + * "xenops", info -> [ "syslog" ] + *) +let __log_mapping = Hashtbl.create 32 + +let get_or_open logstring = + if Hashtbl.mem __all_loggers logstring then + Hashtbl.find __all_loggers logstring + else + let t = Log.logger_of_string logstring in + Hashtbl.add __all_loggers logstring t; + t + +(** create a mapping entry for the key "name". + * all log level of key "name" default to "logger" logger. + * a sensible default is put "nil" as a logger and reopen a specific level to + * the logger you want to. + *) +let add key logger = + let kl = { + debug = logger; + info = logger; + warn = logger; + error = logger; + no_default = false; + } in + Hashtbl.add __log_mapping key kl + +let get_by_level keylog level = + match level with + | Log.Debug -> keylog.debug + | Log.Info -> keylog.info + | Log.Warn -> keylog.warn + | Log.Error -> keylog.error + +let set_by_level keylog level logger = + match level with + | Log.Debug -> keylog.debug <- logger + | Log.Info -> keylog.info <- logger + | Log.Warn -> keylog.warn <- logger + | Log.Error -> keylog.error <- logger + +(** set a specific key|level to the logger "logger" *) +let set key level logger = + if not (Hashtbl.mem __log_mapping key) then + add key []; + + let keylog = Hashtbl.find __log_mapping key in + set_by_level keylog level logger + +(** set default logger *) +let set_default level logger = + set_by_level __default_logger level logger + +(** append a logger to the list *) +let append key level logger = + if not (Hashtbl.mem __log_mapping key) then + add key []; + let keylog = Hashtbl.find __log_mapping key in + let loggers = get_by_level keylog level in + set_by_level keylog level (loggers @ [ logger ]) + +(** append a logger to the default list *) +let append_default level logger = + let loggers = get_by_level __default_logger level in + set_by_level __default_logger level (loggers @ [ logger ]) + +(** reopen all logger open *) +let reopen () = + Hashtbl.iter (fun k v -> + Hashtbl.replace __all_loggers k (Log.reopen v)) __all_loggers + +(** reclaim close all logger open that are not use by any other keys *) +let reclaim () = + let list_sort_uniq l = + let oldprev = ref "" and prev = ref "" in + List.fold_left (fun a k -> + oldprev := !prev; + prev := k; + if k = !oldprev then a else k :: a) [] + (List.sort compare l) + in + let flatten_keylogger v = + list_sort_uniq (v.debug @ v.info @ v.warn @ v.error) in + let oldkeys = Hashtbl.fold (fun k v a -> k :: a) __all_loggers [] in + let usedkeys = Hashtbl.fold (fun k v a -> + (flatten_keylogger v) @ a) + __log_mapping (flatten_keylogger __default_logger) in + let usedkeys = list_sort_uniq usedkeys in + + List.iter (fun k -> + if not (List.mem k usedkeys) then ( + begin try + Log.close (Hashtbl.find __all_loggers k) + with + Not_found -> () + end; + Hashtbl.remove __all_loggers k + )) oldkeys + +(** clear a specific key|level *) +let clear key level = + try + let keylog = Hashtbl.find __log_mapping key in + set_by_level keylog level []; + reclaim () + with Not_found -> + () + +(** clear a specific default level *) +let clear_default level = + set_default level []; + reclaim () + +(** reset all the loggers to the specified logger *) +let reset_all logger = + Hashtbl.clear __log_mapping; + set_default Log.Debug logger; + set_default Log.Warn logger; + set_default Log.Error logger; + set_default Log.Info logger; + reclaim () + +(** log a fmt message to the key|level logger specified in the log mapping. + * if the logger doesn't exist, assume nil logger. + *) +let log key level ?(extra="") (fmt: ('a, unit, string, unit) format4): 'a = + let keylog = + if Hashtbl.mem __log_mapping key then + let keylog = Hashtbl.find __log_mapping key in + if keylog.no_default = false && + get_by_level keylog level = [] then + __default_logger + else + keylog + else + __default_logger in + let loggers = get_by_level keylog level in + match loggers with + | [] -> Printf.kprintf ignore fmt + | _ -> + let l = List.fold_left (fun acc logger -> + try get_or_open logger :: acc + with _ -> acc + ) [] loggers in + let l = List.rev l in + + (* ksprintf is the preferred name for kprintf, but the former + * is not available in OCaml 3.08.3 *) + Printf.kprintf (fun s -> + List.iter (fun t -> Log.output t ~key ~extra level s) l) fmt + +(* define some convenience functions *) +let debug t ?extra (fmt: ('a , unit, string, unit) format4) = + log t Log.Debug ?extra fmt +let info t ?extra (fmt: ('a , unit, string, unit) format4) = + log t Log.Info ?extra fmt +let warn t ?extra (fmt: ('a , unit, string, unit) format4) = + log t Log.Warn ?extra fmt +let error t ?extra (fmt: ('a , unit, string, unit) format4) = + log t Log.Error ?extra fmt diff --git a/tools/ocaml/libs/log/logs.mli b/tools/ocaml/libs/log/logs.mli new file mode 100644 index 0000000..76e10db --- /dev/null +++ b/tools/ocaml/libs/log/logs.mli @@ -0,0 +1,46 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 keylogger = { + mutable debug : string list; + mutable info : string list; + mutable warn : string list; + mutable error : string list; + no_default : bool; +} +val __all_loggers : (string, Log.t) Hashtbl.t +val __default_logger : keylogger +val __log_mapping : (string, keylogger) Hashtbl.t +val get_or_open : string -> Log.t +val add : string -> string list -> unit +val get_by_level : keylogger -> Log.level -> string list +val set_by_level : keylogger -> Log.level -> string list -> unit +val set : string -> Log.level -> string list -> unit +val set_default : Log.level -> string list -> unit +val append : string -> Log.level -> string -> unit +val append_default : Log.level -> string -> unit +val reopen : unit -> unit +val reclaim : unit -> unit +val clear : string -> Log.level -> unit +val clear_default : Log.level -> unit +val reset_all : string list -> unit +val log : + string -> + Log.level -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +val debug : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +val info : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +val warn : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a +val error : string -> ?extra:string -> ('a, unit, string, unit) format4 -> 'a diff --git a/tools/ocaml/libs/log/syslog.ml b/tools/ocaml/libs/log/syslog.ml new file mode 100644 index 0000000..2b417da --- /dev/null +++ b/tools/ocaml/libs/log/syslog.ml @@ -0,0 +1,26 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug +type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid +type facility = Auth | Authpriv | Cron | Daemon | Ftp | Kern + | Local0 | Local1 | Local2 | Local3 + | Local4 | Local5 | Local6 | Local7 + | Lpr | Mail | News | Syslog | User | Uucp + +(* external init : string -> options list -> facility -> unit = "stub_openlog" *) +external log : facility -> level -> string -> unit = "stub_syslog" +external close : unit -> unit = "stub_closelog" diff --git a/tools/ocaml/libs/log/syslog.mli b/tools/ocaml/libs/log/syslog.mli new file mode 100644 index 0000000..425f42a --- /dev/null +++ b/tools/ocaml/libs/log/syslog.mli @@ -0,0 +1,41 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 level = Emerg | Alert | Crit | Err | Warning | Notice | Info | Debug +type options = Cons | Ndelay | Nowait | Odelay | Perror | Pid +type facility = + Auth + | Authpriv + | Cron + | Daemon + | Ftp + | Kern + | Local0 + | Local1 + | Local2 + | Local3 + | Local4 + | Local5 + | Local6 + | Local7 + | Lpr + | Mail + | News + | Syslog + | User + | Uucp +external log : facility -> level -> string -> unit = "stub_syslog" +external close : unit -> unit = "stub_closelog" diff --git a/tools/ocaml/libs/log/syslog_stubs.c b/tools/ocaml/libs/log/syslog_stubs.c new file mode 100644 index 0000000..965610a --- /dev/null +++ b/tools/ocaml/libs/log/syslog_stubs.c @@ -0,0 +1,73 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 +#include +#include +#include +#include + +static int __syslog_level_table[] = { + LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, + LOG_NOTICE, LOG_INFO, LOG_DEBUG +}; + +static int __syslog_options_table[] = { + LOG_CONS, LOG_NDELAY, LOG_NOWAIT, LOG_ODELAY, LOG_PERROR, LOG_PID +}; + +static int __syslog_facility_table[] = { + LOG_AUTH, LOG_AUTHPRIV, LOG_CRON, LOG_DAEMON, LOG_FTP, LOG_KERN, + LOG_LOCAL0, LOG_LOCAL1, LOG_LOCAL2, LOG_LOCAL3, + LOG_LOCAL4, LOG_LOCAL5, LOG_LOCAL6, LOG_LOCAL7, + LOG_LPR | LOG_MAIL | LOG_NEWS | LOG_SYSLOG | LOG_USER | LOG_UUCP +}; + +/* According to the openlog manpage the 'openlog' call may take a reference + to the 'ident' string and keep it long-term. This means we cannot just pass in + an ocaml string which is under the control of the GC. Since we aren't actually + calling this function we can just comment it out for the time-being. */ +/* +value stub_openlog(value ident, value option, value facility) +{ + CAMLparam3(ident, option, facility); + int c_option; + int c_facility; + + c_option = caml_convert_flag_list(option, __syslog_options_table); + c_facility = __syslog_facility_table[Int_val(facility)]; + openlog(String_val(ident), c_option, c_facility); + CAMLreturn(Val_unit); +} +*/ + +value stub_syslog(value facility, value level, value msg) +{ + CAMLparam3(facility, level, msg); + int c_facility; + + c_facility = __syslog_facility_table[Int_val(facility)] + | __syslog_level_table[Int_val(level)]; + syslog(c_facility, "%s", String_val(msg)); + CAMLreturn(Val_unit); +} + +value stub_closelog(value unit) +{ + CAMLparam1(unit); + closelog(); + CAMLreturn(Val_unit); +} diff --git a/tools/ocaml/libs/mmap/META.in b/tools/ocaml/libs/mmap/META.in new file mode 100644 index 0000000..1d71548 --- /dev/null +++ b/tools/ocaml/libs/mmap/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "Mmap interface extension" +archive(byte) = "mmap.cma" +archive(native) = "mmap.cmxa" diff --git a/tools/ocaml/libs/mmap/Makefile b/tools/ocaml/libs/mmap/Makefile new file mode 100644 index 0000000..bd8ab43 --- /dev/null +++ b/tools/ocaml/libs/mmap/Makefile @@ -0,0 +1,27 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +OBJS = mmap +INTF = $(foreach obj, $(OBJS),$(obj).cmi) +LIBS = mmap.cma mmap.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +mmap_OBJS = $(OBJS) +mmap_C_OBJS = mmap_stubs +OCAML_LIBRARY = mmap + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore mmap META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove mmap + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/mmap/mmap.ml b/tools/ocaml/libs/mmap/mmap.ml new file mode 100644 index 0000000..44b67c8 --- /dev/null +++ b/tools/ocaml/libs/mmap/mmap.ml @@ -0,0 +1,31 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 mmap_interface + +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 + -> 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 getpagesize: unit -> int = "stub_mmap_getpagesize" diff --git a/tools/ocaml/libs/mmap/mmap.mli b/tools/ocaml/libs/mmap/mmap.mli new file mode 100644 index 0000000..8f92ed6 --- /dev/null +++ b/tools/ocaml/libs/mmap/mmap.mli @@ -0,0 +1,28 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 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" + +external getpagesize : unit -> int = "stub_mmap_getpagesize" diff --git a/tools/ocaml/libs/mmap/mmap_stubs.c b/tools/ocaml/libs/mmap/mmap_stubs.c new file mode 100644 index 0000000..e32cef6 --- /dev/null +++ b/tools/ocaml/libs/mmap/mmap_stubs.c @@ -0,0 +1,136 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 +#include +#include +#include +#include +#include "mmap_stubs.h" + +#include +#include +#include +#include +#include +#include + +#define GET_C_STRUCT(a) ((struct mmap_interface *) a) + +static int mmap_interface_init(struct mmap_interface *intf, + int fd, int pflag, int mflag, + int len, int offset) +{ + intf->len = len; + intf->addr = mmap(NULL, len, pflag, mflag, fd, offset); + return (intf->addr == MAP_FAILED) ? errno : 0; +} + +CAMLprim value stub_mmap_init(value fd, value pflag, value mflag, + value len, value offset) +{ + CAMLparam5(fd, pflag, mflag, len, offset); + CAMLlocal1(result); + int c_pflag, c_mflag; + + switch (Int_val(pflag)) { + case 0: c_pflag = PROT_READ; break; + case 1: c_pflag = PROT_WRITE; break; + case 2: c_pflag = PROT_READ|PROT_WRITE; break; + default: caml_invalid_argument("protectiontype"); + } + + switch (Int_val(mflag)) { + case 0: c_mflag = MAP_SHARED; break; + case 1: c_mflag = MAP_PRIVATE; break; + default: caml_invalid_argument("maptype"); + } + + result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + + if (mmap_interface_init(GET_C_STRUCT(result), Int_val(fd), + c_pflag, c_mflag, + Int_val(len), Int_val(offset))) + caml_failwith("mmap"); + CAMLreturn(result); +} + +CAMLprim value stub_mmap_final(value interface) +{ + CAMLparam1(interface); + struct mmap_interface *intf; + + intf = GET_C_STRUCT(interface); + if (intf->addr != MAP_FAILED) + munmap(intf->addr, intf->len); + intf->addr = MAP_FAILED; + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_mmap_read(value interface, value start, value len) +{ + CAMLparam3(interface, start, len); + CAMLlocal1(data); + struct mmap_interface *intf; + int c_start; + int c_len; + + c_start = Int_val(start); + c_len = Int_val(len); + intf = GET_C_STRUCT(interface); + + if (c_start > intf->len) + caml_invalid_argument("start invalid"); + if (c_start + c_len > intf->len) + caml_invalid_argument("len invalid"); + + data = caml_alloc_string(c_len); + memcpy((char *) data, intf->addr + c_start, c_len); + + CAMLreturn(data); +} + +CAMLprim value stub_mmap_write(value interface, value data, + value start, value len) +{ + CAMLparam4(interface, data, start, len); + struct mmap_interface *intf; + int c_start; + int c_len; + + c_start = Int_val(start); + c_len = Int_val(len); + intf = GET_C_STRUCT(interface); + + if (c_start > intf->len) + caml_invalid_argument("start invalid"); + if (c_start + c_len > intf->len) + caml_invalid_argument("len invalid"); + + memcpy(intf->addr + c_start, (char *) data, c_len); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_mmap_getpagesize(value unit) +{ + CAMLparam1(unit); + CAMLlocal1(data); + + data = Val_int(getpagesize()); + CAMLreturn(data); +} diff --git a/tools/ocaml/libs/mmap/mmap_stubs.h b/tools/ocaml/libs/mmap/mmap_stubs.h new file mode 100644 index 0000000..65e4239 --- /dev/null +++ b/tools/ocaml/libs/mmap/mmap_stubs.h @@ -0,0 +1,33 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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. + */ + +#ifndef C_MMAP_H +#define C_MMAP_H + +#include +#include +#include +#include +#include +#include + +struct mmap_interface +{ + void *addr; + int len; +}; + +#endif diff --git a/tools/ocaml/libs/stdext/META.in b/tools/ocaml/libs/stdext/META.in new file mode 100644 index 0000000..bc67d1e --- /dev/null +++ b/tools/ocaml/libs/stdext/META.in @@ -0,0 +1,5 @@ +version = "@VERSION@" +description = "Stdext - Common stdlib extensions" +requires = "unix,uuid" +archive(byte) = "stdext.cma" +archive(native) = "stdext.cmxa" diff --git a/tools/ocaml/libs/stdext/Makefile b/tools/ocaml/libs/stdext/Makefile new file mode 100644 index 0000000..7c51c71 --- /dev/null +++ b/tools/ocaml/libs/stdext/Makefile @@ -0,0 +1,43 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +OCAMLINCLUDE += -I ../uuid + +OCAML_TEST_INC = -I $(shell ocamlfind query oUnit) +OCAML_TEST_LIB = $(shell ocamlfind query oUnit)/oUnit.cmxa + +OBJS = filenameext stringext hashtblext listext pervasiveext threadext ring qring trie opt unixext bigbuffer vIO varmap eventloop +INTF = $(foreach obj, $(OBJS),$(obj).cmi) +LIBS = stdext.cma stdext.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +stdext_OBJS = $(OBJS) +stdext_C_OBJS = unixext_stubs + +OCAML_LIBRARY = stdext + +## OBJS +threadext.cmo: threadext.ml + $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -thread -c -o $@ $<,MLC,$@) + +threadext.cmi: threadext.mli + $(call quiet-command, $(OCAMLC) $(OCAMLCFLAGS) -thread -c -o $@ $<,MLI,$@) + +threadext.cmx: threadext.ml + $(call quiet-command, $(OCAMLOPT) $(OCAMLOPTFLAGS) -thread -c -o $@ $<,MLOPT,$@) + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore stdext META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove stdext + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/stdext/bigbuffer.ml b/tools/ocaml/libs/stdext/bigbuffer.ml new file mode 100644 index 0000000..b2ac54b --- /dev/null +++ b/tools/ocaml/libs/stdext/bigbuffer.ml @@ -0,0 +1,90 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 = { + mutable cells: string option array; + mutable index: int64; +} + +let cell_size = 4096 +let default_array_len = 16 + +let make () = { cells = Array.make default_array_len None; index = 0L } + +let length bigbuf = bigbuf.index + +let rec append_substring bigbuf s offset len = + let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in + let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in + + if Array.length bigbuf.cells <= array_offset then ( + (* we need to reallocate the array *) + bigbuf.cells <- Array.append bigbuf.cells (Array.make default_array_len None) + ); + + let buf = match bigbuf.cells.(array_offset) with + | None -> + let newbuf = String.create cell_size in + bigbuf.cells.(array_offset) <- Some newbuf; + newbuf + | Some buf -> + buf + in + if len + cell_offset <= cell_size then ( + String.blit s offset buf cell_offset len; + bigbuf.index <- Int64.add bigbuf.index (Int64.of_int len); + ) else ( + let rlen = cell_size - cell_offset in + String.blit s offset buf cell_offset rlen; + bigbuf.index <- Int64.add bigbuf.index (Int64.of_int rlen); + append_substring bigbuf s (offset + rlen) (len - rlen) + ); + () + +let to_fct bigbuf f = + let array_offset = Int64.to_int (Int64.div bigbuf.index (Int64.of_int cell_size)) in + let cell_offset = Int64.to_int (Int64.rem bigbuf.index (Int64.of_int cell_size)) in + + (* copy all complete cells *) + for i = 0 to array_offset - 1 + do + match bigbuf.cells.(i) with + | None -> (* ?!?!? *) () + | Some cell -> f cell + done; + + (* copy last cell *) + begin match bigbuf.cells.(array_offset) with + | None -> (* ?!?!?! *) () + | Some cell -> f (String.sub cell 0 cell_offset) + end; + () + +let to_string bigbuf = + if bigbuf.index > (Int64.of_int Sys.max_string_length) then + failwith "cannot allocate string big enough"; + + let dest = String.create (Int64.to_int bigbuf.index) in + let destoff = ref 0 in + to_fct bigbuf (fun s -> + let len = String.length s in + String.blit s 0 dest !destoff len; + destoff := !destoff + len + ); + dest + +let to_stream bigbuf outchan = + to_fct bigbuf (fun s -> output_string outchan s) diff --git a/tools/ocaml/libs/stdext/bigbuffer.mli b/tools/ocaml/libs/stdext/bigbuffer.mli new file mode 100644 index 0000000..f40fd09 --- /dev/null +++ b/tools/ocaml/libs/stdext/bigbuffer.mli @@ -0,0 +1,22 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 +val make : unit -> t +val length : t -> int64 +val append_substring : t -> string -> int -> int -> unit +val to_fct : t -> (string -> unit) -> unit +val to_string : t -> string +val to_stream : t -> out_channel -> unit diff --git a/tools/ocaml/libs/stdext/eventloop.ml b/tools/ocaml/libs/stdext/eventloop.ml new file mode 100644 index 0000000..8d69a4c --- /dev/null +++ b/tools/ocaml/libs/stdext/eventloop.ml @@ -0,0 +1,357 @@ +(* + * Copyright (C) 2009 Citrix Ltd. + * Author Prashanth Mundkur + * + * 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. + *) + +let verbose = ref false + +let dbg fmt = + let logger s = if !verbose then Printf.printf "%s\n%!" s in + Printf.ksprintf logger fmt + +module ConnMap = Map.Make (struct type t = Unix.file_descr let compare = compare end) + +(* A module that supports finding a timer by handle as well as by expiry time. *) +module Timers = struct + + type 'a entry = + { + handle : int; + mutable expires_at: float; + value: 'a; + } + + module Timers_by_expiry = Map.Make (struct type t = float let compare = compare end) + + type 'a t = + { + mutable by_expiry: (('a entry) list) Timers_by_expiry.t; + } + + let create () = { by_expiry = Timers_by_expiry.empty } + + let is_empty t = Timers_by_expiry.is_empty t.by_expiry + + let next_handle = ref 0 + + (** inserts an existing (but not inserted) entry in the map *) + let submit_timer t at e = + e.expires_at <- at; + let es = try Timers_by_expiry.find e.expires_at t.by_expiry with Not_found -> [] in + t.by_expiry <- Timers_by_expiry.add e.expires_at (e :: es) t.by_expiry + + let add_timer t at v = + incr next_handle; + let e = { handle = !next_handle; expires_at = at; value = v } in + submit_timer t at e; + e + + let remove_timer t entry = + let handle = entry.handle in + let es = Timers_by_expiry.find entry.expires_at t.by_expiry in + let es = List.filter (fun e' -> e'.handle <> handle) es in + t.by_expiry <- (match es with + | [] -> Timers_by_expiry.remove entry.expires_at t.by_expiry + | _ -> Timers_by_expiry.add entry.expires_at es t.by_expiry + ) + + exception Found of float + + (* Should only be called on a non-empty Timer set; otherwise, + Not_found is raised. *) + let get_first_expiry_time t = + try + (* This should give the earliest expiry time, + since iteration is done in increasing order. *) + Timers_by_expiry.iter (fun tim -> raise (Found tim)) t.by_expiry; + raise Not_found + with Found tim -> tim + + (* Extracts the timers for time t, and return a list of values for those timers *) + let extract_timers_at t tim = + try + let es = Timers_by_expiry.find tim t.by_expiry in + t.by_expiry <- Timers_by_expiry.remove tim t.by_expiry; + List.map (fun e -> e.value) es + with Not_found -> [] + +end + +type error = Unix.error * string * string + +type handle = Unix.file_descr + +let handle_compare = compare +let handle_hash h = Unixext.int_of_file_descr h + +type conn_status = + | Connecting + | Listening + | Connected + +type conn_callbacks = +{ + accept_callback : t -> handle -> Unix.file_descr -> Unix.sockaddr -> unit; + connect_callback : t -> handle -> unit; + error_callback : t -> handle -> error -> unit; + recv_ready_callback : t -> handle -> Unix.file_descr -> unit; + send_ready_callback : t -> handle -> Unix.file_descr -> unit; +} + +and conn_state = +{ + mutable callbacks : conn_callbacks; + mutable status : conn_status; + mutable send_enabled : bool; + mutable recv_enabled : bool; +} + +and t = +{ + mutable conns: conn_state ConnMap.t; + mutable timers: (unit -> unit) Timers.t; + (* select state *) + readers: Unixext.Fdset.t; + writers: Unixext.Fdset.t; + excepts: Unixext.Fdset.t; + (* dispatch state *) + mutable d_readers: Unixext.Fdset.t; + mutable d_writers: Unixext.Fdset.t; + (** Unix.gettimeofday() at the time the loop iteration started *) + mutable current_time: float; +} + +let create () = +{ conns = ConnMap.empty; + timers = Timers.create (); + readers = Unixext.Fdset.create (); + writers = Unixext.Fdset.create (); + excepts = Unixext.Fdset.create (); + d_readers = Unixext.Fdset.create (); + d_writers = Unixext.Fdset.create (); + current_time = 0.0; +} + +(* connections *) + +let register_conn t fd ?(enable_send=false) ?(enable_recv=true) callbacks = + let conn_state = { callbacks = callbacks; + status = Connected; + send_enabled = enable_send; + recv_enabled = enable_recv; + } + in + t.conns <- ConnMap.add fd conn_state t.conns; + Unix.set_nonblock fd; + if conn_state.recv_enabled then + Unixext.Fdset.set t.readers fd; + if conn_state.send_enabled then + Unixext.Fdset.set t.writers fd; + fd + +let remove_conn t handle = + Unixext.Fdset.clear t.readers handle; + Unixext.Fdset.clear t.writers handle; + (* Also remove this handle from the set we might be + dispatching over. *) + Unixext.Fdset.clear t.d_readers handle; + Unixext.Fdset.clear t.d_writers handle; + t.conns <- ConnMap.remove handle t.conns + +let get_fd t handle = handle + +let connect t handle addr = + let conn_state = ConnMap.find handle t.conns in + conn_state.status <- Connecting; + try + Unix.connect handle addr; + conn_state.status <- Connected; + conn_state.callbacks.connect_callback t handle + with + | Unix.Unix_error (Unix.EINPROGRESS, _, _) -> + Unixext.Fdset.set t.readers handle; + Unixext.Fdset.set t.writers handle + | Unix.Unix_error (ec, f, s) -> + conn_state.callbacks.error_callback t handle (ec, f, s) + +let listen t handle = + let conn_state = ConnMap.find handle t.conns in + Unix.listen handle 5; + Unixext.Fdset.set t.readers handle; + conn_state.recv_enabled <- true; + conn_state.status <- Listening + +let enable_send t handle = + let conn_state = ConnMap.find handle t.conns in + conn_state.send_enabled <- true; + if conn_state.status = Connected then + Unixext.Fdset.set t.writers handle + +let disable_send t handle = + let conn_state = ConnMap.find handle t.conns in + conn_state.send_enabled <- false; + if conn_state.status = Connected then + Unixext.Fdset.clear t.writers handle + +let enable_recv t handle = + let conn_state = ConnMap.find handle t.conns in + conn_state.recv_enabled <- true; + if conn_state.status = Connected then + Unixext.Fdset.set t.readers handle + +let disable_recv t handle = + let conn_state = ConnMap.find handle t.conns in + conn_state.recv_enabled <- false; + if conn_state.status = Connected then + Unixext.Fdset.clear t.readers handle + +let set_callbacks t handle callbacks = + let conn_state = ConnMap.find handle t.conns in + conn_state.callbacks <- callbacks + +let has_connections t = not (ConnMap.is_empty t.conns) + +(* timers *) + +type timer = (unit -> unit) Timers.entry + +let start_timer t time_offset_sec cb = + let at = Unix.gettimeofday () +. time_offset_sec in + Timers.add_timer t.timers at cb + +let start_timer_asap t cb = + Timers.add_timer t.timers t.current_time cb + +let start_periodic_timer t time_offset_sec period cb = + let orig_timer = ref (None: timer option) in + let resubmit_timer_closure () = + let orig_timer = match !orig_timer with None -> raise Not_found | Some x -> x in + Timers.submit_timer t.timers (t.current_time +. period) orig_timer; + cb (); (* invoke the user's callback *) + in + let new_timer = start_timer t time_offset_sec resubmit_timer_closure in + orig_timer := Some (new_timer); + new_timer + +let cancel_timer t timer = + Timers.remove_timer t.timers timer + +let timer_compare tim1 tim2 = compare tim1.Timers.handle tim2.Timers.handle +let timer_hash tim = tim.Timers.handle + +let has_timers t = not (Timers.is_empty t.timers) + +(* event dispatch *) + +let dispatch_read t fd cs = + match cs.status with + | Connecting -> + (match Unix.getsockopt_error fd with + | None -> + cs.status <- Connected; + if not cs.recv_enabled then + Unixext.Fdset.clear t.readers fd; + if not cs.send_enabled then + Unixext.Fdset.clear t.writers fd; + cs.callbacks.connect_callback t fd + | Some err -> + cs.callbacks.error_callback t fd (err, "connect", "") + ) + | Listening -> + (try + let afd, aaddr = Unix.accept fd in + cs.callbacks.accept_callback t fd afd aaddr + with + | Unix.Unix_error (Unix.EWOULDBLOCK, _, _) + | Unix.Unix_error (Unix.ECONNABORTED, _, _) + | Unix.Unix_error (Unix.EINTR, _, _) + -> () + | Unix.Unix_error (ec, f, s) -> + cs.callbacks.error_callback t fd (ec, f, s) + ) + | Connected -> + if cs.recv_enabled + then cs.callbacks.recv_ready_callback t fd fd + else Unixext.Fdset.clear t.readers fd + +let dispatch_write t fd cs = + match cs.status with + | Connecting -> + (match Unix.getsockopt_error fd with + | None -> + cs.status <- Connected; + if not cs.recv_enabled then + Unixext.Fdset.clear t.readers fd; + if not cs.send_enabled then + Unixext.Fdset.clear t.writers fd; + cs.callbacks.connect_callback t fd + | Some err -> + cs.callbacks.error_callback t fd (err, "connect", "") + ) + | Listening -> + (* This should never happen, since listening sockets + are not set for writing. But, to avoid a busy + select loop in case this socket keeps firing for + writes, we disable the write watch. *) + Unixext.Fdset.clear t.writers fd + | Connected -> + if cs.send_enabled + then cs.callbacks.send_ready_callback t fd fd + else Unixext.Fdset.clear t.writers fd + +let dispatch_timers t = + let break = ref false in + while ((not (Timers.is_empty t.timers)) && (not !break)) do + let first_expired = Timers.get_first_expiry_time t.timers in + if first_expired > t.current_time then + break := true + else begin + let cbs = Timers.extract_timers_at t.timers first_expired in + List.iter (fun cb -> cb ()) cbs + end + done + +let dispatch t interval = + t.current_time <- Unix.gettimeofday (); + let interval = + if Timers.is_empty t.timers then interval + else + (* the blocking interval for select is the + smaller of the specified interval, and the + interval before which the earliest timer + expires. + *) + let block_until = if interval > 0.0 then t.current_time +. interval else t.current_time in + let first_expiry = Timers.get_first_expiry_time t.timers in + let block_until = (if first_expiry < block_until then first_expiry else block_until) in + let interval = block_until -. t.current_time in + if interval < 0.0 then 0.0 else interval + in + let events = + try Some (Unixext.Fdset.select t.readers t.writers t.excepts interval) + with Unix.Unix_error (Unix.EINTR, _, _) -> None + in + (match events with + | Some (r, w, _) -> + (* Store dispatch set for remove_conn. *) + t.d_readers <- r; + t.d_writers <- w; + ConnMap.iter (fun fd cs -> + if Unixext.Fdset.is_set t.d_readers fd then + dispatch_read t fd cs; + if Unixext.Fdset.is_set t.d_writers fd then + dispatch_write t fd cs + ) t.conns + | None -> () + ); + dispatch_timers t diff --git a/tools/ocaml/libs/stdext/eventloop.mli b/tools/ocaml/libs/stdext/eventloop.mli new file mode 100644 index 0000000..6e57991 --- /dev/null +++ b/tools/ocaml/libs/stdext/eventloop.mli @@ -0,0 +1,100 @@ +(* + * Copyright (C) 2009 Citrix Ltd. + * Author Prashanth Mundkur + * + * 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 + +val create : unit -> t + +(* connections *) + +type handle +type error = Unix.error * string * string + +type conn_callbacks = +{ + accept_callback : t -> handle -> Unix.file_descr -> Unix.sockaddr -> unit; + connect_callback : t -> handle -> unit; + error_callback : t -> handle -> error -> unit; + recv_ready_callback : t -> handle -> Unix.file_descr -> unit; + send_ready_callback : t -> handle -> Unix.file_descr -> unit; +} + +(* this is to allow collections indexed by connection handles. *) +val handle_compare : handle -> handle -> int +val handle_hash : handle -> int + +(* Connection Management *) + +(* by default, notifications for incoming data are disabled, and enabled for all others. *) +val register_conn : t -> Unix.file_descr -> ?enable_send:bool -> ?enable_recv:bool -> conn_callbacks -> handle +val remove_conn : t -> handle -> unit +val get_fd : t -> handle -> Unix.file_descr + +val connect : t -> handle -> Unix.sockaddr -> unit +val listen : t -> handle -> unit + +val enable_send : t -> handle -> unit +val disable_send : t -> handle -> unit + +val enable_recv : t -> handle -> unit +val disable_recv : t -> handle -> unit + +val set_callbacks : t -> handle -> conn_callbacks -> unit + +(* Timers *) + +type timer + +(** Starts a timer that will fire once only, and return a handle to + this timer, so that it can be cancelled before it fires. The timer + is automatically cancelled once it has fired. +*) +val start_timer : t -> float (* offset, secs *) -> (unit -> unit) -> timer + +(** Enqueues an event that will be invoked in the next event loop + iteration. This behaves as if a timer had been set to fire with + "now" as the trigger time. +*) +val start_timer_asap : t -> (unit -> unit) -> timer + +(** Starts a timer that will fire periodically. The timer needs + explicit cancellation. +*) +val start_periodic_timer: t -> float (* offset from current time, secs *) -> float (* period, secs *) -> (unit -> unit) -> timer + +(** Allows cancelling a timer before it fires. Non-periodic timers + are implicitly cancelled when their timer fires. Periodic timers + however need explicit cancellation. +*) +val cancel_timer : t -> timer -> unit + +(** Utilities for storing timer handles in data structures. *) +val timer_compare: timer -> timer -> int +val timer_hash: timer -> int + +(* Event Dispatch *) + +(* dispatch t intvl will block at most for intvl seconds, and dispatch + any retrieved events and expired timers. +*) +val dispatch : t -> float -> unit + + +(* Event loop management *) + +val has_timers : t -> bool + +val has_connections : t -> bool diff --git a/tools/ocaml/libs/stdext/file.ml b/tools/ocaml/libs/stdext/file.ml new file mode 100644 index 0000000..1b6b42d --- /dev/null +++ b/tools/ocaml/libs/stdext/file.ml @@ -0,0 +1,34 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) + +let write_string file mode s = + let fn_write_string fd = Unixext.really_write fd s 0 (String.length s) in + Unixext.with_file file (Unix.O_WRONLY :: mode) 0o640 fn_write_string + +let write_fn file mode fn = + let fn_write_fn fd = + let quit = ref false in + while not !quit + do + let s = fn () in + if s = "" then + quit := true + else + Unixext.really_write fd s 0 (String.length s) + done + in + Unixext.with_file file (Unix.O_WRONLY :: mode) 0o640 fn_write_fn diff --git a/tools/ocaml/libs/stdext/file.mli b/tools/ocaml/libs/stdext/file.mli new file mode 100644 index 0000000..d3f50e7 --- /dev/null +++ b/tools/ocaml/libs/stdext/file.mli @@ -0,0 +1,18 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) +val write_string : string -> Unix.open_flag list -> string -> unit +val write_fn : string -> Unix.open_flag list -> (unit -> string) -> unit diff --git a/tools/ocaml/libs/stdext/filenameext.ml b/tools/ocaml/libs/stdext/filenameext.ml new file mode 100644 index 0000000..8e4379a --- /dev/null +++ b/tools/ocaml/libs/stdext/filenameext.ml @@ -0,0 +1,33 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) + +(** Makes a new file in the same directory as 'otherfile' *) +let temp_file_in_dir otherfile = + let base_dir = Filename.dirname otherfile in + let rec keep_trying () = + try + let uuid = Uuid.to_string (Uuid.make_uuid ()) in + let newfile = base_dir ^ "/" ^ uuid in + Unix.close (Unix.openfile newfile [Unix.O_CREAT; Unix.O_TRUNC; Unix.O_EXCL] 0o600); + newfile + with + Unix.Unix_error (Unix.EEXIST, _, _) -> keep_trying () + in + keep_trying () + + + diff --git a/tools/ocaml/libs/stdext/filenameext.mli b/tools/ocaml/libs/stdext/filenameext.mli new file mode 100644 index 0000000..db4d76e --- /dev/null +++ b/tools/ocaml/libs/stdext/filenameext.mli @@ -0,0 +1,17 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) +val temp_file_in_dir : string -> string diff --git a/tools/ocaml/libs/stdext/hashtblext.ml b/tools/ocaml/libs/stdext/hashtblext.ml new file mode 100644 index 0000000..de0f2ce --- /dev/null +++ b/tools/ocaml/libs/stdext/hashtblext.ml @@ -0,0 +1,38 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 Hashtbl = struct include Hashtbl + +let to_list tbl = + Hashtbl.fold (fun k v acc -> (k, v) :: acc) tbl [] + +let fold_keys tbl = + Hashtbl.fold (fun k v acc -> k :: acc) tbl [] + +let fold_values tbl = + Hashtbl.fold (fun k v acc -> v :: acc) tbl [] + +let add_empty tbl k v = + if not (Hashtbl.mem tbl k) then + Hashtbl.add tbl k v + +let add_list tbl l = + List.iter (fun (k, v) -> Hashtbl.add tbl k v) l + +let of_list l = + let tbl = Hashtbl.create (List.length l) in + add_list tbl l; + tbl +end diff --git a/tools/ocaml/libs/stdext/hashtblext.mli b/tools/ocaml/libs/stdext/hashtblext.mli new file mode 100644 index 0000000..a117146 --- /dev/null +++ b/tools/ocaml/libs/stdext/hashtblext.mli @@ -0,0 +1,77 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 Hashtbl : + sig + type ('a, 'b) t = ('a, 'b) Hashtbl.t + val create : int -> ('a, 'b) t + val clear : ('a, 'b) t -> unit + val add : ('a, 'b) t -> 'a -> 'b -> unit + val copy : ('a, 'b) t -> ('a, 'b) t + val find : ('a, 'b) t -> 'a -> 'b + val find_all : ('a, 'b) t -> 'a -> 'b list + val mem : ('a, 'b) t -> 'a -> bool + val remove : ('a, 'b) t -> 'a -> unit + val replace : ('a, 'b) t -> 'a -> 'b -> unit + val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit + val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c + val length : ('a, 'b) t -> int + module type HashedType = + sig type t val equal : t -> t -> bool val hash : t -> int end + module type S = + sig + type key + type 'a t + val create : int -> 'a t + val clear : 'a t -> unit + val copy : 'a t -> 'a t + val add : 'a t -> key -> 'a -> unit + val remove : 'a t -> key -> unit + val find : 'a t -> key -> 'a + val find_all : 'a t -> key -> 'a list + val replace : 'a t -> key -> 'a -> unit + val mem : 'a t -> key -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val length : 'a t -> int + end + module Make : + functor (H : HashedType) -> + sig + type key = H.t + type 'a t = 'a Hashtbl.Make(H).t + val create : int -> 'a t + val clear : 'a t -> unit + val copy : 'a t -> 'a t + val add : 'a t -> key -> 'a -> unit + val remove : 'a t -> key -> unit + val find : 'a t -> key -> 'a + val find_all : 'a t -> key -> 'a list + val replace : 'a t -> key -> 'a -> unit + val mem : 'a t -> key -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val length : 'a t -> int + end + val hash : 'a -> int + external hash_param : int -> int -> 'a -> int = "caml_hash_univ_param" + "noalloc" + val to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list + val fold_keys : ('a, 'b) Hashtbl.t -> 'a list + val fold_values : ('a, 'b) Hashtbl.t -> 'b list + val add_empty : ('a, 'b) Hashtbl.t -> 'a -> 'b -> unit + val add_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list -> unit + val of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t + end diff --git a/tools/ocaml/libs/stdext/listext.ml b/tools/ocaml/libs/stdext/listext.ml new file mode 100644 index 0000000..3825add --- /dev/null +++ b/tools/ocaml/libs/stdext/listext.ml @@ -0,0 +1,27 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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 List = struct include List + +let iteri f l = + let i = ref 0 in + List.iter (fun x -> f !i x; incr i) l + +let mapi f l = + let i = ref 0 in + List.map (fun x -> let r = f !i x in incr i; r) l + +end diff --git a/tools/ocaml/libs/stdext/listext.mli b/tools/ocaml/libs/stdext/listext.mli new file mode 100644 index 0000000..c0dfe6d --- /dev/null +++ b/tools/ocaml/libs/stdext/listext.mli @@ -0,0 +1,65 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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 List : + sig + val length : 'a list -> int + val hd : 'a list -> 'a + val tl : 'a list -> 'a list + val nth : 'a list -> int -> 'a + val rev : 'a list -> 'a list + val append : 'a list -> 'a list -> 'a list + val rev_append : 'a list -> 'a list -> 'a list + val concat : 'a list list -> 'a list + val flatten : 'a list list -> 'a list + val iter : ('a -> unit) -> 'a list -> unit + val map : ('a -> 'b) -> 'a list -> 'b list + val rev_map : ('a -> 'b) -> 'a list -> 'b list + val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b + val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit + val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list + val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a + val fold_right2 : + ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c + val for_all : ('a -> bool) -> 'a list -> bool + val exists : ('a -> bool) -> 'a list -> bool + val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool + val mem : 'a -> 'a list -> bool + val memq : 'a -> 'a list -> bool + val find : ('a -> bool) -> 'a list -> 'a + val filter : ('a -> bool) -> 'a list -> 'a list + val find_all : ('a -> bool) -> 'a list -> 'a list + val partition : ('a -> bool) -> 'a list -> 'a list * 'a list + val assoc : 'a -> ('a * 'b) list -> 'b + val assq : 'a -> ('a * 'b) list -> 'b + val mem_assoc : 'a -> ('a * 'b) list -> bool + val mem_assq : 'a -> ('a * 'b) list -> bool + val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list + val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list + val split : ('a * 'b) list -> 'a list * 'b list + val combine : 'a list -> 'b list -> ('a * 'b) list + val sort : ('a -> 'a -> int) -> 'a list -> 'a list + val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list + + val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list + val iteri : (int -> 'a -> unit) -> 'a list -> unit + + end diff --git a/tools/ocaml/libs/stdext/opt.ml b/tools/ocaml/libs/stdext/opt.ml new file mode 100644 index 0000000..bb41672 --- /dev/null +++ b/tools/ocaml/libs/stdext/opt.ml @@ -0,0 +1,48 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) +let iter f = function + | Some x -> f x + | None -> () + +let map f = function + | Some x -> Some(f x) + | None -> None + +let default d = function + | Some x -> x + | None -> d + +let unbox = function + | Some x -> x + | None -> raise Not_found + +let is_boxed = function + | Some _ -> true + | None -> false + +let to_list = function + | Some x -> [x] + | None -> [] + +let fold_left f accu = function + | Some x -> f accu x + | None -> accu + +let fold_right f opt accu = + match opt with + | Some x -> f x accu + | None -> accu diff --git a/tools/ocaml/libs/stdext/opt.mli b/tools/ocaml/libs/stdext/opt.mli new file mode 100644 index 0000000..92b476b --- /dev/null +++ b/tools/ocaml/libs/stdext/opt.mli @@ -0,0 +1,24 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) +val iter : ('a -> unit) -> 'a option -> unit +val map : ('a -> 'b) -> 'a option -> 'b option +val default : 'a -> 'a option -> 'a +val unbox : 'a option -> 'a +val is_boxed : 'a option -> bool +val to_list : 'a option -> 'a list +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b option -> 'a +val fold_right : ('a -> 'b -> 'b) -> 'a option -> 'b -> 'b diff --git a/tools/ocaml/libs/stdext/pervasiveext.ml b/tools/ocaml/libs/stdext/pervasiveext.ml new file mode 100644 index 0000000..8621c82 --- /dev/null +++ b/tools/ocaml/libs/stdext/pervasiveext.ml @@ -0,0 +1,61 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) + +(** apply the clean_f function after fct function has been called. + * Even if fct raises an exception, clean_f is applied + *) + +let exnhook = ref None + +let finally fct clean_f = + let result = try + fct (); + with + exn -> + (match !exnhook with None -> () | Some f -> f exn); + clean_f (); raise exn in + clean_f (); + result + +type ('a, 'b) either = Right of 'a | Left of 'b + +(** if v is not none, apply f on it and return some value else return none. *) +let may f v = + match v with Some x -> Some (f x) | None -> None + +(** default value to d if v is none. *) +let default d v = + match v with Some x -> x | None -> d + +(** apply f on v if not none *) +let maybe f v = + match v with None -> () | Some x -> f x + +(** if bool is false then we intercept and quiten any exception *) +let reraise_if bool fct = + try fct () with exn -> if bool then raise exn else () + +(** execute fct ignoring exceptions *) +let ignore_exn fct = try fct () with _ -> () + +(* non polymorphic ignore function *) +let ignore_int v = let (_: int) = v in () +let ignore_int64 v = let (_: int64) = v in () +let ignore_int32 v = let (_: int32) = v in () +let ignore_string v = let (_: string) = v in () +let ignore_float v = let (_: float) = v in () +let ignore_bool v = let (_: bool) = v in () diff --git a/tools/ocaml/libs/stdext/pervasiveext.mli b/tools/ocaml/libs/stdext/pervasiveext.mli new file mode 100644 index 0000000..0d53745 --- /dev/null +++ b/tools/ocaml/libs/stdext/pervasiveext.mli @@ -0,0 +1,30 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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 ('a, 'b) either = Right of 'a | Left of 'b +val exnhook : (exn -> unit) option ref +val finally : (unit -> 'a) -> (unit -> 'b) -> 'a +val may : ('a -> 'b) -> 'a option -> 'b option +val default : 'a -> 'a option -> 'a +val maybe : ('a -> unit) -> 'a option -> unit +val reraise_if : bool -> (unit -> unit) -> unit +val ignore_exn : (unit -> unit) -> unit +val ignore_int : int -> unit +val ignore_int32 : int32 -> unit +val ignore_int64 : int64 -> unit +val ignore_string : string -> unit +val ignore_float : float -> unit +val ignore_bool : bool -> unit diff --git a/tools/ocaml/libs/stdext/qring.ml b/tools/ocaml/libs/stdext/qring.ml new file mode 100644 index 0000000..859b63b --- /dev/null +++ b/tools/ocaml/libs/stdext/qring.ml @@ -0,0 +1,161 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 = { + sz: int; + data: string; + mutable prod: int; + mutable cons: int; + mutable pwrap: bool; +} + +exception Data_limit +exception Full + +let make sz = { sz = sz; data = String.create sz; prod = 0; cons = 0; pwrap = false } + +let to_consume ring = + if ring.pwrap then + ring.sz - (ring.cons - ring.prod) + else + ring.prod - ring.cons + +let to_fill ring = + if ring.pwrap then + ring.cons - ring.prod + else + ring.cons + (ring.sz - ring.prod) + +let is_full ring = ring.pwrap && ring.prod = ring.cons +let is_empty ring = not ring.pwrap && ring.prod = ring.cons + +let adv_cons ring i = + ring.cons <- ring.cons + i; + if ring.cons >= ring.sz then ( + ring.cons <- ring.cons - ring.sz; + ring.pwrap <- false; + ) + +let adv_prod ring i = + ring.prod <- ring.prod + i; + if ring.prod >= ring.sz then ( + ring.prod <- ring.prod - ring.sz; + ring.pwrap <- true; + ) + +let consume_internal ring out offset sz = + if ring.pwrap then ( + let left_end = ring.sz - ring.cons in + if sz > left_end then ( + String.blit ring.data ring.cons out offset left_end; + String.blit ring.data 0 out (offset + left_end) (sz - left_end); + ) else + String.blit ring.data ring.cons out offset sz; + ) else + String.blit ring.data ring.cons out offset sz; + adv_cons ring sz; + () + +let consume_length_max ring sz = + let max = to_consume ring in + if sz > 0 then + if sz > max then max else sz + else + if max + sz > 0 then max + sz else 0 + +let consume_to ring s offset sz = + let sz = consume_length_max ring sz in + consume_internal ring s offset sz; + sz + +let consume ring sz = + let sz = consume_length_max ring sz in + let out = String.create sz in + consume_internal ring out 0 sz; + out + +let consume_offset ring i = + if i >= ring.cons then + consume ring (i - ring.cons) + else + consume ring (ring.sz - ring.cons + i) + +let consume_all ring = consume ring (max_int) + +let skip ring n = + let max = to_consume ring in + let n = if n > max then max else n in + adv_cons ring n + +let feed ring data offset len = + let max = to_fill ring in + if len > max then + raise Data_limit; + if ring.prod + len > ring.sz then ( + let firstblitsz = ring.sz - ring.prod in + String.blit data offset ring.data ring.prod firstblitsz; + String.blit data (offset + firstblitsz) ring.data 0 (len - firstblitsz); + ) else + String.blit data offset ring.data ring.prod len; + adv_prod ring len; + () + +let feed_data ring data = + feed ring data 0 (String.length data) + +(* read and search directly to the qring. + * since we have give a continuous buffer, we limit our read length to the + * maximum continous length instead of the full length of the qring left. + * after the read, piggyback into the new data. + *) +let read_search ring fread fsearch len = + let prod = ring.prod in + let maxlen = + if ring.pwrap + then ring.cons - ring.prod + else ring.sz - ring.prod + in + if maxlen = 0 then + raise Full; + let len = if maxlen < len then maxlen else len in + let n = fread ring.data prod len in + if n > 0 then ( + adv_prod ring n; + fsearch ring.data prod n + ); + n + +let search ring c = + let search_from_to f t = + let found = ref false in + let i = ref f in + while not !found && !i < t + do + if ring.data.[!i] = c then + found := true + else + incr i + done; + if not !found then + raise Not_found; + !i - f + in + if is_empty ring then + raise Not_found; + if ring.pwrap then ( + try search_from_to ring.cons ring.sz + with Not_found -> search_from_to 0 ring.prod + ) else + search_from_to ring.cons ring.prod diff --git a/tools/ocaml/libs/stdext/qring.mli b/tools/ocaml/libs/stdext/qring.mli new file mode 100644 index 0000000..9b7f184 --- /dev/null +++ b/tools/ocaml/libs/stdext/qring.mli @@ -0,0 +1,47 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 = { + sz: int; + data: string; + mutable prod: int; + mutable cons: int; + mutable pwrap: bool; +} + +exception Data_limit +exception Full + +val make : int -> t + +val to_consume : t -> int +val to_fill : t -> int + +val is_full : t -> bool +val is_empty : t -> bool + +val consume_to : t -> string -> int -> int -> int +val consume : t -> int -> string +val consume_offset : t -> int -> string +val consume_all : t -> string +val skip : t -> int -> unit + +val feed : t -> string -> int -> int -> unit +val feed_data : t -> string -> unit +val read_search : t -> (string -> int -> int -> int) + -> (string -> int -> int -> unit) -> int + -> int +val search : t -> char -> int diff --git a/tools/ocaml/libs/stdext/ring.ml b/tools/ocaml/libs/stdext/ring.ml new file mode 100644 index 0000000..4372e22 --- /dev/null +++ b/tools/ocaml/libs/stdext/ring.ml @@ -0,0 +1,109 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 'a t = { size: int; mutable current: int; data: 'a array; } + +(** create a ring structure with @size record. records inited to @initval *) +let make size initval = + { size = size; current = size - 1; data = Array.create size initval; } + +(** length of the ring *) +let length ring = ring.size + +(** push into the ring one element *) +let push ring e = + ring.current <- ring.current + 1; + if ring.current = ring.size then + ring.current <- 0; + ring.data.(ring.current) <- e + +(** get the @ith old element from the ring *) +let peek ring i = + if i >= ring.size then + raise (Invalid_argument "peek: index"); + let index = + let offset = ring.current - i in + if offset >= 0 then offset else ring.size + offset in + ring.data.(index) + +(** get the top element of the ring *) +let top ring = ring.data.(ring.current) + +(** iterate over nb element of the ring, starting from the top *) +let iter_nb ring f nb = + if nb > ring.size then + raise (Invalid_argument "iter_nb: nb"); + (* FIXME: OPTIMIZE ME with 2 Array.iter ? *) + for i = 0 to nb - 1 + do + f (peek ring i) + done + +(** iter directly on all element without using the index *) +let raw_iter ring f = + Array.iter f ring.data + +(** iterate over all element of the ring, starting from the top *) +let iter ring f = iter_nb ring f (ring.size) + +(** get array of latest #nb value, starting at the top *) +let get_nb ring nb = + if nb > ring.size then + raise (Invalid_argument "get_nb: nb"); + let a = Array.create nb (top ring) in + for i = 1 to nb - 1 + do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(i) <- peek ring i + done; + a + +let get ring = get_nb ring (ring.size) + +(** get list of latest #nb value, starting at the top *) +let get_nb_lst ring nb = + if nb > ring.size then + raise (Invalid_argument "get_nb_lst: nb"); + let l = ref [] in + for i = nb - 1 downto 0 + do + l := peek ring i :: !l + done; + !l + +(** get array of latest #nb value, ending at the top *) +let get_nb_rev ring nb = + if nb > ring.size then + raise (Invalid_argument "get_nb_rev: nb"); + let a = Array.create nb (top ring) in + for i = 1 to nb - 1 + do + (* FIXME: OPTIMIZE ME with 2 Array.blit *) + a.(nb - 1 - i) <- peek ring i + done; + a + +(** get list of latest #nb value, ending at the top *) +let get_nb_rev_lst ring nb = + if nb > ring.size then + raise (Invalid_argument "get_nb_rev_lst: nb"); + let l = ref [] in + for i = 0 to nb - 1 + do + l := peek ring i :: !l + done; + !l + diff --git a/tools/ocaml/libs/stdext/ring.mli b/tools/ocaml/libs/stdext/ring.mli new file mode 100644 index 0000000..183de02 --- /dev/null +++ b/tools/ocaml/libs/stdext/ring.mli @@ -0,0 +1,30 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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 'a t = { size : int; mutable current : int; data : 'a array; } +val make : int -> 'a -> 'a t +val length : 'a t -> int +val push : 'a t -> 'a -> unit +val peek : 'a t -> int -> 'a +val top : 'a t -> 'a +val iter_nb : 'a t -> ('a -> 'b) -> int -> unit +val raw_iter : 'a t -> ('a -> unit) -> unit +val iter : 'a t -> ('a -> 'b) -> unit +val get_nb : 'a t -> int -> 'a array +val get_nb_lst : 'a t -> int -> 'a list +val get : 'a t -> 'a array +val get_nb_rev : 'a t -> int -> 'a array +val get_nb_rev_lst : 'a t -> int -> 'a list diff --git a/tools/ocaml/libs/stdext/stringext.ml b/tools/ocaml/libs/stdext/stringext.ml new file mode 100644 index 0000000..e705be3 --- /dev/null +++ b/tools/ocaml/libs/stdext/stringext.ml @@ -0,0 +1,206 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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 String = struct include String + +let of_char c = String.make 1 c + +let iteri f string = + for i = 0 to length string - 1 do + f i string.[i] + done + +let fold_right f string accu = + let accu = ref accu in + for i = length string - 1 downto 0 do + accu := f string.[i] !accu + done; + !accu + +let fold_left f accu string = + let accu = ref accu in + for i = 0 to length string - 1 do + accu := f !accu string.[i] + done; + !accu + +let explode string = + fold_right (fun h t -> h :: t) string [] + +let implode list = + concat "" (List.map of_char list) + +(** True if string 'x' ends with suffix 'suffix' *) +let endswith suffix x = + let x_l = String.length x and suffix_l = String.length suffix in + suffix_l <= x_l && String.sub x (x_l - suffix_l) suffix_l = suffix + +(** True if string 'x' starts with prefix 'prefix' *) +let startswith prefix x = + let x_l = String.length x and prefix_l = String.length prefix in + prefix_l <= x_l && String.sub x 0 prefix_l = prefix + +(** Returns true for whitespace characters, false otherwise *) +let isspace = function + | ' ' | '\n' | '\r' | '\t' -> true + | _ -> false + +(** Removes all the characters from the ends of a string for which the predicate is true *) +let strip predicate string = + let rec remove = function + | [] -> [] + | c :: cs -> if predicate c then remove cs else c :: cs in + implode (List.rev (remove (List.rev (remove (explode string))))) + +let escaped ?rules string = match rules with + | None -> String.escaped string + | Some rules -> + let aux h t = (try List.assoc h rules + with Not_found -> of_char h) :: t in + concat "" (fold_right aux string []) + +(** Take a predicate and a string, return a list of strings separated by +runs of characters where the predicate was true *) +let split_f p str = + let not_p = fun x -> not (p x) in + let rec split_one p acc = function + | [] -> List.rev acc, [] + | c :: cs -> if p c then split_one p (c :: acc) cs else List.rev acc, c :: cs in + + let rec alternate acc drop chars = + if chars = [] then acc else + begin + let a, b = split_one (if drop then p else not_p) [] chars in + alternate (if drop then acc else a :: acc) (not drop) b + end in + List.rev (List.map implode (alternate [] true (explode str))) + +let rec split ?limit:(limit=(-1)) c s = + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split ~limit: nlimit c b) + +let rtrim s = + let n = String.length s in + if String.get s (n - 1) = '\n' then + String.sub s 0 (n - 1) + else + s + +(** has_substr str sub returns true if sub is a substring of str. Simple, naive, slow. *) +let has_substr str sub = + if String.length sub > String.length str then false else + begin + let result=ref false in + for start = 0 to (String.length str) - (String.length sub) do + if String.sub str start (String.length sub) = sub then result := true + done; + !result + end + +(** find all occurences of needle in haystack and return all their respective index *) +let find_all needle haystack = + let m = String.length needle and n = String.length haystack in + + if m > n then + [] + else ( + let i = ref 0 and found = ref [] in + while !i < (n - m + 1) + do + if (String.sub haystack !i m) = needle then ( + found := !i :: !found; + i := !i + m + ) else ( + incr i + ) + done; + List.rev !found + ) + +(* replace all @f substring in @s by @t *) +let replace f t s = + let indexes = find_all f s in + let n = List.length indexes in + if n > 0 then ( + let len_f = String.length f and len_t = String.length t in + let new_len = String.length s + (n * len_t) - (n * len_f) in + let new_s = String.make new_len '\000' in + let orig_offset = ref 0 and dest_offset = ref 0 in + List.iter (fun h -> + let len = h - !orig_offset in + String.blit s !orig_offset new_s !dest_offset len; + String.blit t 0 new_s (!dest_offset + len) len_t; + orig_offset := !orig_offset + len + len_f; + dest_offset := !dest_offset + len + len_t; + ) indexes; + String.blit s !orig_offset new_s !dest_offset (String.length s - !orig_offset); + new_s + ) else + s + +let filter_chars s valid = + let badchars = ref false in + let buf = Buffer.create 0 in + for i = 0 to String.length s - 1 + do + if !badchars then ( + if valid s.[i] then + Buffer.add_char buf s.[i] + ) else ( + if not (valid s.[i]) then ( + Buffer.add_substring buf s 0 i; + badchars := true + ) + ) + done; + if !badchars then Buffer.contents buf else s + +let map_unlikely s f = + let changed = ref false in + let m = ref 0 in + let buf = Buffer.create 0 in + for i = 0 to String.length s - 1 + do + match f s.[i] with + | None -> () + | Some n -> + changed := true; + Buffer.add_substring buf s !m (i - !m); + Buffer.add_string buf n; + m := i + 1 + done; + if !changed then ( + Buffer.add_substring buf s !m (String.length s - !m); + Buffer.contents buf + ) else + s + +let left s n = + let l = String.length s in + let n = min n l in + String.sub s 0 n + +let right s n = + let l = String.length s in + let p = max 0 (l - n) in + String.sub s p (l - p) +end diff --git a/tools/ocaml/libs/stdext/stringext.mli b/tools/ocaml/libs/stdext/stringext.mli new file mode 100644 index 0000000..4383fd5 --- /dev/null +++ b/tools/ocaml/libs/stdext/stringext.mli @@ -0,0 +1,108 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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 String : + sig + external length : string -> int = "%string_length" + external get : string -> int -> char = "%string_safe_get" + external set : string -> int -> char -> unit = "%string_safe_set" + external create : int -> string = "caml_create_string" + val make : int -> char -> string + val copy : string -> string + val sub : string -> int -> int -> string + val fill : string -> int -> int -> char -> unit + val blit : string -> int -> string -> int -> int -> unit + val concat : string -> string list -> string + val iter : (char -> unit) -> string -> unit + val index : string -> char -> int + val rindex : string -> char -> int + val index_from : string -> int -> char -> int + val rindex_from : string -> int -> char -> int + val contains : string -> char -> bool + val contains_from : string -> int -> char -> bool + val rcontains_from : string -> int -> char -> bool + val uppercase : string -> string + val lowercase : string -> string + val capitalize : string -> string + val uncapitalize : string -> string + type t = string + val compare : t -> t -> int + external unsafe_get : string -> int -> char = "%string_unsafe_get" + external unsafe_set : string -> int -> char -> unit + = "%string_unsafe_set" + external unsafe_blit : string -> int -> string -> int -> int -> unit + = "caml_blit_string" "noalloc" + external unsafe_fill : string -> int -> int -> char -> unit + = "caml_fill_string" "noalloc" + val of_char : char -> string + + (** Iterate over the characters with the character index in argument *) + val iteri : (int -> char -> 'a) -> string -> unit + + val fold_right : (char -> 'a -> 'a) -> string -> 'a -> 'a + val fold_left : ('a -> char -> 'a) -> 'a -> string -> 'a + + (** Split a string into a list of characters. *) + val explode : string -> char list + + (** Concatenate a list of characters into a string. *) + val implode : char list -> string + + (** True if string 'x' ends with suffix 'suffix' *) + val endswith : string -> string -> bool + + (** True if string 'x' starts with prefix 'prefix' *) + val startswith : string -> string -> bool + + (** True if the character is whitespace *) + val isspace : char -> bool + + (** Removes all the characters from the ends of a string for which the predicate is true *) + val strip : (char -> bool) -> string -> string + + (** Backward-compatible string escaping, defaulting to the built-in + OCaml string escaping but allowing an arbitrary mapping from characters + to strings. *) + val escaped : ?rules:(char * string) list -> string -> string + + (** Take a predicate and a string, return a list of strings separated by + runs of characters where the predicate was true *) + val split_f : (char -> bool) -> string -> string list + + (** split a string on a single char *) + val split : ?limit:int -> char -> string -> string list + + (** FIXME document me|remove me if similar to strip *) + val rtrim : string -> string + + (** True if sub is a substr of str *) + val has_substr : string -> string -> bool + + (** replace all @f substring in @s by @t *) + val replace : string -> string -> string -> string + + (** filter chars from a string *) + val filter_chars : string -> (char -> bool) -> string + + (** map a string trying to fill the buffer by chunk *) + val map_unlikely : string -> (char -> string option) -> string + + (** get beginning portion of string *) + val left : string -> int -> string + + (** get end portion of string *) + val right : string -> int -> string + end diff --git a/tools/ocaml/libs/stdext/threadext.ml b/tools/ocaml/libs/stdext/threadext.ml new file mode 100644 index 0000000..5e96600 --- /dev/null +++ b/tools/ocaml/libs/stdext/threadext.ml @@ -0,0 +1,212 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Anil Madhavapeddy + * + * 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 Mutex = struct + include Mutex + (** execute the function f with the mutex hold *) + let execute lock f = + Mutex.lock lock; + let r = begin try f () with exn -> Mutex.unlock lock; raise exn end; in + Mutex.unlock lock; + r +end + +module Condition = struct + include Condition + external timedwait : Condition.t -> Mutex.t -> float -> bool = "caml_condition_timedwait" +end + +module TMutex = struct + +exception Timeout + +type t = { mutex: Mutex.t; mutable time: float; post_locking: unit -> float } + +let init ?(post=(fun () -> 0.)) () = { mutex = Mutex.create (); time = 0.; post_locking = post } + +let lock ?(retry=0) ?(delay=0.05) t = + if retry > 0 then ( + let left = ref retry in + let locked = ref false in + while not !locked && !left > 0 + do + locked := Mutex.try_lock t.mutex; + if not !locked then ( + decr left; + Thread.delay delay; + ) + done; + if not !locked then + raise Timeout + ) else ( + Mutex.lock t.mutex; + ); + try t.time <- t.post_locking () with _ -> (); + () + +let unlock t = + t.time <- 0.; + Mutex.unlock t.mutex + +let execute ?retry ?delay t f = + lock ?retry ?delay t; + let r = begin try f () with exn -> unlock t; raise exn end; in + unlock t; + r + +end + +(** create thread loops which periodically applies a function *) +module Thread_loop + : functor (Tr : sig type t val delay : unit -> float end) -> + sig + val start : Tr.t -> (unit -> unit) -> unit + val stop : Tr.t -> unit + val update : Tr.t -> (unit -> unit) -> unit + end + = functor (Tr: sig type t val delay : unit -> float end) -> struct + + exception Done_loop + let ref_table : ((Tr.t,(Mutex.t * Thread.t * bool ref)) Hashtbl.t) = + Hashtbl.create 1 + + (** Create a thread which periodically applies a function to the + reference specified, and exits cleanly when removed *) + let start xref fn = + let mut = Mutex.create () in + let exit_var = ref false in + (* create thread which periodically applies the function *) + let tid = Thread.create (fun () -> + try while true do + Thread.delay (Tr.delay ()); + Mutex.execute mut (fun () -> + if !exit_var then + raise Done_loop; + let () = fn () in () + ); + done; with Done_loop -> (); + ) () in + (* create thread to manage the reference table and clean it up + safely once the delay thread is removed *) + let _ = Thread.create (fun () -> + Hashtbl.add ref_table xref (mut,tid,exit_var); + Thread.join tid; + List.iter (fun (_,t,_) -> + if tid = t then Hashtbl.remove ref_table xref + ) (Hashtbl.find_all ref_table xref) + ) () in () + + (** Remove a reference from the thread table *) + let stop xref = + try let mut,_,exit_ref = Hashtbl.find ref_table xref in + Mutex.execute mut (fun () -> exit_ref := true) + with Not_found -> () + + (** Replace a thread with another one *) + let update xref fn = + stop xref; + start xref fn +end + +(** Parallel List.iter. Remembers all exceptions and returns an association list mapping input x to an exception. + Applications of x which succeed will be missing from the returned list. *) +let thread_iter_all_exns f xs = + let exns = ref [] in + let m = Mutex.create () in + List.iter + Thread.join + (List.map + (fun x -> + Thread.create + (fun () -> + try + f x + with e -> Mutex.execute m (fun () -> exns := (x, e) :: !exns) + ) + () + ) xs); + !exns + +(** Parallel List.iter. Remembers one exception (at random) and throws it in the + error case. *) +let thread_iter f xs = match thread_iter_all_exns f xs with + | [] -> () + | (_, e) :: _ -> raise e + +module Delay = struct + (* Concrete type is the ends of a pipe *) + type t = { + (* A pipe is used to wake up a thread blocked in wait: *) + mutable pipe_out: Unix.file_descr option; + mutable pipe_in: Unix.file_descr option; + (* Indicates that a signal arrived before a wait: *) + mutable signalled: bool; + m: Mutex.t + } + + let make () = + { pipe_out = None; + pipe_in = None; + signalled = false; + m = Mutex.create () } + + exception Pre_signalled + + let wait (x: t) (seconds: float) = + let to_close = ref [ ] in + let close' fd = + if List.mem fd !to_close then Unix.close fd; + to_close := List.filter (fun x -> fd <> x) !to_close in + Pervasiveext.finally + (fun () -> + try + let pipe_out = Mutex.execute x.m + (fun () -> + if x.signalled then begin + x.signalled <- false; + raise Pre_signalled; + end; + let pipe_out, pipe_in = Unix.pipe () in + (* these will be unconditionally closed on exit *) + to_close := [ pipe_out; pipe_in ]; + x.pipe_out <- Some pipe_out; + x.pipe_in <- Some pipe_in; + x.signalled <- false; + pipe_out) in + let r, _, _ = Unix.select [ pipe_out ] [] [] seconds in + (* flush the single byte from the pipe *) + if r <> [] then ignore(Unix.read pipe_out (String.create 1) 0 1); + (* return true if we waited the full length of time, false if we were woken *) + r = [] + with Pre_signalled -> false + ) + (fun () -> + Mutex.execute x.m + (fun () -> + x.pipe_out <- None; + x.pipe_in <- None; + List.iter close' !to_close) + ) + + let signal (x: t) = + Mutex.execute x.m + (fun () -> + match x.pipe_in with + | Some fd -> ignore(Unix.write fd "X" 0 1) + | None -> x.signalled <- true (* If the wait hasn't happened yet then store up the signal *) + ) +end diff --git a/tools/ocaml/libs/stdext/threadext.mli b/tools/ocaml/libs/stdext/threadext.mli new file mode 100644 index 0000000..d25c795 --- /dev/null +++ b/tools/ocaml/libs/stdext/threadext.mli @@ -0,0 +1,67 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Anil Madhavapeddy + * + * 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 Mutex : + sig + type t = Mutex.t + val create : unit -> t + val lock : t -> unit + val try_lock : t -> bool + val unlock : t -> unit + val execute : Mutex.t -> (unit -> 'a) -> 'a + end + +module Condition : + sig + type t = Condition.t + val create : unit -> t + val signal : t -> unit + val broadcast: t -> unit + val wait : t -> Mutex.t -> unit + val timedwait : t -> Mutex.t -> float -> bool + end + +module TMutex : sig + exception Timeout + type t + val init : ?post:(unit -> float) -> unit -> t + val lock : ?retry:int -> ?delay:float -> t -> unit + val unlock : t -> unit + val execute : ?retry:int -> ?delay:float -> t -> (unit -> 'a) -> 'a +end + +module Thread_loop : + functor (Tr : sig type t val delay : unit -> float end) -> + sig + val start : Tr.t -> (unit -> unit) -> unit + val stop : Tr.t -> unit + val update : Tr.t -> (unit -> unit) -> unit + end +val thread_iter_all_exns: ('a -> unit) -> 'a list -> ('a * exn) list +val thread_iter: ('a -> unit) -> 'a list -> unit + +module Delay : + sig + type t + val make : unit -> t + (** Blocks the calling thread for a given period of time with the option of + returning early if someone calls 'signal'. Returns true if the full time + period elapsed and false if signalled. Note that multple 'signals' are + coalesced; 'signals' sent before 'wait' is called are not lost. *) + val wait : t -> float -> bool + (** Sends a signal to a waiting thread. See 'wait' *) + val signal : t -> unit + end diff --git a/tools/ocaml/libs/stdext/trie.ml b/tools/ocaml/libs/stdext/trie.ml new file mode 100644 index 0000000..bc9a903 --- /dev/null +++ b/tools/ocaml/libs/stdext/trie.ml @@ -0,0 +1,182 @@ +(* + * Copyright (C) 2008-2009 Citrix Ltd. + * Author Thomas Gazagnaire + * + * 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 Node = +struct + type ('a,'b) t = { + key: 'a; + value: 'b option; + children: ('a,'b) t list; + } + + let create key value = { + key = key; + value = Some value; + children = []; + } + + let empty key = { + key = key; + value = None; + children = [] + } + + let get_key node = node.key + let get_value node = + match node.value with + | None -> raise Not_found + | Some value -> value + + let get_children node = node.children + + let set_value node value = + { node with value = Some value } + let set_children node children = + { node with children = children } + + let add_child node child = + { node with children = child :: node.children } +end + +type ('a,'b) t = ('a,'b) Node.t list + +let mem_node nodes key = + List.exists (fun n -> n.Node.key = key) nodes + +let find_node nodes key = + List.find (fun n -> n.Node.key = key) nodes + +let replace_node nodes key node = + let rec aux = function + | [] -> [] + | h :: tl when h.Node.key = key -> node :: tl + | h :: tl -> h :: aux tl + in + aux nodes + +let remove_node nodes key = + let rec aux = function + | [] -> raise Not_found + | h :: tl when h.Node.key = key -> tl + | h :: tl -> h :: aux tl + in + aux nodes + +let create () = [] + +let rec iter f tree = + let rec aux node = + f node.Node.key node.Node.value; + iter f node.Node.children + in + List.iter aux tree + +let rec map f tree = + let rec aux node = + let value = + match node.Node.value with + | None -> None + | Some value -> f value + in + { node with Node.value = value; Node.children = map f node.Node.children } + in + List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree) + +let rec fold f tree acc = + let rec aux accu node = + fold f node.Node.children (f node.Node.key node.Node.value accu) + in + List.fold_left aux acc tree + +(* return a sub-trie *) +let rec sub_node tree = function + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + if t = [] + then node + else sub_node node.Node.children t + end else + raise Not_found + +let sub tree path = + try (sub_node tree path).Node.children + with Not_found -> [] + +let find tree path = + Node.get_value (sub_node tree path) + +(* return false if the node doesn't exists or if it is not associated to any value *) +let rec mem tree = function + | [] -> false + | h::t -> + mem_node tree h + && (let node = find_node tree h in + if t = [] + then node.Node.value <> None + else mem node.Node.children t) + +(* Iterate over the longest valid prefix *) +let rec iter_path f tree = function + | [] -> () + | h::l -> + if mem_node tree h + then begin + let node = find_node tree h in + f node.Node.key node.Node.value; + iter_path f node.Node.children l + end + +let rec set_node node path value = + if path = [] + then Node.set_value node value + else begin + let children = set node.Node.children path value in + Node.set_children node children + end + +and set tree path value = + match path with + | [] -> raise Not_found + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + replace_node tree h (set_node node t value) + end else begin + let node = Node.empty h in + set_node node t value :: tree + end + +let rec unset tree = function + | [] -> tree + | h::t -> + if mem_node tree h + then begin + let node = find_node tree h in + let children = unset node.Node.children t in + let new_node = + if t = [] + then Node.set_children (Node.empty h) children + else Node.set_children node children + in + if children = [] && new_node.Node.value = None + then remove_node tree h + else replace_node tree h new_node + end else + raise Not_found + diff --git a/tools/ocaml/libs/stdext/trie.mli b/tools/ocaml/libs/stdext/trie.mli new file mode 100644 index 0000000..25db9d0 --- /dev/null +++ b/tools/ocaml/libs/stdext/trie.mli @@ -0,0 +1,60 @@ +(* + * Copyright (C) 2008-2009 Citrix Ltd. + * Author Thomas Gazagnaire + * + * 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. + *) + +(** Basic Implementation of polymorphic tries (ie. prefix trees) *) + +type ('a, 'b) t +(** The type of tries. ['a list] is the type of keys, ['b] the type of values. + Internally, a trie is represented as a labeled tree, where node contains values + of type ['a * 'b option]. *) + +val create : unit -> ('a,'b) t +(** Creates an empty trie. *) + +val mem : ('a,'b) t -> 'a list -> bool +(** [mem t k] returns true if a value is associated with the key [k] in the trie [t]. + Otherwise, it returns false. *) + +val find : ('a, 'b) t -> 'a list -> 'b +(** [find t k] returns the value associated with the key [k] in the trie [t]. + Returns [Not_found] if no values are associated with [k] in [t]. *) + +val set : ('a, 'b) t -> 'a list -> 'b -> ('a, 'b) t +(** [set t k v] associates the value [v] with the key [k] in the trie [t]. *) + +val unset : ('a, 'b) t -> 'a list -> ('a, 'b) t +(** [unset k v] removes the association of value [v] with the key [k] in the trie [t]. + Moreover, it automatically clean the trie, ie. it removes recursively + every nodes of [t] containing no values and having no chil. *) + +val iter : ('a -> 'b option -> unit) -> ('a, 'b) t -> unit +(** [iter f t] applies the function [f] to every node of the trie [t]. + As nodes of the trie [t] do not necessary contains a value, the second argument of + [f] is an option type. *) + +val iter_path : ('a -> 'b option -> unit) -> ('a, 'b) t -> 'a list -> unit +(** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t]. + If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *) + +val fold : ('a -> 'b option -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c +(** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *) + +val map : ('b -> 'c option) -> ('a,'b) t -> ('a,'c) t +(** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option + as one may wants to remove value associated to a key. This function is not tail-recursive. *) + +val sub : ('a, 'b) t -> 'a list -> ('a,'b) t +(** [sub t p] returns the sub-trie associated with the path [p] in the trie [t]. + If [p] is not a valid path of [t], it returns an empty trie. *) diff --git a/tools/ocaml/libs/stdext/unixext.ml b/tools/ocaml/libs/stdext/unixext.ml new file mode 100644 index 0000000..c34b274 --- /dev/null +++ b/tools/ocaml/libs/stdext/unixext.ml @@ -0,0 +1,437 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) +open Pervasiveext + +exception Unix_error of int + +external _exit : int -> unit = "unix_exit" + +(** remove a file, but doesn't raise an exception if the file is already removed *) +let unlink_safe file = + try Unix.unlink file with (* Unix.Unix_error (Unix.ENOENT, _ , _)*) _ -> () + +(** create a directory but doesn't raise an exception if the directory already exist *) +let mkdir_safe dir perm = + try Unix.mkdir dir perm with Unix.Unix_error (Unix.EEXIST, _, _) -> () + +(** create a directory, and create parent if doesn't exist *) +let mkdir_rec dir perm = + let rec p_mkdir dir = + let p_name = Filename.dirname dir in + if p_name <> "/" && p_name <> "." + then p_mkdir p_name; + mkdir_safe dir perm in + p_mkdir dir + +(** write a pidfile file *) +let pidfile_write filename = + let fd = Unix.openfile filename + [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] + 0o640 in + finally + (fun () -> + let pid = Unix.getpid () in + let buf = string_of_int pid ^ "\n" in + let len = String.length buf in + if Unix.write fd buf 0 len <> len + then failwith "pidfile_write failed"; + ) + (fun () -> Unix.close fd) + +(** read a pidfile file, return either Some pid or None *) +let pidfile_read filename = + let fd = Unix.openfile filename [ Unix.O_RDONLY ] 0o640 in + finally + (fun () -> + try + let buf = String.create 80 in + let rd = Unix.read fd buf 0 (String.length buf) in + if rd = 0 then + failwith "pidfile_read failed"; + Scanf.sscanf (String.sub buf 0 rd) "%d" (fun i -> Some i) + with exn -> None) + (fun () -> Unix.close fd) + +(** daemonize a process *) +(* !! Must call this before spawning any threads !! *) +let daemonize () = + match Unix.fork () with + | 0 -> + if Unix.setsid () == -1 then + failwith "Unix.setsid failed"; + + begin match Unix.fork () with + | 0 -> + let nullfd = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0 in + begin try + Unix.close Unix.stdin; + Unix.dup2 nullfd Unix.stdout; + Unix.dup2 nullfd Unix.stderr; + with exn -> Unix.close nullfd; raise exn + end; + Unix.close nullfd + | _ -> exit 0 + end + | _ -> exit 0 + +(** Run a function over every line in a file *) +let readfile_line fn fname = + let fin = open_in fname in + try + while true do + let line = input_line fin in + fn line + done; + close_in fin; + with + | End_of_file -> close_in fin + | exn -> close_in fin; raise exn + +(** open a file, and make sure the close is always done *) +let with_file file mode perms f = + let fd = Unix.openfile file mode perms in + let r = + try f fd + with exn -> Unix.close fd; raise exn + in + Unix.close fd; + r + +let with_directory dir f = + let dh = Unix.opendir dir in + let r = + try f dh + with exn -> Unix.closedir dh; raise exn + in + Unix.closedir dh; + r + +(** Read whole file from specified fd *) +let read_whole_file size_hint block_size fd = + let filebuf = Buffer.create size_hint in + let blockbuf = String.create block_size in + let rec do_read() = + let nread = Unix.read fd blockbuf 0 block_size in + if nread=0 then + Buffer.contents filebuf + else + begin + Buffer.add_substring filebuf blockbuf 0 nread; + do_read() + end in + do_read() + +(** Read whole file into string *) +let read_whole_file_to_string fname = + with_file fname [ Unix.O_RDONLY ] 0o0 (read_whole_file 1024 1024) + +(** Atomically write a string to a file *) +let write_string_to_file fname s = + let tmp = Filenameext.temp_file_in_dir fname in + Pervasiveext.finally + (fun () -> + let fd = Unix.openfile tmp [Unix.O_WRONLY; Unix.O_CREAT] 0o644 in + Pervasiveext.finally + (fun () -> + let len = String.length s in + let written = Unix.write fd s 0 len in + if written <> len then (failwith "Short write occured!")) + (fun () -> Unix.close fd); + Unix.rename tmp fname) + (fun () -> unlink_safe tmp) + +let execv_get_output cmd args = + let (pipe_exit, pipe_entrance) = Unix.pipe () in + let r = try Unix.set_close_on_exec pipe_exit; true with _ -> false in + match Unix.fork () with + | 0 -> + Unix.dup2 pipe_entrance Unix.stdout; + Unix.close pipe_entrance; + if not r then + Unix.close pipe_exit; + begin try Unix.execv cmd args with _ -> exit 127 end + | pid -> + Unix.close pipe_entrance; + pid, pipe_exit + +(** Copy all data from an in_channel to an out_channel, + * returning the total number of bytes *) +let copy_file ?limit ifd ofd = + let buffer = String.make 65536 '\000' in + let buffer_len = Int64.of_int (String.length buffer) in + let finished = ref false in + let total_bytes = ref 0L in + let limit = ref limit in + while not(!finished) do + let requested = min (Opt.default buffer_len !limit) buffer_len in + let num = Unix.read ifd buffer 0 (Int64.to_int requested) in + let num64 = Int64.of_int num in + + limit := Opt.map (fun x -> Int64.sub x num64) !limit; + let wnum = Unix.write ofd buffer 0 num in + total_bytes := Int64.add !total_bytes num64; + finished := wnum = 0 || !limit = Some 0L; + done; + !total_bytes + +(** Create a new file descriptor, connect it to host:port and return it *) +exception Host_not_found of string +let open_connection_fd host port = + let s = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in + try + let he = + try + Unix.gethostbyname host + with + Not_found -> raise (Host_not_found host) in + if Array.length he.Unix.h_addr_list = 0 + then failwith (Printf.sprintf "Couldn't resolve hostname: %s" host); + let ip = he.Unix.h_addr_list.(0) in + let addr = Unix.ADDR_INET(ip, port) in + Unix.connect s addr; + s + with e -> Unix.close s; raise e + + +let open_connection_unix_fd filename = + let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + try + let addr = Unix.ADDR_UNIX(filename) in + Unix.connect s addr; + s + with e -> Unix.close s; raise e + +type endpoint = { fd: Unix.file_descr; mutable buffer: string; mutable buffer_len: int } + +let make_endpoint fd = { + fd = fd; + buffer = String.make 4096 '\000'; + buffer_len = 0 +} + +exception Process_still_alive + +let kill_and_wait ?(signal = Sys.sigterm) ?(timeout=10.) pid = + let proc_entry_exists pid = + try Unix.access (Printf.sprintf "/proc/%d" pid) [ Unix.F_OK ]; true + with _ -> false + in + if pid > 0 && proc_entry_exists pid then ( + let loop_time_waiting = 0.03 in + let left = ref timeout in + let readcmdline pid = + try read_whole_file_to_string (Printf.sprintf "/proc/%d/cmdline" pid) + with _ -> "" + in + let reference = readcmdline pid and quit = ref false in + Unix.kill pid signal; + + (* We cannot do a waitpid here, since we might not be parent of + the process, so instead we are waiting for the /proc/%d to go + away. Also we verify that the cmdline stay the same if it's still here + to prevent the very very unlikely event that the pid get reused before + we notice it's gone *) + while proc_entry_exists pid && not !quit && !left > 0. + do + let cmdline = readcmdline pid in + if cmdline = reference then ( + (* still up, let's sleep a bit *) + ignore (Unix.select [] [] [] loop_time_waiting); + left := !left -. loop_time_waiting + ) else ( + (* not the same, it's gone ! *) + quit := true + ) + done; + if !left <= 0. then + raise Process_still_alive; + ) + +let proxy (a: Unix.file_descr) (b: Unix.file_descr) = + let a' = make_endpoint a and b' = make_endpoint b in + Unix.set_nonblock a; + Unix.set_nonblock b; + + let can_read x = + x.buffer_len < (String.length x.buffer - 1) in + let can_write x = + x.buffer_len > 0 in + let write_from x fd = + let written = Unix.single_write fd x.buffer 0 x.buffer_len in + String.blit x.buffer written x.buffer 0 (x.buffer_len - written); + x.buffer_len <- x.buffer_len - written in + let read_into x = + let read = Unix.read x.fd x.buffer x.buffer_len (String.length x.buffer - x.buffer_len) in + if read = 0 then raise End_of_file; + x.buffer_len <- x.buffer_len + read in + + try + while true do + let r = (if can_read a' then [ a ] else []) @ (if can_read b' then [ b ] else []) in + let w = (if can_write a' then [ b ] else []) @ (if can_write b' then [ a ] else []) in + + let r, w, _ = Unix.select r w [] (-1.0) in + (* Do the writing before the reading *) + List.iter (fun fd -> if a = fd then write_from b' a else write_from a' b) w; + List.iter (fun fd -> if a = fd then read_into a' else read_into b') r + done + with _ -> + (try Unix.clear_nonblock a with _ -> ()); + (try Unix.clear_nonblock b with _ -> ()); + (try Unix.close a with _ -> ()); + (try Unix.close b with _ -> ()) + +let rec really_read fd string off n = + if n=0 then () else + let m = Unix.read fd string off n in + if m = 0 then raise End_of_file; + really_read fd string (off+m) (n-m) + +let really_write fd string off n = + let written = ref 0 in + while !written < n + do + let wr = Unix.write fd string (off + !written) (n - !written) in + written := wr + !written + done + +let spawnvp ?(pid_callback=(fun _ -> ())) cmd args = + match Unix.fork () with + | 0 -> + Unix.execvp cmd args + | pid -> + begin try pid_callback pid with _ -> () end; + snd (Unix.waitpid [] pid) + +let double_fork f = + match Unix.fork () with + | 0 -> + begin match Unix.fork () with + (* NB: use _exit (calls C lib _exit directly) to avoid + calling at_exit handlers and flushing output channels + which wouild cause intermittent deadlocks if we + forked from a threaded program *) + | 0 -> (try f () with _ -> ()); _exit 0 + | _ -> _exit 0 + end + | pid -> ignore(Unix.waitpid [] pid) + +external set_tcp_nodelay : Unix.file_descr -> bool -> unit = "stub_unixext_set_tcp_nodelay" + +external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" + +external get_max_fd : unit -> int = "stub_unixext_get_max_fd" + +let int_of_file_descr (x: Unix.file_descr) : int = Obj.magic x +let file_descr_of_int (x: int) : Unix.file_descr = Obj.magic x + +(** Forcibly closes all open file descriptors except those explicitly passed in as arguments. + Useful to avoid accidentally passing a file descriptor opened in another thread to a + process being concurrently fork()ed (there's a race between open/set_close_on_exec). + NB this assumes that 'type Unix.file_descr = int' +*) +let close_all_fds_except (fds: Unix.file_descr list) = + (* get at the file descriptor within *) + let fds' = List.map int_of_file_descr fds in + let close' (x: int) = + try Unix.close(file_descr_of_int x) with _ -> () in + + let highest_to_keep = List.fold_left max (-1) fds' in + (* close all the fds higher than the one we want to keep *) + for i = highest_to_keep + 1 to get_max_fd () do close' i done; + (* close all the rest *) + for i = 0 to highest_to_keep - 1 do + if not(List.mem i fds') then close' i + done + +exception Process_output_error of string +let get_process_output ?(handler) cmd : string = + let inchan = Unix.open_process_in cmd in + + let buffer = Buffer.create 1024 + and buf = String.make 1024 '\000' in + + let rec read_until_eof () = + let rd = input inchan buf 0 1024 in + if rd = 0 then + () + else ( + Buffer.add_substring buffer buf 0 rd; + read_until_eof () + ) in + (* Make sure an exception doesn't prevent us from waiting for the child process *) + (try read_until_eof () with _ -> ()); + match (Unix.close_process_in inchan), handler with + | Unix.WEXITED 0, _ -> Buffer.contents buffer + | Unix.WEXITED n, Some handler -> handler cmd n + | _ -> raise (Process_output_error cmd) + +(** Remove "." and ".." from paths (NB doesn't attempt to resolve symlinks) *) +let resolve_dot_and_dotdot (path: string) : string = + let of_string (x: string): string list = + let rec rev_split path = + let basename = Filename.basename path + and dirname = Filename.dirname path in + let rest = if Filename.dirname dirname = dirname then [] else rev_split dirname in + basename :: rest in + let abs_path path = + if Filename.is_relative path + then Filename.concat "/" path (* no notion of a cwd *) + else path in + rev_split (abs_path x) in + + let to_string (x: string list) = List.fold_left Filename.concat "/" (List.rev x) in + + (* Process all "." and ".." references *) + let rec remove_dots (n: int) (x: string list) = + match x, n with + | [], _ -> [] + | "." :: rest, _ -> remove_dots n rest (* throw away ".", don't count as parent for ".." *) + | ".." :: rest, _ -> remove_dots (n + 1) rest (* note the number of ".." *) + | x :: rest, 0 -> x :: (remove_dots 0 rest) + | x :: rest, n -> remove_dots (n - 1) rest (* munch *) in + to_string (remove_dots 0 (of_string path)) + +type statfs_t = { + statfs_type: int64; + statfs_bsize: int; + statfs_blocks: int64; + statfs_bfree: int64; + statfs_bavail: int64; + statfs_files: int64; + statfs_ffree: int64; + statfs_namelen: int; +} + +external statfs: string -> statfs_t = "stub_unixext_statfs" + +external get_major_minor : string -> int * int = "stub_unixext_get_major_minor" + +module Fdset = struct + type t + external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" + let create () = of_list [] + external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" + external set : t -> Unix.file_descr -> unit = "stub_fdset_set" + external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" + external _select : t -> t -> t -> float -> t * t * t = "stub_fdset_select" + external _select_ro : t -> float -> t = "stub_fdset_select_ro" + let select r w e t = _select r w e t + let select_ro r t = _select_ro r t +end + +let _ = Callback.register_exception "unixext.unix_error" (Unix_error (0)) diff --git a/tools/ocaml/libs/stdext/unixext.mli b/tools/ocaml/libs/stdext/unixext.mli new file mode 100644 index 0000000..b6dc96f --- /dev/null +++ b/tools/ocaml/libs/stdext/unixext.mli @@ -0,0 +1,84 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * Author Dave Scott + * + * 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. + *) +external _exit : int -> unit = "unix_exit" +val unlink_safe : string -> unit +val mkdir_safe : string -> Unix.file_perm -> unit +val mkdir_rec : string -> Unix.file_perm -> unit +val pidfile_write : string -> unit +val pidfile_read : string -> int option +val daemonize : unit -> unit +val with_file : string -> Unix.open_flag list -> Unix.file_perm -> (Unix.file_descr -> 'a) -> 'a +val with_directory : string -> (Unix.dir_handle -> 'a) -> 'a +val readfile_line : (string -> 'a) -> string -> unit +val read_whole_file : int -> int -> Unix.file_descr -> string +val read_whole_file_to_string : string -> string +val write_string_to_file : string -> string -> unit +val execv_get_output : string -> string array -> int * Unix.file_descr +val copy_file : ?limit:int64 -> Unix.file_descr -> Unix.file_descr -> int64 +exception Host_not_found of string +val open_connection_fd : string -> int -> Unix.file_descr +val open_connection_unix_fd : string -> Unix.file_descr +type endpoint = { + fd : Unix.file_descr; + mutable buffer : string; + mutable buffer_len : int; +} +exception Process_still_alive +val kill_and_wait : ?signal:int -> ?timeout:float -> int -> unit +val make_endpoint : Unix.file_descr -> endpoint +val proxy : Unix.file_descr -> Unix.file_descr -> unit +val really_read : Unix.file_descr -> string -> int -> int -> unit +val really_write : Unix.file_descr -> string -> int -> int -> unit +val spawnvp : + ?pid_callback:(int -> unit) -> + string -> string array -> Unix.process_status +val double_fork : (unit -> unit) -> unit +external set_tcp_nodelay : Unix.file_descr -> bool -> unit + = "stub_unixext_set_tcp_nodelay" +external fsync : Unix.file_descr -> unit = "stub_unixext_fsync" +external get_max_fd : unit -> int = "stub_unixext_get_max_fd" +val int_of_file_descr : Unix.file_descr -> int +val file_descr_of_int : int -> Unix.file_descr +val close_all_fds_except : Unix.file_descr list -> unit +val get_process_output : ?handler:(string -> int -> string) -> string -> string +val resolve_dot_and_dotdot : string -> string + +type statfs_t = { + statfs_type: int64; + statfs_bsize: int; + statfs_blocks: int64; + statfs_bfree: int64; + statfs_bavail: int64; + statfs_files: int64; + statfs_ffree: int64; + statfs_namelen: int; +} + +val statfs: string -> statfs_t +val get_major_minor : string -> int * int + +module Fdset : sig + type t + val create : unit -> t + external of_list : Unix.file_descr list -> t = "stub_fdset_of_list" + external is_set : t -> Unix.file_descr -> bool = "stub_fdset_is_set" + external set : t -> Unix.file_descr -> unit = "stub_fdset_set" + external clear : t -> Unix.file_descr -> unit = "stub_fdset_clear" + + val select : t -> t -> t -> float -> t * t * t + val select_ro : t -> float -> t +end diff --git a/tools/ocaml/libs/stdext/unixext_stubs.c b/tools/ocaml/libs/stdext/unixext_stubs.c new file mode 100644 index 0000000..cbe1519 --- /dev/null +++ b/tools/ocaml/libs/stdext/unixext_stubs.c @@ -0,0 +1,304 @@ +#include +#include +#include +#include +#include +#include +#include +#include /* needed for _SC_OPEN_MAX */ +#include /* snprintf */ +#include /* needed for caml_condition_timedwait */ + +#include +#include +#include +#include +#include +#include +#include + +static void failwith_errno(void) +{ + char buf[256]; + char buf2[280]; + memset(buf, '\0', sizeof(buf)); + //strerror_r(errno, buf, sizeof(buf)); + snprintf(buf2, sizeof(buf2), "errno: %d msg: %s", errno, buf); + caml_failwith(buf2); +} + +/* Set the TCP_NODELAY flag on a Unix.file_descr */ +CAMLprim value stub_unixext_set_tcp_nodelay (value fd, value bool) +{ + CAMLparam2 (fd, bool); + int c_fd = Int_val(fd); + int opt = (Bool_val(bool)) ? 1 : 0; + if (setsockopt(c_fd, IPPROTO_TCP, TCP_NODELAY, (void *)&opt, sizeof(opt)) != 0){ + failwith_errno(); + } + CAMLreturn(Val_unit); +} + +CAMLprim value stub_unixext_fsync (value fd) +{ + CAMLparam1(fd); + int c_fd = Int_val(fd); + if (fsync(c_fd) != 0) failwith_errno(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_unixext_get_max_fd (value unit) +{ + CAMLparam1 (unit); + long maxfd; + maxfd = sysconf(_SC_OPEN_MAX); + CAMLreturn(Val_int(maxfd)); +} + +#include + +CAMLprim value stub_unixext_statfs(value path) +{ + CAMLparam1(path); + CAMLlocal1(statinfo); + struct statfs info; + + if (statfs(String_val(path), &info)) + failwith_errno(); + + statinfo = caml_alloc_tuple(8); + Store_field(statinfo, 0, caml_copy_int64(info.f_type)); + Store_field(statinfo, 1, Val_int(info.f_bsize)); + Store_field(statinfo, 2, caml_copy_int64(info.f_blocks)); + Store_field(statinfo, 3, caml_copy_int64(info.f_bfree)); + Store_field(statinfo, 4, caml_copy_int64(info.f_bavail)); + Store_field(statinfo, 5, caml_copy_int64(info.f_files)); + Store_field(statinfo, 6, caml_copy_int64(info.f_ffree)); + Store_field(statinfo, 7, Val_int(info.f_namelen)); + + CAMLreturn(statinfo); +} + +#define FDSET_OF_VALUE(v) (&(((struct fdset_t *) v)->fds)) +#define MAXFD_OF_VALUE(v) (((struct fdset_t *) v)->max) +struct fdset_t { fd_set fds; int max; }; + +CAMLprim value stub_fdset_of_list(value l) +{ + CAMLparam1(l); + CAMLlocal1(set); + + set = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + FD_ZERO(FDSET_OF_VALUE(set)); + MAXFD_OF_VALUE(set) = -1; + while (l != Val_int(0)) { + int fd; + fd = Int_val(Field(l, 0)); + FD_SET(fd, FDSET_OF_VALUE(set)); + if (fd > MAXFD_OF_VALUE(set)) + MAXFD_OF_VALUE(set) = fd; + l = Field(l, 1); + } + CAMLreturn(set); +} + +CAMLprim value stub_fdset_is_set(value set, value fd) +{ + CAMLparam2(set, fd); + CAMLreturn(Val_bool(FD_ISSET(Int_val(fd), FDSET_OF_VALUE(set)))); +} + +CAMLprim value stub_fdset_set(value set, value fd) +{ + CAMLparam2(set, fd); + int cfd; + + cfd = Int_val(fd); + FD_SET(cfd, FDSET_OF_VALUE(set)); + if (cfd > MAXFD_OF_VALUE(set)) + MAXFD_OF_VALUE(set) = cfd; + CAMLreturn(Val_unit); +} + +CAMLprim value stub_fdset_clear(value set, value fd) +{ + CAMLparam2(set, fd); + int cfd, d; + + cfd = Int_val(fd); + FD_CLR(cfd, FDSET_OF_VALUE(set)); + if (cfd == MAXFD_OF_VALUE(set)) { + for (d = cfd - 1; d >= 0; d--) { + if (FD_ISSET(d, FDSET_OF_VALUE(set))) { + MAXFD_OF_VALUE(set) = d; + break; + } + } + if (d < 0) + MAXFD_OF_VALUE(set) = -1; + } + CAMLreturn(Val_unit); +} + +void unixext_error(int code) +{ + static value *exn = NULL; + + if (!exn) { + exn = caml_named_value("unixext.unix_error"); + if (!exn) + caml_invalid_argument("unixext.unix_error not initialiazed"); + } + caml_raise_with_arg(*exn, Val_int(code)); +} + +CAMLprim value stub_fdset_select(value rset, value wset, value eset, value t) +{ + CAMLparam4(rset, wset, eset, t); + CAMLlocal4(ret, nrset, nwset, neset); + fd_set r, w, e; + int maxfd; + double tm; + struct timeval tv; + struct timeval *tvp; + int v; + + memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set)); + memcpy(&w, FDSET_OF_VALUE(wset), sizeof(fd_set)); + memcpy(&e, FDSET_OF_VALUE(eset), sizeof(fd_set)); + + maxfd = (MAXFD_OF_VALUE(rset) > MAXFD_OF_VALUE(wset)) + ? MAXFD_OF_VALUE(rset) + : MAXFD_OF_VALUE(wset); + maxfd = (maxfd > MAXFD_OF_VALUE(eset)) ? maxfd : MAXFD_OF_VALUE(eset); + + tm = Double_val(t); + if (tm < 0.0) + tvp = NULL; + else { + tv.tv_sec = (int) tm; + tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); + tvp = &tv; + } + + caml_enter_blocking_section(); + v = select(maxfd + 1, &r, &w, &e, tvp); + caml_leave_blocking_section(); + if (v == -1) + unixext_error(errno); + + nrset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + nwset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + neset = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + + memcpy(FDSET_OF_VALUE(nrset), &r, sizeof(fd_set)); + memcpy(FDSET_OF_VALUE(nwset), &w, sizeof(fd_set)); + memcpy(FDSET_OF_VALUE(neset), &e, sizeof(fd_set)); + MAXFD_OF_VALUE(nrset) = MAXFD_OF_VALUE(rset); + MAXFD_OF_VALUE(nwset) = MAXFD_OF_VALUE(wset); + MAXFD_OF_VALUE(neset) = MAXFD_OF_VALUE(eset); + + ret = caml_alloc_small(3, 0); + Field(ret, 0) = nrset; + Field(ret, 1) = nwset; + Field(ret, 2) = neset; + + CAMLreturn(ret); +} + +CAMLprim value stub_fdset_select_ro(value rset, value t) +{ + CAMLparam2(rset, t); + CAMLlocal1(ret); + fd_set r; + int maxfd; + double tm; + struct timeval tv; + struct timeval *tvp; + int v; + + memcpy(&r, FDSET_OF_VALUE(rset), sizeof(fd_set)); + maxfd = MAXFD_OF_VALUE(rset); + + tm = Double_val(t); + if (tm < 0.0) + tvp = NULL; + else { + tv.tv_sec = (int) tm; + tv.tv_usec = (int) (1e6 * (tm - tv.tv_sec)); + tvp = &tv; + } + + caml_enter_blocking_section(); + v = select(maxfd + 1, &r, NULL, NULL, tvp); + caml_leave_blocking_section(); + if (v == -1) + unixext_error(errno); + + ret = caml_alloc(sizeof(struct fdset_t), Abstract_tag); + memcpy(FDSET_OF_VALUE(ret), &r, sizeof(fd_set)); + + CAMLreturn(ret); +} + +value stub_unixext_get_major_minor(value dpath) +{ + CAMLparam1(dpath); + CAMLlocal1(majmin); + struct stat statbuf; + unsigned major, minor; + int ret; + + ret = stat(String_val(dpath), &statbuf); + if (ret == -1) + caml_failwith("cannot stat path"); + + major = (statbuf.st_rdev & 0xfff00) >> 8; + minor = (statbuf.st_rdev & 0xff) | ((statbuf.st_rdev >> 12) & 0xfff00); + + majmin = caml_alloc_tuple(2); + Store_field(majmin, 0, Val_int(major)); + Store_field(majmin, 1, Val_int(minor)); + CAMLreturn(majmin); +} + +// from otherlibs/systhreads/posix.c +#define Condition_val(v) (* ((pthread_cond_t **) Data_custom_val(v))) +#define Mutex_val(v) (* ((pthread_mutex_t **) Data_custom_val(v))) + +static void caml_pthread_check(int retcode, char *msg) +{ + char * err; + int errlen, msglen; + value str; + + if (retcode == 0) return; + err = strerror(retcode); + msglen = strlen(msg); + errlen = strlen(err); + str = alloc_string(msglen + 2 + errlen); + memmove (&Byte(str, 0), msg, msglen); + memmove (&Byte(str, msglen), ": ", 2); + memmove (&Byte(str, msglen + 2), err, errlen); + raise_sys_error(str); +} + +// from http://caml.inria.fr/mantis/view.php?id=4104 +CAMLprim value caml_condition_timedwait(value v_cnd, value v_mtx, value v_timeo) +{ + CAMLparam2(v_cnd, v_mtx); + int ret; + pthread_cond_t *cnd = Condition_val(v_cnd); + pthread_mutex_t *mtx = Mutex_val(v_mtx); + double timeo = Double_val(v_timeo); + struct timespec ts; + + ts.tv_sec = timeo; + ts.tv_nsec = (timeo - ts.tv_sec) * 1e9; + enter_blocking_section(); + ret = pthread_cond_timedwait(cnd, mtx, &ts); + leave_blocking_section(); + if (ret == ETIMEDOUT) CAMLreturn(Val_false); + caml_pthread_check(ret, "Condition.timedwait"); + CAMLreturn(Val_true); +} diff --git a/tools/ocaml/libs/stdext/vIO.ml b/tools/ocaml/libs/stdext/vIO.ml new file mode 100644 index 0000000..4f6450a --- /dev/null +++ b/tools/ocaml/libs/stdext/vIO.ml @@ -0,0 +1,250 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008-2009 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 backend = { + blksize: int; + read: string -> int -> int -> int; + write: string -> int -> int -> int; + flush: unit -> unit; + close: unit -> unit; + selectable: Unix.file_descr option; +} + +type cache = { + read_cache_size: int; + write_cache_size: int; + read_ring: Qring.t; + write_ring: Qring.t; +} + +type t = { backend: backend; mutable cache: cache; mutable reached_eof: bool } + +exception Cache_not_empty +exception Invalid_cache_size + +let check_cache_size sz = + if sz < 0 || sz > 1024 * 1024 then + raise Invalid_cache_size + +let make rcache wcache backend = + check_cache_size rcache; + check_cache_size wcache; + let cache = { + read_cache_size = rcache; + write_cache_size = wcache; + read_ring = Qring.make rcache; + write_ring = Qring.make wcache; + } in + { backend = backend; cache = cache; reached_eof = false } + +let set_read_cache con sz = + check_cache_size sz; + if Qring.to_consume con.cache.read_ring > 0 then + raise Cache_not_empty; + con.cache <- { + con.cache with read_cache_size = sz; read_ring = Qring.make sz + } + +let set_write_cache con sz = + check_cache_size sz; + if Qring.to_consume con.cache.write_ring > 0 then + raise Cache_not_empty; + con.cache <- { + con.cache with write_cache_size = sz; write_ring = Qring.make sz + } + +let get_fd con = + match con.backend.selectable with + | None -> assert false + | Some fd -> fd + +let read_fill_cache con = + if con.reached_eof then + 0 + else + let tofill = Qring.to_fill con.cache.read_ring in + let toread = min con.backend.blksize tofill in + let s = String.create toread in + let readed = con.backend.read s 0 toread in + if readed = 0 then + con.reached_eof <- true + else + Qring.feed con.cache.read_ring s 0 readed; + readed + +let has_read_cache con = + Qring.to_consume con.cache.read_ring > 0 + +exception Internal_cache_error + +let read_once_nocache con buf index hint = + con.backend.read buf index hint + +let read_once_cache con buf index hint = + let cached = Qring.to_consume con.cache.read_ring in + if cached >= hint then ( + let rhint = Qring.consume_to con.cache.read_ring buf index hint in + if rhint < hint then + raise Internal_cache_error; + hint + ) else ( + if cached > 0 then ( + let rcached = Qring.consume_to con.cache.read_ring buf index cached in + if rcached < cached then + raise Internal_cache_error; + () + ); + let readed = read_fill_cache con in + if readed > 0 then ( + let left = hint - cached in + let len = if readed > left then left else readed in + let rlen = Qring.consume_to con.cache.read_ring buf (index + cached) len in + if rlen < len then + raise Internal_cache_error; + () + ); + min (readed + cached) hint + ) + +let read_once con = + (if con.cache.read_cache_size = 0 then read_once_nocache else read_once_cache) con + +let write_flush_cache con = + let buf = Qring.consume_all con.cache.write_ring in + let len = String.length buf in + if len > 0 then ( + let written = con.backend.write buf 0 len in + if written = 0 then + 0 + else if written = len then + Qring.to_fill con.cache.write_ring + else ( (* 0 < written < len *) + let to_put_back = len - written in + Qring.feed con.cache.write_ring buf written to_put_back; + Qring.to_fill con.cache.write_ring + ) + ) else + 0 + +let write_once_nocache con buf index hint = + con.backend.write buf index hint + +let write_once_cache con buf index hint = + let can_cache = Qring.to_fill con.cache.write_ring in + (* the cache is full, flush it, and fill the cache with the buf as much as we can *) + if can_cache = 0 then ( + let to_fill = write_flush_cache con in + if to_fill > 0 then ( + let len = min hint can_cache in + Qring.feed con.cache.write_ring buf index len; + len + ) else + 0 + (* the cache is empty *) + ) else if can_cache = con.cache.write_cache_size then ( + (* check if we have enough to send a full buf without copying to the cache *) + if can_cache <= hint then ( + let written = con.backend.write buf index hint in + written + ) else ( + Qring.feed con.cache.write_ring buf index hint; + hint + ) + (* the cache contains something, try filling it *) + ) else ( + (* the cache will be full *) + if can_cache <= hint then ( + Qring.feed con.cache.write_ring buf index can_cache; + let to_fill = write_flush_cache con in + ignore to_fill; + can_cache + ) else ( + Qring.feed con.cache.write_ring buf index hint; + hint + ) + ) + +let write_once con = + (if con.cache.write_cache_size = 0 then write_once_nocache else write_once_cache) con + +let do_rw_io f buf index len = + let left = ref len in + let index = ref index in + let end_of_file = ref false in + while !left > 0 && not !end_of_file + do + let ret = f buf !index !left in + if ret = 0 then + end_of_file := true + else if ret > 0 then ( + left := !left - ret; + index := !index + ret; + ) + done; + len - !left + +let read con buf index size = + do_rw_io (read_once con) buf index size + +exception Line_limit_reached +exception Buffer_limit_reached +exception Eof_reached + +let read_line con max = + let buffer = Buffer.create 80 in + let s = String.create 1 in + let found = ref false and i = ref 0 in + while not !found && (max = 0 || !i < max) + do + let n = read_once con s 0 1 in + if n = 0 then + raise Eof_reached; + + if s.[0] = '\n' then + found := true + else ( + i := !i + n; + Buffer.add_string buffer s; + ) + done; + if !i = max then + raise Line_limit_reached; + Buffer.contents buffer + +let readf_eof con f max = + let end_of_file = ref false in + let acc = ref 0 in + let s = String.create 1024 in + while not !end_of_file + do + let ret = read_once con s 0 1024 in + if ret = 0 then + end_of_file := true + else ( + acc := !acc + ret; + if max > 0 && !acc > max then + raise Buffer_limit_reached; + f s 0 ret + ) + done + + +let write con buf index size = + do_rw_io (write_once con) buf index size + +let flush con = while write_flush_cache con > 0 do () done + +let close con = con.backend.close () diff --git a/tools/ocaml/libs/stdext/vIO.mli b/tools/ocaml/libs/stdext/vIO.mli new file mode 100644 index 0000000..6f05c97 --- /dev/null +++ b/tools/ocaml/libs/stdext/vIO.mli @@ -0,0 +1,51 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008-2009 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 backend = { + blksize: int; + read: string -> int -> int -> int; + write: string -> int -> int -> int; + flush: unit -> unit; + close: unit -> unit; + selectable: Unix.file_descr option; +} + +exception Line_limit_reached +exception Eof_reached +exception Invalid_cache_size + +type t + +val make : int -> int -> backend -> t + +val set_read_cache : t -> int -> unit +val set_write_cache : t -> int -> unit + +val has_read_cache : t -> bool + +val get_fd : t -> Unix.file_descr + +val read_once : t -> string -> int -> int -> int +val write_once : t -> string -> int -> int -> int + +val read : t -> string -> int -> int -> int +val write : t -> string -> int -> int -> int + +val read_line : t -> int -> string +val readf_eof : t -> (string -> int -> int -> unit) -> int -> unit + +val flush : t -> unit +val close : t -> unit diff --git a/tools/ocaml/libs/stdext/varmap.ml b/tools/ocaml/libs/stdext/varmap.ml new file mode 100644 index 0000000..3704305 --- /dev/null +++ b/tools/ocaml/libs/stdext/varmap.ml @@ -0,0 +1,26 @@ +(* + * Copyright (C) 2009 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 Failed_assoc of string +exception Failed_revassoc + +type 'a table = (string * 'a) list + +let assoc (table: 'a table) x = + try snd (List.find (fun (a, b) -> x = a) table) + with Not_found -> raise (Failed_assoc x) + +let rev_assoc (table: 'a table) y = + try fst (List.find (fun (a, b) -> y = b) table) + with Not_found -> raise Failed_revassoc diff --git a/tools/ocaml/libs/stdext/varmap.mli b/tools/ocaml/libs/stdext/varmap.mli new file mode 100644 index 0000000..8ce5ebf --- /dev/null +++ b/tools/ocaml/libs/stdext/varmap.mli @@ -0,0 +1,22 @@ +(* + * Copyright (C) 2009 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 Failed_assoc of string +exception Failed_revassoc + +type 'a table = (string * 'a) list + +val assoc : 'a table -> string -> 'a +val rev_assoc : 'a table -> 'a -> string diff --git a/tools/ocaml/libs/uuid/META.in b/tools/ocaml/libs/uuid/META.in new file mode 100644 index 0000000..f33c980 --- /dev/null +++ b/tools/ocaml/libs/uuid/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "Uuid - universal identifer" +archive(byte) = "uuid.cma" +archive(native) = "uuid.cmxa" diff --git a/tools/ocaml/libs/uuid/Makefile b/tools/ocaml/libs/uuid/Makefile new file mode 100644 index 0000000..8ddb0e2 --- /dev/null +++ b/tools/ocaml/libs/uuid/Makefile @@ -0,0 +1,26 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +OBJS = uuid +INTF = $(foreach obj, $(OBJS),$(obj).cmi) +LIBS = uuid.cma uuid.cmxa + +all: $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +uuid_OBJS = $(OBJS) +OCAML_NOC_LIBRARY = uuid + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore uuid META $(INTF) $(LIBS) *.a *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove uuid + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/uuid/uuid.ml b/tools/ocaml/libs/uuid/uuid.ml new file mode 100644 index 0000000..7c25247 --- /dev/null +++ b/tools/ocaml/libs/uuid/uuid.ml @@ -0,0 +1,88 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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-safe UUIDs. *) + +(** Internally, a UUID is simply a string. *) +type 'a t = string + +type cookie = string + +let of_string s = s +let to_string s = s + +(* deprecated: we don't need to duplicate the uuid prefix/suffix *) +let uuid_of_string = of_string +let string_of_uuid = to_string + +let string_of_cookie s = s + +let cookie_of_string s = s + +(** FIXME: using /dev/random is too slow but using /dev/urandom is too + deterministic. *) +let dev_random = "/dev/urandom" + +let read_random n = + let ic = open_in_bin dev_random in + try + let result = Array.init n (fun _ -> input_byte ic) in + close_in ic; + result + with e -> + close_in ic; + raise e + +let uuid_of_int_array uuid = + Printf.sprintf "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x" + uuid.(0) uuid.(1) uuid.(2) uuid.(3) uuid.(4) uuid.(5) + uuid.(6) uuid.(7) uuid.(8) uuid.(9) uuid.(10) uuid.(11) + uuid.(12) uuid.(13) uuid.(14) uuid.(15) + +(** Return a new random UUID *) +let make_uuid() = uuid_of_int_array (read_random 16) + +(** Return a new random, big UUID (hopefully big and random enough to be + unguessable) *) +let make_cookie() = + let bytes = Array.to_list (read_random 64) in + String.concat "" (List.map (Printf.sprintf "%1x") bytes) +(* + let hexencode x = + let nibble x = + char_of_int (if x < 10 + then int_of_char '0' + x + else int_of_char 'a' + (x - 10)) in + let result = String.make (String.length x * 2) ' ' in + for i = 0 to String.length x - 1 do + let byte = int_of_char x.[i] in + result.[i * 2 + 0] <- nibble((byte lsr 4) land 15); + result.[i * 2 + 1] <- nibble((byte lsr 0) land 15); + done; + result in + let n = 64 in + hexencode (String.concat "" (List.map (fun x -> String.make 1 (char_of_int x)) (Array.to_list (read_n_random_bytes n)))) +*) + +let int_array_of_uuid s = + try + let l = ref [] in + Scanf.sscanf s "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x" + (fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 -> + l := [ a0; a1; a2; a3; a4; a5; a6; a7; a8; a9; + a10; a11; a12; a13; a14; a15; ]); + Array.of_list !l + with _ -> invalid_arg "Uuid.int_array_of_uuid" diff --git a/tools/ocaml/libs/uuid/uuid.mli b/tools/ocaml/libs/uuid/uuid.mli new file mode 100644 index 0000000..3b4a937 --- /dev/null +++ b/tools/ocaml/libs/uuid/uuid.mli @@ -0,0 +1,53 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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-safe UUIDs. + Probably need to refactor this; UUIDs are used in two places: + 1. to uniquely name things across the cluster + 2. as secure session IDs + There is the additional constraint that current Xen tools use + a particular format of UUID (the 16 byte variety generated by fresh ()) +*) + +(** A 128-bit UUID referencing a value of type 'a. *) +type 'a t + +(** A 512-bit UUID. *) +type cookie + +(** Create a fresh (unique!) UUID *) +val make_uuid : unit -> 'a t + +(** Create a fresh secure (bigger and hopefully unguessable) UUID *) +val make_cookie : unit -> cookie + +(** Create a type-safe UUID. *) +val of_string : string -> 'a t + +(** Marshal a UUID to a (type-unsafe) string. *) +val to_string : 'a t -> string + +(* deprecated alias for previous one *) +val uuid_of_string : string -> 'a t +val string_of_uuid : 'a t -> string + +val cookie_of_string : string -> cookie + +val string_of_cookie : cookie -> string + +val uuid_of_int_array : int array -> 'a t + +val int_array_of_uuid : 'a t -> int array diff --git a/tools/ocaml/libs/xb/META.in b/tools/ocaml/libs/xb/META.in new file mode 100644 index 0000000..c041010 --- /dev/null +++ b/tools/ocaml/libs/xb/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "XenBus Interface" +archive(byte) = "xb.cma" +archive(native) = "xb.cmxa" diff --git a/tools/ocaml/libs/xb/Makefile b/tools/ocaml/libs/xb/Makefile new file mode 100644 index 0000000..56afb4a --- /dev/null +++ b/tools/ocaml/libs/xb/Makefile @@ -0,0 +1,41 @@ +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 diff --git a/tools/ocaml/libs/xb/op.ml b/tools/ocaml/libs/xb/op.ml new file mode 100644 index 0000000..6ea8fe6 --- /dev/null +++ b/tools/ocaml/libs/xb/op.ml @@ -0,0 +1,84 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 *) +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" diff --git a/tools/ocaml/libs/xb/packet.ml b/tools/ocaml/libs/xb/packet.ml new file mode 100644 index 0000000..74c04bb --- /dev/null +++ b/tools/ocaml/libs/xb/packet.ml @@ -0,0 +1,50 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 diff --git a/tools/ocaml/libs/xb/partial.ml b/tools/ocaml/libs/xb/partial.ml new file mode 100644 index 0000000..3558889 --- /dev/null +++ b/tools/ocaml/libs/xb/partial.ml @@ -0,0 +1,44 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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) diff --git a/tools/ocaml/libs/xb/xb.ml b/tools/ocaml/libs/xb/xb.ml new file mode 100644 index 0000000..4d02376 --- /dev/null +++ b/tools/ocaml/libs/xb/xb.ml @@ -0,0 +1,189 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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") diff --git a/tools/ocaml/libs/xb/xb.mli b/tools/ocaml/libs/xb/xb.mli new file mode 100644 index 0000000..6cbf0a8 --- /dev/null +++ b/tools/ocaml/libs/xb/xb.mli @@ -0,0 +1,83 @@ +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 + +exception End_of_file +exception Eagain +exception Noent +exception Invalid + +type t + +(** queue a packet into the output queue for later sending *) +val queue : t -> Packet.t -> unit + +(** process the output queue, return if a packet has been totally sent *) +val output : t -> bool + +(** process the input queue, return if a packet has been totally received *) +val input : t -> bool + +(** create new connection using a fd interface *) +val open_fd : Unix.file_descr -> t +(** create new connection using a mmap intf and a function to notify eventchn *) +val open_mmap : Mmap.mmap_interface -> (unit -> unit) -> t + +(* close a connection *) +val close : t -> unit + +val is_fd : t -> bool +val is_mmap : t -> bool + +val output_len : t -> int +val has_new_output : t -> bool +val has_old_output : t -> bool +val has_output : t -> bool +val peek_output : t -> Packet.t + +val input_len : t -> int +val has_in_packet : t -> bool +val get_in_packet : t -> Packet.t +val has_more_input : t -> bool + +val is_selectable : t -> bool +val get_fd : t -> Unix.file_descr diff --git a/tools/ocaml/libs/xb/xb_stubs.c b/tools/ocaml/libs/xb/xb_stubs.c new file mode 100644 index 0000000..b4d1ee6 --- /dev/null +++ b/tools/ocaml/libs/xb/xb_stubs.c @@ -0,0 +1,74 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 +#include +#include +#include +#include + +#include +#include +#include +#include +#include +#include + +#define __XEN_TOOLS__ + +#include +#define u32 uint32_t +#include + +CAMLprim value stub_header_size(void) +{ + CAMLparam0(); + CAMLreturn(Val_int(sizeof(struct xsd_sockmsg))); +} + +CAMLprim value stub_header_of_string(value s) +{ + CAMLparam1(s); + CAMLlocal1(ret); + struct xsd_sockmsg *hdr; + + if (caml_string_length(s) != sizeof(struct xsd_sockmsg)) + caml_failwith("xb header incomplete"); + ret = caml_alloc_tuple(4); + hdr = (struct xsd_sockmsg *) String_val(s); + Store_field(ret, 0, Val_int(hdr->tx_id)); + Store_field(ret, 1, Val_int(hdr->req_id)); + Store_field(ret, 2, Val_int(hdr->type)); + Store_field(ret, 3, Val_int(hdr->len)); + CAMLreturn(ret); +} + +CAMLprim value stub_string_of_header(value tid, value rid, value ty, value len) +{ + CAMLparam4(tid, rid, ty, len); + CAMLlocal1(ret); + struct xsd_sockmsg xsd = { + .type = Int_val(ty), + .tx_id = Int_val(tid), + .req_id = Int_val(rid), + .len = Int_val(len), + }; + + ret = caml_alloc_string(sizeof(struct xsd_sockmsg)); + memcpy(String_val(ret), &xsd, sizeof(struct xsd_sockmsg)); + + CAMLreturn(ret); +} diff --git a/tools/ocaml/libs/xb/xs_ring.ml b/tools/ocaml/libs/xb/xs_ring.ml new file mode 100644 index 0000000..00c18d5 --- /dev/null +++ b/tools/ocaml/libs/xb/xs_ring.ml @@ -0,0 +1,18 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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. + *) + +external read: Mmap.mmap_interface -> string -> int -> int = "ml_interface_read" +external write: Mmap.mmap_interface -> string -> int -> int = "ml_interface_write" diff --git a/tools/ocaml/libs/xb/xs_ring_stubs.c b/tools/ocaml/libs/xb/xs_ring_stubs.c new file mode 100644 index 0000000..9aef23e --- /dev/null +++ b/tools/ocaml/libs/xb/xs_ring_stubs.c @@ -0,0 +1,117 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 +#include +#include +#include +#include +#include + +#define __XEN_TOOLS__ + +#include +#define u32 uint32_t +#include + +#include +#include +#include +#include +#include +#include + +#include "mmap_stubs.h" + +#define GET_C_STRUCT(a) ((struct mmap_interface *) a) + +#ifndef xen_mb +#define xen_mb() mb() +#endif + +static int xs_ring_read(struct mmap_interface *interface, + char *buffer, int len) +{ + struct xenstore_domain_interface *intf = interface->addr; + XENSTORE_RING_IDX cons, prod; + int to_read; + + cons = intf->req_cons; + prod = intf->req_prod; + xen_mb(); + if (prod == cons) + return 0; + if (MASK_XENSTORE_IDX(prod) > MASK_XENSTORE_IDX(cons)) + to_read = prod - cons; + else + to_read = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(cons); + if (to_read < len) + len = to_read; + memcpy(buffer, intf->req + MASK_XENSTORE_IDX(cons), len); + xen_mb(); + intf->req_cons += len; + return len; +} + +static int xs_ring_write(struct mmap_interface *interface, + char *buffer, int len) +{ + struct xenstore_domain_interface *intf = interface->addr; + XENSTORE_RING_IDX cons, prod; + int can_write; + + cons = intf->rsp_cons; + prod = intf->rsp_prod; + xen_mb(); + if ( (prod - cons) >= XENSTORE_RING_SIZE ) + return 0; + if (MASK_XENSTORE_IDX(prod) >= MASK_XENSTORE_IDX(cons)) + can_write = XENSTORE_RING_SIZE - MASK_XENSTORE_IDX(prod); + else + can_write = MASK_XENSTORE_IDX(cons) - MASK_XENSTORE_IDX(prod); + if (can_write < len) + len = can_write; + memcpy(intf->rsp + MASK_XENSTORE_IDX(prod), buffer, len); + xen_mb(); + intf->rsp_prod += len; + return len; +} + +CAMLprim value ml_interface_read(value interface, value buffer, value len) +{ + CAMLparam3(interface, buffer, len); + CAMLlocal1(result); + int res; + + res = xs_ring_read(GET_C_STRUCT(interface), + String_val(buffer), Int_val(len)); + if (res == -1) + caml_failwith("huh"); + result = Val_int(res); + CAMLreturn(result); +} + +CAMLprim value ml_interface_write(value interface, value buffer, value len) +{ + CAMLparam3(interface, buffer, len); + CAMLlocal1(result); + int res; + + res = xs_ring_write(GET_C_STRUCT(interface), + String_val(buffer), Int_val(len)); + result = Val_int(res); + CAMLreturn(result); +} diff --git a/tools/ocaml/libs/xc/META.in b/tools/ocaml/libs/xc/META.in new file mode 100644 index 0000000..e46d7dd --- /dev/null +++ b/tools/ocaml/libs/xc/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "Xen Control Interface" +archive(byte) = "xc.cma" +archive(native) = "xc.cmxa" diff --git a/tools/ocaml/libs/xc/Makefile b/tools/ocaml/libs/xc/Makefile new file mode 100644 index 0000000..9e361b5 --- /dev/null +++ b/tools/ocaml/libs/xc/Makefile @@ -0,0 +1,28 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +CFLAGS += -I../mmap -I./ +OCAMLINCLUDE += -I ../mmap -I ../uuid + +OBJS = xc +INTF = xc.cmi +LIBS = xc.cma xc.cmxa + +xc_OBJS = $(OBJS) +xc_C_OBJS = xc_lib xc_stubs + +OCAML_LIBRARY = xc + +all: $(INTF) $(LIBS) + +libs: $(LIBS) + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xc META $(INTF) $(LIBS) *.a *.so *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove xc + +include $(TOPLEVEL)/Makefile.rules diff --git a/tools/ocaml/libs/xc/xc.h b/tools/ocaml/libs/xc/xc.h new file mode 100644 index 0000000..8ef7009 --- /dev/null +++ b/tools/ocaml/libs/xc/xc.h @@ -0,0 +1,191 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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. + */ + +#define __XEN_TOOLS__ + +#include +#include +#include +#include +#include +#include +#if XEN_SYSCTL_INTERFACE_VERSION < 4 +#include +#else +#include +#endif +#include +#include +#include +#include +#include "xc_e820.h" + +typedef xen_domctl_getdomaininfo_t xc_domaininfo_t; +typedef xen_domctl_getvcpuinfo_t xc_vcpuinfo_t; +typedef xen_sysctl_physinfo_t xc_physinfo_t; + +struct xc_core_header { + unsigned int xch_magic; + unsigned int xch_nr_vcpus; + unsigned int xch_nr_pages; + unsigned int xch_ctxt_offset; + unsigned int xch_index_offset; + unsigned int xch_pages_offset; +}; + +typedef union { +#if defined(__i386__) || defined(__x86_64__) + vcpu_guest_context_x86_64_t x64; + vcpu_guest_context_x86_32_t x32; +#endif + vcpu_guest_context_t c; +} vcpu_guest_context_any_t; + +char * xc_error_get(void); +void xc_error_clear(void); + +int xc_using_injection(void); + +int xc_interface_open(void); +int xc_interface_close(int handle); + +int xc_domain_create(int handle, unsigned int ssidref, + xen_domain_handle_t dhandle, + unsigned int flags, unsigned int *pdomid); +int xc_domain_pause(int handle, unsigned int domid); +int xc_domain_unpause(int handle, unsigned int domid); +int xc_domain_resume_fast(int handle, unsigned int domid); +int xc_domain_destroy(int handle, unsigned int domid); +int xc_domain_shutdown(int handle, int domid, int reason); + +int xc_vcpu_setaffinity(int handle, unsigned int domid, int vcpu, + uint64_t cpumap); +int xc_vcpu_getaffinity(int handle, unsigned int domid, int vcpu, + uint64_t *cpumap); + +int xc_domain_getinfolist(int handle, unsigned int first_domain, + unsigned int max_domains, xc_domaininfo_t *info); +int xc_domain_getinfo(int handle, unsigned int first_domain, + xc_domaininfo_t *info); + +int xc_domain_setmaxmem(int handle, unsigned int domid, unsigned int max_memkb); +int xc_domain_set_memmap_limit(int handle, unsigned int domid, + unsigned long map_limitkb); + +int xc_domain_set_time_offset(int handle, unsigned int domid, int time_offset); + +int xc_domain_memory_increase_reservation(int handle, unsigned int domid, + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start); +int xc_domain_memory_decrease_reservation(int handle, unsigned int domid, + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start); +int xc_domain_memory_populate_physmap(int handle, unsigned int domid, + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start); +int xc_domain_setvmxassist(int handle, unsigned int domid, int use_vmxassist); +int xc_domain_max_vcpus(int handle, unsigned int domid, unsigned int max); +int xc_domain_sethandle(int handle, unsigned int domid, + xen_domain_handle_t dhandle); +int xc_vcpu_getinfo(int handle, unsigned int domid, unsigned int vcpu, + xc_vcpuinfo_t *info); +int xc_domain_ioport_permission(int handle, unsigned int domid, + unsigned int first_port, unsigned int nr_ports, + unsigned int allow_access); +int xc_vcpu_setcontext(int handle, unsigned int domid, + unsigned int vcpu, vcpu_guest_context_any_t *ctxt); +int xc_vcpu_getcontext(int handle, unsigned int domid, + unsigned int vcpu, vcpu_guest_context_any_t *ctxt); +int xc_domain_irq_permission(int handle, unsigned int domid, + unsigned char pirq, unsigned char allow_access); +int xc_domain_iomem_permission(int handle, unsigned int domid, + unsigned long first_mfn, unsigned long nr_mfns, + unsigned char allow_access); +long long xc_domain_get_cpu_usage(int handle, unsigned int domid, + unsigned int vcpu); +void *xc_map_foreign_range(int handle, unsigned int domid, + int size, int prot, unsigned long mfn); +int xc_map_foreign_ranges(int handle, unsigned int domid, + privcmd_mmap_entry_t *entries, int nr); +int xc_readconsolering(int handle, char **pbuffer, + unsigned int *pnr_chars, int clear); +int xc_send_debug_keys(int handle, char *keys); +int xc_physinfo(int handle, xc_physinfo_t *put_info); +int xc_pcpu_info(int handle, int max_cpus, uint64_t *info, int *nr_cpus); +int xc_sched_id(int handle, int *sched_id); +int xc_version(int handle, int cmd, void *arg); +int xc_evtchn_alloc_unbound(int handle, unsigned int domid, + unsigned int remote_domid); +int xc_evtchn_reset(int handle, unsigned int domid); + +int xc_sched_credit_domain_set(int handle, unsigned int domid, + struct xen_domctl_sched_credit *sdom); +int xc_sched_credit_domain_get(int handle, unsigned int domid, + struct xen_domctl_sched_credit *sdom); +int xc_shadow_allocation_get(int handle, unsigned int domid, + uint32_t *mb); +int xc_shadow_allocation_set(int handle, unsigned int domid, + uint32_t mb); +int xc_domain_get_pfn_list(int handle, unsigned int domid, + xen_pfn_t *pfn_array, unsigned long max_pfns); +int xc_hvm_check_pvdriver(int handle, unsigned int domid); + +int xc_domain_assign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func); +int xc_domain_deassign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func); +int xc_domain_test_assign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func); +int xc_domain_watchdog(int handle, int id, uint32_t timeout); +int xc_domain_set_machine_address_size(int xc, uint32_t domid, unsigned int width); +int xc_domain_get_machine_address_size(int xc, uint32_t domid); + +int xc_domain_cpuid_set(int xc, unsigned int domid, int hvm, + uint32_t input, uint32_t oinput, + char *config[4], char *config_out[4]); +int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm); +int xc_cpuid_check(uint32_t input, uint32_t optsubinput, + char *config[4], char *config_out[4]); + +int xc_domain_send_s3resume(int handle, unsigned int domid); +int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_align); +int xc_domain_set_hpet(int handle, unsigned int domid, int hpet); +int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode); +int xc_domain_get_acpi_s_state(int handle, unsigned int domid); + +#if XEN_SYSCTL_INTERFACE_VERSION >= 6 +#define SAFEDIV(a, b) (((b) > 0) ? (a) / (b) : (a)) +#define COMPAT_FIELD_physinfo_get_nr_cpus(p) (p).nr_cpus +#define COMPAT_FIELD_physinfo_get_sockets_per_node(p) \ + SAFEDIV((p).nr_cpus, ((p).threads_per_core * (p).cores_per_socket * (p).nr_nodes)) +#else +#define COMPAT_FIELD_physinfo_get_nr_cpus(p) \ + ((p).threads_per_core * (p).sockets_per_node * \ + (p).cores_per_socket * (p).threads_per_core) +#define COMPAT_FIELD_physinfo_get_sockets_per_node(p) (p).sockets_per_node +#endif + +#if __XEN_LATEST_INTERFACE_VERSION__ >= 0x00030209 +#define COMPAT_FIELD_ADDRESS_BITS mem_flags +#else +#define COMPAT_FIELD_ADDRESS_BITS address_bits +#endif diff --git a/tools/ocaml/libs/xc/xc.ml b/tools/ocaml/libs/xc/xc.ml new file mode 100644 index 0000000..b9dd284 --- /dev/null +++ b/tools/ocaml/libs/xc/xc.ml @@ -0,0 +1,340 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 domid = int + +(* ** xenctrl.h ** *) + +type vcpuinfo = +{ + online: bool; + blocked: bool; + running: bool; + cputime: int64; + cpumap: int32; +} + +type domaininfo = +{ + domid : domid; + dying : bool; + shutdown : bool; + paused : bool; + blocked : bool; + running : bool; + hvm_guest : bool; + shutdown_code : int; + total_memory_pages: nativeint; + max_memory_pages : nativeint; + shared_info_frame : int64; + cpu_time : int64; + nr_online_vcpus : int; + max_vcpu_id : int; + ssidref : int32; + handle : int array; +} + +type sched_control = +{ + weight : int; + cap : int; +} + +type physinfo_cap_flag = + | CAP_HVM + | CAP_DirectIO + +type physinfo = +{ + threads_per_core : int; + cores_per_socket : int; + nr_cpus : int; + max_node_id : int; + cpu_khz : int; + total_pages : nativeint; + free_pages : nativeint; + scrub_pages : nativeint; + (* XXX hw_cap *) + capabilities : physinfo_cap_flag list; +} + +type version = +{ + major : int; + minor : int; + extra : string; +} + + +type compile_info = +{ + compiler : string; + compile_by : string; + compile_domain : string; + compile_date : string; +} + +type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt + +type domain_create_flag = CDF_HVM | CDF_HAP + +exception Error of string + +type handle + +(* this is only use by coredumping *) +external sizeof_core_header: unit -> int + = "stub_sizeof_core_header" +external sizeof_vcpu_guest_context: unit -> int + = "stub_sizeof_vcpu_guest_context" +external sizeof_xen_pfn: unit -> int = "stub_sizeof_xen_pfn" +(* end of use *) + +external interface_open: unit -> handle = "stub_xc_interface_open" +external interface_close: handle -> unit = "stub_xc_interface_close" + +external using_injection: unit -> bool = "stub_xc_using_injection" + +let with_intf f = + let xc = interface_open () in + let r = try f xc with exn -> interface_close xc; raise exn in + interface_close xc; + r + +external _domain_create: handle -> int32 -> domain_create_flag list -> int array -> domid + = "stub_xc_domain_create" + +let domain_create handle n flags uuid = + _domain_create handle n flags (Uuid.int_array_of_uuid uuid) + +external _domain_sethandle: handle -> domid -> int array -> unit + = "stub_xc_domain_sethandle" + +let domain_sethandle handle n uuid = + _domain_sethandle handle n (Uuid.int_array_of_uuid uuid) + +external domain_setvmxassist: handle -> domid -> bool -> unit + = "stub_xc_domain_setvmxassist" + +external domain_max_vcpus: handle -> domid -> int -> unit + = "stub_xc_domain_max_vcpus" + +external domain_pause: handle -> domid -> unit = "stub_xc_domain_pause" +external domain_unpause: handle -> domid -> unit = "stub_xc_domain_unpause" +external domain_resume_fast: handle -> domid -> unit = "stub_xc_domain_resume_fast" +external domain_destroy: handle -> domid -> unit = "stub_xc_domain_destroy" + +external domain_shutdown: handle -> domid -> shutdown_reason -> unit + = "stub_xc_domain_shutdown" + +external _domain_getinfolist: handle -> domid -> int -> domaininfo list + = "stub_xc_domain_getinfolist" + +let domain_getinfolist handle first_domain = + let nb = 2 in + let last_domid l = (List.hd l).domid + 1 in + let rec __getlist from = + let l = _domain_getinfolist handle from nb in + (if List.length l = nb then __getlist (last_domid l) else []) @ l + in + List.rev (__getlist first_domain) + +external domain_getinfo: handle -> domid -> domaininfo= "stub_xc_domain_getinfo" + +external domain_get_vcpuinfo: handle -> int -> int -> vcpuinfo + = "stub_xc_vcpu_getinfo" + +external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit + = "stub_xc_domain_ioport_permission" +external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit + = "stub_xc_domain_iomem_permission" +external domain_irq_permission: handle -> domid -> int -> bool -> unit + = "stub_xc_domain_irq_permission" + +external vcpu_affinity_set: handle -> domid -> int -> int64 -> unit + = "stub_xc_vcpu_setaffinity" +external vcpu_affinity_get: handle -> domid -> int -> int64 + = "stub_xc_vcpu_getaffinity" + +external vcpu_context_get: handle -> domid -> int -> string + = "stub_xc_vcpu_context_get" + +external sched_id: handle -> int = "stub_xc_sched_id" + +external sched_credit_domain_set: handle -> domid -> sched_control -> unit + = "stub_sched_credit_domain_set" +external sched_credit_domain_get: handle -> domid -> sched_control + = "stub_sched_credit_domain_get" + +external shadow_allocation_set: handle -> domid -> int -> unit + = "stub_shadow_allocation_set" +external shadow_allocation_get: handle -> domid -> int + = "stub_shadow_allocation_get" + +external evtchn_alloc_unbound: handle -> domid -> domid -> int + = "stub_xc_evtchn_alloc_unbound" +external evtchn_reset: handle -> domid -> unit = "stub_xc_evtchn_reset" + +external readconsolering: handle -> string = "stub_xc_readconsolering" + +external send_debug_keys: handle -> string -> unit = "stub_xc_send_debug_keys" +external physinfo: handle -> physinfo = "stub_xc_physinfo" +external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info" + +external domain_setmaxmem: handle -> domid -> int64 -> unit + = "stub_xc_domain_setmaxmem" +external domain_set_memmap_limit: handle -> domid -> int64 -> unit + = "stub_xc_domain_set_memmap_limit" +external domain_memory_increase_reservation: handle -> domid -> int64 -> unit + = "stub_xc_domain_memory_increase_reservation" + +external domain_set_machine_address_size: handle -> domid -> int -> unit + = "stub_xc_domain_set_machine_address_size" +external domain_get_machine_address_size: handle -> domid -> int + = "stub_xc_domain_get_machine_address_size" + +external domain_cpuid_set: handle -> domid -> bool -> (int64 * (int64 option)) + -> string option array + -> string option array + = "stub_xc_domain_cpuid_set" +external domain_cpuid_apply: handle -> domid -> bool -> unit + = "stub_xc_domain_cpuid_apply" +external cpuid_check: (int64 * (int64 option)) -> string option array -> (bool * string option array) + = "stub_xc_cpuid_check" + +external map_foreign_range: handle -> domid -> int + -> nativeint -> Mmap.mmap_interface + = "stub_map_foreign_range" + +external domain_get_pfn_list: handle -> domid -> nativeint -> nativeint array + = "stub_xc_domain_get_pfn_list" + +external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit + = "stub_xc_domain_assign_device" +external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit + = "stub_xc_domain_deassign_device" +external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool + = "stub_xc_domain_test_assign_device" + +external domain_set_timer_mode: handle -> domid -> int -> unit = "stub_xc_domain_set_timer_mode" +external domain_set_hpet: handle -> domid -> int -> unit = "stub_xc_domain_set_hpet" +external domain_set_vpt_align: handle -> domid -> int -> unit = "stub_xc_domain_set_vpt_align" + +external domain_send_s3resume: handle -> domid -> unit = "stub_xc_domain_send_s3resume" +external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state" + +(** check if some hvm domain got pv driver or not *) +external hvm_check_pvdriver: handle -> domid -> bool + = "stub_xc_hvm_check_pvdriver" + +external version: handle -> version = "stub_xc_version_version" +external version_compile_info: handle -> compile_info + = "stub_xc_version_compile_info" +external version_changeset: handle -> string = "stub_xc_version_changeset" +external version_capabilities: handle -> string = + "stub_xc_version_capabilities" + +external watchdog : handle -> int -> int32 -> int + = "stub_xc_watchdog" + +(* core dump structure *) +type core_magic = Magic_hvm | Magic_pv + +type core_header = { + xch_magic: core_magic; + xch_nr_vcpus: int; + xch_nr_pages: nativeint; + xch_index_offset: int64; + xch_ctxt_offset: int64; + xch_pages_offset: int64; +} + +external marshall_core_header: core_header -> string = "stub_marshall_core_header" + +(* coredump *) +let coredump xch domid fd = + let dump s = + let wd = Unix.write fd s 0 (String.length s) in + if wd <> String.length s then + failwith "error while writing"; + in + + let info = domain_getinfo xch domid in + + let nrpages = info.total_memory_pages in + let ctxt = Array.make info.max_vcpu_id None in + let nr_vcpus = ref 0 in + for i = 0 to info.max_vcpu_id - 1 + do + ctxt.(i) <- try + let v = vcpu_context_get xch domid i in + incr nr_vcpus; + Some v + with _ -> None + done; + + (* FIXME page offset if not rounded to sup *) + let page_offset = + Int64.add + (Int64.of_int (sizeof_core_header () + + (sizeof_vcpu_guest_context () * !nr_vcpus))) + (Int64.of_nativeint ( + Nativeint.mul + (Nativeint.of_int (sizeof_xen_pfn ())) + nrpages) + ) + in + + let header = { + xch_magic = if info.hvm_guest then Magic_hvm else Magic_pv; + xch_nr_vcpus = !nr_vcpus; + xch_nr_pages = nrpages; + xch_ctxt_offset = Int64.of_int (sizeof_core_header ()); + xch_index_offset = Int64.of_int (sizeof_core_header () + + sizeof_vcpu_guest_context ()); + xch_pages_offset = page_offset; + } in + + dump (marshall_core_header header); + for i = 0 to info.max_vcpu_id - 1 + do + match ctxt.(i) with + | None -> () + | Some ctxt_i -> dump ctxt_i + done; + let pfns = domain_get_pfn_list xch domid nrpages in + if Array.length pfns <> Nativeint.to_int nrpages then + failwith "could not get the page frame list"; + + let page_size = Mmap.getpagesize () in + for i = 0 to Nativeint.to_int nrpages - 1 + do + let page = map_foreign_range xch domid page_size pfns.(i) in + let data = Mmap.read page 0 page_size in + Mmap.unmap page; + dump data + done + +(* ** Misc ** *) + +(** + Convert the given number of pages to an amount in KiB, rounded up. + *) +external pages_to_kib : int64 -> int64 = "stub_pages_to_kib" +let pages_to_mib pages = Int64.div (pages_to_kib pages) 1024L + +let _ = Callback.register_exception "xc.error" (Error "register_callback") diff --git a/tools/ocaml/libs/xc/xc.mli b/tools/ocaml/libs/xc/xc.mli new file mode 100644 index 0000000..dc55b67 --- /dev/null +++ b/tools/ocaml/libs/xc/xc.mli @@ -0,0 +1,196 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 domid = int +type vcpuinfo = { + online : bool; + blocked : bool; + running : bool; + cputime : int64; + cpumap : int32; +} +type domaininfo = { + domid : domid; + dying : bool; + shutdown : bool; + paused : bool; + blocked : bool; + running : bool; + hvm_guest : bool; + shutdown_code : int; + total_memory_pages : nativeint; + max_memory_pages : nativeint; + shared_info_frame : int64; + cpu_time : int64; + nr_online_vcpus : int; + max_vcpu_id : int; + ssidref : int32; + handle : int array; +} +type sched_control = { weight : int; cap : int; } +type physinfo_cap_flag = CAP_HVM | CAP_DirectIO +type physinfo = { + threads_per_core : int; + cores_per_socket : int; + nr_cpus : int; + max_node_id : int; + cpu_khz : int; + total_pages : nativeint; + free_pages : nativeint; + scrub_pages : nativeint; + capabilities : physinfo_cap_flag list; +} +type version = { major : int; minor : int; extra : string; } +type compile_info = { + compiler : string; + compile_by : string; + compile_domain : string; + compile_date : string; +} +type shutdown_reason = Poweroff | Reboot | Suspend | Crash | Halt + +type domain_create_flag = CDF_HVM | CDF_HAP + +exception Error of string +type handle +external sizeof_core_header : unit -> int = "stub_sizeof_core_header" +external sizeof_vcpu_guest_context : unit -> int + = "stub_sizeof_vcpu_guest_context" +external sizeof_xen_pfn : unit -> int = "stub_sizeof_xen_pfn" +external interface_open : unit -> handle = "stub_xc_interface_open" +external using_injection : unit -> bool = "stub_xc_using_injection" +external interface_close : handle -> unit = "stub_xc_interface_close" +val with_intf : (handle -> 'a) -> 'a +external _domain_create : handle -> int32 -> domain_create_flag list -> int array -> domid + = "stub_xc_domain_create" +val domain_create : handle -> int32 -> domain_create_flag list -> 'a Uuid.t -> domid +external _domain_sethandle : handle -> domid -> int array -> unit + = "stub_xc_domain_sethandle" +val domain_sethandle : handle -> domid -> 'a Uuid.t -> unit +external domain_setvmxassist: handle -> domid -> bool -> unit + = "stub_xc_domain_setvmxassist" +external domain_max_vcpus : handle -> domid -> int -> unit + = "stub_xc_domain_max_vcpus" +external domain_pause : handle -> domid -> unit = "stub_xc_domain_pause" +external domain_unpause : handle -> domid -> unit = "stub_xc_domain_unpause" +external domain_resume_fast : handle -> domid -> unit + = "stub_xc_domain_resume_fast" +external domain_destroy : handle -> domid -> unit = "stub_xc_domain_destroy" +external domain_shutdown : handle -> domid -> shutdown_reason -> unit + = "stub_xc_domain_shutdown" +external _domain_getinfolist : handle -> domid -> int -> domaininfo list + = "stub_xc_domain_getinfolist" +val domain_getinfolist : handle -> domid -> domaininfo list +external domain_getinfo : handle -> domid -> domaininfo + = "stub_xc_domain_getinfo" +external domain_get_vcpuinfo : handle -> int -> int -> vcpuinfo + = "stub_xc_vcpu_getinfo" +external domain_ioport_permission: handle -> domid -> int -> int -> bool -> unit + = "stub_xc_domain_ioport_permission" +external domain_iomem_permission: handle -> domid -> nativeint -> nativeint -> bool -> unit + = "stub_xc_domain_iomem_permission" +external domain_irq_permission: handle -> domid -> int -> bool -> unit + = "stub_xc_domain_irq_permission" +external vcpu_affinity_set : handle -> domid -> int -> int64 -> unit + = "stub_xc_vcpu_setaffinity" +external vcpu_affinity_get : handle -> domid -> int -> int64 + = "stub_xc_vcpu_getaffinity" +external vcpu_context_get : handle -> domid -> int -> string + = "stub_xc_vcpu_context_get" +external sched_id : handle -> int = "stub_xc_sched_id" +external sched_credit_domain_set : handle -> domid -> sched_control -> unit + = "stub_sched_credit_domain_set" +external sched_credit_domain_get : handle -> domid -> sched_control + = "stub_sched_credit_domain_get" +external shadow_allocation_set : handle -> domid -> int -> unit + = "stub_shadow_allocation_set" +external shadow_allocation_get : handle -> domid -> int + = "stub_shadow_allocation_get" +external evtchn_alloc_unbound : handle -> domid -> domid -> int + = "stub_xc_evtchn_alloc_unbound" +external evtchn_reset : handle -> domid -> unit = "stub_xc_evtchn_reset" +external readconsolering : handle -> string = "stub_xc_readconsolering" +external send_debug_keys : handle -> string -> unit = "stub_xc_send_debug_keys" +external physinfo : handle -> physinfo = "stub_xc_physinfo" +external pcpu_info: handle -> int -> int64 array = "stub_xc_pcpu_info" +external domain_setmaxmem : handle -> domid -> int64 -> unit + = "stub_xc_domain_setmaxmem" +external domain_set_memmap_limit : handle -> domid -> int64 -> unit + = "stub_xc_domain_set_memmap_limit" +external domain_memory_increase_reservation : + handle -> domid -> int64 -> unit + = "stub_xc_domain_memory_increase_reservation" +external map_foreign_range : + handle -> domid -> int -> nativeint -> Mmap.mmap_interface + = "stub_map_foreign_range" +external domain_get_pfn_list : + handle -> domid -> nativeint -> nativeint array + = "stub_xc_domain_get_pfn_list" + +external domain_assign_device: handle -> domid -> (int * int * int * int) -> unit + = "stub_xc_domain_assign_device" +external domain_deassign_device: handle -> domid -> (int * int * int * int) -> unit + = "stub_xc_domain_deassign_device" +external domain_test_assign_device: handle -> domid -> (int * int * int * int) -> bool + = "stub_xc_domain_test_assign_device" + +external domain_set_timer_mode: handle -> domid -> int -> unit = "stub_xc_domain_set_timer_mode" +external domain_set_hpet: handle -> domid -> int -> unit = "stub_xc_domain_set_hpet" +external domain_set_vpt_align: handle -> domid -> int -> unit = "stub_xc_domain_set_vpt_align" + +external domain_send_s3resume: handle -> domid -> unit + = "stub_xc_domain_send_s3resume" +external domain_get_acpi_s_state: handle -> domid -> int = "stub_xc_domain_get_acpi_s_state" + +external hvm_check_pvdriver : handle -> domid -> bool + = "stub_xc_hvm_check_pvdriver" +external version : handle -> version = "stub_xc_version_version" +external version_compile_info : handle -> compile_info + = "stub_xc_version_compile_info" +external version_changeset : handle -> string = "stub_xc_version_changeset" +external version_capabilities : handle -> string + = "stub_xc_version_capabilities" +type core_magic = Magic_hvm | Magic_pv +type core_header = { + xch_magic : core_magic; + xch_nr_vcpus : int; + xch_nr_pages : nativeint; + xch_index_offset : int64; + xch_ctxt_offset : int64; + xch_pages_offset : int64; +} +external marshall_core_header : core_header -> string + = "stub_marshall_core_header" +val coredump : handle -> domid -> Unix.file_descr -> unit +external pages_to_kib : int64 -> int64 = "stub_pages_to_kib" +val pages_to_mib : int64 -> int64 +external watchdog : handle -> int -> int32 -> int + = "stub_xc_watchdog" + +external domain_set_machine_address_size: handle -> domid -> int -> unit + = "stub_xc_domain_set_machine_address_size" +external domain_get_machine_address_size: handle -> domid -> int + = "stub_xc_domain_get_machine_address_size" + +external domain_cpuid_set: handle -> domid -> bool -> (int64 * (int64 option)) + -> string option array + -> string option array + = "stub_xc_domain_cpuid_set" +external domain_cpuid_apply: handle -> domid -> bool -> unit + = "stub_xc_domain_cpuid_apply" +external cpuid_check: (int64 * (int64 option)) -> string option array -> (bool * string option array) + = "stub_xc_cpuid_check" + diff --git a/tools/ocaml/libs/xc/xc_cpufeature.h b/tools/ocaml/libs/xc/xc_cpufeature.h new file mode 100644 index 0000000..047a6c9 --- /dev/null +++ b/tools/ocaml/libs/xc/xc_cpufeature.h @@ -0,0 +1,116 @@ +#ifndef __LIBXC_CPUFEATURE_H +#define __LIBXC_CPUFEATURE_H + +/* Intel-defined CPU features, CPUID level 0x00000001 (edx), word 0 */ +#define X86_FEATURE_FPU (0*32+ 0) /* Onboard FPU */ +#define X86_FEATURE_VME (0*32+ 1) /* Virtual Mode Extensions */ +#define X86_FEATURE_DE (0*32+ 2) /* Debugging Extensions */ +#define X86_FEATURE_PSE (0*32+ 3) /* Page Size Extensions */ +#define X86_FEATURE_TSC (0*32+ 4) /* Time Stamp Counter */ +#define X86_FEATURE_MSR (0*32+ 5) /* Model-Specific Registers, RDMSR, WRMSR */ +#define X86_FEATURE_PAE (0*32+ 6) /* Physical Address Extensions */ +#define X86_FEATURE_MCE (0*32+ 7) /* Machine Check Architecture */ +#define X86_FEATURE_CX8 (0*32+ 8) /* CMPXCHG8 instruction */ +#define X86_FEATURE_APIC (0*32+ 9) /* Onboard APIC */ +#define X86_FEATURE_SEP (0*32+11) /* SYSENTER/SYSEXIT */ +#define X86_FEATURE_MTRR (0*32+12) /* Memory Type Range Registers */ +#define X86_FEATURE_PGE (0*32+13) /* Page Global Enable */ +#define X86_FEATURE_MCA (0*32+14) /* Machine Check Architecture */ +#define X86_FEATURE_CMOV (0*32+15) /* CMOV instruction (FCMOVCC and FCOMI too if FPU present) */ +#define X86_FEATURE_PAT (0*32+16) /* Page Attribute Table */ +#define X86_FEATURE_PSE36 (0*32+17) /* 36-bit PSEs */ +#define X86_FEATURE_PN (0*32+18) /* Processor serial number */ +#define X86_FEATURE_CLFLSH (0*32+19) /* Supports the CLFLUSH instruction */ +#define X86_FEATURE_DS (0*32+21) /* Debug Store */ +#define X86_FEATURE_ACPI (0*32+22) /* ACPI via MSR */ +#define X86_FEATURE_MMX (0*32+23) /* Multimedia Extensions */ +#define X86_FEATURE_FXSR (0*32+24) /* FXSAVE and FXRSTOR instructions (fast save and restore */ + /* of FPU context), and CR4.OSFXSR available */ +#define X86_FEATURE_XMM (0*32+25) /* Streaming SIMD Extensions */ +#define X86_FEATURE_XMM2 (0*32+26) /* Streaming SIMD Extensions-2 */ +#define X86_FEATURE_SELFSNOOP (0*32+27) /* CPU self snoop */ +#define X86_FEATURE_HT (0*32+28) /* Hyper-Threading */ +#define X86_FEATURE_ACC (0*32+29) /* Automatic clock control */ +#define X86_FEATURE_IA64 (0*32+30) /* IA-64 processor */ +#define X86_FEATURE_PBE (0*32+31) /* Pending Break Enable */ + +/* AMD-defined CPU features, CPUID level 0x80000001, word 1 */ +/* Don't duplicate feature flags which are redundant with Intel! */ +#define X86_FEATURE_SYSCALL (1*32+11) /* SYSCALL/SYSRET */ +#define X86_FEATURE_MP (1*32+19) /* MP Capable. */ +#define X86_FEATURE_NX (1*32+20) /* Execute Disable */ +#define X86_FEATURE_MMXEXT (1*32+22) /* AMD MMX extensions */ +#define X86_FEATURE_FFXSR (1*32+25) /* FFXSR instruction optimizations */ +#define X86_FEATURE_PAGE1GB (1*32+26) /* 1Gb large page support */ +#define X86_FEATURE_RDTSCP (1*32+27) /* RDTSCP */ +#define X86_FEATURE_LM (1*32+29) /* Long Mode (x86-64) */ +#define X86_FEATURE_3DNOWEXT (1*32+30) /* AMD 3DNow! extensions */ +#define X86_FEATURE_3DNOW (1*32+31) /* 3DNow! */ + +/* Transmeta-defined CPU features, CPUID level 0x80860001, word 2 */ +#define X86_FEATURE_RECOVERY (2*32+ 0) /* CPU in recovery mode */ +#define X86_FEATURE_LONGRUN (2*32+ 1) /* Longrun power control */ +#define X86_FEATURE_LRTI (2*32+ 3) /* LongRun table interface */ + +/* Other features, Linux-defined mapping, word 3 */ +/* This range is used for feature bits which conflict or are synthesized */ +#define X86_FEATURE_CXMMX (3*32+ 0) /* Cyrix MMX extensions */ +#define X86_FEATURE_K6_MTRR (3*32+ 1) /* AMD K6 nonstandard MTRRs */ +#define X86_FEATURE_CYRIX_ARR (3*32+ 2) /* Cyrix ARRs (= MTRRs) */ +#define X86_FEATURE_CENTAUR_MCR (3*32+ 3) /* Centaur MCRs (= MTRRs) */ +/* cpu types for specific tunings: */ +#define X86_FEATURE_K8 (3*32+ 4) /* Opteron, Athlon64 */ +#define X86_FEATURE_K7 (3*32+ 5) /* Athlon */ +#define X86_FEATURE_P3 (3*32+ 6) /* P3 */ +#define X86_FEATURE_P4 (3*32+ 7) /* P4 */ +#define X86_FEATURE_CONSTANT_TSC (3*32+ 8) /* TSC ticks at a constant rate */ + +/* Intel-defined CPU features, CPUID level 0x00000001 (ecx), word 4 */ +#define X86_FEATURE_XMM3 (4*32+ 0) /* Streaming SIMD Extensions-3 */ +#define X86_FEATURE_DTES64 (4*32+ 2) /* 64-bit Debug Store */ +#define X86_FEATURE_MWAIT (4*32+ 3) /* Monitor/Mwait support */ +#define X86_FEATURE_DSCPL (4*32+ 4) /* CPL Qualified Debug Store */ +#define X86_FEATURE_VMXE (4*32+ 5) /* Virtual Machine Extensions */ +#define X86_FEATURE_SMXE (4*32+ 6) /* Safer Mode Extensions */ +#define X86_FEATURE_EST (4*32+ 7) /* Enhanced SpeedStep */ +#define X86_FEATURE_TM2 (4*32+ 8) /* Thermal Monitor 2 */ +#define X86_FEATURE_SSSE3 (4*32+ 9) /* Supplemental Streaming SIMD Extensions-3 */ +#define X86_FEATURE_CID (4*32+10) /* Context ID */ +#define X86_FEATURE_CX16 (4*32+13) /* CMPXCHG16B */ +#define X86_FEATURE_XTPR (4*32+14) /* Send Task Priority Messages */ +#define X86_FEATURE_PDCM (4*32+15) /* Perf/Debug Capability MSR */ +#define X86_FEATURE_DCA (4*32+18) /* Direct Cache Access */ +#define X86_FEATURE_SSE4_1 (4*32+19) /* Streaming SIMD Extensions 4.1 */ +#define X86_FEATURE_SSE4_2 (4*32+20) /* Streaming SIMD Extensions 4.2 */ +#define X86_FEATURE_POPCNT (4*32+23) /* POPCNT instruction */ +#define X86_FEATURE_HYPERVISOR (4*32+31) /* Running under some hypervisor */ + +/* VIA/Cyrix/Centaur-defined CPU features, CPUID level 0xC0000001, word 5 */ +#define X86_FEATURE_XSTORE (5*32+ 2) /* on-CPU RNG present (xstore insn) */ +#define X86_FEATURE_XSTORE_EN (5*32+ 3) /* on-CPU RNG enabled */ +#define X86_FEATURE_XCRYPT (5*32+ 6) /* on-CPU crypto (xcrypt insn) */ +#define X86_FEATURE_XCRYPT_EN (5*32+ 7) /* on-CPU crypto enabled */ +#define X86_FEATURE_ACE2 (5*32+ 8) /* Advanced Cryptography Engine v2 */ +#define X86_FEATURE_ACE2_EN (5*32+ 9) /* ACE v2 enabled */ +#define X86_FEATURE_PHE (5*32+ 10) /* PadLock Hash Engine */ +#define X86_FEATURE_PHE_EN (5*32+ 11) /* PHE enabled */ +#define X86_FEATURE_PMM (5*32+ 12) /* PadLock Montgomery Multiplier */ +#define X86_FEATURE_PMM_EN (5*32+ 13) /* PMM enabled */ + +/* More extended AMD flags: CPUID level 0x80000001, ecx, word 6 */ +#define X86_FEATURE_LAHF_LM (6*32+ 0) /* LAHF/SAHF in long mode */ +#define X86_FEATURE_CMP_LEGACY (6*32+ 1) /* If yes HyperThreading not valid */ +#define X86_FEATURE_SVME (6*32+ 2) /* Secure Virtual Machine */ +#define X86_FEATURE_EXTAPICSPACE (6*32+ 3) /* Extended APIC space */ +#define X86_FEATURE_ALTMOVCR (6*32+ 4) /* LOCK MOV CR accesses CR+8 */ +#define X86_FEATURE_ABM (6*32+ 5) /* Advanced Bit Manipulation */ +#define X86_FEATURE_SSE4A (6*32+ 6) /* AMD Streaming SIMD Extensions-4a */ +#define X86_FEATURE_MISALIGNSSE (6*32+ 7) /* Misaligned SSE Access */ +#define X86_FEATURE_3DNOWPF (6*32+ 8) /* 3DNow! Prefetch */ +#define X86_FEATURE_OSVW (6*32+ 9) /* OS Visible Workaround */ +#define X86_FEATURE_IBS (6*32+ 10) /* Instruction Based Sampling */ +#define X86_FEATURE_SSE5 (6*32+ 11) /* AMD Streaming SIMD Extensions-5 */ +#define X86_FEATURE_SKINIT (6*32+ 12) /* SKINIT, STGI/CLGI, DEV */ +#define X86_FEATURE_WDT (6*32+ 13) /* Watchdog Timer */ + +#endif /* __LIBXC_CPUFEATURE_H */ diff --git a/tools/ocaml/libs/xc/xc_cpuid.h b/tools/ocaml/libs/xc/xc_cpuid.h new file mode 100644 index 0000000..43743ef --- /dev/null +++ b/tools/ocaml/libs/xc/xc_cpuid.h @@ -0,0 +1,285 @@ +#ifndef XC_CPUID_H +#define XC_CPUID_H + +#ifdef XEN_DOMCTL_set_cpuid + +#include "xc_cpufeature.h" + +#define bitmaskof(idx) (1u << ((idx) & 31)) +#define clear_bit(idx, dst) ((dst) &= ~(1u << ((idx) & 31))) +#define set_bit(idx, dst) ((dst) |= (1u << ((idx) & 31))) + +#define DEF_MAX_BASE 0x00000004u +#define DEF_MAX_EXT 0x80000008u + +static void xc_cpuid(uint32_t eax, uint32_t ecx, uint32_t regs[4]) +{ + unsigned int realecx = (ecx == XEN_CPUID_INPUT_UNUSED) ? 0 : ecx; + asm ( +#ifdef __i386__ + "push %%ebx; cpuid; mov %%ebx,%1; pop %%ebx" +#else + "push %%rbx; cpuid; mov %%ebx,%1; pop %%rbx" +#endif + : "=a" (regs[0]), "=r" (regs[1]), "=c" (regs[2]), "=d" (regs[3]) + : "0" (eax), "2" (realecx)); +} + +enum { CPU_BRAND_INTEL, CPU_BRAND_AMD, CPU_BRAND_UNKNOWN }; + +static int xc_cpuid_brand_get(void) +{ + uint32_t regs[4]; + char str[13]; + uint32_t *istr = (uint32_t *) str; + + xc_cpuid(0, 0, regs); + istr[0] = regs[1]; + istr[1] = regs[3]; + istr[2] = regs[2]; + str[12] = '\0'; + if (strcmp(str, "AuthenticAMD") == 0) { + return CPU_BRAND_AMD; + } else if (strcmp(str, "GenuineIntel") == 0) { + return CPU_BRAND_INTEL; + } else + return CPU_BRAND_UNKNOWN; +} + +static int hypervisor_is_64bit(int xc) +{ + xen_capabilities_info_t xen_caps; + return ((xc_version(xc, XENVER_capabilities, &xen_caps) == 0) && + (strstr(xen_caps, "x86_64") != NULL)); +} + +static void do_hvm_cpuid_policy(int xc, int domid, uint32_t input, uint32_t regs[4]) +{ + unsigned long is_pae; + int brand; + + /* pae ? */ + xc_get_hvm_param(xc, domid, HVM_PARAM_PAE_ENABLED, &is_pae); + is_pae = !!is_pae; + + switch (input) { + case 0x00000000: + if (regs[0] > DEF_MAX_BASE) + regs[0] = DEF_MAX_BASE; + break; + case 0x00000001: + regs[2] &= (bitmaskof(X86_FEATURE_XMM3) | + bitmaskof(X86_FEATURE_SSSE3) | + bitmaskof(X86_FEATURE_CX16) | + bitmaskof(X86_FEATURE_SSE4_1) | + bitmaskof(X86_FEATURE_SSE4_2) | + bitmaskof(X86_FEATURE_POPCNT)); + + regs[2] |= bitmaskof(X86_FEATURE_HYPERVISOR); + + regs[3] &= (bitmaskof(X86_FEATURE_FPU) | + bitmaskof(X86_FEATURE_VME) | + bitmaskof(X86_FEATURE_DE) | + bitmaskof(X86_FEATURE_PSE) | + bitmaskof(X86_FEATURE_TSC) | + bitmaskof(X86_FEATURE_MSR) | + bitmaskof(X86_FEATURE_PAE) | + bitmaskof(X86_FEATURE_MCE) | + bitmaskof(X86_FEATURE_CX8) | + bitmaskof(X86_FEATURE_APIC) | + bitmaskof(X86_FEATURE_SEP) | + bitmaskof(X86_FEATURE_MTRR) | + bitmaskof(X86_FEATURE_PGE) | + bitmaskof(X86_FEATURE_MCA) | + bitmaskof(X86_FEATURE_CMOV) | + bitmaskof(X86_FEATURE_PAT) | + bitmaskof(X86_FEATURE_CLFLSH) | + bitmaskof(X86_FEATURE_MMX) | + bitmaskof(X86_FEATURE_FXSR) | + bitmaskof(X86_FEATURE_XMM) | + bitmaskof(X86_FEATURE_XMM2)); + /* We always support MTRR MSRs. */ + regs[3] |= bitmaskof(X86_FEATURE_MTRR); + + if (!is_pae) + clear_bit(X86_FEATURE_PAE, regs[3]); + break; + case 0x80000000: + if (regs[0] > DEF_MAX_EXT) + regs[0] = DEF_MAX_EXT; + break; + case 0x80000001: + if (!is_pae) + clear_bit(X86_FEATURE_NX, regs[3]); + break; + case 0x80000008: + regs[0] &= 0x0000ffffu; + regs[1] = regs[2] = regs[3] = 0; + break; + case 0x00000002: /* Intel cache info (dumped by AMD policy) */ + case 0x00000004: /* Intel cache info (dumped by AMD policy) */ + case 0x80000002: /* Processor name string */ + case 0x80000003: /* ... continued */ + case 0x80000004: /* ... continued */ + case 0x80000005: /* AMD L1 cache/TLB info (dumped by Intel policy) */ + case 0x80000006: /* AMD L2/3 cache/TLB info ; Intel L2 cache features */ + break; + default: + regs[0] = regs[1] = regs[2] = regs[3] = 0; + break; + } + + brand = xc_cpuid_brand_get(); + if (brand == CPU_BRAND_AMD) { + switch (input) { + case 0x00000001: + /* Mask Intel-only features. */ + regs[2] &= ~(bitmaskof(X86_FEATURE_SSSE3) | + bitmaskof(X86_FEATURE_SSE4_1) | + bitmaskof(X86_FEATURE_SSE4_2)); + break; + + case 0x00000002: + case 0x00000004: + regs[0] = regs[1] = regs[2] = 0; + break; + + case 0x80000001: { + int is_64bit = hypervisor_is_64bit(xc) && is_pae; + + if (!is_pae) + clear_bit(X86_FEATURE_PAE, regs[3]); + clear_bit(X86_FEATURE_PSE36, regs[3]); + + /* Filter all other features according to a whitelist. */ + regs[2] &= ((is_64bit ? bitmaskof(X86_FEATURE_LAHF_LM) : 0) | + bitmaskof(X86_FEATURE_ALTMOVCR) | + bitmaskof(X86_FEATURE_ABM) | + bitmaskof(X86_FEATURE_SSE4A) | + bitmaskof(X86_FEATURE_MISALIGNSSE) | + bitmaskof(X86_FEATURE_3DNOWPF)); + regs[3] &= (0x0183f3ff | /* features shared with 0x00000001:EDX */ + (is_pae ? bitmaskof(X86_FEATURE_NX) : 0) | + (is_64bit ? bitmaskof(X86_FEATURE_LM) : 0) | + bitmaskof(X86_FEATURE_SYSCALL) | + bitmaskof(X86_FEATURE_MP) | + bitmaskof(X86_FEATURE_MMXEXT) | + bitmaskof(X86_FEATURE_FFXSR) | + bitmaskof(X86_FEATURE_3DNOW) | + bitmaskof(X86_FEATURE_3DNOWEXT)); + break; + } + } + } else if (brand == CPU_BRAND_INTEL) { + switch (input) { + case 0x00000001: + /* Mask AMD-only features. */ + regs[2] &= ~(bitmaskof(X86_FEATURE_POPCNT)); + break; + + case 0x00000004: + regs[0] &= 0x3FF; + regs[3] &= 0x3FF; + break; + + case 0x80000001: + { + int is_64bit = hypervisor_is_64bit(xc) && is_pae; + + /* Only a few features are advertised in Intel's 0x80000001. */ + regs[2] &= (is_64bit ? bitmaskof(X86_FEATURE_LAHF_LM) : 0); + regs[3] &= ((is_pae ? bitmaskof(X86_FEATURE_NX) : 0) | + (is_64bit ? bitmaskof(X86_FEATURE_LM) : 0) | + (is_64bit ? bitmaskof(X86_FEATURE_SYSCALL) : 0)); + break; + } + case 0x80000005: + { + regs[0] = regs[1] = regs[2] = 0; + break; + } + } + } +} + +static void do_pv_cpuid_policy(int xc, int domid, uint32_t input, uint32_t regs[4]) +{ + int brand; + int guest_64_bits, xen_64_bits; + int ret; + + ret = xc_domain_get_machine_address_size(xc, domid); + if (ret < 0) + return; + guest_64_bits = (ret == 64); + xen_64_bits = hypervisor_is_64bit(xc); + brand = xc_cpuid_brand_get(); + + if ((input & 0x7fffffff) == 1) { + clear_bit(X86_FEATURE_VME, regs[3]); + clear_bit(X86_FEATURE_PSE, regs[3]); + clear_bit(X86_FEATURE_PGE, regs[3]); + clear_bit(X86_FEATURE_MCE, regs[3]); + clear_bit(X86_FEATURE_MCA, regs[3]); + clear_bit(X86_FEATURE_MTRR, regs[3]); + clear_bit(X86_FEATURE_PSE36, regs[3]); + } + + switch (input) { + case 1: + if (!xen_64_bits || brand == CPU_BRAND_AMD) + clear_bit(X86_FEATURE_SEP, regs[3]); + clear_bit(X86_FEATURE_DS, regs[3]); + clear_bit(X86_FEATURE_ACC, regs[3]); + clear_bit(X86_FEATURE_PBE, regs[3]); + + clear_bit(X86_FEATURE_DTES64, regs[2]); + clear_bit(X86_FEATURE_MWAIT, regs[2]); + clear_bit(X86_FEATURE_DSCPL, regs[2]); + clear_bit(X86_FEATURE_VMXE, regs[2]); + clear_bit(X86_FEATURE_SMXE, regs[2]); + clear_bit(X86_FEATURE_EST, regs[2]); + clear_bit(X86_FEATURE_TM2, regs[2]); + if (!guest_64_bits) + clear_bit(X86_FEATURE_CX16, regs[2]); + clear_bit(X86_FEATURE_XTPR, regs[2]); + clear_bit(X86_FEATURE_PDCM, regs[2]); + clear_bit(X86_FEATURE_DCA, regs[2]); + break; + case 0x80000001: + if (!guest_64_bits) { + clear_bit(X86_FEATURE_LM, regs[3]); + clear_bit(X86_FEATURE_LAHF_LM, regs[2]); + if (brand != CPU_BRAND_AMD) + clear_bit(X86_FEATURE_SYSCALL, regs[3]); + } else + set_bit(X86_FEATURE_SYSCALL, regs[3]); + clear_bit(X86_FEATURE_PAGE1GB, regs[3]); + clear_bit(X86_FEATURE_RDTSCP, regs[3]); + + clear_bit(X86_FEATURE_SVME, regs[2]); + clear_bit(X86_FEATURE_OSVW, regs[2]); + clear_bit(X86_FEATURE_IBS, regs[2]); + clear_bit(X86_FEATURE_SKINIT, regs[2]); + clear_bit(X86_FEATURE_WDT, regs[2]); + break; + case 5: /* MONITOR/MWAIT */ + case 0xa: /* Architectural Performance Monitor Features */ + case 0x8000000a: /* SVM revision and features */ + case 0x8000001b: /* Instruction Based Sampling */ + regs[0] = regs[1] = regs[2] = regs[3] = 0; + break; + } +} + +static void do_cpuid_policy(int xc, int domid, int hvm, uint32_t input, uint32_t regs[4]) +{ + if (hvm) + do_hvm_cpuid_policy(xc, domid, input, regs); + else + do_pv_cpuid_policy(xc, domid, input, regs); +} + +#endif + +#endif diff --git a/tools/ocaml/libs/xc/xc_e820.h b/tools/ocaml/libs/xc/xc_e820.h new file mode 100644 index 0000000..52bbb0f --- /dev/null +++ b/tools/ocaml/libs/xc/xc_e820.h @@ -0,0 +1,20 @@ +#ifndef __XC_E820_H__ +#define __XC_E820_H__ + +#include + +/* + * PC BIOS standard E820 types and structure. + */ +#define E820_RAM 1 +#define E820_RESERVED 2 +#define E820_ACPI 3 +#define E820_NVS 4 + +struct e820entry { + uint64_t addr; + uint64_t size; + uint32_t type; +} __attribute__((packed)); + +#endif /* __XC_E820_H__ */ diff --git a/tools/ocaml/libs/xc/xc_lib.c b/tools/ocaml/libs/xc/xc_lib.c new file mode 100644 index 0000000..7fffc43 --- /dev/null +++ b/tools/ocaml/libs/xc/xc_lib.c @@ -0,0 +1,1502 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#include "xc.h" + +#define PAGE_SHIFT 12 +#define PAGE_SIZE (1UL << PAGE_SHIFT) +#define PAGE_MASK (~(PAGE_SIZE-1)) + +#define MIN(a, b) (((a) < (b)) ? (a) : (b)) + +#define DECLARE_DOMCTL(_cmd, _domain) \ + struct xen_domctl domctl = { \ + .cmd = _cmd, \ + .domain = _domain, \ + .interface_version = XEN_DOMCTL_INTERFACE_VERSION, \ + } + +#define DECLARE_SYSCTL(_cmd) \ + struct xen_sysctl sysctl = { \ + .cmd = _cmd, \ + .interface_version = XEN_SYSCTL_INTERFACE_VERSION, \ + } + +#define DECLARE_HYPERCALL2(_cmd, _arg0, _arg1) \ + privcmd_hypercall_t hypercall = { \ + .op = _cmd, \ + .arg[0] = (unsigned long) _arg0,\ + .arg[1] = (unsigned long) _arg1,\ + } +#define DECLARE_HYPERCALL0(_cmd) DECLARE_HYPERCALL2(_cmd, 0, 0); +#define DECLARE_HYPERCALL1(_cmd, _arg0) DECLARE_HYPERCALL2(_cmd, _arg0, 0); + +/*---- Errors handlings ----*/ +#ifndef WITHOUT_GOOD_ERROR +#define ERROR_STRLEN 256 + +static char __error_str[ERROR_STRLEN]; + +char * xc_error_get(void) +{ + return __error_str; +} + +static void xc_error_set(const char *fmt, ...) +{ + va_list ap; + char __errordup[ERROR_STRLEN]; + + va_start(ap, fmt); + vsnprintf(__errordup, ERROR_STRLEN, fmt, ap); + va_end(ap); + memcpy(__error_str, __errordup, ERROR_STRLEN); +} + +static void xc_error_dom_set(unsigned int domid, const char *fmt, ...) +{ + va_list ap; + char __errordup[ERROR_STRLEN]; + int i; + + i = snprintf(__errordup, ERROR_STRLEN, "domain %u - ", domid); + va_start(ap, fmt); + i += vsnprintf(__errordup + i, ERROR_STRLEN - i, fmt, ap); + va_end(ap); + snprintf(__errordup + i, ERROR_STRLEN - i, + " failed: %s", xc_error_get()); + memcpy(__error_str, __errordup, ERROR_STRLEN); +} + +void xc_error_clear(void) +{ + memset(__error_str, '\0', ERROR_STRLEN); +} +#else +char * xc_error_get(void) +{ + return ""; +} +#define xc_error_set(fmt, ...) do {} while (0) +#define xc_error_dom_set(id, fmt, ...) do {} while (0) +#define xc_error_clear() do {} while (0) +#endif + +#define xc_error_hypercall(_h, _r) \ + xc_error_set("hypercall %lld fail: %d: %s (ret %d)", _h.op, errno, errno ? strerror(errno) : strerror(-_r), _r) + +int xc_using_injection(void) +{ + return 0; +} + +/*---- Trivia ----*/ +int xc_interface_open(void) +{ + int fd, ret; + + fd = open("/proc/xen/privcmd", O_RDWR); + if (fd == -1) { + xc_error_set("open /proc/xen/privcmd failed: %s", + strerror(errno)); + return -1; + } + + ret = fcntl(fd, F_GETFD); + if (ret < 0) { + xc_error_set("cannot get handle flags: %s", + strerror(errno)); + goto out; + } + + ret = fcntl(fd, F_SETFD, ret | FD_CLOEXEC); + if (ret < 0) { + xc_error_set("cannot set handle flags: %s", + strerror(errno)); + goto out; + } + + return fd; +out: + close(fd); + return -1; +} + +int xc_interface_close(int handle) +{ + int ret; + + ret = close(handle); + if (ret != 0) + xc_error_set("close xc failed: %s", strerror(errno)); + return ret; +} + +/*---- Low private operations ----*/ +static int do_xen_hypercall(int handle, privcmd_hypercall_t *hypercall) +{ + return ioctl(handle, IOCTL_PRIVCMD_HYPERCALL, (unsigned long) hypercall); +} + +static int do_domctl(int handle, struct xen_domctl *domctl) +{ + int ret; + DECLARE_HYPERCALL1(__HYPERVISOR_domctl, domctl); + + if (mlock(domctl, sizeof(*domctl)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret < 0) + xc_error_hypercall(hypercall, ret); + + munlock(domctl, sizeof(*domctl)); + return ret; +} + +static int do_sysctl(int handle, struct xen_sysctl *sysctl) +{ + int ret; + DECLARE_HYPERCALL1(__HYPERVISOR_sysctl, sysctl); + + if (mlock(sysctl, sizeof(*sysctl)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret < 0) + xc_error_hypercall(hypercall, ret); + + munlock(sysctl, sizeof(*sysctl)); + return ret; +} + +static int do_evtchnctl(int handle, int cmd, void *arg, size_t arg_size) +{ + DECLARE_HYPERCALL2(__HYPERVISOR_event_channel_op, cmd, arg); + int ret; + + if (mlock(arg, arg_size) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret < 0) + xc_error_hypercall(hypercall, ret); + munlock(arg, arg_size); + return ret; +} + +static int do_memctl_reservation(int handle, int cmd, + struct xen_memory_reservation *reservation) +{ + int ret; + DECLARE_HYPERCALL2(__HYPERVISOR_memory_op, cmd, reservation); + xen_pfn_t *extent_start; + + if (cmd != XENMEM_increase_reservation && + cmd != XENMEM_decrease_reservation && + cmd != XENMEM_populate_physmap) { + xc_error_set("do_memctl_reservation: unknown cmd %d", cmd); + return -EINVAL; + } + + if (mlock(reservation, sizeof(*reservation)) == -1) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -ENOMEM; + } + get_xen_guest_handle(extent_start, reservation->extent_start); + if (extent_start && mlock(extent_start, reservation->nr_extents + * sizeof(xen_pfn_t)) == -1) { + xc_error_set("mlock failed: %s", strerror(errno)); + munlock(reservation, sizeof(*reservation)); + return -3; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + munlock(extent_start, reservation->nr_extents * sizeof(xen_pfn_t)); + get_xen_guest_handle(extent_start, reservation->extent_start); + munlock(reservation, sizeof(*reservation)); + return ret; +} + +static int do_ioctl(int handle, int cmd, void *arg) +{ + return ioctl(handle, cmd, arg); +} + +static void * do_mmap(void *start, size_t length, int prot, int flags, + int fd, off_t offset) +{ + return mmap(start, length, prot, flags, fd, offset); +} + +int xc_get_hvm_param(int handle, unsigned int domid, + int param, unsigned long *value) +{ + struct xen_hvm_param arg = { + .domid = domid, + .index = param, + }; + DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_get_param, + (unsigned long) &arg); + int ret; + + if (mlock(&arg, sizeof(arg)) == -1) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + *value = arg.value; + munlock(&arg, sizeof(arg)); + return ret; +} + +static int xc_set_hvm_param(int handle, unsigned int domid, + int param, unsigned long value) +{ + struct xen_hvm_param arg = { + .domid = domid, + .index = param, + .value = value, + }; + DECLARE_HYPERCALL2(__HYPERVISOR_hvm_op, HVMOP_set_param, (unsigned long) &arg); + int ret; + + if (mlock(&arg, sizeof(arg)) == -1) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + munlock(&arg, sizeof(arg)); + return ret; +} + + +/*---- XC API ----*/ +int xc_domain_create(int handle, unsigned int ssidref, + xen_domain_handle_t dhandle, + unsigned int flags, unsigned int *pdomid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_createdomain, *pdomid); + domctl.u.createdomain.ssidref = ssidref; + domctl.u.createdomain.flags = flags; + memcpy(domctl.u.createdomain.handle, dhandle, sizeof(xen_domain_handle_t)); + + ret = do_domctl(handle, &domctl); + if (ret != 0) { + xc_error_set("creating domain failed: %s", xc_error_get()); + return ret; + } + *pdomid = domctl.domain; + return 0; +} + +int xc_domain_pause(int handle, unsigned int domid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_pausedomain, domid); + + ret = do_domctl(handle, &domctl); + if (ret != 0) + xc_error_dom_set(domid, "pause"); + return ret; +} + +int xc_domain_unpause(int handle, unsigned int domid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_unpausedomain, domid); + + ret = do_domctl(handle, &domctl); + if (ret != 0) + xc_error_dom_set(domid, "unpause"); + return ret; +} + +/* return 1 if hvm domain got pv driver, 0 if not. -1 is error occurs */ +int xc_hvm_check_pvdriver(int handle, unsigned int domid) +{ + int ret; + unsigned long irq = 0; + xc_domaininfo_t info; + + ret = xc_domain_getinfolist(handle, domid, 1, &info); + if (ret != 1) { + xc_error_set("domain getinfo failed: %s", strerror(errno)); + xc_error_dom_set(domid, "hvm_check_pvdriver"); + return -1; + } + + if (!(info.flags & XEN_DOMINF_hvm_guest)) { + xc_error_set("domain is not hvm"); + xc_error_dom_set(domid, "hvm_check_pvdriver"); + return -1; + } + xc_get_hvm_param(handle, domid, HVM_PARAM_CALLBACK_IRQ, &irq); + return irq; +} + +static int modify_returncode_register(int handle, unsigned int domid) +{ + int ret; + xc_domaininfo_t info; + xen_capabilities_info_t caps; + vcpu_guest_context_any_t context; + + ret = xc_domain_getinfolist(handle, domid, 1, &info); + if (ret != 1) { + xc_error_set("domain getinfo failed: %s", strerror(errno)); + return -1; + } + + /* HVM guests without PV drivers do not have a return code to modify */ + if (info.flags & XEN_DOMINF_hvm_guest) { + unsigned long irq = 0; + xc_get_hvm_param(handle, domid, HVM_PARAM_CALLBACK_IRQ, &irq); + if (!irq) + return 0; + } + + ret = xc_version(handle, XENVER_capabilities, &caps); + if (ret) { + xc_error_set("could not get Xen capabilities"); + return ret; + } + + ret = xc_vcpu_getcontext(handle, domid, 0, &context); + if (ret) { + xc_error_set("could not get vcpu 0 context"); + return ret; + } + + if (!(info.flags & XEN_DOMINF_hvm_guest)) + context.c.user_regs.eax = 1; + else if (strstr(caps, "x86_64")) + context.x64.user_regs.eax = 1; + else + context.x32.user_regs.eax = 1; + + ret = xc_vcpu_setcontext(handle, domid, 0, &context); + if (ret) { + xc_error_set("could not set vcpu 0 context"); + return ret; + } + return 0; +} + +int xc_domain_resume_fast(int handle, unsigned int domid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_resumedomain, domid); + + ret = modify_returncode_register(handle, domid); + if (ret != 0) { + xc_error_dom_set(domid, "resume_fast"); + return ret; + } + + ret = do_domctl(handle, &domctl); + if (ret != 0) + xc_error_dom_set(domid, "resume_fast"); + return ret; +} + +int xc_domain_destroy(int handle, unsigned int domid) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_destroydomain, domid); + + do { + ret = do_domctl(handle, &domctl); + } while (ret && (errno == EAGAIN)); + if (ret != 0) + xc_error_dom_set(domid, "destroy"); + return ret; +} + +int xc_domain_shutdown(int handle, int domid, int reason) +{ + sched_remote_shutdown_t arg = { + .domain_id = domid, + .reason = reason, + }; + DECLARE_HYPERCALL2(__HYPERVISOR_sched_op, SCHEDOP_remote_shutdown, &arg); + int ret; + + if (mlock(&arg, sizeof(arg)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + xc_error_dom_set(domid, "shutdown %d", reason); + return -1; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret < 0) { + xc_error_hypercall(hypercall, ret); + xc_error_dom_set(domid, "shutdown %d", reason); + } + munlock(&arg, sizeof(arg)); + return ret; +} + +int xc_vcpu_setaffinity(int handle, unsigned int domid, int vcpu, + uint64_t cpumap) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_setvcpuaffinity, domid); + domctl.u.vcpuaffinity.vcpu = vcpu; + domctl.u.vcpuaffinity.cpumap.nr_cpus = sizeof(cpumap) * 8; + + set_xen_guest_handle(domctl.u.vcpuaffinity.cpumap.bitmap, (uint8_t *) &cpumap); + + if (mlock(&cpumap, sizeof(cpumap)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + xc_error_dom_set(domid, "vcpu %d set affinity", vcpu); + return -1; + } + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "vcpu %d set affinity", vcpu); + munlock(&cpumap, sizeof(cpumap)); + return ret; +} + +int xc_vcpu_getaffinity(int handle, unsigned int domid, int vcpu, + uint64_t *cpumap) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getvcpuaffinity, domid); + domctl.u.vcpuaffinity.vcpu = vcpu; + domctl.u.vcpuaffinity.cpumap.nr_cpus = sizeof(*cpumap) * 8; + + set_xen_guest_handle(domctl.u.vcpuaffinity.cpumap.bitmap, cpumap); + + if (mlock(cpumap, sizeof(*cpumap)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + xc_error_dom_set(domid, "vcpu %d get affinity", vcpu); + return -1; + } + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "vcpu %d get affinity", vcpu); + munlock(cpumap, sizeof(*cpumap)); + return ret; +} + +int xc_vcpu_context_get(int handle, unsigned int domid, unsigned short vcpu, + struct vcpu_guest_context *ctxt) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getvcpucontext, domid); + domctl.u.vcpucontext.vcpu = vcpu; + + set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt); + + if (mlock(ctxt, sizeof(struct vcpu_guest_context)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + xc_error_dom_set(domid, "vcpu %d get context", vcpu); + return -1; + } + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "vcpu %d get context", vcpu); + munlock(ctxt, sizeof(struct vcpu_guest_context)); + + return ret; +} + +int xc_domain_getinfolist(int handle, unsigned int first_domain, + unsigned int max_domains, xc_domaininfo_t *info) +{ + int ret; + DECLARE_SYSCTL(XEN_SYSCTL_getdomaininfolist); + sysctl.u.getdomaininfolist.first_domain = first_domain; + sysctl.u.getdomaininfolist.max_domains = max_domains; + set_xen_guest_handle(sysctl.u.getdomaininfolist.buffer, info); + + if (mlock(info, max_domains * sizeof(xc_domaininfo_t)) != 0) { + xc_error_set("getinfolist(%d, %u, %u, %x (%d)) failed: mlock failed: %s", + handle, first_domain, max_domains, info, sizeof(xc_domaininfo_t), + strerror(errno)); + return -1; + } + + ret = do_sysctl(handle, &sysctl); + if (ret < 0) + xc_error_set("getinfolist(%d, %u, %u, %x (%d)) failed: %s", + handle, first_domain, max_domains, info, sizeof(xc_domaininfo_t), + xc_error_get()); + else + ret = sysctl.u.getdomaininfolist.num_domains; + + munlock(info, max_domains * sizeof(xc_domaininfo_t)); + return ret; +} + +int xc_domain_getinfo(int handle, unsigned int domid, xc_domaininfo_t *info) +{ + int ret; + ret = xc_domain_getinfolist(handle, domid, 1, info); + if (ret != 1) { + xc_error_set("getinfo failed: domain %d: %s", domid, xc_error_get()); + return -1; + } + + /* If the requested domain didn't exist but there exists one with a + higher domain ID, this will be returned. We consider this an error since + we only wanted info about a specific domain. */ + if (info->domain != domid) { + xc_error_set("getinfo failed: domain %d nolonger exists", domid); + return -1; + } + + return 0; +} + +int xc_domain_setmaxmem(int handle, unsigned int domid, unsigned int max_memkb) +{ + DECLARE_DOMCTL(XEN_DOMCTL_max_mem, domid); + domctl.u.max_mem.max_memkb = max_memkb; + int ret; + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "set max memory to %u", max_memkb); + return ret; +} + +int xc_domain_set_memmap_limit(int handle, unsigned int domid, + unsigned long map_limitkb) +{ + int ret; + struct xen_foreign_memory_map fmap = { + .domid = domid, + .map = { .nr_entries = 1 } + }; + struct e820entry e820 = { + .addr = 0, + .size = (uint64_t)map_limitkb << 10, + .type = E820_RAM + }; + DECLARE_HYPERCALL2(__HYPERVISOR_memory_op, XENMEM_set_memory_map, &fmap); + + set_xen_guest_handle(fmap.map.buffer, &e820); + + if (mlock(&fmap, sizeof(fmap)) != 0) { + xc_error_set("set_memmap_limit failed: mlock failed: %s", + strerror(errno)); + return -1; + } + + if (mlock(&e820, sizeof(e820)) != 0) { + xc_error_set("set_memmap_limit failed: mlock failed: %s", + strerror(errno)); + munlock(&fmap, sizeof(fmap)); + return -1; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + + munlock(&e820, sizeof(e820)); + munlock(&fmap, sizeof(fmap)); + return ret; +} + +int xc_domain_set_time_offset(int handle, unsigned int domid, int time_offset) +{ + DECLARE_DOMCTL(XEN_DOMCTL_settimeoffset, domid); + domctl.u.settimeoffset.time_offset_seconds = time_offset; + int ret; + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "set time offset %d", time_offset); + return ret; +} + +int xc_domain_memory_increase_reservation(int handle, unsigned int domid, + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start) +{ + int ret; + struct xen_memory_reservation reservation = { + .nr_extents = nr_extents, + .extent_order = extent_order, + .COMPAT_FIELD_ADDRESS_BITS = address_bits, + .domid = domid + }; + + set_xen_guest_handle(reservation.extent_start, extent_start); + + ret = do_memctl_reservation(handle, XENMEM_increase_reservation, + &reservation); + if (ret != nr_extents) { + xc_error_dom_set(domid, "increase reservation to %lu", + nr_extents); + return (ret >= 0) ? -1 : ret; + } + return 0; +} + +int xc_domain_memory_decrease_reservation(int handle, unsigned int domid, + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start) +{ + int ret; + struct xen_memory_reservation reservation = { + .nr_extents = nr_extents, + .extent_order = extent_order, + .COMPAT_FIELD_ADDRESS_BITS = 0, + .domid = domid + }; + + set_xen_guest_handle(reservation.extent_start, extent_start); + if (!extent_start) { + xc_error_set("decrease reservation: extent start is NULL"); + return -EINVAL; + } + + ret = do_memctl_reservation(handle, XENMEM_decrease_reservation, + &reservation); + if (ret < nr_extents) { + xc_error_dom_set(domid, "decrease reservation to %lu", + nr_extents); + return (ret >= 0) ? -1 : ret; + } + return 0; +} + +int xc_domain_memory_populate_physmap(int handle, unsigned int domid, + unsigned long nr_extents, + unsigned int extent_order, + unsigned int address_bits, + xen_pfn_t *extent_start) +{ + int ret; + struct xen_memory_reservation reservation = { + .nr_extents = nr_extents, + .extent_order = extent_order, + .COMPAT_FIELD_ADDRESS_BITS = address_bits, + .domid = domid + }; + + set_xen_guest_handle(reservation.extent_start, extent_start); + ret = do_memctl_reservation(handle, XENMEM_populate_physmap, + &reservation); + if (ret < nr_extents) { + xc_error_dom_set(domid, "populate physmap"); + return (ret >= 0) ? -1 : ret; + } + return 0; +} + +int xc_domain_setvmxassist(int handle, unsigned int domid, int use_vmxassist) +{ + int ret = 0; +#ifdef XEN_DOMCTL_setvmxassist + DECLARE_DOMCTL(XEN_DOMCTL_setvmxassist, domid); + domctl.u.setvmxassist.use_vmxassist = use_vmxassist; + + ret = do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "setting vmxassist to %d", + use_vmxassist); +#endif + return ret; +} + +int xc_domain_max_vcpus(int handle, unsigned int domid, unsigned int max) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_max_vcpus, domid); + domctl.u.max_vcpus.max = max; + + ret = do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "setting max vcpus to %d", max); + return ret; +} + +int xc_domain_sethandle(int handle, unsigned int domid, + xen_domain_handle_t dhandle) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_setdomainhandle, domid); + memcpy(domctl.u.setdomainhandle.handle, dhandle, sizeof(xen_domain_handle_t)); + + ret = do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "set handle"); + return ret; +} + +int xc_vcpu_getinfo(int handle, unsigned int domid, unsigned int vcpu, + xc_vcpuinfo_t *info) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getvcpuinfo, domid); + domctl.u.getvcpuinfo.vcpu = vcpu; + + ret = do_domctl(handle, &domctl); + if (ret < 0) { + xc_error_dom_set(domid, "vcpu %u getinfo", vcpu); + return ret; + } + memcpy(info, &domctl.u.getvcpuinfo, sizeof(*info)); + return ret; +} + +int xc_domain_ioport_permission(int handle, unsigned int domid, + unsigned int first_port, unsigned int nr_ports, + unsigned int allow_access) +{ + DECLARE_DOMCTL(XEN_DOMCTL_ioport_permission, domid); + domctl.u.ioport_permission.first_port = first_port; + domctl.u.ioport_permission.nr_ports = nr_ports; + domctl.u.ioport_permission.allow_access = allow_access; + + return do_domctl(handle, &domctl); +} + +int xc_vcpu_getcontext(int handle, unsigned int domid, + unsigned int vcpu, vcpu_guest_context_any_t *ctxt) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getvcpucontext, domid); + domctl.u.vcpucontext.vcpu = vcpu; + set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt); + + if (mlock(ctxt, sizeof(*ctxt)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "vcpu %u getcontext", vcpu); + munlock(ctxt, sizeof(*ctxt)); + return ret; +} + +int xc_vcpu_setcontext(int handle, unsigned int domid, + unsigned int vcpu, vcpu_guest_context_any_t *ctxt) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_setvcpucontext, domid); + domctl.u.vcpucontext.vcpu = vcpu; + set_xen_guest_handle(domctl.u.vcpucontext.ctxt, ctxt); + + if (mlock(ctxt, sizeof(*ctxt)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "vcpu %u setcontext", vcpu); + + munlock(ctxt, sizeof(*ctxt)); + return ret; +} + +int xc_domain_irq_permission(int handle, unsigned int domid, + unsigned char pirq, unsigned char allow_access) +{ + DECLARE_DOMCTL(XEN_DOMCTL_irq_permission, domid); + domctl.u.irq_permission.pirq = pirq; + domctl.u.irq_permission.allow_access = allow_access; + int ret; + + ret = do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "irq permission %u to %u", + pirq, allow_access); + return ret; +} + +int xc_domain_iomem_permission(int handle, unsigned int domid, + unsigned long first_mfn, unsigned long nr_mfns, + unsigned char allow_access) +{ + DECLARE_DOMCTL(XEN_DOMCTL_iomem_permission, domid); + domctl.u.iomem_permission.first_mfn = first_mfn; + domctl.u.iomem_permission.nr_mfns = nr_mfns; + domctl.u.iomem_permission.allow_access = allow_access; + int ret; + + ret = do_domctl(handle, &domctl); + if (ret) + xc_error_dom_set(domid, "iomem permission [%lu, %lu] to %u", + first_mfn, first_mfn + nr_mfns, allow_access); + return ret; +} + +long long xc_domain_get_cpu_usage(int handle, unsigned int domid, + unsigned int vcpu) +{ + DECLARE_DOMCTL(XEN_DOMCTL_getvcpuinfo, domid); + domctl.u.getvcpuinfo.vcpu = vcpu; + + if (do_domctl(handle, &domctl) < 0) { + xc_error_dom_set(domid, "get cpu %d usage", vcpu); + return -1; + } + return domctl.u.getvcpuinfo.cpu_time; +} + +void *xc_map_foreign_range(int handle, unsigned int domid, + int size, int prot, unsigned long mfn) +{ + privcmd_mmap_entry_t entry = { + .mfn = mfn, + .npages = (size + PAGE_SIZE - 1) >> PAGE_SHIFT, + }; + privcmd_mmap_t ioctlx = { + .num = 1, + .dom = domid, + .entry = &entry, + }; + void *addr; + + addr = do_mmap(NULL, size, prot, MAP_SHARED, handle, 0); + if (addr == MAP_FAILED) { + xc_error_set("mmap failed: %s", strerror(errno)); + xc_error_dom_set(domid, "map foreign range [%lx,%lx] prot %u", + mfn, mfn + size, prot); + return NULL; + } + entry.va = (unsigned long) addr; + if (do_ioctl(handle, IOCTL_PRIVCMD_MMAP, &ioctlx) < 0) { + xc_error_set("ioctl failed: %s", strerror(errno)); + xc_error_dom_set(domid, "map foreign range [%lx,%lx] prot %u", + mfn, mfn + size, prot); + munmap(addr, size); + return NULL; + } + return addr; +} + +int xc_map_foreign_ranges(int handle, unsigned int domid, + privcmd_mmap_entry_t *entries, int nr) +{ + privcmd_mmap_t ioctlx = { + .num = nr, + .dom = domid, + .entry = entries, + }; + int ret; + + ret = do_ioctl(handle, IOCTL_PRIVCMD_MMAP, &ioctlx); + if (ret < 0) { + xc_error_set("ioctl failed: %s", strerror(errno)); + xc_error_dom_set(domid, "map foreign ranges"); + return -1; + } + return ret; +} + +int xc_readconsolering(int handle, char **pbuffer, + unsigned int *pnr_chars, int clear) +{ + int ret; + DECLARE_SYSCTL(XEN_SYSCTL_readconsole); + char *buffer = *pbuffer; + unsigned int nr_chars = *pnr_chars; + + set_xen_guest_handle(sysctl.u.readconsole.buffer, buffer); + sysctl.u.readconsole.count = nr_chars; + sysctl.u.readconsole.clear = clear; + + if (mlock(buffer, nr_chars) != 0) { + xc_error_set("read console ring: mlock failed: %s", + strerror(errno)); + return -1; + } + + ret = do_sysctl(handle, &sysctl); + if (ret != 0) + xc_error_set("read console ring failed: %s", xc_error_get()); + else + *pnr_chars = sysctl.u.readconsole.count; + + munlock(buffer, nr_chars); + return ret; +} + +int xc_send_debug_keys(int handle, char *keys) +{ + int ret; + DECLARE_SYSCTL(XEN_SYSCTL_debug_keys); + + set_xen_guest_handle(sysctl.u.debug_keys.keys, keys); + sysctl.u.debug_keys.nr_keys = strlen(keys); + + if (mlock(keys, sysctl.u.debug_keys.nr_keys) != 0) { + xc_error_set("send debug keys: mlock failed: %s", + strerror(errno)); + return -1; + } + + ret = do_sysctl(handle, &sysctl); + if (ret != 0) + xc_error_set("send debug keys: %s", xc_error_get()); + + munlock(keys, sysctl.u.debug_keys.nr_keys); + return ret; +} + +int xc_physinfo(int handle, xc_physinfo_t *put_info) +{ + DECLARE_SYSCTL(XEN_SYSCTL_physinfo); + int ret; + + ret = do_sysctl(handle, &sysctl); + if (ret) { + xc_error_set("physinfo failed: %s", xc_error_get()); + return ret; + } + memcpy(put_info, &sysctl.u.physinfo, sizeof(*put_info)); + return 0; +} + +int xc_pcpu_info(int handle, int max_cpus, uint64_t *info, int *nr_cpus) +{ + DECLARE_SYSCTL(XEN_SYSCTL_getcpuinfo); + int ret; + + sysctl.u.getcpuinfo.max_cpus = max_cpus; + set_xen_guest_handle(sysctl.u.getcpuinfo.info, info); + + if (mlock(info, sizeof(*info) * max_cpus) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_sysctl(handle, &sysctl); + if (ret) + xc_error_set("pcpu info failed: %s", xc_error_get()); + else if (ret == 0 && nr_cpus) + *nr_cpus = sysctl.u.getcpuinfo.nr_cpus; + munlock(info, sizeof(*info) * max_cpus); + return ret; +} + +int xc_sched_id(int handle, int *sched_id) +{ + DECLARE_SYSCTL(XEN_SYSCTL_sched_id); + int ret; + + ret = do_sysctl(handle, &sysctl); + if (ret) { + xc_error_set("sched id failed: %s", xc_error_get()); + return ret; + } + *sched_id = sysctl.u.sched_id.sched_id; + return 0; +} + +int xc_version(int handle, int cmd, void *arg) +{ + int argsize; + int ret; + DECLARE_HYPERCALL2(__HYPERVISOR_xen_version, cmd, arg); + + switch (cmd) { + case XENVER_extraversion: + argsize = sizeof(xen_extraversion_t); break; + case XENVER_compile_info: + argsize = sizeof(xen_compile_info_t); break; + case XENVER_capabilities: + argsize = sizeof(xen_capabilities_info_t); break; + case XENVER_changeset: + argsize = sizeof(xen_changeset_info_t); break; + case XENVER_platform_parameters: + argsize = sizeof(xen_platform_parameters_t); break; + case XENVER_version: + argsize = 0; break; + default: + xc_error_set("version: unknown command"); + return -1; + } + if (argsize && mlock(arg, argsize) == -1) { + xc_error_set("version: mlock failed: %s", strerror(errno)); + return -ENOMEM; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret) + xc_error_hypercall(hypercall, ret); + + if (argsize) + munlock(arg, argsize); + return ret; +} + +int xc_evtchn_alloc_unbound(int handle, unsigned int domid, + unsigned int remote_domid) +{ + struct evtchn_alloc_unbound arg = { + .dom = domid, + .remote_dom = remote_domid, + }; + int ret; + + ret = do_evtchnctl(handle, EVTCHNOP_alloc_unbound, &arg, sizeof(arg)); + if (ret) { + xc_error_dom_set(domid, "alloc unbound evtchn to %d", + remote_domid); + return ret; + } + return arg.port; +} + +int xc_evtchn_reset(int handle, unsigned int domid) +{ + struct evtchn_reset arg = { + .dom = domid, + }; + int ret; + + ret = do_evtchnctl(handle, EVTCHNOP_reset, &arg, sizeof(arg)); + if (ret) + xc_error_dom_set(domid, "reset evtchn of %d", domid); + return ret; +} + +int xc_sched_credit_domain_set(int handle, unsigned int domid, + struct xen_domctl_sched_credit *sdom) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_scheduler_op, domid); + domctl.u.scheduler_op.sched_id = XEN_SCHEDULER_CREDIT; + domctl.u.scheduler_op.cmd = XEN_DOMCTL_SCHEDOP_putinfo; + domctl.u.scheduler_op.u.credit = *sdom; + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "credit scheduler domain set"); + return ret; +} + +int xc_sched_credit_domain_get(int handle, unsigned int domid, + struct xen_domctl_sched_credit *sdom) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_scheduler_op, domid); + + domctl.u.scheduler_op.sched_id = XEN_SCHEDULER_CREDIT; + domctl.u.scheduler_op.cmd = XEN_DOMCTL_SCHEDOP_getinfo; + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "credit scheduler domain get"); + else + *sdom = domctl.u.scheduler_op.u.credit; + return ret; +} + +int xc_shadow_allocation_get(int handle, unsigned int domid, uint32_t *mb) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_shadow_op, domid); + + domctl.u.shadow_op.op = XEN_DOMCTL_SHADOW_OP_GET_ALLOCATION; + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "shadow allocation get"); + else + *mb = domctl.u.shadow_op.mb; + return ret; +} + +int xc_shadow_allocation_set(int handle, unsigned int domid, uint32_t mb) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_shadow_op, domid); + + domctl.u.shadow_op.op = XEN_DOMCTL_SHADOW_OP_SET_ALLOCATION; + domctl.u.shadow_op.mb = mb; + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "shadow allocation set"); + return ret; +} + +int xc_domain_get_pfn_list(int handle, unsigned int domid, + xen_pfn_t *pfn_array, unsigned long max_pfns) +{ + int ret; + DECLARE_DOMCTL(XEN_DOMCTL_getmemlist, domid); + + domctl.u.getmemlist.max_pfns = max_pfns; + set_xen_guest_handle(domctl.u.getmemlist.buffer, pfn_array); + + if (mlock(pfn_array, max_pfns * sizeof(xen_pfn_t)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "get pfn list"); + + munlock(pfn_array, max_pfns * sizeof(xen_pfn_t)); + return (ret < 0) ? ret : domctl.u.getmemlist.num_pfns; +} + +#define MARSHALL_BDF(d,b,s,f) \ + (((b) & 0xff) << 16 | ((s) & 0x1f) << 11 | ((f) & 0x7) << 8) + +int xc_domain_assign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func) +{ + int ret = -EBADF; +#ifdef XEN_DOMCTL_assign_device + DECLARE_DOMCTL(XEN_DOMCTL_assign_device, domid); + + domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func); + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "assign device"); +#endif + return ret; +} + +int xc_domain_deassign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func) +{ + int ret = -EBADF; +#ifdef XEN_DOMCTL_deassign_device + DECLARE_DOMCTL(XEN_DOMCTL_deassign_device, domid); + + domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func); + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "deassign device"); +#endif + return ret; +} + +int xc_domain_test_assign_device(int handle, unsigned int domid, + int domain, int bus, int slot, int func) +{ + int ret = -EBADF; +#ifdef XEN_DOMCTL_test_assign_device + DECLARE_DOMCTL(XEN_DOMCTL_test_assign_device, domid); + domctl.u.assign_device.machine_bdf = MARSHALL_BDF(domain, bus, slot, func); + + ret = do_domctl(handle, &domctl); + if (ret < 0) + xc_error_dom_set(domid, "test assign device"); +#endif + return ret; +} + +int xc_domain_watchdog(int handle, int id, uint32_t timeout) +{ + int ret = -EBADF; +#ifdef SCHEDOP_watchdog + sched_watchdog_t arg = { + .id = (uint32_t) id, + .timeout = timeout, + }; + DECLARE_HYPERCALL2(__HYPERVISOR_sched_op, SCHEDOP_watchdog, &arg); + + if (mlock(&arg, sizeof(arg)) != 0) { + xc_error_set("mlock failed: %s", strerror(errno)); + return -1; + } + + ret = do_xen_hypercall(handle, &hypercall); + if (ret < 0) { + xc_error_hypercall(hypercall, ret); + } + munlock(&arg, sizeof(arg)); +#endif + return ret; +} + +int xc_domain_set_machine_address_size(int xc, uint32_t domid, unsigned int width) +{ + DECLARE_DOMCTL(XEN_DOMCTL_set_machine_address_size, domid); + int rc; + + domctl.u.address_size.size = width; + rc = do_domctl(xc, &domctl); + if (rc != 0) + xc_error_dom_set(domid, "set machine address size"); + + return rc; +} + +int xc_domain_get_machine_address_size(int xc, uint32_t domid) +{ + DECLARE_DOMCTL(XEN_DOMCTL_get_machine_address_size, domid); + int rc; + + rc = do_domctl(xc, &domctl); + if (rc != 0) + xc_error_dom_set(domid, "get machine address size"); + return rc == 0 ? domctl.u.address_size.size : rc; +} + +#include "xc_cpuid.h" +int xc_domain_cpuid_set(int xc, unsigned int domid, int hvm, + uint32_t input, uint32_t oinput, + char *config[4], char *config_out[4]) +{ + int ret = -EBADF; +#ifdef XEN_DOMCTL_set_cpuid + DECLARE_DOMCTL(XEN_DOMCTL_set_cpuid, domid); + uint32_t regs[4], polregs[4]; + int i, j; + + xc_cpuid(input, oinput, regs); + memcpy(polregs, regs, sizeof(regs)); + do_cpuid_policy(xc, domid, hvm, input, polregs); + + for (i = 0; i < 4; i++) { + if (!config[i]) { + regs[i] = polregs[i]; + continue; + } + + for (j = 0; j < 32; j++) { + unsigned char val, polval; + + val = !!((regs[i] & (1U << (31 - j)))); + polval = !!((regs[i] & (1U << (31 - j)))); + + switch (config[i][j]) { + case '1': val = 1; break; /* force to true */ + case '0': val = 0; break; /* force to false */ + case 'x': val = polval; break; + case 'k': case 's': break; + default: + xc_error_dom_set(domid, "domain cpuid set: invalid config"); + ret = -EINVAL; + goto out; + } + + if (val) + set_bit(31 - j, regs[i]); + else + clear_bit(31 - j, regs[i]); + + if (config_out && config_out[i]) { + config_out[i][j] = (config[i][j] == 's') + ? '0' + val + : config[i][j]; + } + } + } + + domctl.u.cpuid.input[0] = input; + domctl.u.cpuid.input[1] = oinput; + domctl.u.cpuid.eax = regs[0]; + domctl.u.cpuid.ebx = regs[1]; + domctl.u.cpuid.ecx = regs[2]; + domctl.u.cpuid.edx = regs[3]; + ret = do_domctl(xc, &domctl); + if (ret) { + xc_error_dom_set(domid, "cpuid set"); + goto out; + } +out: +#endif + return ret; +} + +int xc_domain_cpuid_apply(int xc, unsigned int domid, int hvm) +{ + int ret = -EBADF; +#ifdef XEN_DOMCTL_set_cpuid + uint32_t regs[4], base_max, ext_max, eax, ecx; + + /* determinate cpuid range */ + xc_cpuid(0, 0, regs); + base_max = MIN(regs[0], DEF_MAX_BASE); + xc_cpuid(0x80000000, 0, regs); + ext_max = MIN(regs[0], DEF_MAX_EXT); + + eax = ecx = 0; + while (!(eax & 0x80000000) || (eax <= ext_max)) { + xc_cpuid(eax, ecx, regs); + + do_cpuid_policy(xc, domid, hvm, eax, regs); + + if (regs[0] || regs[1] || regs[2] || regs[3]) { + DECLARE_DOMCTL(XEN_DOMCTL_set_cpuid, domid); + + domctl.u.cpuid.input[0] = eax; + domctl.u.cpuid.input[1] = (eax == 4) ? ecx : XEN_CPUID_INPUT_UNUSED; + domctl.u.cpuid.eax = regs[0]; + domctl.u.cpuid.ebx = regs[1]; + domctl.u.cpuid.ecx = regs[2]; + domctl.u.cpuid.edx = regs[3]; + + ret = do_domctl(xc, &domctl); + if (ret) { + xc_error_dom_set(domid, "cpuid apply"); + goto out; + } + + /* we repeat when doing node 4 (cache descriptor leaves) increasing ecx + * until the cpuid eax value masked is 0 */ + if (eax == 4) { + ecx++; + if ((regs[0] & 0x1f) != 0) + continue; + ecx = 0; + } + } + + eax++; + if (!(eax & 0x80000000) && (eax > base_max)) + eax = 0x80000000; + } + ret = 0; +out: +#endif + return ret; +} + +/* + * return 1 on checking success + * 0 on checking failure + * -EINVAL if the config contains unknown character + */ +int xc_cpuid_check(uint32_t input, uint32_t optsubinput, + char *config[4], char *config_out[4]) +{ + int ret = -EBADF; +#ifdef XEN_DOMCTL_set_cpuid + uint32_t regs[4]; + int i, j; + + xc_cpuid(input, optsubinput, regs); + + ret = 1; + for (i = 0; i < 4; i++) { + if (!config[i]) + continue; + for (j = 0; j < 32; j++) { + unsigned char val; + + val = !!((regs[i] & (1U << (31 - j)))); + + switch (config[i][j]) { + case '1': if (!val) { ret = 0; goto out; }; break; + case '0': if (val) { ret = 0; goto out; }; break; + case 'x': case 's': break; + default: + xc_error_set("cpuid check: invalid config"); + ret = -EINVAL; + goto out; + } + + if (config_out && config_out[i]) { + config_out[i][j] = (config[i][j] == 's') + ? '0' + val + : config[i][j]; + } + } + } +out: +#endif + return ret; +} + +#ifndef HVM_PARAM_HPET_ENABLED +#define HVM_PARAM_HPET_ENABLED 11 +#endif + +#ifndef HVM_PARAM_ACPI_S_STATE +#define HVM_PARAM_ACPI_S_STATE 14 +#endif + +#ifndef HVM_PARAM_VPT_ALIGN +#define HVM_PARAM_VPT_ALIGN 16 +#endif + +int xc_domain_send_s3resume(int handle, unsigned int domid) +{ + return xc_set_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, 0); +} + +int xc_domain_set_timer_mode(int handle, unsigned int domid, int mode) +{ + return xc_set_hvm_param(handle, domid, + HVM_PARAM_TIMER_MODE, (unsigned long) mode); +} + +int xc_domain_set_hpet(int handle, unsigned int domid, int hpet) +{ + return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigned long) hpet); +} + +int xc_domain_set_vpt_align(int handle, unsigned int domid, int vpt_align) +{ + return xc_set_hvm_param(handle, domid, HVM_PARAM_HPET_ENABLED, (unsigned long) vpt_align); +} + +int xc_domain_get_acpi_s_state(int handle, unsigned int domid) +{ + int ret; + unsigned long value; + + ret = xc_get_hvm_param(handle, domid, HVM_PARAM_ACPI_S_STATE, &value); + if (ret != 0) + xc_error_dom_set(domid, "get acpi s-state"); + return value; +} diff --git a/tools/ocaml/libs/xc/xc_stubs.c b/tools/ocaml/libs/xc/xc_stubs.c new file mode 100644 index 0000000..b43a750 --- /dev/null +++ b/tools/ocaml/libs/xc/xc_stubs.c @@ -0,0 +1,1170 @@ +/* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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. + */ + +#define _XOPEN_SOURCE 600 +#include + +#define CAML_NAME_SPACE +#include +#include +#include +#include +#include + +#include +#include +#include + +#include "xc.h" + +#include "mmap_stubs.h" + +#define PAGE_SHIFT 12 +#define PAGE_SIZE (1UL << PAGE_SHIFT) +#define PAGE_MASK (~(PAGE_SIZE-1)) + +#define _H(__h) (Int_val(__h)) +#define _D(__d) ((uint32_t)Int_val(__d)) + +#define Val_none (Val_int(0)) + +#define string_of_option_array(array, index) \ + ((Field(array, index) == Val_none) ? NULL : String_val(Field(Field(array, index), 0))) + +/* maybe here we should check the range of the input instead of blindly + * casting it to uint32 */ +#define cpuid_input_of_val(i1, i2, input) \ + i1 = (uint32_t) Int64_val(Field(input, 0)); \ + i2 = ((Field(input, 1) == Val_none) ? 0xffffffff : (uint32_t) Int64_val(Field(Field(input, 1), 0))); + +/** + * Convert the given number of pages to an amount in MiB, rounded up. + */ +void failwith_xc(void) +{ + caml_raise_with_string(*caml_named_value("xc.error"), xc_error_get()); +} + +CAMLprim value stub_sizeof_core_header(value unit) +{ + CAMLparam1(unit); + CAMLreturn(Val_int(sizeof(struct xc_core_header))); +} + +CAMLprim value stub_sizeof_vcpu_guest_context(value unit) +{ + CAMLparam1(unit); + CAMLreturn(Val_int(sizeof(struct vcpu_guest_context))); +} + +CAMLprim value stub_sizeof_xen_pfn(value unit) +{ + CAMLparam1(unit); + CAMLreturn(Val_int(sizeof(xen_pfn_t))); +} + +#define XC_CORE_MAGIC 0xF00FEBED +#define XC_CORE_MAGIC_HVM 0xF00FEBEE + +CAMLprim value stub_marshall_core_header(value header) +{ + CAMLparam1(header); + CAMLlocal1(s); + struct xc_core_header c_header; + + c_header.xch_magic = (Field(header, 0)) + ? XC_CORE_MAGIC + : XC_CORE_MAGIC_HVM; + c_header.xch_nr_vcpus = Int_val(Field(header, 1)); + c_header.xch_nr_pages = Nativeint_val(Field(header, 2)); + c_header.xch_ctxt_offset = Int64_val(Field(header, 3)); + c_header.xch_index_offset = Int64_val(Field(header, 4)); + c_header.xch_pages_offset = Int64_val(Field(header, 5)); + + s = caml_alloc_string(sizeof(c_header)); + memcpy(String_val(s), (char *) &c_header, sizeof(c_header)); + CAMLreturn(s); +} + +CAMLprim value stub_xc_interface_open() +{ + int handle; + handle = xc_interface_open(); + if (handle == -1) + failwith_xc(); + return Val_int(handle); +} + + +CAMLprim value stub_xc_interface_open_fake() +{ + return Val_int(-1); +} + +CAMLprim value stub_xc_using_injection() +{ + if (xc_using_injection ()){ + return Val_int(1); + } else { + return Val_int(0); + } +} + +CAMLprim value stub_xc_interface_close(value xc_handle) +{ + CAMLparam1(xc_handle); + + int handle = _H(xc_handle); + // caml_enter_blocking_section(); + xc_interface_close(handle); + // caml_leave_blocking_section(); + + CAMLreturn(Val_unit); +} + +static int domain_create_flag_table[] = { + XEN_DOMCTL_CDF_hvm_guest, + XEN_DOMCTL_CDF_hap, +}; + +CAMLprim value stub_xc_domain_create(value xc_handle, value ssidref, + value flags, value handle) +{ + CAMLparam4(xc_handle, ssidref, flags, handle); + + uint32_t domid = 0; + xen_domain_handle_t h = { 0 }; + int result; + int i; + int c_xc_handle = _H(xc_handle); + uint32_t c_ssidref = Int32_val(ssidref); + unsigned int c_flags = 0; + value l; + + if (Wosize_val(handle) != 16) + caml_invalid_argument("Handle not a 16-integer array"); + + for (i = 0; i < sizeof(h); i++) { + h[i] = Int_val(Field(handle, i)) & 0xff; + } + + for (l = flags; l != Val_none; l = Field(l, 1)) { + int v = Int_val(Field(l, 0)); + c_flags |= domain_create_flag_table[v]; + } + + // caml_enter_blocking_section(); + result = xc_domain_create(c_xc_handle, c_ssidref, h, c_flags, &domid); + // caml_leave_blocking_section(); + + if (result < 0) + failwith_xc(); + + CAMLreturn(Val_int(domid)); +} + +CAMLprim value stub_xc_domain_setvmxassist(value xc_handle, value domid, + value use_vmxassist) +{ + CAMLparam3(xc_handle, domid, use_vmxassist); + int r; + + r = xc_domain_setvmxassist(_H(xc_handle), _D(domid), + Bool_val(use_vmxassist)); + if (r) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_max_vcpus(value xc_handle, value domid, + value max_vcpus) +{ + CAMLparam3(xc_handle, domid, max_vcpus); + int r; + + r = xc_domain_max_vcpus(_H(xc_handle), _D(domid), Int_val(max_vcpus)); + if (r) + failwith_xc(); + + CAMLreturn(Val_unit); +} + + +value stub_xc_domain_sethandle(value xc_handle, value domid, value handle) +{ + CAMLparam3(xc_handle, domid, handle); + xen_domain_handle_t h = { 0 }; + int i; + + if (Wosize_val(handle) != 16) + caml_invalid_argument("Handle not a 16-integer array"); + + for (i = 0; i < sizeof(h); i++) { + h[i] = Int_val(Field(handle, i)) & 0xff; + } + + i = xc_domain_sethandle(_H(xc_handle), _D(domid), h); + if (i) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +static value dom_op(value xc_handle, value domid, int (*fn)(int, uint32_t)) +{ + CAMLparam2(xc_handle, domid); + + int c_xc_handle = _H(xc_handle); + uint32_t c_domid = _D(domid); + + // caml_enter_blocking_section(); + int result = fn(c_xc_handle, c_domid); + // caml_leave_blocking_section(); + if (result) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_pause(value xc_handle, value domid) +{ + return dom_op(xc_handle, domid, xc_domain_pause); +} + + +CAMLprim value stub_xc_domain_unpause(value xc_handle, value domid) +{ + return dom_op(xc_handle, domid, xc_domain_unpause); +} + +CAMLprim value stub_xc_domain_destroy(value xc_handle, value domid) +{ + return dom_op(xc_handle, domid, xc_domain_destroy); +} + +CAMLprim value stub_xc_domain_resume_fast(value xc_handle, value domid) +{ + return dom_op(xc_handle, domid, xc_domain_resume_fast); +} + +CAMLprim value stub_xc_domain_shutdown(value handle, value domid, value reason) +{ + CAMLparam3(handle, domid, reason); + int ret; + + ret = xc_domain_shutdown(_H(handle), _D(domid), Int_val(reason)); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +static value alloc_domaininfo(xc_domaininfo_t * info) +{ + CAMLparam0(); + CAMLlocal2(result, tmp); + int i; + + result = caml_alloc_tuple(16); + + Store_field(result, 0, Val_int(info->domain)); + Store_field(result, 1, Val_bool(info->flags & XEN_DOMINF_dying)); + Store_field(result, 2, Val_bool(info->flags & XEN_DOMINF_shutdown)); + Store_field(result, 3, Val_bool(info->flags & XEN_DOMINF_paused)); + Store_field(result, 4, Val_bool(info->flags & XEN_DOMINF_blocked)); + Store_field(result, 5, Val_bool(info->flags & XEN_DOMINF_running)); + Store_field(result, 6, Val_bool(info->flags & XEN_DOMINF_hvm_guest)); + Store_field(result, 7, Val_int((info->flags >> XEN_DOMINF_shutdownshift) + & XEN_DOMINF_shutdownmask)); + Store_field(result, 8, caml_copy_nativeint(info->tot_pages)); + Store_field(result, 9, caml_copy_nativeint(info->max_pages)); + Store_field(result, 10, caml_copy_int64(info->shared_info_frame)); + Store_field(result, 11, caml_copy_int64(info->cpu_time)); + Store_field(result, 12, Val_int(info->nr_online_vcpus)); + Store_field(result, 13, Val_int(info->max_vcpu_id)); + Store_field(result, 14, caml_copy_int32(info->ssidref)); + + tmp = caml_alloc_small(16, 0); + for (i = 0; i < 16; i++) { + Field(tmp, i) = Val_int(info->handle[i]); + } + + Store_field(result, 15, tmp); + + CAMLreturn(result); +} + +CAMLprim value stub_xc_domain_getinfolist(value xc_handle, value first_domain, value nb) +{ + CAMLparam3(xc_handle, first_domain, nb); + CAMLlocal2(result, temp); + xc_domaininfo_t * info; + int i, ret, toalloc; + + /* get the minimum number of allocate byte we need and bump it up to page boundary */ + toalloc = (sizeof(xc_domaininfo_t) * Int_val(nb)) | 0xfff; + ret = posix_memalign((void **) ((void *) &info), 4096, toalloc); + if (ret) + caml_raise_out_of_memory(); + + result = temp = Val_emptylist; + + int c_xc_handle = _H(xc_handle); + uint32_t c_first_domain = _D(first_domain); + unsigned int c_max_domains = Int_val(nb); + // caml_enter_blocking_section(); + int retval = xc_domain_getinfolist(c_xc_handle, c_first_domain, + c_max_domains, info); + // caml_leave_blocking_section(); + + if (retval < 0) { + free(info); + failwith_xc(); + } + for (i = 0; i < retval; i++) { + result = caml_alloc_small(2, Tag_cons); + Field(result, 0) = Val_int(0); + Field(result, 1) = temp; + temp = result; + + Store_field(result, 0, alloc_domaininfo(info + i)); + } + + free(info); + CAMLreturn(result); +} + +CAMLprim value stub_xc_domain_getinfo(value xc_handle, value domid) +{ + CAMLparam2(xc_handle, domid); + CAMLlocal1(result); + xc_domaininfo_t info; + int ret; + + ret = xc_domain_getinfo(_H(xc_handle), _D(domid), &info); + if (ret != 0) + failwith_xc(); + + result = alloc_domaininfo(&info); + CAMLreturn(result); +} + +CAMLprim value stub_xc_vcpu_getinfo(value xc_handle, value domid, value vcpu) +{ + CAMLparam3(xc_handle, domid, vcpu); + CAMLlocal1(result); + xc_vcpuinfo_t info; + int retval; + + int c_xc_handle = _H(xc_handle); + uint32_t c_domid = _D(domid); + uint32_t c_vcpu = Int_val(vcpu); + // caml_enter_blocking_section(); + retval = xc_vcpu_getinfo(c_xc_handle, c_domid, + c_vcpu, &info); + // caml_leave_blocking_section(); + if (retval < 0) + failwith_xc(); + + result = caml_alloc_tuple(5); + Store_field(result, 0, Val_bool(info.online)); + Store_field(result, 1, Val_bool(info.blocked)); + Store_field(result, 2, Val_bool(info.running)); + Store_field(result, 3, caml_copy_int64(info.cpu_time)); + Store_field(result, 4, caml_copy_int32(info.cpu)); + + CAMLreturn(result); +} + +CAMLprim value stub_xc_vcpu_context_get(value xc_handle, value domid, + value cpu) +{ + CAMLparam3(xc_handle, domid, cpu); + CAMLlocal1(context); + int ret; + struct vcpu_guest_context ctxt; + + ret = xc_vcpu_getcontext(_H(xc_handle), _D(domid), Int_val(cpu), &ctxt); + + context = caml_alloc_string(sizeof(ctxt)); + memcpy(String_val(context), (char *) &ctxt, sizeof(ctxt)); + + CAMLreturn(context); +} + +CAMLprim value stub_xc_vcpu_setaffinity(value xc_handle, value domid, + value vcpu, value cpumap) +{ + CAMLparam4(xc_handle, domid, vcpu, cpumap); + uint64_t c_cpumap; + int retval; + + c_cpumap = Int64_val(cpumap); + retval = xc_vcpu_setaffinity(_H(xc_handle), _D(domid), + Int_val(vcpu), c_cpumap); + if (retval < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_vcpu_getaffinity(value xc_handle, value domid, + value vcpu) +{ + CAMLparam3(xc_handle, domid, vcpu); + CAMLlocal1(ret); + uint64_t cpumap; + int retval; + + retval = xc_vcpu_getaffinity(_H(xc_handle), _D(domid), + Int_val(vcpu), &cpumap); + if (retval < 0) + failwith_xc(); + ret = caml_copy_int64(cpumap); + CAMLreturn(ret); +} + +CAMLprim value stub_xc_sched_id(value xc_handle) +{ + CAMLparam1(xc_handle); + int sched_id; + + if (xc_sched_id(_H(xc_handle), &sched_id)) + failwith_xc(); + CAMLreturn(Val_int(sched_id)); +} + +CAMLprim value stub_xc_evtchn_alloc_unbound(value xc_handle, + value local_domid, + value remote_domid) +{ + CAMLparam3(xc_handle, local_domid, remote_domid); + + int c_xc_handle = _H(xc_handle); + uint32_t c_local_domid = _D(local_domid); + uint32_t c_remote_domid = _D(remote_domid); + + // caml_enter_blocking_section(); + int result = xc_evtchn_alloc_unbound(c_xc_handle, c_local_domid, + c_remote_domid); + // caml_leave_blocking_section(); + + if (result < 0) + failwith_xc(); + CAMLreturn(Val_int(result)); +} + +CAMLprim value stub_xc_evtchn_reset(value handle, value domid) +{ + CAMLparam2(handle, domid); + int r; + + r = xc_evtchn_reset(_H(handle), _D(domid)); + if (r < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + + +#define RING_SIZE 32768 +static char ring[RING_SIZE]; + +CAMLprim value stub_xc_readconsolering(value xc_handle) +{ + unsigned int size = RING_SIZE; + char *ring_ptr = ring; + + CAMLparam1(xc_handle); + int c_xc_handle = _H(xc_handle); + + // caml_enter_blocking_section(); + int retval = xc_readconsolering(c_xc_handle, &ring_ptr, &size, 0); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + ring[size] = '\0'; + CAMLreturn(caml_copy_string(ring)); +} + +CAMLprim value stub_xc_send_debug_keys(value xc_handle, value keys) +{ + CAMLparam2(xc_handle, keys); + int r; + + r = xc_send_debug_keys(_H(xc_handle), String_val(keys)); + if (r) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_physinfo(value xc_handle) +{ + CAMLparam1(xc_handle); + CAMLlocal3(physinfo, cap_list, tmp); + xc_physinfo_t c_physinfo; + int r; + + // caml_enter_blocking_section(); + r = xc_physinfo(_H(xc_handle), &c_physinfo); + // caml_leave_blocking_section(); + + if (r) + failwith_xc(); + + tmp = cap_list = Val_emptylist; + for (r = 0; r < 2; r++) { + if ((c_physinfo.capabilities >> r) & 1) { + tmp = caml_alloc_small(2, Tag_cons); + Field(tmp, 0) = Val_int(r); + Field(tmp, 1) = cap_list; + cap_list = tmp; + } + } + + physinfo = caml_alloc_tuple(9); + Store_field(physinfo, 0, Val_int(c_physinfo.threads_per_core)); + Store_field(physinfo, 1, Val_int(c_physinfo.cores_per_socket)); + Store_field(physinfo, 2, Val_int(c_physinfo.nr_cpus)); + Store_field(physinfo, 3, Val_int(c_physinfo.max_node_id)); + Store_field(physinfo, 4, Val_int(c_physinfo.cpu_khz)); + Store_field(physinfo, 5, caml_copy_nativeint(c_physinfo.total_pages)); + Store_field(physinfo, 6, caml_copy_nativeint(c_physinfo.free_pages)); + Store_field(physinfo, 7, caml_copy_nativeint(c_physinfo.scrub_pages)); + Store_field(physinfo, 8, cap_list); + + CAMLreturn(physinfo); +} + +CAMLprim value stub_xc_pcpu_info(value xc_handle, value nr_cpus) +{ + CAMLparam2(xc_handle, nr_cpus); + CAMLlocal2(pcpus, v); + uint64_t *info; + int r, size; + + if (Int_val(nr_cpus) < 1) + caml_invalid_argument("nr_cpus"); + + info = calloc(Int_val(nr_cpus) + 1, sizeof(uint64_t)); + if (!info) + caml_raise_out_of_memory(); + + // caml_enter_blocking_section(); + r = xc_pcpu_info(_H(xc_handle), Int_val(nr_cpus), info, &size); + // caml_leave_blocking_section(); + + if (r) { + free(info); + failwith_xc(); + } + + if (size > 0) { + int i; + pcpus = caml_alloc(size, 0); + for (i = 0; i < size; i++) { + v = caml_copy_int64(info[i]); + caml_modify(&Field(pcpus, i), v); + } + } else + pcpus = Atom(0); + free(info); + CAMLreturn(pcpus); +} + +CAMLprim value stub_xc_domain_setmaxmem(value xc_handle, value domid, + value max_memkb) +{ + CAMLparam3(xc_handle, domid, max_memkb); + + int c_xc_handle = _H(xc_handle); + uint32_t c_domid = _D(domid); + unsigned int c_max_memkb = Int64_val(max_memkb); + // caml_enter_blocking_section(); + int retval = xc_domain_setmaxmem(c_xc_handle, c_domid, + c_max_memkb); + // caml_leave_blocking_section(); + if (retval) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_memmap_limit(value xc_handle, value domid, + value map_limitkb) +{ + CAMLparam3(xc_handle, domid, map_limitkb); + unsigned long v; + int retval; + + v = Int64_val(map_limitkb); + retval = xc_domain_set_memmap_limit(_H(xc_handle), _D(domid), v); + if (retval) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_memory_increase_reservation(value xc_handle, + value domid, + value mem_kb) +{ + CAMLparam3(xc_handle, domid, mem_kb); + + unsigned long nr_extents = ((unsigned long)(Int64_val(mem_kb))) >> (PAGE_SHIFT - 10); + + int c_xc_handle = _H(xc_handle); + uint32_t c_domid = _D(domid); + // caml_enter_blocking_section(); + int retval = xc_domain_memory_increase_reservation(c_xc_handle, c_domid, + nr_extents, 0, 0, NULL); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_machine_address_size(value xc_handle, + value domid, + value width) +{ + CAMLparam3(xc_handle, domid, width); + int c_xc_handle = _H(xc_handle); + uint32_t c_domid = _D(domid); + int c_width = Int_val(width); + + int retval = xc_domain_set_machine_address_size(c_xc_handle, c_domid, c_width); + if (retval) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_get_machine_address_size(value xc_handle, + value domid) +{ + CAMLparam2(xc_handle, domid); + int retval; + + retval = xc_domain_get_machine_address_size(_H(xc_handle), _D(domid)); + if (retval < 0) + failwith_xc(); + CAMLreturn(Val_int(retval)); +} + +CAMLprim value stub_xc_domain_cpuid_set(value xc_handle, value domid, + value is_hvm, value input, + value config) +{ + CAMLparam5(xc_handle, domid, is_hvm, input, config); + CAMLlocal2(array, tmp); + int r; + char *c_config[4], *out_config[4]; + uint32_t c_input, c_oinput; + + c_config[0] = string_of_option_array(config, 0); + c_config[1] = string_of_option_array(config, 1); + c_config[2] = string_of_option_array(config, 2); + c_config[3] = string_of_option_array(config, 3); + + cpuid_input_of_val(c_input, c_oinput, input); + + array = caml_alloc(4, 0); + for (r = 0; r < 4; r++) { + tmp = Val_none; + if (c_config[r]) { + tmp = caml_alloc_small(1, 0); + Field(tmp, 0) = caml_alloc_string(32); + } + Store_field(array, r, tmp); + } + + for (r = 0; r < 4; r++) + out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL; + + r = xc_domain_cpuid_set(_H(xc_handle), _D(domid), Bool_val(is_hvm), + c_input, c_oinput, c_config, out_config); + if (r < 0) + failwith_xc(); + CAMLreturn(array); +} + +CAMLprim value stub_xc_domain_cpuid_apply(value xc_handle, value domid, value is_hvm) +{ + CAMLparam3(xc_handle, domid, is_hvm); + int r; + r = xc_domain_cpuid_apply(_H(xc_handle), _D(domid), Bool_val(is_hvm)); + if (r < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_cpuid_check(value input, value config) +{ + CAMLparam2(input, config); + CAMLlocal3(ret, array, tmp); + int r; + uint32_t c_input, c_oinput; + char *c_config[4], *out_config[4]; + + c_config[0] = string_of_option_array(config, 0); + c_config[1] = string_of_option_array(config, 1); + c_config[2] = string_of_option_array(config, 2); + c_config[3] = string_of_option_array(config, 3); + + cpuid_input_of_val(c_input, c_oinput, input); + + array = caml_alloc(4, 0); + for (r = 0; r < 4; r++) { + tmp = Val_none; + if (c_config[r]) { + tmp = caml_alloc_small(1, 0); + Field(tmp, 0) = caml_alloc_string(32); + } + Store_field(array, r, tmp); + } + + for (r = 0; r < 4; r++) + out_config[r] = (c_config[r]) ? String_val(Field(Field(array, r), 0)) : NULL; + + r = xc_cpuid_check(c_input, c_oinput, c_config, out_config); + if (r < 0) + failwith_xc(); + + ret = caml_alloc_tuple(2); + Store_field(ret, 0, Val_bool(r)); + Store_field(ret, 1, array); + + CAMLreturn(ret); +} + +CAMLprim value stub_xc_version_version(value xc_handle) +{ + CAMLparam1(xc_handle); + CAMLlocal1(result); + xen_extraversion_t extra; + long packed; + int retval; + + int c_xc_handle = _H(xc_handle); + // caml_enter_blocking_section(); + packed = xc_version(c_xc_handle, XENVER_version, NULL); + retval = xc_version(c_xc_handle, XENVER_extraversion, &extra); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + + result = caml_alloc_tuple(3); + + Store_field(result, 0, Val_int(packed >> 16)); + Store_field(result, 1, Val_int(packed & 0xffff)); + Store_field(result, 2, caml_copy_string(extra)); + + CAMLreturn(result); +} + + +CAMLprim value stub_xc_version_compile_info(value xc_handle) +{ + CAMLparam1(xc_handle); + CAMLlocal1(result); + xen_compile_info_t ci; + int retval; + + int c_xc_handle = _H(xc_handle); + // caml_enter_blocking_section(); + retval = xc_version(c_xc_handle, XENVER_compile_info, &ci); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + + result = caml_alloc_tuple(4); + + Store_field(result, 0, caml_copy_string(ci.compiler)); + Store_field(result, 1, caml_copy_string(ci.compile_by)); + Store_field(result, 2, caml_copy_string(ci.compile_domain)); + Store_field(result, 3, caml_copy_string(ci.compile_date)); + + CAMLreturn(result); +} + + +static value xc_version_single_string(value xc_handle, int code, void *info) +{ + CAMLparam1(xc_handle); + int retval; + + int c_xc_handle = _H(xc_handle); + // caml_enter_blocking_section(); + retval = xc_version(c_xc_handle, code, info); + // caml_leave_blocking_section(); + + if (retval) + failwith_xc(); + + CAMLreturn(caml_copy_string((char *)info)); +} + + +CAMLprim value stub_xc_version_changeset(value xc_handle) +{ + xen_changeset_info_t ci; + + return xc_version_single_string(xc_handle, XENVER_changeset, &ci); +} + + +CAMLprim value stub_xc_version_capabilities(value xc_handle) +{ + xen_capabilities_info_t ci; + + return xc_version_single_string(xc_handle, XENVER_capabilities, &ci); +} + + +CAMLprim value stub_pages_to_kib(value pages) +{ + CAMLparam1(pages); + + CAMLreturn(caml_copy_int64(Int64_val(pages) << (PAGE_SHIFT - 10))); +} + + +CAMLprim value stub_map_foreign_range(value xc_handle, value dom, + value size, value mfn) +{ + CAMLparam4(xc_handle, dom, size, mfn); + CAMLlocal1(result); + struct mmap_interface *intf; + + result = caml_alloc(sizeof(struct mmap_interface), Abstract_tag); + intf = (struct mmap_interface *) result; + + intf->len = Int_val(size); + + int c_xc_handle = _H(xc_handle); + uint32_t c_dom = _D(dom); + unsigned long c_mfn = Nativeint_val(mfn); + // caml_enter_blocking_section(); + intf->addr = xc_map_foreign_range(c_xc_handle, c_dom, + intf->len, PROT_READ|PROT_WRITE, + c_mfn); + // caml_leave_blocking_section(); + if (!intf->addr) + caml_failwith("xc_map_foreign_range error"); + CAMLreturn(result); +} + +CAMLprim value stub_sched_credit_domain_get(value xc_handle, value domid) +{ + CAMLparam2(xc_handle, domid); + CAMLlocal1(sdom); + struct xen_domctl_sched_credit c_sdom; + int ret; + + // caml_enter_blocking_section(); + ret = xc_sched_credit_domain_get(_H(xc_handle), _D(domid), &c_sdom); + // caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(); + + sdom = caml_alloc_tuple(2); + Store_field(sdom, 0, Val_int(c_sdom.weight)); + Store_field(sdom, 1, Val_int(c_sdom.cap)); + + CAMLreturn(sdom); +} + +CAMLprim value stub_sched_credit_domain_set(value xc_handle, value domid, + value sdom) +{ + CAMLparam3(xc_handle, domid, sdom); + struct xen_domctl_sched_credit c_sdom; + int ret; + + c_sdom.weight = Int_val(Field(sdom, 0)); + c_sdom.cap = Int_val(Field(sdom, 1)); + // caml_enter_blocking_section(); + ret = xc_sched_credit_domain_set(_H(xc_handle), _D(domid), &c_sdom); + // caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_shadow_allocation_get(value xc_handle, value domid) +{ + CAMLparam2(xc_handle, domid); + CAMLlocal1(mb); + uint32_t c_mb; + int ret; + + // caml_enter_blocking_section(); + ret = xc_shadow_allocation_get(_H(xc_handle), _D(domid), &c_mb); + // caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(); + + mb = Val_int(c_mb); + CAMLreturn(mb); +} + +CAMLprim value stub_shadow_allocation_set(value xc_handle, value domid, + value mb) +{ + CAMLparam3(xc_handle, domid, mb); + uint32_t c_mb; + int ret; + + c_mb = Int_val(mb); + // caml_enter_blocking_section(); + ret = xc_shadow_allocation_set(_H(xc_handle), _D(domid), c_mb); + // caml_leave_blocking_section(); + if (ret != 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_get_pfn_list(value xc_handle, value domid, + value nr_pfns) +{ + CAMLparam3(xc_handle, domid, nr_pfns); + CAMLlocal2(array, v); + unsigned long c_nr_pfns; + long ret, i; + xen_pfn_t *c_array; + + c_nr_pfns = Nativeint_val(nr_pfns); + + c_array = malloc(sizeof(xen_pfn_t) * c_nr_pfns); + if (!c_array) + caml_raise_out_of_memory(); + + ret = xc_domain_get_pfn_list(_H(xc_handle), _D(domid), + c_array, c_nr_pfns); + if (ret < 0) { + free(c_array); + failwith_xc(); + } + + array = caml_alloc(ret, 0); + for (i = 0; i < ret; i++) { + v = caml_copy_nativeint(c_array[i]); + Store_field(array, i, v); + } + free(c_array); + + CAMLreturn(array); +} + +CAMLprim value stub_xc_domain_ioport_permission(value xc_handle, value domid, + value start_port, value nr_ports, + value allow) +{ + CAMLparam5(xc_handle, domid, start_port, nr_ports, allow); + uint32_t c_start_port, c_nr_ports; + uint8_t c_allow; + int ret; + + c_start_port = Int_val(start_port); + c_nr_ports = Int_val(nr_ports); + c_allow = Bool_val(allow); + + ret = xc_domain_ioport_permission(_H(xc_handle), _D(domid), + c_start_port, c_nr_ports, c_allow); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_iomem_permission(value xc_handle, value domid, + value start_pfn, value nr_pfns, + value allow) +{ + CAMLparam5(xc_handle, domid, start_pfn, nr_pfns, allow); + unsigned long c_start_pfn, c_nr_pfns; + uint8_t c_allow; + int ret; + + c_start_pfn = Nativeint_val(start_pfn); + c_nr_pfns = Nativeint_val(nr_pfns); + c_allow = Bool_val(allow); + + ret = xc_domain_iomem_permission(_H(xc_handle), _D(domid), + c_start_pfn, c_nr_pfns, c_allow); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_irq_permission(value xc_handle, value domid, + value pirq, value allow) +{ + CAMLparam4(xc_handle, domid, pirq, allow); + uint8_t c_pirq; + uint8_t c_allow; + int ret; + + c_pirq = Int_val(pirq); + c_allow = Bool_val(allow); + + ret = xc_domain_irq_permission(_H(xc_handle), _D(domid), + c_pirq, c_allow); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_hvm_check_pvdriver(value xc_handle, value domid) +{ + CAMLparam2(xc_handle, domid); + int ret; + + ret = xc_hvm_check_pvdriver(_H(xc_handle), _D(domid)); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_bool(ret)); +} + +CAMLprim value stub_xc_domain_test_assign_device(value xc_handle, value domid, value desc) +{ + CAMLparam3(xc_handle, domid, desc); + int ret; + int domain, bus, slot, func; + + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + slot = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + + ret = xc_domain_test_assign_device(_H(xc_handle), _D(domid), + domain, bus, slot, func); + CAMLreturn(Val_bool(ret == 0)); +} + +CAMLprim value stub_xc_domain_assign_device(value xc_handle, value domid, value desc) +{ + CAMLparam3(xc_handle, domid, desc); + int ret; + int domain, bus, slot, func; + + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + slot = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + + ret = xc_domain_assign_device(_H(xc_handle), _D(domid), + domain, bus, slot, func); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_deassign_device(value xc_handle, value domid, value desc) +{ + CAMLparam3(xc_handle, domid, desc); + int ret; + int domain, bus, slot, func; + + domain = Int_val(Field(desc, 0)); + bus = Int_val(Field(desc, 1)); + slot = Int_val(Field(desc, 2)); + func = Int_val(Field(desc, 3)); + + ret = xc_domain_deassign_device(_H(xc_handle), _D(domid), + domain, bus, slot, func); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_timer_mode(value handle, value id, value mode) +{ + CAMLparam3(handle, id, mode); + int ret; + + ret = xc_domain_set_timer_mode(_H(handle), _D(id), Int_val(mode)); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_hpet(value handle, value id, value mode) +{ + CAMLparam3(handle, id, mode); + int ret; + + ret = xc_domain_set_hpet(_H(handle), _D(id), Int_val(mode)); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_set_vpt_align(value handle, value id, value mode) +{ + CAMLparam3(handle, id, mode); + int ret; + + ret = xc_domain_set_vpt_align(_H(handle), _D(id), Int_val(mode)); + if (ret < 0) + failwith_xc(); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_watchdog(value handle, value domid, value timeout) +{ + CAMLparam3(handle, domid, timeout); + int ret; + unsigned int c_timeout = Int32_val(timeout); + + ret = xc_domain_watchdog(_H(handle), _D(domid), c_timeout); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_int(ret)); +} + +CAMLprim value stub_xc_domain_send_s3resume(value handle, value domid) +{ + CAMLparam2(handle, domid); + xc_domain_send_s3resume(_H(handle), _D(domid)); + CAMLreturn(Val_unit); +} + +CAMLprim value stub_xc_domain_get_acpi_s_state(value handle, value domid) +{ + CAMLparam2(handle, domid); + int ret; + + ret = xc_domain_get_acpi_s_state(_H(handle), _D(domid)); + if (ret < 0) + failwith_xc(); + + CAMLreturn(Val_int(ret)); +} + +/* + * Local variables: + * indent-tabs-mode: t + * c-basic-offset: 8 + * tab-width: 8 + * End: + */ diff --git a/tools/ocaml/libs/xs/META.in b/tools/ocaml/libs/xs/META.in new file mode 100644 index 0000000..77d93b5 --- /dev/null +++ b/tools/ocaml/libs/xs/META.in @@ -0,0 +1,4 @@ +version = "@VERSION@" +description = "XenStore Interface" +archive(byte) = "xs.cma" +archive(native) = "xs.cmxa" diff --git a/tools/ocaml/libs/xs/Makefile b/tools/ocaml/libs/xs/Makefile new file mode 100644 index 0000000..87cd375 --- /dev/null +++ b/tools/ocaml/libs/xs/Makefile @@ -0,0 +1,42 @@ +TOPLEVEL=../.. +include $(TOPLEVEL)/common.make + +OCAMLINCLUDE += -I ../xb/ + +.NOTPARALLEL: +# Ocaml is such a PITA! + +PREINTF = xsraw.cmi xst.cmi +PREOBJS = queueop xsraw xst +PRELIBS = $(foreach obj, $(PREOBJS),$(obj).cmo) $(foreach obj,$(PREOJBS),$(obj).cmx) +OBJS = queueop xsraw xst xs +INTF = xsraw.cmi xst.cmi xs.cmi +LIBS = xs.cma xs.cmxa + +all: $(PREINTF) $(PRELIBS) $(INTF) $(LIBS) $(PROGRAMS) + +bins: $(PROGRAMS) + +libs: $(LIBS) + +xs_OBJS = $(OBJS) +OCAML_NOC_LIBRARY = xs + +#xs.cmxa: $(foreach obj,$(OBJS),$(obj).cmx) +# $(E) " MLLIB $@" +# $(Q)$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmx) +# +#xs.cma: $(foreach obj,$(OBJS),$(obj).cmo) +# $(E) " MLLIB $@" +# $(Q)$(OCAMLC) -a -o $@ $(foreach obj,$(OBJS),$(obj).cmo) + +.PHONY: install +install: $(LIBS) META + ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore xs META $(INTF) xs.mli xst.mli xsraw.mli $(LIBS) *.a *.cmx + +.PHONY: uninstall +uninstall: + ocamlfind remove xs + +include $(TOPLEVEL)/Makefile.rules + diff --git a/tools/ocaml/libs/xs/queueop.ml b/tools/ocaml/libs/xs/queueop.ml new file mode 100644 index 0000000..cb298f5 --- /dev/null +++ b/tools/ocaml/libs/xs/queueop.ml @@ -0,0 +1,73 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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. + *) + +let data_concat ls = (String.concat "\000" ls) ^ "\000" +let queue_path ty (tid: int) (path: string) con = + let data = data_concat [ path; ] in + Xb.queue con (Xb.Packet.create tid 0 ty data) + +(* operations *) +let directory tid path con = queue_path Xb.Op.Directory tid path con +let read tid path con = queue_path Xb.Op.Read tid path con + +let getperms tid path con = queue_path Xb.Op.Getperms tid path con + +let debug commands con = + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Debug (data_concat commands)) + +let watch path data con = + let data = data_concat [ path; data; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Watch data) + +let unwatch path data con = + let data = data_concat [ path; data; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Unwatch data) + +let transaction_start con = + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Transaction_start (data_concat [])) + +let transaction_end tid commit con = + let data = data_concat [ (if commit then "T" else "F"); ] in + Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Transaction_end data) + +let introduce domid mfn port con = + let data = data_concat [ Printf.sprintf "%u" domid; + Printf.sprintf "%nu" mfn; + string_of_int port; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Introduce data) + +let release domid con = + let data = data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Release data) + +let resume domid con = + let data = data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Resume data) + +let getdomainpath domid con = + let data = data_concat [ Printf.sprintf "%u" domid; ] in + Xb.queue con (Xb.Packet.create 0 0 Xb.Op.Getdomainpath data) + +let write tid path value con = + let data = path ^ "\000" ^ value (* no NULL at the end *) in + Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Write data) + +let mkdir tid path con = queue_path Xb.Op.Mkdir tid path con +let rm tid path con = queue_path Xb.Op.Rm tid path con + +let setperms tid path perms con = + let data = data_concat [ path; perms ] in + Xb.queue con (Xb.Packet.create tid 0 Xb.Op.Setperms data) diff --git a/tools/ocaml/libs/xs/xs.ml b/tools/ocaml/libs/xs/xs.ml new file mode 100644 index 0000000..768778f --- /dev/null +++ b/tools/ocaml/libs/xs/xs.ml @@ -0,0 +1,170 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 perms = Xsraw.perms +type con = Xsraw.con +type domid = int + +type xsh = +{ + con: con; + debug: string list -> string; + directory: string -> string list; + read: string -> string; + readv: string -> string list -> string list; + write: string -> string -> unit; + writev: string -> (string * string) list -> unit; + mkdir: string -> unit; + rm: string -> unit; + getperms: string -> perms; + setperms: string -> perms -> unit; + setpermsv: string -> string list -> perms -> unit; + introduce: domid -> nativeint -> int -> unit; + release: domid -> unit; + resume: domid -> unit; + getdomainpath: domid -> string; + watch: string -> string -> unit; + unwatch: string -> string -> unit; +} + +let get_operations con = { + con = con; + debug = (fun commands -> Xsraw.debug commands con); + directory = (fun path -> Xsraw.directory 0 path con); + read = (fun path -> Xsraw.read 0 path con); + readv = (fun dir vec -> Xsraw.readv 0 dir vec con); + write = (fun path value -> Xsraw.write 0 path value con); + writev = (fun dir vec -> Xsraw.writev 0 dir vec con); + mkdir = (fun path -> Xsraw.mkdir 0 path con); + rm = (fun path -> Xsraw.rm 0 path con); + getperms = (fun path -> Xsraw.getperms 0 path con); + setperms = (fun path perms -> Xsraw.setperms 0 path perms con); + setpermsv = (fun dir vec perms -> Xsraw.setpermsv 0 dir vec perms con); + introduce = (fun id mfn port -> Xsraw.introduce id mfn port con); + release = (fun id -> Xsraw.release id con); + resume = (fun id -> Xsraw.resume id con); + getdomainpath = (fun id -> Xsraw.getdomainpath id con); + watch = (fun path data -> Xsraw.watch path data con); + unwatch = (fun path data -> Xsraw.unwatch path data con); +} + +let transaction xsh = Xst.transaction xsh.con + +let has_watchevents xsh = Xsraw.has_watchevents xsh.con +let get_watchevent xsh = Xsraw.get_watchevent xsh.con + +let read_watchevent xsh = Xsraw.read_watchevent xsh.con + +let make fd = get_operations (Xsraw.open_fd fd) +let get_fd xsh = Xb.get_fd xsh.con.Xsraw.xb + +exception Timeout + +(* Should never be thrown, indicates a bug in the read_watchevent_timetout function *) +exception Timeout_with_nonempty_queue + +(* Just in case we screw up: poll the callback every couple of seconds rather + than wait for the whole timeout period *) +let max_blocking_time = 5. (* seconds *) + +let read_watchevent_timeout xsh timeout callback = + let start_time = Unix.gettimeofday () in + let end_time = start_time +. timeout in + + let left = ref timeout in + + (* Returns true if a watch event in the queue satisfied us *) + let process_queued_events () = + let success = ref false in + while Xsraw.has_watchevents xsh.con && not(!success) + do + success := callback (Xsraw.get_watchevent xsh.con) + done; + !success in + (* Returns true if a watch event read from the socket satisfied us *) + let process_incoming_event () = + let fd = get_fd xsh in + let r, _, _ = Unix.select [ fd ] [] [] (min max_blocking_time !left) in + + (* If data is available for reading then read it *) + if r = [] + then false (* timeout, either a max_blocking_time or global *) + else callback (Xsraw.read_watchevent xsh.con) in + + let success = ref false in + while !left > 0. && not(!success) + do + (* NB the 'callback' might call back into Xs functions + and as a side-effect, watches might be queued. Hence + we must process the queue on every loop iteration *) + + (* First process all queued watch events *) + if not(!success) + then success := process_queued_events (); + (* Then block for one more watch event *) + if not(!success) + then success := process_incoming_event (); + (* Just in case our callback caused events to be queued + and this is our last time round the loop: this prevents + us throwing the Timeout_with_nonempty_queue spuriously *) + if not(!success) + then success := process_queued_events (); + + (* Update the time left *) + let current_time = Unix.gettimeofday () in + left := end_time -. current_time + done; + if not(!success) then begin + (* Sanity check: it should be impossible for any + events to be queued here *) + if Xsraw.has_watchevents xsh.con + then raise Timeout_with_nonempty_queue + else raise Timeout + end + + +let monitor_paths xsh l time callback = + let unwatch () = + List.iter (fun (w,v) -> try xsh.unwatch w v with _ -> ()) l in + List.iter (fun (w,v) -> xsh.watch w v) l; + begin try + read_watchevent_timeout xsh time callback; + with + exn -> unwatch (); raise exn; + end; + unwatch () + +let daemon_socket = "/var/run/xenstored/socket" + +(** Throws this rather than a miscellaneous Unix.connect failed *) +exception Failed_to_connect + +let daemon_open () = + try + let sockaddr = Unix.ADDR_UNIX(daemon_socket) in + let sock = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in + Unix.connect sock sockaddr; + Unix.set_close_on_exec sock; + make sock + with _ -> raise Failed_to_connect + +let domain_open () = + let path = "/proc/xen/xenbus" in + let fd = Unix.openfile path [ Unix.O_RDWR ] 0o550 in + Unix.set_close_on_exec fd; + make fd + +let close xsh = Xsraw.close xsh.con diff --git a/tools/ocaml/libs/xs/xs.mli b/tools/ocaml/libs/xs/xs.mli new file mode 100644 index 0000000..ce505b6 --- /dev/null +++ b/tools/ocaml/libs/xs/xs.mli @@ -0,0 +1,90 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 Timeout + +(** Throws this rather than a miscellaneous Unix.connect failed *) +exception Failed_to_connect + +(** perms contains 3 things: + - owner domid. + - other perm: applied to domain that is not owner or in ACL. + - ACL: list of per-domain permission + *) +type perms = Xsraw.perms + +type domid = int +type con + +type xsh = { + con : con; + debug: string list -> string; + directory : string -> string list; + read : string -> string; + readv : string -> string list -> string list; + write : string -> string -> unit; + writev : string -> (string * string) list -> unit; + mkdir : string -> unit; + rm : string -> unit; + getperms : string -> perms; + setperms : string -> perms -> unit; + setpermsv : string -> string list -> perms -> unit; + introduce : domid -> nativeint -> int -> unit; + release : domid -> unit; + resume : domid -> unit; + getdomainpath : domid -> string; + watch : string -> string -> unit; + unwatch : string -> string -> unit; +} + +(** get operations provide a vector of xenstore function that apply to one + connection *) +val get_operations : con -> xsh + +(** create a transaction with a vector of function that can be applied + into the transaction. *) +val transaction : xsh -> (Xst.ops -> 'a) -> 'a + +(** watch manipulation on a connection *) +val has_watchevents : xsh -> bool +val get_watchevent : xsh -> string * string +val read_watchevent : xsh -> string * string + +(** get_fd return the fd of the connection to be able to select on it. + NOTE: it works only for socket-based connection *) +val get_fd : xsh -> Unix.file_descr + +(** wait for watchevent with a timeout. Until the callback return true, + every watch during the time specified, will be pass to the callback. + NOTE: it works only when use with a socket-based connection *) +val read_watchevent_timeout : xsh -> float -> (string * string -> bool) -> unit + +(** register a set of watches, then wait for watchevent. + remove all watches previously set before giving back the hand. *) +val monitor_paths : xsh + -> (string * string) list + -> float + -> (string * string -> bool) + -> unit + +(** open a socket-based xenstored connection *) +val daemon_open : unit -> xsh + +(** open a mmap-based xenstored connection *) +val domain_open : unit -> xsh + +(** close any xenstored connection *) +val close : xsh -> unit diff --git a/tools/ocaml/libs/xs/xsraw.ml b/tools/ocaml/libs/xs/xsraw.ml new file mode 100644 index 0000000..370d38e --- /dev/null +++ b/tools/ocaml/libs/xs/xsraw.ml @@ -0,0 +1,265 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 Partial_not_empty +exception Unexpected_packet of string + +(** Thrown when a path looks invalid e.g. if it contains "//" *) +exception Invalid_path of string + +let unexpected_packet expected received = + let s = Printf.sprintf "expecting %s received %s" + (Xb.Op.to_string expected) + (Xb.Op.to_string received) in + raise (Unexpected_packet s) + +type con = { + xb: Xb.t; + watchevents: (string * string) Queue.t; +} + +let close con = + Xb.close con.xb + +let open_fd fd = { + xb = Xb.open_fd fd; + watchevents = Queue.create (); +} + +let rec split_string ?limit:(limit=(-1)) c s = + let i = try String.index s c with Not_found -> -1 in + let nlimit = if limit = -1 || limit = 0 then limit else limit - 1 in + if i = -1 || nlimit = 0 then + [ s ] + else + let a = String.sub s 0 i + and b = String.sub s (i + 1) (String.length s - i - 1) in + a :: (split_string ~limit: nlimit c b) + +type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR + +type perms = int * perm * (int * perm) list + +let string_of_perms perms = + let owner, other, acl = perms in + let char_of_perm perm = + match perm with PERM_NONE -> 'n' | PERM_READ -> 'r' + | PERM_WRITE -> 'w' | PERM_RDWR -> 'b' in + let string_of_perm (id, perm) = Printf.sprintf "%c%u" (char_of_perm perm) id in + String.concat "\000" (List.map string_of_perm ((owner,other) :: acl)) + +let perms_of_string s = + let perm_of_char c = + match c with 'n' -> PERM_NONE | 'r' -> PERM_READ + | 'w' -> PERM_WRITE | 'b' -> PERM_RDWR + | c -> invalid_arg (Printf.sprintf "unknown permission type: %c" c) in + let perm_of_string s = + if String.length s < 2 + then invalid_arg (Printf.sprintf "perm of string: length = %d; contents=\"%s\"" (String.length s) s) + else + begin + int_of_string (String.sub s 1 (String.length s - 1)), + perm_of_char s.[0] + end in + let rec split s = + try let i = String.index s '\000' in + String.sub s 0 i :: split (String.sub s (i + 1) (String.length s - 1 - i)) + with Not_found -> if s = "" then [] else [ s ] in + let l = List.map perm_of_string (split s) in + match l with h :: l -> (fst h, snd h, l) | [] -> (0, PERM_NONE, []) + +(* send one packet - can sleep *) +let pkt_send con = + if Xb.has_old_output con.xb then + raise Partial_not_empty; + let workdone = ref false in + while not !workdone + do + workdone := Xb.output con.xb + done + +(* receive one packet - can sleep *) +let pkt_recv con = + let workdone = ref false in + while not !workdone + do + workdone := Xb.input con.xb + done; + Xb.get_in_packet con.xb + +let pkt_recv_timeout con timeout = + let fd = Xb.get_fd con.xb in + let r, _, _ = Unix.select [ fd ] [] [] timeout in + if r = [] then + true, None + else ( + let workdone = Xb.input con.xb in + if workdone then + false, (Some (Xb.get_in_packet con.xb)) + else + false, None + ) + +let queue_watchevent con data = + let ls = split_string ~limit:2 '\000' data in + if List.length ls != 2 then + raise (Xb.Packet.DataError "arguments number mismatch"); + let event = List.nth ls 0 + and event_data = List.nth ls 1 in + Queue.push (event, event_data) con.watchevents + +let has_watchevents con = Queue.length con.watchevents > 0 +let get_watchevent con = Queue.pop con.watchevents + +let read_watchevent con = + let pkt = pkt_recv con in + match Xb.Packet.get_ty pkt with + | Xb.Op.Watchevent -> + queue_watchevent con (Xb.Packet.get_data pkt); + Queue.pop con.watchevents + | ty -> unexpected_packet Xb.Op.Watchevent ty + +(* send one packet in the queue, and wait for reply *) +let rec sync_recv ty con = + let pkt = pkt_recv con in + match Xb.Packet.get_ty pkt with + | Xb.Op.Error -> ( + match Xb.Packet.get_data pkt with + | "ENOENT" -> raise Xb.Noent + | "EAGAIN" -> raise Xb.Eagain + | "EINVAL" -> raise Xb.Invalid + | s -> raise (Xb.Packet.Error s)) + | Xb.Op.Watchevent -> + queue_watchevent con (Xb.Packet.get_data pkt); + sync_recv ty con + | rty when rty = ty -> Xb.Packet.get_data pkt + | rty -> unexpected_packet ty rty + +let sync f con = + (* queue a query using function f *) + f con.xb; + if Xb.output_len con.xb = 0 then + Printf.printf "output len = 0\n%!"; + let ty = Xb.Packet.get_ty (Xb.peek_output con.xb) in + pkt_send con; + sync_recv ty con + +let ack s = + if s = "OK" then () else raise (Xb.Packet.DataError s) + +(** Check paths are suitable for read/write/mkdir/rm/directory etc (NOT watches) *) +let validate_path path = + (* Paths shouldn't have a "//" in the middle *) + let bad = "//" in + for offset = 0 to String.length path - (String.length bad) do + if String.sub path offset (String.length bad) = bad then + raise (Invalid_path path) + done; + (* Paths shouldn't have a "/" at the end, except for the root *) + if path <> "/" && path <> "" && path.[String.length path - 1] = '/' then + raise (Invalid_path path) + +(** Check to see if a path is suitable for watches *) +let validate_watch_path path = + (* Check for stuff like @releaseDomain etc first *) + if path <> "" && path.[0] = '@' then () + else validate_path path + +let debug command con = + sync (Queueop.debug command) con + +let directory tid path con = + validate_path path; + let data = sync (Queueop.directory tid path) con in + split_string '\000' data + +let read tid path con = + validate_path path; + sync (Queueop.read tid path) con + +let readv tid dir vec con = + List.map (fun path -> validate_path path; read tid path con) + (if dir <> "" then + (List.map (fun v -> dir ^ "/" ^ v) vec) else vec) + +let getperms tid path con = + validate_path path; + perms_of_string (sync (Queueop.getperms tid path) con) + +let watch path data con = + validate_watch_path path; + ack (sync (Queueop.watch path data) con) + +let unwatch path data con = + validate_watch_path path; + ack (sync (Queueop.unwatch path data) con) + +let transaction_start con = + let data = sync (Queueop.transaction_start) con in + try + int_of_string data + with + _ -> raise (Packet.DataError (Printf.sprintf "int expected; got '%s'" data)) + +let transaction_end tid commit con = + try + ack (sync (Queueop.transaction_end tid commit) con); + true + with + Xb.Eagain -> false + +let introduce domid mfn port con = + ack (sync (Queueop.introduce domid mfn port) con) + +let release domid con = + ack (sync (Queueop.release domid) con) + +let resume domid con = + ack (sync (Queueop.resume domid) con) + +let getdomainpath domid con = + sync (Queueop.getdomainpath domid) con + +let write tid path value con = + validate_path path; + ack (sync (Queueop.write tid path value) con) + +let writev tid dir vec con = + List.iter (fun (entry, value) -> + let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + write tid path value con) vec + +let mkdir tid path con = + validate_path path; + ack (sync (Queueop.mkdir tid path) con) + +let rm tid path con = + validate_path path; + try + ack (sync (Queueop.rm tid path) con) + with + Xb.Noent -> () + +let setperms tid path perms con = + validate_path path; + ack (sync (Queueop.setperms tid path (string_of_perms perms)) con) + +let setpermsv tid dir vec perms con = + List.iter (fun entry -> + let path = (if dir <> "" then dir ^ "/" ^ entry else entry) in + validate_path path; + setperms tid path perms con) vec diff --git a/tools/ocaml/libs/xs/xsraw.mli b/tools/ocaml/libs/xs/xsraw.mli new file mode 100644 index 0000000..42f87b6 --- /dev/null +++ b/tools/ocaml/libs/xs/xsraw.mli @@ -0,0 +1,60 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 Partial_not_empty +exception Unexpected_packet of string +exception Invalid_path of string +val unexpected_packet : Xb.Op.operation -> Xb.Op.operation -> 'a +type con = { xb : Xb.t; watchevents : (string * string) Queue.t; } +val close : con -> unit +val open_fd : Unix.file_descr -> con +val split_string : ?limit:int -> char -> string -> string list +type perm = PERM_NONE | PERM_READ | PERM_WRITE | PERM_RDWR +type perms = int * perm * (int * perm) list +val string_of_perms : int * perm * (int * perm) list -> string +val perms_of_string : string -> int * perm * (int * perm) list +val pkt_send : con -> unit +val pkt_recv : con -> Xb.Packet.t +val pkt_recv_timeout : con -> float -> bool * Xb.Packet.t option +val queue_watchevent : con -> string -> unit +val has_watchevents : con -> bool +val get_watchevent : con -> string * string +val read_watchevent : con -> string * string +val sync_recv : Xb.Op.operation -> con -> string +val sync : (Xb.t -> 'a) -> con -> string +val ack : string -> unit +val validate_path : string -> unit +val validate_watch_path : string -> unit +val directory : int -> string -> con -> string list +val debug : string list -> con -> string +val read : int -> string -> con -> string +val readv : int -> string -> string list -> con -> string list +val getperms : int -> string -> con -> int * perm * (int * perm) list +val watch : string -> string -> con -> unit +val unwatch : string -> string -> con -> unit +val transaction_start : con -> int +val transaction_end : int -> bool -> con -> bool +val introduce : int -> nativeint -> int -> con -> unit +val release : int -> con -> unit +val resume : int -> con -> unit +val getdomainpath : int -> con -> string +val write : int -> string -> string -> con -> unit +val writev : int -> string -> (string * string) list -> con -> unit +val mkdir : int -> string -> con -> unit +val rm : int -> string -> con -> unit +val setperms : int -> string -> int * perm * (int * perm) list -> con -> unit +val setpermsv : + int -> + string -> string list -> int * perm * (int * perm) list -> con -> unit diff --git a/tools/ocaml/libs/xs/xst.ml b/tools/ocaml/libs/xs/xst.ml new file mode 100644 index 0000000..16affd2 --- /dev/null +++ b/tools/ocaml/libs/xs/xst.ml @@ -0,0 +1,61 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 ops = +{ + directory: string -> string list; + read: string -> string; + readv: string -> string list -> string list; + write: string -> string -> unit; + writev: string -> (string * string) list -> unit; + mkdir: string -> unit; + rm: string -> unit; + getperms: string -> Xsraw.perms; + setperms: string -> Xsraw.perms -> unit; + setpermsv: string -> string list -> Xsraw.perms -> unit; +} + +let get_operations tid xsh = { + directory = (fun path -> Xsraw.directory tid path xsh); + read = (fun path -> Xsraw.read tid path xsh); + readv = (fun dir vec -> Xsraw.readv tid dir vec xsh); + write = (fun path value -> Xsraw.write tid path value xsh); + writev = (fun dir vec -> Xsraw.writev tid dir vec xsh); + mkdir = (fun path -> Xsraw.mkdir tid path xsh); + rm = (fun path -> Xsraw.rm tid path xsh); + getperms = (fun path -> Xsraw.getperms tid path xsh); + setperms = (fun path perms -> Xsraw.setperms tid path perms xsh); + setpermsv = (fun dir vec perms -> Xsraw.setpermsv tid dir vec perms xsh); +} + +let transaction xsh (f: ops -> 'a) : 'a = + let commited = ref false and result = ref None in + while not !commited + do + let tid = Xsraw.transaction_start xsh in + let t = get_operations tid xsh in + + begin try + result := Some (f t) + with exn -> + ignore (Xsraw.transaction_end tid false xsh); + raise exn + end; + commited := Xsraw.transaction_end tid true xsh + done; + match !result with + | None -> failwith "internal error in transaction" + | Some result -> result diff --git a/tools/ocaml/libs/xs/xst.mli b/tools/ocaml/libs/xs/xst.mli new file mode 100644 index 0000000..5ae5604 --- /dev/null +++ b/tools/ocaml/libs/xs/xst.mli @@ -0,0 +1,30 @@ +(* + * Copyright (C) 2006-2007 XenSource Ltd. + * Copyright (C) 2008 Citrix Ltd. + * Author Vincent Hanquez + * + * 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 ops = { + directory : string -> string list; + read : string -> string; + readv : string -> string list -> string list; + write : string -> string -> unit; + writev : string -> (string * string) list -> unit; + mkdir : string -> unit; + rm : string -> unit; + getperms : string -> Xsraw.perms; + setperms : string -> Xsraw.perms -> unit; + setpermsv : string -> string list -> Xsraw.perms -> unit; +} + +val get_operations : int -> Xsraw.con -> ops +val transaction : Xsraw.con -> (ops -> 'a) -> 'a