STM: use a real priority queue

1 files changed, 43 insertions, 13 deletions

diff --git a/stm/tQueue.ml b/stm/tQueue.ml
index bf55eaf77..e4b9d382d 100644
--- a/stm/tQueue.ml
+++ b/stm/tQueue.ml
@@ -6,8 +6,38 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+module PriorityQueue : sig
+  type 'a t
+  val create : unit -> 'a t
+  val set_rel : ('a -> 'a -> int) -> 'a t -> unit
+  val is_empty : 'a t -> bool
+  val pop : 'a t -> 'a
+  val push : 'a -> 'a t -> unit
+  val clear : 'a t -> unit
+end = struct
+  type 'a item = int * 'a
+  type 'a rel = 'a item -> 'a item -> int
+  type 'a t = ('a item list * 'a rel) ref
+  let sort_timestamp (i,_) (j,_) = i - j
+  let age = ref 0
+  let create () = ref ([],sort_timestamp)
+  let is_empty t = fst !t = []
+  let pop ({ contents = (l, rel) } as t) =
+    match l with
+    | [] -> raise Queue.Empty
+    | (_,x) :: xs -> t := (xs, rel); x
+  let push x ({ contents = (xs, rel) } as t) =
+    incr age;
+    (* re-roting the whole list is not the most efficient way... *)
+    t := (List.sort rel (xs @ [!age,x]), rel)
+  let clear ({ contents = (l, rel) } as t) = t := ([], rel)
+  let set_rel rel ({ contents = (xs, _) } as t) =
+    let rel (_,x) (_,y) = rel x y in
+    t := (List.sort rel xs, rel)
+end
+
 type 'a t = {
-  queue: 'a Queue.t;
+  queue: 'a PriorityQueue.t;
   lock : Mutex.t;
   cond : Condition.t;
   mutable nwaiting : int;
@@ -15,7 +45,7 @@ type 'a t = {
 }
 
 let create () = {
-  queue = Queue.create ();
+  queue = PriorityQueue.create ();
   lock = Mutex.create ();
   cond = Condition.create ();
   nwaiting = 0;
@@ -24,13 +54,13 @@ let create () = {
 
 let pop ({ queue = q; lock = m; cond = c; cond_waiting = cn } as tq) =
   Mutex.lock m;
-  while Queue.is_empty q do
+  while PriorityQueue.is_empty q do
     tq.nwaiting <- tq.nwaiting + 1;
     Condition.signal cn;
     Condition.wait c m;
     tq.nwaiting <- tq.nwaiting - 1;
   done;
-  let x = Queue.pop q in
+  let x = PriorityQueue.pop q in
   Condition.signal c;
   Condition.signal cn;
   Mutex.unlock m;
@@ -38,20 +68,20 @@ let pop ({ queue = q; lock = m; cond = c; cond_waiting = cn } as tq) =
 
 let push { queue = q; lock = m; cond = c } x =
   Mutex.lock m;
-  Queue.push x q;
+  PriorityQueue.push x q;
   Condition.signal c;
   Mutex.unlock m
 
 let clear { queue = q; lock = m; cond = c } =
   Mutex.lock m;
-  Queue.clear q;
+  PriorityQueue.clear q;
   Mutex.unlock m
 
-let is_empty { queue = q } = Queue.is_empty q
+let is_empty { queue = q } = PriorityQueue.is_empty q
 
 let wait_until_n_are_waiting_and_queue_empty j tq =
   Mutex.lock tq.lock;
-  while not (Queue.is_empty tq.queue) || tq.nwaiting < j do
+  while not (PriorityQueue.is_empty tq.queue) || tq.nwaiting < j do
     Condition.wait tq.cond_waiting tq.lock
   done;
   Mutex.unlock tq.lock
@@ -59,13 +89,13 @@ let wait_until_n_are_waiting_and_queue_empty j tq =
 let dump { queue; lock } =
   let l = ref [] in
   Mutex.lock lock;
-  while not (Queue.is_empty queue) do l := Queue.pop queue :: !l done;
+  while not (PriorityQueue.is_empty queue) do
+    l := PriorityQueue.pop queue :: !l
+  done;
   Mutex.unlock lock;
   List.rev !l
 
-let reorder tq rel =
+let set_order tq rel =
   Mutex.lock tq.lock;
-  let l = ref [] in
-  while not (Queue.is_empty tq.queue) do l := Queue.pop tq.queue :: !l done;
-  List.iter (fun x -> Queue.push x tq.queue) (List.sort rel !l);
+  PriorityQueue.set_rel rel tq.queue;
   Mutex.unlock tq.lock