[PATCH v4 4/4] tools/ocaml/xenstored: use more efficient tries

[Edwin Török <edvin.torok@xxxxxxxxxx>]

No functional change, just an optimization.

Signed-off-by: Edwin Török <edvin.torok@xxxxxxxxxx>
Acked-by: Christian Lindig <christian.lindig@xxxxxxxxxx>
---
Changes since V3:
* none, repost after previous commits fix compatibility with OCaml 4.02
---
 tools/ocaml/xenstored/connections.ml |  2 +-
 tools/ocaml/xenstored/symbol.ml      |  6 +--
 tools/ocaml/xenstored/trie.ml        | 59 ++++++++++++----------------
 tools/ocaml/xenstored/trie.mli       | 26 ++++++------
 4 files changed, 43 insertions(+), 50 deletions(-)

diff --git a/tools/ocaml/xenstored/connections.ml 
b/tools/ocaml/xenstored/connections.ml
index f02ef6b526..4983c7370b 100644
--- a/tools/ocaml/xenstored/connections.ml
+++ b/tools/ocaml/xenstored/connections.ml
@@ -21,7 +21,7 @@ type t = {
        anonymous: (Unix.file_descr, Connection.t) Hashtbl.t;
        domains: (int, Connection.t) Hashtbl.t;
        ports: (Xeneventchn.t, Connection.t) Hashtbl.t;
-       mutable watches: (string, Connection.watch list) Trie.t;
+       mutable watches: Connection.watch list Trie.t;
 }
 
 let create () = {
diff --git a/tools/ocaml/xenstored/symbol.ml b/tools/ocaml/xenstored/symbol.ml
index 301639f16f..72a84ebf80 100644
--- a/tools/ocaml/xenstored/symbol.ml
+++ b/tools/ocaml/xenstored/symbol.ml
@@ -31,9 +31,9 @@ let equal a b =
   (* compare using physical equality, both members have to be part of the 
above weak table *)
   a == b
 
-let compare a b =
-  if equal a b then 0
-  else -(String.compare a b)
+(* the sort order is reversed here, so that Map.fold constructs a list
+   in ascending order *)
+let compare a b = String.compare b a
 
 let stats () =
   let len, entries, _, _, _, _ = WeakTable.stats tbl in
diff --git a/tools/ocaml/xenstored/trie.ml b/tools/ocaml/xenstored/trie.ml
index f513f4e608..ad2aed5123 100644
--- a/tools/ocaml/xenstored/trie.ml
+++ b/tools/ocaml/xenstored/trie.ml
@@ -15,24 +15,26 @@
 
 open Stdext
 
+module StringMap = Map.Make(String)
+
 module Node =
 struct
-       type ('a,'b) t =  {
-               key: 'a;
-               value: 'b option;
-               children: ('a,'b) t list;
+       type 'a t =  {
+               key: string;
+               value: 'a option;
+               children: 'a t StringMap.t;
        }
 
        let _create key value = {
                key = key;
                value = Some value;
-               children = [];
+               children = StringMap.empty;
        }
 
        let empty key = {
                key = key;
                value = None;
-               children = []
+               children = StringMap.empty;
        }
 
        let _get_key node = node.key
@@ -49,41 +51,31 @@ struct
                { node with children = children }
 
        let _add_child node child =
-               { node with children = child :: node.children }
+               { node with children = StringMap.add child.key child 
node.children }
 end
 
-type ('a,'b) t = ('a,'b) Node.t list
+type 'a t = 'a Node.t StringMap.t
 
 let mem_node nodes key =
-       List.exists (fun n -> n.Node.key = key) nodes
+       StringMap.mem key nodes
 
 let find_node nodes key =
-       List.find (fun n -> n.Node.key = key) nodes
+       StringMap.find 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
+       StringMap.update key (function None -> None | Some _ -> Some node) 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
+       StringMap.update key (function None -> raise Not_found | Some _ -> 
None) nodes
 
-let create () = []
+let create () = StringMap.empty
 
 let rec iter f tree =
-       let aux node =
-               f node.Node.key node.Node.value;
+       let aux key node =
+               f key node.Node.value;
                iter f node.Node.children
        in
-       List.iter aux tree
+       StringMap.iter aux tree
 
 let rec map f tree =
        let aux node =
@@ -94,13 +86,14 @@ let rec map f tree =
                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)
+       tree |> StringMap.map aux
+       |> StringMap.filter (fun _ n -> n.Node.value <> None || not 
(StringMap.is_empty n.Node.children) )
 
 let rec fold f tree acc =
-       let aux accu node =
-               fold f node.Node.children (f node.Node.key node.Node.value accu)
+       let aux key node accu =
+               fold f node.Node.children (f key node.Node.value accu)
        in
-       List.fold_left aux acc tree
+       StringMap.fold aux tree acc
 
 (* return a sub-trie *)
 let rec sub_node tree = function
@@ -117,7 +110,7 @@ let rec sub_node tree = function
 
 let sub tree path =
        try (sub_node tree path).Node.children
-       with Not_found -> []
+       with Not_found -> StringMap.empty
 
 let find tree path =
        Node.get_value (sub_node tree path)
@@ -161,7 +154,7 @@ and set tree path value =
                                  replace_node tree h (set_node node t value)
                          end else begin
                                  let node = Node.empty h in
-                                 set_node node t value :: tree
+                                 StringMap.add node.Node.key (set_node node t 
value) tree
                          end
 
 let rec unset tree = function
@@ -176,7 +169,7 @@ let rec unset tree = function
                                  then Node.set_children (Node.empty h) children
                                  else Node.set_children node children
                          in
-                         if children = [] && new_node.Node.value = None
+                         if StringMap.is_empty children && new_node.Node.value 
= None
                          then remove_node tree h
                          else replace_node tree h new_node
                  end else
diff --git a/tools/ocaml/xenstored/trie.mli b/tools/ocaml/xenstored/trie.mli
index 5dc53c1cb1..27785154f5 100644
--- a/tools/ocaml/xenstored/trie.mli
+++ b/tools/ocaml/xenstored/trie.mli
@@ -15,46 +15,46 @@
 
 (** 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.
+type 'a t
+(** The type of tries. ['a] the type of values.
        Internally, a trie is represented as a labeled tree, where node 
contains values
-       of type ['a * 'b option]. *)
+       of type [string * 'a option]. *)
 
-val create : unit -> ('a,'b) t
+val create : unit -> 'a t
 (** Creates an empty trie. *)
 
-val mem : ('a,'b) t -> 'a list -> bool
+val mem : 'a t -> string 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
+val find : 'a t -> string list -> 'a
 (** [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
+val set : 'a t -> string list -> 'a -> 'a 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
+val unset : 'a t -> string list -> 'a 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
+val iter : (string -> 'a option -> unit) -> 'a 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
+val iter_path : (string -> 'a option -> unit) -> 'a t -> string 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
+val fold : (string -> 'a option -> 'c -> 'c) -> 'a 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
+val map : ('a -> 'b option) -> 'a t -> 'b 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
+val sub : 'a t -> string list -> 'a 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. *)
-- 
2.25.1