update neg_tests examples

ocaml-multicore · Jun 1, 2022 · 9386979 · 9386979
1 parent ca77469
commit 9386979
Show file tree

Hide file tree

Showing 6 changed files with 74 additions and 77 deletions.
diff --git a/src/neg_tests/conclist_test.ml b/src/neg_tests/conclist_test.ml
@@ -59,5 +59,5 @@ QCheck_runner.run_tests_main
   (let count = 1000 in
    [CLT_int.agree_test       ~count ~name:"int CList test";
     CLT_int64.agree_test     ~count ~name:"int64 CList test";
-    CLT_int.agree_test_par   ~count ~name:"int CList test";
-    CLT_int64.agree_test_par ~count ~name:"int64 CList test"])
+    CLT_int.neg_agree_test_par   ~count ~name:"int CList test";
+    CLT_int64.neg_agree_test_par ~count ~name:"int64 CList test"])
diff --git a/src/neg_tests/domain_lin_tests.ml b/src/neg_tests/domain_lin_tests.ml
@@ -7,7 +7,7 @@ Util.set_ci_printing ()
 ;;
 QCheck_runner.run_tests_main
   (let count = 1000 in
-   [RT_int.lin_test    `Domain ~count ~name:"ref int test";
-    RT_int64.lin_test  `Domain ~count ~name:"ref int64 test";
-    CLT_int.lin_test   `Domain ~count ~name:"CList int test";
-    CLT_int64.lin_test `Domain ~count ~name:"CList int64 test"])
+   [RT_int.neg_lin_test    `Domain ~count ~name:"ref int test";
+    RT_int64.neg_lin_test  `Domain ~count ~name:"ref int64 test";
+    CLT_int.neg_lin_test   `Domain ~count ~name:"CList int test";
+    CLT_int64.neg_lin_test `Domain ~count ~name:"CList int64 test"])
diff --git a/src/neg_tests/dune b/src/neg_tests/dune
@@ -12,19 +12,11 @@
  (libraries qcheck STM)
  (preprocess (pps ppx_deriving.show ppx_deriving.eq)))
 
-(env
- (_
-  (binaries
-   (../check_error_count.exe as check_error_count))))
-
 (rule
  (alias runtest)
  (package multicoretests)
  (deps ref_test.exe)
- (action
-  (progn
-   (bash "(./ref_test.exe --no-colors --verbose || echo 'test run triggered an error') | tee ref-output.txt")
-   (run %{bin:check_error_count} "neg_tests/ref_test" 4 ref-output.txt))))
+ (action (run ./%{deps} --no-colors --verbose)))
 
 (library
  (name CList)
@@ -40,10 +32,7 @@
  (alias runtest)
  (package multicoretests)
  (deps conclist_test.exe)
- (action
-  (progn
-   (bash "(./conclist_test.exe --no-colors --verbose || echo 'test run triggered an error') | tee cl-output.txt")
-   (run %{bin:check_error_count} "neg_tests/conclist_test" 2 cl-output.txt))))
+ (action (run ./%{deps} --no-colors --verbose)))
 
 
 ;; Linearizability tests of ref and Clist
@@ -65,31 +54,22 @@
  (modules effect_lin_tests)
  (flags (:standard -w -27))
  (libraries lin_tests_common)
