Upgrade dscheck to allow testing on OCaml 4 with ocaml-ci

Author: polytypic

.github/workflows/main.yml

@@ -46,32 +46,3 @@ jobs:
 
       - name: Test
         run: opam exec -- dune runtest
-
-  build-4_x:
-    strategy:
-      fail-fast: false
-      matrix:
-        os:
-          - ubuntu-latest
-        ocaml-compiler:
-          - 4.13.x
-          - 4.14.x
-
-    runs-on: ${{ matrix.os }}
-
-    steps:
-      - name: Check out code
-        uses: actions/checkout@v3
-
-      - name: Set up OCaml
-        uses: ocaml/setup-ocaml@v2
-        with:
-          opam-pin: false
-          opam-depext: false
-          ocaml-compiler: ${{ matrix.ocaml-compiler }}
-
-      - name: Install dependencies
-        run: opam install . --deps-only
-
-      - name: Build (release)
-        run: opam exec -- dune build --release

bench/bench_queue.ml

@@ -46,8 +46,13 @@ let run_one ~budgetf ?(n_adders = 2) ?(n_takers = 2)
         let n = Util.alloc n_msgs_to_take in
         if n <> 0 then
           let rec loop n =
-            if 0 < n then
-              loop (n - Bool.to_int (Option.is_some (Queue.pop_opt t)))
+            if 0 < n then begin
+              match Queue.pop_opt t with
+              | None ->
+                  Domain.cpu_relax ();
+                  loop n
+              | Some _ -> loop (n - 1)
+            end
             else work ()
           in
           loop n

bench/bench_relaxed_queue.ml

@@ -31,13 +31,23 @@ let run_one ~budgetf ~n_adders ~n_takers ?(n_msgs = 50 * Util.iter_factor)
               work ()
           | `Not_lockfree ->
               let rec loop n =
-                if 0 < n then loop (n - Bool.to_int (Not_lockfree.push t i))
+                if 0 < n then
+                  if Not_lockfree.push t i then loop (n - 1)
+                  else begin
+                    Domain.cpu_relax ();
+                    loop n
+                  end
                 else work ()
               in
               loop n
           | `CAS_interface ->
               let rec loop n =
-                if 0 < n then loop (n - Bool.to_int (CAS_interface.push t i))
+                if 0 < n then
+                  if CAS_interface.push t i then loop (n - 1)
+                  else begin
+                    Domain.cpu_relax ();
+                    loop n
+                  end
                 else work ()
               in
               loop n
@@ -56,15 +66,25 @@ let run_one ~budgetf ~n_adders ~n_takers ?(n_msgs = 50 * Util.iter_factor)
               work ()
           | `Not_lockfree ->
               let rec loop n =
-                if 0 < n then
-                  loop (n - Bool.to_int (Option.is_some (Not_lockfree.pop t)))
+                if 0 < n then begin
+                  match Not_lockfree.pop t with
+                  | None ->
+                      Domain.cpu_relax ();
+                      loop n
+                  | Some _ -> loop (n - 1)
+                end
                 else work ()
               in
               loop n
           | `CAS_interface ->
               let rec loop n =
-                if 0 < n then
-                  loop (n - Bool.to_int (Option.is_some (CAS_interface.pop t)))
+                if 0 < n then begin
+                  match CAS_interface.pop t with
+                  | None ->
+                      Domain.cpu_relax ();
+                      loop n
+                  | Some _ -> loop (n - 1)
+                end
                 else work ()
               in
               loop n

bench/bench_spsc_queue.ml

@@ -17,13 +17,22 @@ let run_one ~budgetf ?(size_exponent = 3) ?(n_msgs = 80 * Util.iter_factor) () =
   let work i () =
     if i = 0 then
       let rec loop n =
-        if 0 < n then loop (n - Bool.to_int (Queue.try_push t n))
+        if 0 < n then
+          if Queue.try_push t n then loop (n - 1)
+          else begin
+            Domain.cpu_relax ();
+            loop n
+          end
       in
       loop n_msgs
     else
       let rec loop n =
         if 0 < n then
-          match Queue.pop_opt t with Some _ -> loop (n - 1) | None -> loop n
+          match Queue.pop_opt t with
+          | Some _ -> loop (n - 1)
+          | None ->
+              Domain.cpu_relax ();
+              loop n
       in
       loop n_msgs
   in

bench/bench_ws_deque.ml

@@ -29,7 +29,11 @@ let run_one ~budgetf ?(n_domains = 1) () =
     | work ->
         work own;
         run own
-    | exception Exit -> if not !exit then run own
+    | exception Exit ->
+        if not !exit then begin
+          Domain.cpu_relax ();
+          run own
+        end
   in
 
   let spawn own work =
