unikernel/duniverse/ocaml-re/lib_test/concurrency/dune

@@ -0,0 +1,13 @@
+(test
+ (name test)
+ (build_if
+  (>= %{ocaml_version} 5.0))
+ (action
+  (pipe-outputs
+   (setenv
+    TSAN_OPTIONS
+    suppressions=suppress.txt
+    (run %{test}))
+   (run cat)))
+ (deps suppress.txt)
+ (libraries re))

unikernel/duniverse/ocaml-re/lib_test/concurrency/suppress.txt

@@ -0,0 +1,22 @@
+
+# Data race between Compile.State.follow_transition (inlined in Compile.next)
+# and Compile.State.set_transition
+race_top:^camlRe__Compile.next
+
+# Data race within Compile.find_initial_state (read/write re.initial_states)
+race_top:^camlRe__Compile.find_initial_state
+
+# Spurious data race due to the two-step initialization in Compile.State.make
+# (between Compile.State.get_info and Compile.State.set_info, both inlined)
+race_top:^camlRe__Compile.loop
+
+# Race within Automata.Desc.status and Automata.Desc.status_no_mutex
+# (read/write s.status)
+race_top:^camlRe__Automata.status
+
+# Race within Compile.final
+race_top:^camlRe__Compile.final
+
+# Spurious data race due to the two-step initialization in Mark_info.make
+# (between Mark_info.make and other functions in module Mark_infos)
+race_top:^camlRe__Mark_infos.set

unikernel/duniverse/ocaml-re/lib_test/concurrency/test.expected

@@ -0,0 +1,2 @@
+Sequential
+Concurrent

unikernel/duniverse/ocaml-re/lib_test/concurrency/test.ml

@@ -0,0 +1,142 @@
+module Barrier = struct
+  type t =
+    { waiters : int Atomic.t
+    ; size : int
+    ; passed : int Atomic.t
+    }
+
+  let create n = { waiters = Atomic.make n; size = n; passed = Atomic.make 0 }
+
+  let await { waiters; size; passed } =
+    if Atomic.fetch_and_add passed 1 = size - 1
+    then (
+      Atomic.set passed 0;
+      Atomic.set waiters 0);
+    while Atomic.get waiters = size do
+      Domain.cpu_relax ()
+    done;
+    Atomic.incr waiters;
+    while Atomic.get waiters < size do
+      Domain.cpu_relax ()
+    done
+  ;;
+end
+
+let shuffle_array a =
+  let n = Array.length a in
+  let a' = Array.copy a in
+  for i = n - 1 downto 1 do
+    let j = Random.int (i + 1) in
+    let temp = a'.(i) in
+    a'.(i) <- a'.(j);
+    a'.(j) <- temp
+  done;
+  a'
+;;
+
+let inverse_permutation p =
+  let n = Array.length p in
+  let inv = Array.make n 0 in
+  for i = 0 to n - 1 do
+    inv.(p.(i)) <- i
+  done;
+  inv
+;;
+
+let apply_permutation p a =
+  let n = Array.length p in
+  let b = Array.make n a.(0) in
+  for i = 0 to n - 1 do
+    b.(i) <- a.(p.(i))
+  done;
+  b
+;;
+
+(****)
+
+let re1 = Re.(alt [ group (char 'a'); char 'b' ])
+let re2 = Re.(seq [ re1; re1 ])
+let re3 = Re.(seq [ re2; re2 ])
+let re4 = Re.(seq [ re3; re3 ])
+
+let re5 =
+  Re.(
+    alt
+      [ seq [ re4; re4 ]
+      ; group (str "b")
+      ; group (str "bb")
+      ; group (str "bbb")
+      ; group (str "bbbb")
+      ])
+;;
+
+let size = 300
+
+let strings =
+  Array.init size (fun _ -> String.init 30 (fun _ -> if Random.bool () then 'a' else 'b'))
+;;
+
+let execute ~short re a =
+  apply_permutation
+    (inverse_permutation a)
+    (Array.map
+       (fun i ->
+         try
+           Some
+             (Re.Group.all_offset
+              @@ Re.exec ~pos:(if short then 30 - 7 else 0) re strings.(i))
+         with
+         | Not_found -> None)
+       a)
+;;
+
+let compare_groups g g' = g = g'
+
+let concurrent f f' =
+  let barrier = Barrier.create 2 in
+  let domain =
+    Domain.spawn
+    @@ fun () ->
+    Barrier.await barrier;
+    f' ()
+  in
+  Barrier.await barrier;
+  let res = f () in
+  let res' = Domain.join domain in
+  res, res'
+;;
+
+let sequential f f' = f (), f' ()
+
+let test compose ~short n =
+  let success = ref true in
+  for _ = 1 to n do
+    let re = Re.compile re5 in
+    let a = shuffle_array (Array.init size Fun.id) in
+    let a' = shuffle_array a in
+    try
+      let groups, groups' =
+        compose (fun () -> execute ~short re a) (fun () -> execute ~short re a')
+      in
+      let ok = Array.for_all2 (Option.equal compare_groups) groups groups' in
+      success := !success && ok;
+      if not ok then prerr_endline "Bad group"
+    with
+    | Invalid_argument msg ->
+      prerr_endline ("Invalid_argument " ^ msg);
+      success := false
+    | Division_by_zero ->
+      prerr_endline "Division_by_zero";
+      success := false
+  done;
+  if not !success then exit 1
+;;
+
+let () =
+  prerr_endline "Sequential";
+  test sequential ~short:false 20;
+  test sequential ~short:true 10;
+  prerr_endline "Concurrent";
+  test ~short:false concurrent 750;
+  test ~short:true concurrent 250
+;;