- (preprocess (pps ppx_deriving_qcheck ppx_deriving.show)))
+ (preprocess (pps ppx_deriving_qcheck ppx_deriving.show ppx_deriving.eq)))
 
 (rule
  (alias runtest)
  (package multicoretests)
  (deps domain_lin_tests.exe)
- (action
-  (progn
-   (bash "(./domain_lin_tests.exe --no-colors --verbose || echo 'test run triggered an error') | tee domain-lin-output.txt")
-   (run %{bin:check_error_count} "neg_tests/domain_lin_tests" 4 domain-lin-output.txt))))
+ (action (run ./%{deps} --no-colors --verbose)))
 
 (rule
  (alias runtest)
  (package multicoretests)
  (deps thread_lin_tests.exe)
- (action
-  (progn
-   (bash "(./thread_lin_tests.exe --no-colors --verbose || echo 'test run triggered an error') | tee thread-lin-output.txt")
-   (run %{bin:check_error_count} "neg_tests/thread_lin_tests" 1 thread-lin-output.txt))))
+ (action (run ./%{deps} --no-colors --verbose)))
 
 (rule
  (alias runtest)
  (package multicoretests)
  (deps effect_lin_tests.exe)
- (action
-  (progn
-   (bash "(./effect_lin_tests.exe --no-colors --verbose || echo 'test run triggered an error') | tee effect-lin-output.txt")
-   (run %{bin:check_error_count} "neg_tests/effect_lin_tests" 4 effect-lin-output.txt))))
+ (action (run ./%{deps} --no-colors --verbose)))
diff --git a/src/neg_tests/effect_lin_tests.ml b/src/neg_tests/effect_lin_tests.ml
@@ -1,4 +1,5 @@
 open Lin_tests_common
+open Util
 
 (** This is a driver of the negative tests over the Effect module *)
 
@@ -7,37 +8,53 @@ open Lin_tests_common
    The following raises the Yield effect inside the `run` command.
    This results in an `Unhandled` exception when running outside a fiber-based scheduler,
    such as when interpreting these sequentially. *)
-module RT_int' =
-  Lin.Make(struct
-    include RConf_int
-    let run c r = match c with
-      | Add i -> (let tmp = Sut_int.get r in Lin.yield (); Sut_int.set r (tmp+i); RAdd)
-      | _     -> run c r
-  end)
-
-module RT_int64' =
-  Lin.Make(struct
-    include RConf_int64
-    let run c r = match c with
-      | Add i -> (let tmp = Sut_int.get r in Lin.yield (); Sut_int.set r (Int64.add tmp i); RAdd)
-      | _     -> run c r
-  end)
-
-module CLT_int' =
-  Lin.Make(struct
-    include CLConf(Int)
-    let run c r = match c with
-      | Add_node _ -> Lin.yield (); run c r
-      | Member _   -> run c r
-  end)
-
-module CLT_int64' =
-  Lin.Make(struct
-    include CLConf(Int64)
-    let run c r = match c with
-      | Add_node _ -> Lin.yield (); run c r
-      | Member _   -> run c r
-  end)
+module RConf_int' =
+struct
+  include RConf_int
+  type res = RGet of int | RSet | RAdd of (unit,exn) result | RIncr | RDecr [@@deriving show { with_path = false }, eq]
+
+  let run c r = match c with
+    | Get   -> RGet (Sut_int.get r)
+    | Set i -> (Sut_int.set r i; RSet)
+    | Add i -> (try let tmp = Sut_int.get r in Lin.yield (); Sut_int.set r (tmp+i); RAdd (Ok ()) with exn -> RAdd (Error exn))
+    | Incr  -> (Sut_int.incr r; RIncr)
+    | Decr  -> (Sut_int.decr r; RDecr)
+end
+module RT_int' = Lin.Make(RConf_int')
+
+module RConf_int64' =
+struct
+  include RConf_int64
+  type res = RGet of int64 | RSet | RAdd of (unit,exn) result | RIncr | RDecr [@@deriving show { with_path = false }, eq]
+
+  let run c r = match c with
+    | Get   -> RGet (Sut_int64.get r)
+    | Set i -> (Sut_int64.set r i; RSet)
+    | Add i -> (try let tmp = Sut_int.get r in Lin.yield (); Sut_int.set r (Int64.add tmp i); RAdd (Ok ()) with exn -> RAdd (Error exn))
+    | Incr  -> (Sut_int64.incr r; RIncr)
+    | Decr  -> (Sut_int64.decr r; RDecr)
+end
+module RT_int64' = Lin.Make(RConf_int64')
+
+module CLConf_int' =
+struct
+  include CLConf(Int)
+  type res = RAdd_node of (bool,exn) result | RMember of bool [@@deriving show { with_path = false }, eq]
+  let run c r = match c with
+    | Add_node i -> RAdd_node (try Lin.yield (); Ok (CList.add_node r i) with exn -> Error exn)
+    | Member i   -> RMember (CList.member r i)
+end
+module CLT_int' = Lin.Make(CLConf_int')
+
+module CLConf_int64' =
+struct
+  include CLConf(Int64)
+  type res = RAdd_node of (bool,exn) result | RMember of bool [@@deriving show { with_path = false }, eq]
+  let run c r = match c with
+    | Add_node i -> RAdd_node (try Lin.yield (); Ok (CList.add_node r i) with exn -> Error exn)
+    | Member i   -> RMember (CList.member r i)
+end
+module CLT_int64' = Lin.Make(CLConf_int64')
 
 ;;
 Util.set_ci_printing ()