@@ -42,7 +46,9 @@ let run_one ~budgetf ?(n_domains = 1) () =
     let x = !promise in
     if x == Obj.magic exit then begin
       begin
-        match try_own own with exception Exit -> () | work -> work own
+        match try_own own with
+        | exception Exit -> Domain.cpu_relax ()
+        | work -> work own
       end;
       await own promise
     end

bench/dune

@@ -1,4 +1,15 @@
+(* -*- tuareg -*- *)
+
+let maybe_domain_shims =
+  if Jbuild_plugin.V1.ocaml_version < "5" then "domain_shims" else ""
+
+let () =
+  Jbuild_plugin.V1.send
+  @@ {|
+
 (test
  (package saturn)
  (name main)
- (libraries saturn multicore-bench multicore-magic))
+ (libraries saturn multicore-bench multicore-magic |}
+  ^ maybe_domain_shims ^ {| ))
+|}

dune-project

@@ -1,4 +1,4 @@
-(lang dune 3.2)
+(lang dune 3.9)
 (name saturn)
 (generate_opam_files true)
 (implicit_transitive_deps false)
@@ -16,12 +16,13 @@
   (saturn_lockfree (= :version))
   (multicore-magic (and (>= 2.1.0) :with-test))
   (multicore-bench (and (>= 0.1.0) :with-test))
+  (backoff (and (>= 0.1.0) :with-test))
   (alcotest (and (>= 1.7.0) :with-test))
   (qcheck (and (>= 0.21.3) :with-test))
   (qcheck-stm (and (>= 0.3) :with-test))
   (qcheck-alcotest (and (>= 0.21.3) :with-test))
   (yojson (and (>= 2.0.2) :with-test))
-  (dscheck (and (>= 0.2.0) :with-test))))
+  (dscheck (and (>= 0.4.0) :with-test))))
 (package
  (name saturn_lockfree)
  (synopsis "Collection of lock-free data structures for Multicore OCaml")
@@ -37,4 +38,4 @@
   (qcheck-multicoretests-util (and (>= 0.3) :with-test))
   (qcheck-alcotest (and (>= 0.21.3) :with-test))
   (yojson (and (>= 2.0.2) :with-test))
-  (dscheck (and (>= 0.2.0) :with-test))))
+  (dscheck (and (>= 0.4.0) :with-test))))

saturn.opam

