Ported some tests (stm{052,064,065}) to new testsuite
authorHerbert Valerio Riedel <hvr@gnu.org>
Sun, 9 Sep 2018 11:25:40 +0000 (13:25 +0200)
committerHerbert Valerio Riedel <hvr@gnu.org>
Sun, 9 Sep 2018 11:25:40 +0000 (13:25 +0200)
These are tests which were easy to convert as embedded testcases.

testsuite/src/Main.hs
testsuite/src/Stm052.hs [new file with mode: 0644]
testsuite/src/Stm064.hs [new file with mode: 0644]
testsuite/src/Stm065.hs [new file with mode: 0644]
testsuite/testsuite.cabal

index c37e3a7..8cbb8db 100644 (file)
@@ -6,6 +6,9 @@ import           Test.Framework                 (defaultMain, testGroup)
 import           Test.Framework.Providers.HUnit
 
 import qualified Issue9
+import qualified Stm052
+import qualified Stm064
+import qualified Stm065
 
 main :: IO ()
 main = do
@@ -15,6 +18,9 @@ main = do
     tests = [
       testGroup "regression"
         [ testCase "issue #9" Issue9.main
+        , testCase "stm052" Stm052.main
+        , testCase "stm064" Stm064.main
+        , testCase "stm065" Stm065.main
         ]
       ]
 
diff --git a/testsuite/src/Stm052.hs b/testsuite/src/Stm052.hs
new file mode 100644 (file)
index 0000000..ac5bfca
--- /dev/null
@@ -0,0 +1,70 @@
+-- STM stress test
+
+module Stm052 (main) where
+
+import           Control.Concurrent
+import           Control.Exception
+import           Control.Monad      (mapM_, when)
+import           Data.Array
+import           Data.List
+import           Foreign
+import           Foreign.C
+import           GHC.Conc
+import           GHC.Conc           (unsafeIOToSTM)
+import           System.Environment
+import           System.IO
+import           System.IO.Unsafe
+import           System.Random
+
+-- | The number of array elements
+n_elems :: Int
+n_elems = 20
+
+-- | The number of threads swapping elements
+n_threads :: Int
+n_threads = 2
+
+-- | The number of swaps for each thread to perform
+iterations :: Int
+iterations = 20000
+
+type Elements = Array Int (TVar Int)
+
+thread :: TVar Int -> Elements -> IO ()
+thread done elements = loop iterations
+ where loop 0 = atomically $ do x <- readTVar done; writeTVar done (x+1)
+       loop n = do
+          i1 <- randomRIO (1,n_elems)
+          i2 <- randomRIO (1,n_elems)
+          let e1 = elements ! i1
+          let e2 = elements ! i2
+          atomically $ do
+            e1_v <- readTVar e1
+            e2_v <- readTVar e2
+            writeTVar e1 e2_v
+            writeTVar e2 e1_v
+          loop (n-1)
+
+await_end :: TVar Int -> IO ()
+await_end done = atomically $ do x <- readTVar done
+                                 if (x == n_threads)  then return () else retry
+
+main :: IO ()
+main = do
+  _ <- Foreign.newStablePtr stdout
+  setStdGen (read "526454551 6356")
+  let init_vals = [1..n_elems] -- take n_elems
+  tvars <- atomically $ mapM newTVar init_vals
+  let elements = listArray (1,n_elems) tvars
+  done <- atomically (newTVar 0)
+  _ <- sequence [ forkIO (thread done elements) | _id <- [1..n_threads] ]
+  await_end done
+  fin_vals <- mapM (\t -> atomically $ readTVar t) (elems elements)
+
+  when (sort fin_vals /= init_vals) $ do
+    putStr("Before: ")
+    mapM_ (\v -> putStr ((show v) ++ " " )) init_vals
+    putStr("\nAfter: ")
+    mapM_ (\v -> putStr ((show v) ++ " " )) (sort fin_vals)
+    putStr("\n")
+    fail "mismatch"
diff --git a/testsuite/src/Stm064.hs b/testsuite/src/Stm064.hs
new file mode 100644 (file)
index 0000000..3e65332
--- /dev/null
@@ -0,0 +1,28 @@
+{-# LANGUAGE CPP #-}
+
+{- NB: This one fails for GHC < 7.6 which had a bug exposed via
+       nested uses of `orElse` in `stmCommitNestedTransaction`
+
+This was fixed in GHC via
+ f184d9caffa09750ef6a374a7987b9213d6db28e
+-}
+
+module Stm064 (main) where
+
+import           Control.Concurrent.STM
+import           Control.Monad          (unless)
+
+main :: IO ()
+#if __GLASGOW_HASKELL__ >= 706
+main = do
+  x <- atomically $ do
+         t <- newTVar (1 :: Integer)
+         writeTVar t 2
+         ((readTVar t >> retry) `orElse` return ()) `orElse` return ()
+         readTVar t
+
+  unless (x == 2) $
+    fail (show x)
+#else
+main = putStrLn "Warning: test disabled for GHC < 7.6"
+#endif
diff --git a/testsuite/src/Stm065.hs b/testsuite/src/Stm065.hs
new file mode 100644 (file)
index 0000000..77371b8
--- /dev/null
@@ -0,0 +1,15 @@
+module Stm065 (main) where
+
+import           Control.Concurrent.STM
+import           Control.Monad          (unless)
+
+main :: IO ()
+main = do
+  x <- atomically $ do
+         r <- newTVar []
+         writeTVar r [2 :: Integer]
+         writeTVar r [] `orElse` return ()
+         readTVar r
+
+  unless (null x) $ do
+    fail (show x)
index 0c0487c..627fac9 100644 (file)
@@ -19,6 +19,9 @@ test-suite stm
   main-is: Main.hs
   other-modules:
     Issue9
+    Stm052
+    Stm064
+    Stm065
 
   type: exitcode-stdio-1.0
 
@@ -38,5 +41,9 @@ test-suite stm
     -- Testing with GHC < 7.4 requires 'HUnit-1.3.1.2' which didn't depend on 'call-stack' (which requires GHC >= 7.4)
                          || ^>= 1.3.1.2
 
+    -- some tests need 'array' & 'random'
+    , array ^>= 0.3.0.2 || ^>= 0.4.0.0 || ^>= 0.5.0.0
+    , random ^>= 1.1
+
   ghc-options: -Wall -fno-warn-unused-imports
   ghc-options: -threaded