@@ -50,8 +67,8 @@ QCheck_runner.run_tests_main
       CLT_int.lin_test    `Effect ~count ~name:"CList int test";
       CLT_int64.lin_test  `Effect ~count ~name:"CList int64 test";
       (* These next four tests are negative - and are expected to fail with exception `Unhandled` *)
-      RT_int'.lin_test    `Effect ~count ~name:"negative ref int test";
-      RT_int64'.lin_test  `Effect ~count ~name:"negative ref int64 test";
-      CLT_int'.lin_test   `Effect ~count ~name:"negative CList int test";
-      CLT_int64'.lin_test `Effect ~count ~name:"negative CList int64 test"
+      RT_int'.neg_lin_test    `Effect ~count ~name:"negative ref int test";
+      RT_int64'.neg_lin_test  `Effect ~count ~name:"negative ref int64 test";
+      CLT_int'.neg_lin_test   `Effect ~count ~name:"negative CList int test";
+      CLT_int64'.neg_lin_test `Effect ~count ~name:"negative CList int64 test"
     ])
diff --git a/src/neg_tests/ref_test.ml b/src/neg_tests/ref_test.ml
@@ -142,10 +142,10 @@ Util.set_ci_printing ()
 ;;
 QCheck_runner.run_tests_main
   (let count = 1000 in
-   [RT_int.agree_test        ~count ~name:"global int ref test";
-    RT_int.agree_test_par    ~count ~name:"global int ref test";
-    RT_int_GC.agree_test_par ~count ~name:"global int ref test (w/AddGC functor)";
-    RT_int.agree_test        ~count ~name:"global int64 ref test";
-    RT_int.agree_test_par    ~count ~name:"global int64 ref test";
-    RT_int_GC.agree_test_par ~count ~name:"global int64 ref test (w/AddGC functor)";
+   [RT_int.agree_test            ~count ~name:"global int ref test";
+    RT_int.neg_agree_test_par    ~count ~name:"global int ref test";
+    RT_int_GC.neg_agree_test_par ~count ~name:"global int ref test (w/AddGC functor)";
+    RT_int.agree_test            ~count ~name:"global int64 ref test";
+    RT_int.neg_agree_test_par    ~count ~name:"global int64 ref test";
+    RT_int_GC.neg_agree_test_par ~count ~name:"global int64 ref test (w/AddGC functor)";
    ])
diff --git a/src/neg_tests/thread_lin_tests.ml b/src/neg_tests/thread_lin_tests.ml
@@ -7,7 +7,7 @@ Util.set_ci_printing ()
 ;;
 QCheck_runner.run_tests_main
   (let count = 1000 in
-   [RT_int.lin_test    `Thread ~count ~name:"ref int test";
-    RT_int64.lin_test  `Thread ~count ~name:"ref int64 test";
-    CLT_int.lin_test   `Thread ~count ~name:"CList int test";
-    CLT_int64.lin_test `Thread ~count ~name:"CList int64 test"])
+   [RT_int.lin_test        `Thread ~count ~name:"ref int test";   (* unboxed, hence no allocations to trigger context switch *)
+    RT_int64.neg_lin_test  `Thread ~count ~name:"ref int64 test";
+    CLT_int.lin_test       `Thread ~count ~name:"CList int test"; (* unboxed, hence no allocations to trigger context switch *)
+    CLT_int64.lin_test `Thread ~count ~name:"CList int64 test"])  (* not triggering context switch, unfortunately *)