@@ -9,18 +9,19 @@ homepage: "https://github.com/ocaml-multicore/saturn"
 doc: "https://ocaml-multicore.github.io/saturn/"
 bug-reports: "https://github.com/ocaml-multicore/saturn/issues"
 depends: [
-  "dune" {>= "3.2"}
+  "dune" {>= "3.9"}
   "ocaml" {>= "4.13"}
   "domain_shims" {>= "0.1.0" & with-test}
   "saturn_lockfree" {= version}
   "multicore-magic" {>= "2.1.0" & with-test}
   "multicore-bench" {>= "0.1.0" & with-test}
+  "backoff" {>= "0.1.0" & with-test}
   "alcotest" {>= "1.7.0" & with-test}
   "qcheck" {>= "0.21.3" & with-test}
   "qcheck-stm" {>= "0.3" & with-test}
   "qcheck-alcotest" {>= "0.21.3" & with-test}
   "yojson" {>= "2.0.2" & with-test}
-  "dscheck" {>= "0.2.0" & with-test}
+  "dscheck" {>= "0.4.0" & with-test}
   "odoc" {with-doc}
 ]
 build: [

saturn_lockfree.opam

@@ -8,7 +8,7 @@ homepage: "https://github.com/ocaml-multicore/saturn"
 doc: "https://ocaml-multicore.github.io/saturn/"
 bug-reports: "https://github.com/ocaml-multicore/saturn/issues"
 depends: [
-  "dune" {>= "3.2"}
+  "dune" {>= "3.9"}
   "ocaml" {>= "4.13"}
   "domain_shims" {>= "0.1.0" & with-test}
   "backoff" {>= "0.1.0"}
@@ -20,7 +20,7 @@ depends: [
   "qcheck-multicoretests-util" {>= "0.3" & with-test}
   "qcheck-alcotest" {>= "0.21.3" & with-test}
   "yojson" {>= "2.0.2" & with-test}
-  "dscheck" {>= "0.2.0" & with-test}
+  "dscheck" {>= "0.4.0" & with-test}
   "odoc" {with-doc}
 ]
 build: [

src/domain.ocaml4.ml

@@ -0,0 +1 @@
+let cpu_relax = Thread.yield

src/dune

@@ -1,5 +1,23 @@
+(* -*- tuareg -*- *)
+
+let maybe_threads =
+  if Jbuild_plugin.V1.ocaml_version < "5" then "threads.posix" else ""
+
+let () =
+  Jbuild_plugin.V1.send
+  @@ {|
+
 (library
  (name saturn)
  (public_name saturn)
  (libraries
-  (re_export saturn_lockfree)))
+  (re_export saturn_lockfree) |}
+  ^ maybe_threads
+  ^ {| ))
+
+(rule
+ (enabled_if
+  (< %{ocaml_version} 5.0.0))
+ (action
+  (copy domain.ocaml4.ml domain.ml)))
+|}

src/mpmc_relaxed_queue.ml

@@ -44,8 +44,11 @@ module Not_lockfree = struct
         time_to_try_push_forward nth_attempt && ccas head tail_val (tail_val + 1)
       then (* pushed forward head *)
         false
-      else (* retry *)
+      else begin
+        Domain.cpu_relax ();
+        (* retry *)
         take_or_rollback (nth_attempt + 1)
+      end
     in
 
     (* if succeeded return true otherwise clean up *)
@@ -87,7 +90,10 @@ module Not_lockfree = struct
           && ccas tail old_head (old_head + 1)
         then (* pushed tail forward *)
           None
-        else take_or_rollback (nth_attempt + 1)
+        else begin
+          Domain.cpu_relax ();
+          take_or_rollback (nth_attempt + 1)
+        end
       in
 
       (* return if got item, clean up otherwise *)
@@ -99,7 +105,7 @@ module Not_lockfree = struct
       let head_val = Atomic.get head in
       let size = mask + 1 in
       if tail_val - head_val >= size then false
-      else if ccas tail tail_val (tail_val + 1) then (
+      else if ccas tail tail_val (tail_val + 1) then begin
         let index = tail_val land mask in
         let cell = Array.get array index in
         (*
@@ -119,25 +125,28 @@ module Not_lockfree = struct
           standard interface.
         *)
         while not (Atomic.compare_and_set cell None (Some item)) do
-          ()
+          Domain.cpu_relax ()
         done;
-        true)
+        true
+      end
       else push t item
 
     let rec pop ({ array; tail; head; mask; _ } as t) =
       let tail_val = Atomic.get tail in
       let head_val = Atomic.get head in
       if head_val - tail_val >= 0 then None
-      else if ccas head head_val (head_val + 1) then (
+      else if ccas head head_val (head_val + 1) then begin
         let index = head_val land mask in
         let cell = Array.get array index in
         let item = ref (Atomic.get cell) in
         while
           not (Option.is_some !item && Atomic.compare_and_set cell !item None)
         do
+          Domain.cpu_relax ();
           item := Atomic.get cell
         done;
-        !item)
+        !item
+      end
       else pop t
   end
 end

test/atomic/dune

@@ -1,3 +1,5 @@
 (library
  (name atomic)
- (libraries dscheck))
+ (libraries dscheck)
+ (enabled_if
+  (>= %{ocaml_version} 5)))

test/barrier/dune

@@ -1,2 +1,3 @@
 (library
- (name barrier))
+ (name barrier)
+ (libraries domain_shims))

test/michael_scott_queue/dune

@@ -7,11 +7,13 @@
  (package saturn_lockfree)
  (name michael_scott_queue_dscheck)
  (libraries atomic dscheck alcotest backoff)
- (enabled_if
-  (not
-   (and
-    (= %{arch_sixtyfour} false)
-    (= %{architecture} arm))))
+ (build_if
+  (and
+   (>= %{ocaml_version} 5)
+   (not
+    (and
+     (= %{arch_sixtyfour} false)
+     (= %{architecture} arm)))))
  (modules michael_scott_queue michael_scott_queue_dscheck))
 
 (test
@@ -23,21 +25,14 @@
   qcheck
   qcheck-core
   qcheck-alcotest
+  domain_shims
   alcotest)
  (modules qcheck_michael_scott_queue))
 
 (test
  (package saturn_lockfree)
  (name stm_michael_scott_queue)
  (modules stm_michael_scott_queue)
- (libraries
-  saturn_lockfree
-  qcheck-core
-  qcheck-core.runner
-  qcheck-stm.stm
-  qcheck-stm.sequential
-  qcheck-stm.domain)
+ (libraries saturn_lockfree qcheck-core qcheck-stm.stm stm_run)
  (enabled_if
-  (= %{arch_sixtyfour} true))
- (action
-  (run %{test} --verbose)))
+  (= %{arch_sixtyfour} true)))