From 56ca108e63191e90c3d4169c37a4c97017e3c6ae Mon Sep 17 00:00:00 2001
From: Alec Faithfull
Date: Tue, 6 Oct 2015 14:19:34 +0200
Subject: TQueue: Expose the length of TQueues

---
 stm/tQueue.ml  | 8 ++++++++
 stm/tQueue.mli | 2 ++
 2 files changed, 10 insertions(+)

diff --git a/stm/tQueue.ml b/stm/tQueue.ml
index 6fef895ae8..2a43cd7d13 100644
--- a/stm/tQueue.ml
+++ b/stm/tQueue.ml
@@ -15,6 +15,7 @@ module PriorityQueue : sig
   val pop : ?picky:('a -> bool) -> 'a t -> 'a
   val push : 'a t -> 'a -> unit
   val clear : 'a t -> unit
+  val length : 'a t -> int
 end = struct
   type 'a item = int * 'a
   type 'a rel = 'a item -> 'a item -> int
@@ -38,6 +39,7 @@ end = struct
   let set_rel rel ({ contents = (xs, _) } as t) =
     let rel (_,x) (_,y) = rel x y in
     t := (List.sort rel xs, rel)
+  let length ({ contents = (l, _) }) = List.length l
 end
 
 type 'a t = {
@@ -92,6 +94,12 @@ let push { queue = q; lock = m; cond = c; release } x =
   Condition.broadcast c;
   Mutex.unlock m
 
+let length { queue = q; lock = m } =
+  Mutex.lock m;
+  let n = PriorityQueue.length q in
+  Mutex.unlock m;
+  n
+
 let clear { queue = q; lock = m; cond = c } =
   Mutex.lock m;
   PriorityQueue.clear q;
diff --git a/stm/tQueue.mli b/stm/tQueue.mli
index 7458de510f..f54af4df47 100644
--- a/stm/tQueue.mli
+++ b/stm/tQueue.mli
@@ -28,3 +28,5 @@ exception BeingDestroyed
 (* Threads blocked in pop can get this exception if the queue is being
  * destroyed *)
 val destroy : 'a t -> unit
+
+val length : 'a t -> int
-- 
cgit v1.2.3