some tests for lfqueue

qtest/dune

@@ -7,7 +7,8 @@
 (rule
   (targets run_qtest.ml)
   (deps ./make.exe (source_tree ../src))
-  (action (run ./make.exe -target %{targets} ../src/core ../src/unix/)))
+  (action (run ./make.exe -target %{targets} ../src/core
+               ../src/lf_queue/ ../src/unix/)))
 
 (executable
   (name run_qtest)
@@ -15,7 +16,8 @@
   (modules run_qtest)
   ; disable some warnings in qtests
   (flags :standard -warn-error -a -w -3-33-35-27-39-50)
-  (libraries iter gen qcheck containers containers.unix unix uutf threads))
+  (libraries iter gen qcheck containers containers.unix
+             containers.lfqueue unix uutf threads))
 
 (rule
   (alias runtest)

src/lf_queue/containers_lfqueue.ml

@@ -57,55 +57,39 @@ let pop_nonblock self : _ option =
   done;
   !res
 
-module Blocking = struct
+(*$R
-  type nonrec 'a t = {
+  let q = create ~dummy:0 () in
-    q: 'a t;
+  push q 1;
-    n_parked: int A.t; (* threads waiting *)
+  push q 2;
-    park_lock: Mutex.t;
+  assert_equal (Some 1) (pop_nonblock q);
-    park_cond: Condition.t;
+  assert_equal (Some 2) (pop_nonblock q);
-  }
+  assert_equal None (pop_nonblock q);
+  push q 3;
+  assert_equal (Some 3) (pop_nonblock q);
+  assert_equal None (pop_nonblock q);
+*)
 
-  let create ~dummy () : _ t =
+(*$R
-    { q=create ~dummy ();
+  let q = create ~dummy:0 () in
-      n_parked=A.make 0;
-      park_lock=Mutex.create();
-      park_cond=Condition.create();
-    }
 
-  let push (self:_ t) x : unit =
+  let gen () =
-    push self.q x;
+    for i = 0 to 5 do
-    (* if any thread is parked, try to unpark one thread. It is possible
+      Thread.delay 0.01;
-       that a thread was parked, and woke up from another signal, to pick the
+      push q i
-       value already, but this should be safe. *)
+    done
-    if A.get self.n_parked > 0 then (
+  in
-      Mutex.lock self.park_lock;
-      Condition.signal self.park_cond;
-      Mutex.unlock self.park_lock;
-    )
 
-  let[@inline] pop_nonblock self : _ option =
+  let out = ref [] in
-    pop_nonblock self.q
+  let consume () =
+    let missing = ref 6 in
+    while !missing > 0 do
+      match pop_nonblock q with
+        | Some x -> out := x :: !out; decr missing
+        | None -> Thread.yield();
+    done
+  in
 
-  let pop_block (self:'a t) : 'a =
+  let th = [Thread.create gen (); Thread.create consume ()] in
-
+  List.iter Thread.join th;
-    (* be on the safe side: assume we're going to park,
+  assert_equal [5;4;3;2;1;0] !out
-       so that if another thread pushes after the "PARK" line it'll unpark us *)
+*)
-    A.incr self.n_parked;
-
-    let rec loop () =
-      match pop_nonblock self with
-        | Some x ->
-          (* release the token in self.n_parked *)
-          A.decr self.n_parked;
-          x
-        | None ->
-          (* PARK *)
-          Mutex.lock self.park_lock;
-          Condition.wait self.park_cond self.park_lock;
-          Mutex.unlock self.park_lock;
-          (* try again *)
-          (loop [@tailcall]) ()
-    in
-    loop()
-
-end

src/lf_queue/containers_lfqueue.mli

@@ -17,21 +17,3 @@ val push : 'a t -> 'a -> unit
 
 val pop_nonblock : 'a t -> 'a option
 (** pop the first element, or return [None]. *)
-
-(** Blocking queue.
-
-    This couples the non-blocking queue {!_ t} above,
-    with mutex/condition for the blocking case.
-*)
-module Blocking : sig
-  type 'a t
-
-  val create : dummy:'a -> unit -> 'a t
-
-  val push : 'a t -> 'a -> unit
-
-  val pop_nonblock : 'a t -> 'a option
-
-  (* FIXME *)
-  val pop_block : 'a t -> 'a
-end