Upgrade QCheck STM to version with wrap_cmd_seq support

Also reorganize code under `test/` such that libraries are under `test/lib/`.

Co-authored-by: Jan Midtgaard <[email protected]>

picos_meta.opam

@@ -55,3 +55,7 @@ build: [
   ]
 ]
 dev-repo: "git+https://github.com/ocaml-multicore/picos.git"
+pin-depends: [
+  [ "qcheck-stm.dev" "git+https://github.com/ocaml-multicore/multicoretests#59296ec5491475b191cac6babf8f290c9ced47a4" ]
+  [ "qcheck-multicoretests-util.dev" "git+https://github.com/ocaml-multicore/multicoretests#59296ec5491475b191cac6babf8f290c9ced47a4" ]
+]

picos_meta.opam.template

@@ -0,0 +1,4 @@
+pin-depends: [
+  [ "qcheck-stm.dev" "git+https://github.com/ocaml-multicore/multicoretests#59296ec5491475b191cac6babf8f290c9ced47a4" ]
+  [ "qcheck-multicoretests-util.dev" "git+https://github.com/ocaml-multicore/multicoretests#59296ec5491475b191cac6babf8f290c9ced47a4" ]
+]

test/dune

@@ -1,29 +1,3 @@
-(library
- (package picos_meta)
- (name test_scheduler)
- (modules test_scheduler)
- (libraries
-  (re_export picos)
-  picos_io.select
-  (select
-   test_scheduler.ml
-   from
-   (picos.thread
-    picos_lwt.unix
-    picos_mux.random
-    picos_mux.fifo
-    picos_mux.multififo
-    ->
-    test_scheduler.ocaml5.ml)
-   (picos_mux.thread lwt.unix -> test_scheduler.ocaml4.ml))))
-
-(library
- (package picos_meta)
- (name test_util)
- (modules test_util))
-
-;;
-
 (test
  (package picos_meta)
  (name test_picos)

test/stm_run/stm_run.ocaml4.ml → test/lib/stm_run/stm_run.ocaml4.ml

@@ -1,9 +1,9 @@
 include Intf
 
 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
+    ~name ?make_domain (module Spec : STM.SpecExt) =
+  let module Seq = STM_sequential.MakeExt (Spec) in
+  let module Con = STM_thread.MakeExt (Spec) [@alert "-experimental"] in
   Util.run_with_budget ~budgetf ~count @@ fun count ->
   [
     [ Seq.agree_test ~count ~name:(name ^ " sequential") ];

test/stm_run/stm_run.ocaml5.ml → test/lib/stm_run/stm_run.ocaml5.ml

@@ -2,14 +2,14 @@ include Intf
 
 let run (type cmd state sut) ?(verbose = true) ?(count = default_count)
     ?(budgetf = default_budgetf) ~name ?make_domain
-    (module Spec : STM.Spec
+    (module Spec : STM.SpecExt
       with type cmd = cmd
        and type state = state
        and type sut = sut) =
-  let module Seq = STM_sequential.Make (Spec) in
+  let module Seq = STM_sequential.MakeExt (Spec) in
   let module Dom = struct
     module Spec = Spec
-    include STM_domain.Make (Spec)
+    include STM_domain.MakeExt (Spec)
   end in
   Util.run_with_budget ~budgetf ~count @@ fun count ->
   [

test/lib/stm_wrap/dune

@@ -0,0 +1,11 @@
+(library
+ (package picos_meta)
+ (name stm_wrap)
+ (modules stm_wrap)
+ (libraries
+  picos
+  (select
+   stm_wrap.ml
+   from
+   (picos_mux.fifo -> stm_wrap.ocaml5.ml)
+   (threads.posix -> stm_wrap.ocaml4.ml))))

test/lib/stm_wrap/stm_wrap.ocaml4.ml

@@ -0,0 +1,25 @@
+open Picos
+
+let[@inline never] error entry _ = failwith entry
+
+let handler =
+  let current fiber = fiber
+  and spawn _ _ = error "spawn"
+  and yield = error "yield"
+  and cancel_after _ _ ~seconds:_ _ = error "cancel_after"
+  and await _ t =
+    while not (Trigger.is_signaled t) do
+      Thread.yield ()
+    done;
+    None
+  in
+  Handler.{ current; spawn; yield; cancel_after; await }
+
+let wrap_cmd_seq th =
+  let result = ref (Error Exit) in
+  Handler.using handler
+    (Fiber.create ~forbid:false (Computation.create ()))
+    (fun _fiber ->
+      result :=
+        match th () with value -> Ok value | exception exn -> Error exn);
+  match !result with Ok value -> value | Error exn -> raise exn

test/lib/stm_wrap/stm_wrap.ocaml5.ml

@@ -0,0 +1,15 @@
+let wrap_cmd_seq th =
+  let open Picos in
+  let effc (type a) (e : a Effect.t) :
+      ((a, _) Effect.Deep.continuation -> _) option =
+    match e with
+    | Trigger.Await t ->
+        Some
+          (fun k ->
+            while not (Trigger.is_signaled t) do
+              Domain.cpu_relax ()
+            done;
+            Effect.Deep.continue k None)
+    | _ -> None
+  in
+  Effect.Deep.match_with th () { effc; exnc = raise; retc = Fun.id }

test/lib/test_scheduler/dune

@@ -0,0 +1,18 @@
+(library
+ (package picos_meta)
+ (name test_scheduler)
+ (modules test_scheduler)
+ (libraries
+  (re_export picos)
+  picos_io.select
+  (select
+   test_scheduler.ml
+   from
+   (picos.thread
+    picos_lwt.unix
+    picos_mux.random
+    picos_mux.fifo
+    picos_mux.multififo
+    ->
+    test_scheduler.ocaml5.ml)
+   (picos_mux.thread lwt.unix -> test_scheduler.ocaml4.ml))))

test/lib/test_util/dune

@@ -0,0 +1,4 @@
+(library
+ (package picos_meta)
+ (name test_util)
+ (modules test_util))

test/test_htbl.ml

@@ -26,6 +26,8 @@ module Int = struct
 end
 
 module Spec = struct
+  include SpecDefaults
+
   type cmd =
     | Try_add of int
     | Mem of int
@@ -61,7 +63,6 @@ module Spec = struct
 
   let init_state = State.empty
   let init_sut () = Htbl.create ~hashed_type:(module Int) ()
-  let cleanup _ = ()
 
   let next_state c s =
     match c with
@@ -72,8 +73,6 @@ module Spec = struct
     | To_keys -> s
     | Remove_all -> State.empty
 
-  let precond _ _ = true
-
   let run c d =
     match c with
     | Try_add x -> Res (bool, Htbl.try_add d x x)

test/test_mpmcq.ml

@@ -13,6 +13,8 @@ let () =
   match Queue.pop_exn q with _ -> assert false | exception Queue.Empty -> ()
 
 module Spec = struct
+  include SpecDefaults
+
   type cmd = Push of int | Push_head of int | Pop_opt | Length
 
   let show_cmd = function
@@ -48,7 +50,6 @@ module Spec = struct
 
   let init_state = ([], [])
   let init_sut () = Queue.create ~padded:true ()
-  let cleanup _ = ()
 
   let next_state c s =
     match c with
@@ -57,8 +58,6 @@ module Spec = struct
     | Pop_opt -> State.drop s
     | Length -> s
 
-  let precond _ _ = true
-
   let run c d =
     match c with
     | Push x -> Res (unit, Queue.push d x)

test/test_mpscq.ml

@@ -1,6 +1,9 @@
+open STM
 module Queue = Picos_aux_mpscq
 
 module Spec = struct
+  include SpecDefaults
+
   type cmd = Push of int | Push_head of int | Pop | Pop_all
 
   let show_cmd c =
@@ -35,7 +38,6 @@ module Spec = struct
 
   let init_state = []
   let init_sut () = Queue.create ()
-  let cleanup _ = ()
 
   let next_state c s =
     match c with
@@ -44,10 +46,7 @@ module Spec = struct
     | Pop -> ( match s with _ :: s -> s | [] -> [])
     | Pop_all -> []
 
-  let precond _ _ = true
-
   let run c d =
-    let open STM in
     match c with
     | Push i -> Res (unit, Queue.push d i)
     | Push_head i -> Res (unit, Queue.push_head d i)
@@ -60,7 +59,6 @@ module Spec = struct
     | Pop_all -> Res (list int, Queue.pop_all d |> List.of_seq)
 
   let postcond c (s : state) res =
-    let open STM in
     match (c, res) with
     | Push _, Res ((Unit, _), ()) -> true
     | Push_head _, Res ((Unit, _), ()) -> true