lazyList contains a simple lazy list implementation.
extentlistSet contains a Set implementation where elements are stored as a list of (start, length) pairs
set_test contains functions to test a set implementation
extentlistset_test contains test cases for extentlistSet using set_test.
Signed-off-by: David Scott <dave.scott@eu.citrix.com>
STDEXT_OBJS = fun opt listext filenameext stringext arrayext hashtblext pervasiveext threadext ring \
qring fring bigbuffer unixext range vIO trie config date encodings fe fecomms \
- forkhelpers gzip sha1sum zerocheck base64 backtrace tar mapext os either
+ forkhelpers gzip sha1sum zerocheck base64 backtrace tar mapext os either \
+ lazyList extentlistSet set_test
INTF = $(foreach obj, $(STDEXT_OBJS),$(obj).cmi)
LIBS = stdext.cma stdext.cmxa
-PROGRAMS = base64pp fe_cli fe_test
+PROGRAMS = base64pp fe_cli fe_test extentlistset_test
DOCDIR = /myrepos/xen-api-libs.hg/doc
fe_test: fe_test.ml all libstdext_stubs.a
ocamlfind $(OCAMLOPT) $(OCAMLOPTFLAGS) unix.cmxa ../uuid/uuid.cmxa ../rpc-light/rpc.cmx ../rpc-light/jsonrpc.cmx stdext.cmxa -linkpkg -I ../uuid -o $@ $< -ccopt -L.
+extentlistset_test: extentlistset_test.ml all libstdext_stubs.a
+ ocamlfind $(OCAMLOPT) $(OCAMLOPTFLAGS) unix.cmxa stdext.cmxa -linkpkg -o $@ $< -ccopt -L.
+
stdext.cmxa: libstdext_stubs.a $(foreach obj,$(STDEXT_OBJS),$(obj).cmx)
$(OCAMLOPT) $(OCAMLOPTFLAGS) -a -o $@ -cclib -lstdext_stubs $(foreach obj,$(STDEXT_OBJS),$(obj).cmx)
--- /dev/null
+
+module type Number = sig
+ type t
+ val zero: t
+ val add : t -> t -> t
+ val sub : t -> t -> t
+end
+
+module ExtentlistSet (A : Number) =
+struct
+ type extent = A.t * A.t
+ type t = extent list
+
+ let ($+) = A.add
+ let ($-) = A.sub
+
+ let empty = []
+
+ let sort list : t =
+ List.sort (fun x y -> compare (fst x) (fst y)) list
+
+ let remove_zeroes = List.filter (fun (_, y) -> y <> A.zero)
+
+ let union (list1: t) (list2: t) : t =
+ let combined = sort (list1 @ list2) in
+ let rec inner l acc =
+ match l with
+ | (s1,e1)::(s2,e2)::ls ->
+ let extent1_end = s1 $+ e1 in
+ if extent1_end < s2 then
+ inner ((s2,e2)::ls) ((s1,e1)::acc)
+ else
+ let extent2_end = s2 $+ e2 in
+ if extent1_end > extent2_end then
+ inner ((s1,e1)::ls) acc
+ else
+ inner ((s1,s2 $+ e2 $- s1)::ls) acc
+ | (s1,e1)::[] -> (s1,e1)::acc
+ | [] -> []
+ in List.rev (inner combined [])
+
+ let intersection (list1: t) (list2: t) =
+ let rec inner l1 l2 acc =
+ match (l1,l2) with
+ | (s1,e1)::l1s , (s2,e2)::l2s ->
+ if s1 > s2 then inner l2 l1 acc else
+ if s1 $+ e1 < s2 then inner l1s l2 acc else
+ if s1 < s2 then inner ((s2,e1 $+ s1 $- s2)::l1s) l2 acc else
+ (* s1=s2 *)
+ if e1 < e2 then
+ inner l1s ((s2 $+ e1,e2 $- e1)::l2s) ((s1,e1)::acc)
+ else if e1 > e2 then
+ inner ((s1 $+ e2,e1 $- e2)::l1s) l2s ((s2,e2)::acc)
+ else (* e1=e2 *)
+ inner l1s l2s ((s1,e1)::acc)
+ | _ -> List.rev acc
+ in
+ remove_zeroes(inner list1 list2 [])
+
+ let difference (list1: t) (list2: t) : t =
+ let rec inner l1 l2 acc =
+ match (l1,l2) with
+ | (s1,e1)::l1s , (s2,e2)::l2s ->
+ if s1<s2 then begin
+ if s1 $+ e1 > s2 then
+ inner ((s2,s1 $+ e1 $- s2)::l1s) l2 ((s1,s2 $- s1)::acc)
+ else
+ inner l1s l2 ((s1,e1)::acc)
+ end else if s1>s2 then begin
+ if s2 $+ e2 > s1 then
+ inner l1 ((s1,s2 $+ e2 $- s1)::l2s) acc
+ else
+ inner l1 l2s acc
+ end else begin
+ (* s1=s2 *)
+ if e1 > e2 then
+ inner ((s1 $+ e2,e1 $- e2)::l1s) l2s acc
+ else if e1 < e2 then
+ inner l1s ((s2 $+ e1,e2 $- e1)::l2s) acc
+ else
+ inner l1s l2s acc
+ end
+ | l1s, [] -> (List.rev acc) @ l1s
+ | [], _ -> List.rev acc
+ in
+ remove_zeroes(inner list1 list2 [])
+
+ let of_list (list: extent list) : t =
+ let l = sort list in
+ let rec inner ls acc =
+ match ls with
+ | (s1,e1)::(s2,e2)::rest ->
+ (* extents should be non-overlapping *)
+ if s1 $+ e1 > s2 then failwith "Bad list"
+ (* adjacent extents should be coalesced *)
+ else if s1 $+ e1=s2 then inner ((s1,e1 $+ e2)::rest) acc
+ else inner ((s2,e2)::rest) ((s1,e1)::acc)
+ | (s1,e1)::[] -> List.rev ((s1,e1)::acc)
+ | [] -> List.rev acc
+ in
+ inner l []
+
+ let fold_left = List.fold_left
+
+ let to_list x = x
+end
--- /dev/null
+(** A module to represent sets of elements as (start, length) pairs. *)\r
+\r
+(** Elements must be 'Numbers': *)\r
+module type Number = sig \r
+ type t \r
+ val zero: t\r
+ val add : t -> t -> t \r
+ val sub : t -> t -> t \r
+\r
+end\r
+\r
+(** Representation of a Set *)\r
+module ExtentlistSet: functor (A : Number) -> sig\r
+ type extent = A.t * A.t\r
+ type t\r
+\r
+ val empty : t\r
+\r
+ val union : t -> t -> t\r
+ val intersection : t -> t -> t\r
+ val difference : t -> t -> t\r
+\r
+ val of_list : extent list -> t\r
+ val to_list : t -> extent list\r
+ val fold_left : ('a -> extent -> 'a) -> 'a -> t -> 'a\r
+end\r
+\r
--- /dev/null
+(* We will check if a list of set equalities hold over random inputs *)
+
+open Set_test
+
+(* We test using the integer domain only. *)
+module Intextentlist = ExtentlistSet.ExtentlistSet(struct
+ type t=int
+ let zero=0
+ let add=(+)
+ let sub=(-)
+end)
+open Intextentlist
+
+(* Sets are finite, up to cardinality [size] *)
+let size = 1000
+
+module Tests = SetEqualities(struct
+ type t = Intextentlist.t
+ let universe = of_list [(0, size)]
+ let (+) = union
+ let (^) = intersection
+ let (-) = difference
+
+ let not x = universe - x
+ let (=) x y = (x - y = empty) && (y - x = empty)
+ let extent_to_string (s, l) = Printf.sprintf "(%d, %d)" s l
+ let to_string xs = String.concat ", " (List.map extent_to_string (to_list xs))
+end)
+(* Given a triple of inputs, check that all the set equalities hold *)
+let one (a, b, c) = List.iter (fun f -> f a b c) Tests.all
+
+open LazyList
+
+(** [make p s e] return an extentlist starting at [s], ending before [e] where
+ an integer x is covered by the extentlist iff [p x] *)
+let make p s e =
+ let rec ints acc a b = if a < b then ints (a :: acc) (a + 1) b else acc in
+ of_list (List.fold_left (fun acc x -> if p x then (x, 1)::acc else acc) [] (ints [] s e))
+
+(* A lazy-list of random triples (a, b, c)*)
+let random_inputs =
+ let one () = make (fun _ -> Random.bool ()) 0 (size - 1) in
+ (* Create triples of random inputs for the checker *)
+ let three () = one (), one (), one () in
+ let rec f () = lazy (Cons(three (), f ())) in
+ f ()
+
+let _ =
+ let n = 1000 in
+ iter (fun _ -> ()) (take n (map one random_inputs));
+ Printf.printf "%d random sets of maximum size %d checked.\n" n size
+
+type run =
+ | Empty of int
+ | Full of int
+let to_run_list xs =
+ let rec inner acc index = function
+ | [] -> acc
+ | (x, y) :: xs -> inner (Full y :: (Empty (x - index)) :: acc) (x + y) xs in let map f xs =
+ let rec inner acc f = function
+ | [] -> acc
+ | (x :: xs) -> inner ((f x)::acc) f xs in
+ inner [] f xs in
+
+ List.rev (inner [] 0 xs)
+
+let _ =
+ (* vhds have max size of 2 TiB, in 2 MiB blocks => 2**20 blocks *)
+ (* The BAT consists of up to 2**20 blocks in any order *)
+ (* Worst case for us is as many singleton blocks as possible, which *)
+ (* can't be coalesced because they don't have neighbours. The maximum *)
+ (* number of blocks is achieved with the allocation pattern 10101010... *)
+ (* i.e. 2**19 singleton blocks. *)
+
+ (* As a bitmap we would have 2**19 / 2**3 = 2**16 bytes (64kbit) *)
+ let worst_case = make (fun x -> x mod 2 = 1) 0 (1024*1024/2/12) in
+ let hex (a, b) = Printf.sprintf "%x,%x" a b in
+ let to_string xs = "[" ^ (String.concat ";" (Listext.List.map_tr hex xs)) ^ "]" in
+
+
+ Printf.printf "generated\n";
+ let x = to_list worst_case in
+Printf.printf "got a list\n";
+ let y = Listext.List.map_tr hex x in
+Printf.printf "got lots of strings\n";
+ let s = to_string (to_list worst_case) in
+ Printf.printf "Extent size=%d\n" (String.length s);
+ let string_of_run = function
+ | Empty x -> Printf.sprintf "-%d" x
+ | Full x -> Printf.sprintf "+%d" x in
+ let s' = String.concat ";" (Listext.List.map_tr string_of_run (to_run_list x)) in
+ Printf.printf "Runs size=%d\n" (String.length s')
--- /dev/null
+(* A lazy-list implementation *)
+
+type 'a elt =
+ | Empty
+ | Cons of 'a * 'a t
+and 'a t = 'a elt lazy_t
+
+let rec map f xs = lazy(match Lazy.force xs with
+ | Empty -> Empty
+ | Cons(x, xs) -> Cons(f x, map f xs))
+
+let rec take n xs = lazy(match n, Lazy.force xs with
+ | 0, _ -> Empty
+ | n, Empty -> raise Not_found
+ | n, Cons(x, xs) -> Cons(x, take (n - 1) xs))
+
+let rec iter f xs = match Lazy.force xs with
+ | Empty -> ()
+ | Cons(x, xs) -> f x; iter f xs
+
--- /dev/null
+(** A lazy-list *)
+
+(** A forced lazy list element *)
+type 'a elt = Empty | Cons of 'a * 'a t
+
+(** A lazy list *)
+and 'a t = 'a elt lazy_t
+
+(** [map f xs] returns the list [f 1; f 2; ...; f n] *)
+val map : ('a -> 'b) -> 'a t -> 'b t
+
+(** [take n xs] returns the list truncated to the first [n] elements *)
+val take : int -> 'a t -> 'a t
+
+(** [iter f xs] applies every list element to [f] *)
+val iter : ('a -> 'b) -> 'a t -> unit
--- /dev/null
+module type Set = sig
+ type t
+ val (+): t -> t -> t (* union *)
+ val (^): t -> t -> t (* intersection *)
+ val (-): t -> t -> t (* difference *)
+ val not: t -> t (* complement *)
+ val (=): t -> t -> bool
+
+ val to_string: t -> string
+end
+
+module SetEqualities(S: Set) = struct
+ open S
+
+ let w txt f a b c =
+ if Pervasives.not(f a b c)
+ then failwith (Printf.sprintf "%s a=%s b=%s c=%s" txt (S.to_string a) (S.to_string b) (S.to_string c))
+
+ let all = [
+ w "commutative_1" (fun a b _ -> a + b = b + a);
+ w "commutative_2" (fun a b _ -> a ^ b = b ^ a);
+ w "associative_1" (fun a b c -> (a + b) + c = a + (b + c));
+ w "associative_2" (fun a b c -> (a ^ b) ^ c = a ^ (b ^ c));
+ w "distributive_1" (fun a b c -> a + (b ^ c) = (a + b) ^ (a + c));
+ w "distributive_2" (fun a b c -> a ^ (b + c) = (a ^ b) + (a ^ c));
+ w "complement_1" (fun a _ _ -> not (not a) = a);
+ w "demorgan_1" (fun a b _ -> not (a + b) = (not a) ^ (not b));
+ w "demorgan_2" (fun a b _ -> not (a ^ b) = (not a) + (not b));
+ ]
+end
+
--- /dev/null
+module type Set =
+ sig
+ type t
+ val ( + ) : t -> t -> t
+ val ( ^ ) : t -> t -> t
+ val ( - ) : t -> t -> t
+ val not : t -> t
+ val ( = ) : t -> t -> bool
+ val to_string : t -> string
+ end
+module SetEqualities :
+ functor (S : Set) ->
+ sig
+ val all : (S.t -> S.t -> S.t -> unit) list
+ end
/opt/xensource/libexec/pciutil
/opt/xensource/libexec/sexprpp
/opt/xensource/libexec/xmlpp
-
+ /opt/xensource/libexec/extentlistset_test
%files devel
%defattr(-,root,root,-)
/usr/lib/ocaml/stdext/dllstdext_stubs.so
/usr/lib/ocaml/stdext/encodings.cmi
/usr/lib/ocaml/stdext/encodings.cmx
+ /usr/lib/ocaml/stdext/extentlistSet.cmi
+ /usr/lib/ocaml/stdext/extentlistSet.cmx
+ /usr/lib/ocaml/stdext/extentlistset_test.cmx
/usr/lib/ocaml/stdext/fe.cmi
/usr/lib/ocaml/stdext/fe.cmx
/usr/lib/ocaml/stdext/fecomms.cmi
/usr/lib/ocaml/stdext/hashtblext.cmi
/usr/lib/ocaml/stdext/hashtblext.cmx
/usr/lib/ocaml/stdext/libstdext_stubs.a
+ /usr/lib/ocaml/stdext/lazyList.cmi
+ /usr/lib/ocaml/stdext/lazyList.cmx
/usr/lib/ocaml/stdext/listext.cmi
/usr/lib/ocaml/stdext/listext.cmx
/usr/lib/ocaml/stdext/mapext.cmi
/usr/lib/ocaml/stdext/range.cmx
/usr/lib/ocaml/stdext/ring.cmi
/usr/lib/ocaml/stdext/ring.cmx
+ /usr/lib/ocaml/stdext/set_test.cmi
+ /usr/lib/ocaml/stdext/set_test.cmx
/usr/lib/ocaml/stdext/sha1sum.cmi
/usr/lib/ocaml/stdext/sha1sum.cmx
/usr/lib/ocaml/stdext/stdext.a
projects / xcp / xen-api-libs.git / commitdiff