Add time limit for stm tests. (#152)

* Add time limit for stm tests.

* No need to skip STM tests on 32-bit

---------

Co-authored-by: Vesa Karvonen <[email protected]>

test/michael_scott_queue/dune

@@ -57,6 +57,4 @@
  (package saturn_lockfree)
  (name stm_michael_scott_queue)
  (modules stm_michael_scott_queue)
- (libraries ms_queues saturn_lockfree qcheck-core qcheck-stm.stm stm_run)
- (enabled_if
-  (= %{arch_sixtyfour} true)))
+ (libraries ms_queues saturn_lockfree qcheck-core qcheck-stm.stm stm_run))

test/michael_scott_queue/stm_michael_scott_queue.ml

@@ -58,10 +58,7 @@ module STM_ms_queue (Queue : Ms_queues.MS_queue_tests) = struct
       | _, _ -> false
   end
 
-  let run () =
-    Stm_run.run ~count:500 ~verbose:true
-      ~name:("Saturn_lockfree." ^ Queue.name)
-      (module Spec)
+  let run () = Stm_run.run ~name:("Saturn_lockfree." ^ Queue.name) (module Spec)
 end
 
 let () =

test/mpsc_queue/dune

@@ -33,6 +33,4 @@
   qcheck-core
   qcheck-multicoretests-util
   qcheck-stm.stm
-  stm_run)
- (enabled_if
-  (= %{arch_sixtyfour} true)))
+  stm_run))

test/mpsc_queue/stm_mpsc_queue.ml

@@ -114,7 +114,5 @@ let () =
       Dom.neg_agree_test_par ~count ~name:(name ^ " parallel, negative");
     ]
   in
-  Stm_run.run ~count:1000 ~name:"Saturn_lockfree.Mpsc_queue" ~verbose:true
-    ~make_domain
-    (module Spec)
+  Stm_run.run ~name:"Saturn_lockfree.Mpsc_queue" ~make_domain (module Spec)
   |> exit

test/skiplist/stm_skiplist.ml

@@ -64,6 +64,4 @@ module Spec = struct
     | _, _ -> false
 end
 
-let () =
-  Stm_run.run ~count:1000 ~verbose:true ~name:"Lockfree.Skiplist" (module Spec)
-  |> exit
+let () = Stm_run.run ~name:"Lockfree.Skiplist" (module Spec) |> exit

test/spsc_queue/dune

@@ -53,6 +53,4 @@
   qcheck-core
   qcheck-multicoretests-util
   qcheck-stm.stm
-  stm_run)
- (enabled_if
-  (= %{arch_sixtyfour} true)))
+  stm_run))

test/spsc_queue/stm_spsc_queue.ml

@@ -96,9 +96,9 @@ module STM_spsc (Spsc_queue : Spsc_queues.SPSC_tests) = struct
         Dom.neg_agree_test_par ~count ~name:(name ^ " parallel, negative");
       ]
     in
-    Stm_run.run ~count:1000
+    Stm_run.run
       ~name:("Saturn_lockfree." ^ Spsc_queue.name)
-      ~verbose:true ~make_domain
+      ~make_domain
       (module Spec)
 end
 

test/stm_run/dune

@@ -17,6 +17,7 @@
   qcheck-stm.stm
   qcheck-stm.sequential
   qcheck-stm.thread
+  unix
   (select
    empty.ml
    from

test/stm_run/intf.ml

@@ -43,3 +43,6 @@ module type STM_domain = sig
   val agree_test_par_asym : count:int -> name:string -> QCheck.Test.t
   val neg_agree_test_par_asym : count:int -> name:string -> QCheck.Test.t
 end
+
+let default_count = 1_000
+let default_budgetf = 60.0

test/stm_run/stm_run.ocaml4.ml

@@ -1,8 +1,10 @@
 include Intf
 
-let run ~verbose ~count ~name ?make_domain (module Spec : STM.Spec) =
+let run ?(verbose = true) ?(count = default_count) ?(budgetf = default_budgetf)
+    ~name ?make_domain (module Spec : STM.Spec) =
   let module Seq = STM_sequential.Make (Spec) in
   let module Con = STM_thread.Make (Spec) [@alert "-experimental"] in
+  Util.run_with_budget ~budgetf ~count @@ fun count ->
   [
     [ Seq.agree_test ~count ~name:(name ^ " sequential") ];
     (match make_domain with

test/stm_run/stm_run.ocaml5.ml

@@ -1,6 +1,7 @@
 include Intf
 
-let run (type cmd state sut) ~verbose ~count ~name ?make_domain
+let run (type cmd state sut) ?(verbose = true) ?(count = default_count)
+    ?(budgetf = default_budgetf) ~name ?make_domain
     (module Spec : STM.Spec
       with type cmd = cmd
        and type state = state
@@ -10,6 +11,7 @@ let run (type cmd state sut) ~verbose ~count ~name ?make_domain
     module Spec = Spec
     include STM_domain.Make (Spec)
   end in
+  Util.run_with_budget ~budgetf ~count @@ fun count ->
   [
     [ Seq.agree_test ~count ~name:(name ^ " sequential") ];
     (match make_domain with

test/stm_run/util.ml

@@ -0,0 +1,23 @@
+let run_with_budget ~budgetf ~count run =
+  let state = Random.State.make_self_init () in
+  let start = Unix.gettimeofday () in
+  let rec loop ~total n =
+    let current = Unix.gettimeofday () in
+    if current -. start <= budgetf && total < count then begin
+      let count =
+        if total = 0 then n
+        else
+          let per_test = (current -. start) /. Float.of_int total in
+          let max_count =
+            Float.to_int ((start +. budgetf -. current) /. per_test)
+          in
+          Int.min (Int.min n (count - total)) max_count |> Int.max 32
+      in
+      let seed = Random.State.full_int state Int.max_int in
+      QCheck_base_runner.set_seed seed;
+      let error_code = run count in
+      if error_code = 0 then loop ~total:(total + count) (n * 2) else error_code
+    end
+    else 0
+  in
+  loop ~total:0 32

test/treiber_stack/dune

@@ -33,6 +33,4 @@
  (package saturn_lockfree)
  (name stm_treiber_stack)
  (modules stm_treiber_stack)
- (libraries saturn_lockfree qcheck-core qcheck-stm.stm stm_run)
- (enabled_if
-  (= %{arch_sixtyfour} true)))
+ (libraries saturn_lockfree qcheck-core qcheck-stm.stm stm_run))

test/treiber_stack/stm_treiber_stack.ml

@@ -55,7 +55,4 @@ module Spec = struct
     | _, _ -> false
 end
 
-let () =
-  Stm_run.run ~count:500 ~verbose:true ~name:"Saturn_lockfree.Treiber_stack"
-    (module Spec)
-  |> exit
+let () = Stm_run.run ~name:"Saturn_lockfree.Treiber_stack" (module Spec) |> exit

test/ws_deque/dune

@@ -49,6 +49,4 @@
   qcheck-core
   qcheck-multicoretests-util
   qcheck-stm.stm
-  stm_run)
- (enabled_if
-  (= %{arch_sixtyfour} true)))
+  stm_run))

test/ws_deque/stm_ws_deque.ml

@@ -83,7 +83,5 @@ let () =
       Dom.neg_agree_test_par ~count ~name:(name ^ " parallel, negative");
     ]
   in
-  Stm_run.run ~count:1000 ~name:"Saturn_lockfree.Ws_deque" ~verbose:true
-    ~make_domain
-    (module Spec)
+  Stm_run.run ~name:"Saturn_lockfree.Ws_deque" ~make_domain (module Spec)
   |> exit