From 62e1c3712a1f85e1fd0cffe7e22498bb759f17a8 Mon Sep 17 00:00:00 2001
From: Simon Cruanes <simon.cruanes.2007@m4x.org>
Date: Tue, 22 Mar 2022 21:35:00 -0400
Subject: [PATCH] some tests for lfqueue

---
 qtest/dune                          |  6 ++-
 src/lf_queue/containers_lfqueue.ml  | 80 ++++++++++++-----------------
 src/lf_queue/containers_lfqueue.mli | 18 -------
 3 files changed, 36 insertions(+), 68 deletions(-)

diff --git a/qtest/dune b/qtest/dune
index f55c6a09..3fdfc089 100644
--- a/qtest/dune
+++ b/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)
diff --git a/src/lf_queue/containers_lfqueue.ml b/src/lf_queue/containers_lfqueue.ml
index 616fe757..c2184448 100644
--- a/src/lf_queue/containers_lfqueue.ml
+++ b/src/lf_queue/containers_lfqueue.ml
@@ -57,55 +57,39 @@ let pop_nonblock self : _ option =
   done;
   !res
 
-module Blocking = struct
-  type nonrec 'a t = {
-    q: 'a t;
-    n_parked: int A.t; (* threads waiting *)
-    park_lock: Mutex.t;
-    park_cond: Condition.t;
-  }
+(*$R
+  let q = create ~dummy:0 () in
+  push q 1;
+  push q 2;
+  assert_equal (Some 1) (pop_nonblock q);
+  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 =
-    { q=create ~dummy ();
-      n_parked=A.make 0;
-      park_lock=Mutex.create();
-      park_cond=Condition.create();
-    }
+(*$R
+  let q = create ~dummy:0 () in
 
-  let push (self:_ t) x : unit =
-    push self.q x;
-    (* if any thread is parked, try to unpark one thread. It is possible
-       that a thread was parked, and woke up from another signal, to pick the
-       value already, but this should be safe. *)
-    if A.get self.n_parked > 0 then (
-      Mutex.lock self.park_lock;
-      Condition.signal self.park_cond;
-      Mutex.unlock self.park_lock;
-    )
+  let gen () =
+    for i = 0 to 5 do
+      Thread.delay 0.01;
+      push q i
+    done
+  in
 
-  let[@inline] pop_nonblock self : _ option =
-    pop_nonblock self.q
+  let out = ref [] in
+  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 =
-
-    (* be on the safe side: assume we're going to park,
-       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
+  let th = [Thread.create gen (); Thread.create consume ()] in
+  List.iter Thread.join th;
+  assert_equal [5;4;3;2;1;0] !out
+*)
diff --git a/src/lf_queue/containers_lfqueue.mli b/src/lf_queue/containers_lfqueue.mli
index 6c4a18d2..a6ebd096 100644
--- a/src/lf_queue/containers_lfqueue.mli
+++ b/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