Fix MS queue test loop loop without safe point

Author: polytypic

test/michael_scott_queue/qcheck_michael_scott_queue.ml

@@ -1,4 +1,4 @@
-open Saturn_lockfree.Queue
+module Queue = Saturn_lockfree.Queue
 
 let tests_sequential =
   QCheck.
@@ -7,57 +7,59 @@ let tests_sequential =
       Test.make ~name:"push" (list int) (fun lpush ->
           assume (lpush <> []);
           (* Building a random queue *)
-          let queue = create () in
-          List.iter (push queue) lpush;
+          let queue = Queue.create () in
+          List.iter (Queue.push queue) lpush;
 
           (* Testing property *)
-          not (is_empty queue));
+          not (Queue.is_empty queue));
       (* TEST 2 - push, pop until empty *)
       Test.make ~name:"push_pop_opt_until_empty" (list int) (fun lpush ->
           (* Building a random queue *)
-          let queue = create () in
-          List.iter (push queue) lpush;
+          let queue = Queue.create () in
+          List.iter (Queue.push queue) lpush;
 
           (* Popping until [is_empty q] is true *)
           let count = ref 0 in
-          while not (is_empty queue) do
+          while not (Queue.is_empty queue) do
             incr count;
-            ignore (pop_opt queue)
+            ignore (Queue.pop_opt queue)
           done;
 
           (* Testing property *)
-          pop_opt queue = None && !count = List.length lpush);
+          Queue.pop_opt queue = None && !count = List.length lpush);
       (* TEST 3 - push, pop_opt, check FIFO  *)
       Test.make ~name:"fifo" (list int) (fun lpush ->
           (* Building a random queue *)
-          let queue = create () in
-          List.iter (push queue) lpush;
+          let queue = Queue.create () in
+          List.iter (Queue.push queue) lpush;
 
           let out = ref [] in
           let insert v = out := v :: !out in
 
           for _ = 1 to List.length lpush do
-            match pop_opt queue with None -> assert false | Some v -> insert v
+            match Queue.pop_opt queue with
+            | None -> assert false
+            | Some v -> insert v
           done;
 
           (* Testing property *)
           lpush = List.rev !out);
       (* TEST 3 - push, pop_opt, peek_opt check FIFO  *)
       Test.make ~name:"fifo_peek_opt" (list int) (fun lpush ->
           (* Building a random queue *)
-          let queue = create () in
-          List.iter (push queue) lpush;
+          let queue = Queue.create () in
+          List.iter (Queue.push queue) lpush;
 
           let pop = ref [] in
           let peek = ref [] in
           let insert out v = out := v :: !out in
 
           for _ = 1 to List.length lpush do
-            match peek_opt queue with
+            match Queue.peek_opt queue with
             | None -> assert false
             | Some v -> (
                 insert peek v;
-                match pop_opt queue with
+                match Queue.pop_opt queue with
                 | None -> assert false
                 | Some v -> insert pop v)
           done;
@@ -73,28 +75,31 @@ let tests_one_consumer_one_producer =
          Parallel [push] and [pop_opt]. *)
       Test.make ~name:"parallel_fifo" (list int) (fun lpush ->
           (* Initialization *)
-          let queue = create () in
+          let queue = Queue.create () in
           let barrier = Barrier.create 2 in
 
           (* Producer pushes. *)
           let producer =
             Domain.spawn (fun () ->
                 Barrier.await barrier;
-                List.iter (push queue) lpush)
+                List.iter (Queue.push queue) lpush)
           in
 
           Barrier.await barrier;
           let fifo =
             List.fold_left
               (fun acc item ->
-                let popped = ref None in
-                while Option.is_none !popped do
-                  popped := pop_opt queue
-                done;
-                acc && item = Option.get !popped)
+                let rec pop_one () =
+                  match Queue.pop_opt queue with
+                  | None ->
+                      Domain.cpu_relax ();
+                      pop_one ()
+                  | Some item' -> acc && item = item'
+                in
+                pop_one ())
               true lpush
           in
-          let empty = is_empty queue in
+          let empty = Queue.is_empty queue in
 
           (* Ensure nothing is left behind. *)
           Domain.join producer;
@@ -104,22 +109,22 @@ let tests_one_consumer_one_producer =
       Test.make ~name:"parallel_peek" (list int) (fun pushed ->
           (* Initialization *)
           let npush = List.length pushed in
-          let queue = create () in
+          let queue = Queue.create () in
           let barrier = Barrier.create 2 in
 
           (* Producer pushes. *)
           let producer =
             Domain.spawn (fun () ->
                 Barrier.await barrier;
-                List.iter (push queue) pushed)
+                List.iter (Queue.push queue) pushed)
           in
 
           let peeked = ref [] in
           let popped = ref [] in
           Barrier.await barrier;
           for _ = 1 to npush do
-            peeked := peek_opt queue :: !peeked;
-            popped := pop_opt queue :: !popped
+            peeked := Queue.peek_opt queue :: !peeked;
+            popped := Queue.pop_opt queue :: !popped
           done;
 
           Domain.join producer;
@@ -147,7 +152,7 @@ let tests_two_domains =
       Test.make ~name:"parallel_pop_opt_push" (pair small_nat small_nat)
         (fun (npush1, npush2) ->
           (* Initialization *)
-          let queue = create () in
+          let queue = Queue.create () in
           let barrier = Barrier.create 2 in
 
           (* Using these lists instead of a random one enables to
@@ -158,9 +163,9 @@ let tests_two_domains =
           let work lpush =
             List.map
               (fun elt ->
-                push queue elt;
+                Queue.push queue elt;
                 Domain.cpu_relax ();
-                pop_opt queue)
+                Queue.pop_opt queue)
               lpush
           in
 
@@ -205,7 +210,7 @@ let tests_two_domains =
       Test.make ~name:"parallel_pop_opt_push_random" (pair small_nat small_nat)
         (fun (npush1, npush2) ->
           (* Initialization *)
-          let queue = create () in
+          let queue = Queue.create () in
           let barrier = Barrier.create 2 in
 
           let lpush1 = List.init npush1 (fun i -> i) in
@@ -222,11 +227,11 @@ let tests_two_domains =
                 match lpush with
                 | [] -> popped
                 | elt :: xs ->
-                    push queue elt;
+                    Queue.push queue elt;
                     loop xs popped)
               else (
                 incr consecutive_pop;
-                let p = pop_opt queue in
+                let p = Queue.pop_opt queue in
                 loop lpush (p :: popped))
             in
             loop lpush []
@@ -256,7 +261,7 @@ let tests_two_domains =
           (* Pop everything that is still on the queue *)
           let popped3 =
             let rec loop popped =
-              match pop_opt queue with
+              match Queue.pop_opt queue with
               | None -> popped
               | Some v -> loop (v :: popped)
             in