Move STM-specific tests from testsuite/tests/ghc-regress/concurrent/should_run
authorSimon Marlow <simonmar@microsoft.com>
Thu, 17 May 2007 09:01:02 +0000 (09:01 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Thu, 17 May 2007 09:01:02 +0000 (09:01 +0000)
31 files changed:
tests/Makefile [new file with mode: 0644]
tests/all.T [new file with mode: 0644]
tests/conc046.hs [new file with mode: 0644]
tests/conc046.stderr [new file with mode: 0644]
tests/conc046.stdout [new file with mode: 0644]
tests/conc047.hs [new file with mode: 0644]
tests/conc047.stderr [new file with mode: 0644]
tests/conc047.stdout [new file with mode: 0644]
tests/conc048.hs [new file with mode: 0644]
tests/conc048.stderr [new file with mode: 0644]
tests/conc048.stdout [new file with mode: 0644]
tests/conc049.hs [new file with mode: 0644]
tests/conc050.hs [new file with mode: 0644]
tests/conc052.hs [new file with mode: 0644]
tests/conc052.stderr [new file with mode: 0644]
tests/conc052.stdout [new file with mode: 0644]
tests/conc053.hs [new file with mode: 0644]
tests/conc054.hs [new file with mode: 0644]
tests/conc054.stdout [new file with mode: 0644]
tests/conc055.hs [new file with mode: 0644]
tests/conc055.stderr [new file with mode: 0644]
tests/conc056.hs [new file with mode: 0644]
tests/conc056.stderr [new file with mode: 0644]
tests/conc060.hs [new file with mode: 0644]
tests/conc060.stdout [new file with mode: 0644]
tests/conc061.hs [new file with mode: 0644]
tests/conc061.stdout [new file with mode: 0644]
tests/conc062.hs [new file with mode: 0644]
tests/conc062.stdout [new file with mode: 0644]
tests/conc063.hs [new file with mode: 0644]
tests/conc063.stdout [new file with mode: 0644]

diff --git a/tests/Makefile b/tests/Makefile
new file mode 100644 (file)
index 0000000..6a0abcf
--- /dev/null
@@ -0,0 +1,7 @@
+# This Makefile runs the tests using GHC's testsuite framework.  It
+# assumes the package is part of a GHC build tree with the testsuite
+# installed in ../../../testsuite.
+
+TOP=../../../testsuite
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/tests/all.T b/tests/all.T
new file mode 100644 (file)
index 0000000..f47d8f9
--- /dev/null
@@ -0,0 +1,25 @@
+test('conc046', only_compiler_types(['ghc']), compile_and_run, [''])
+
+# Omit GHCi for these two, since they appear to deadlock (23/11/2004 --SDM)
+test('conc047', compose(only_compiler_types(['ghc']), 
+                        omit_ways(['ghci'])), compile_and_run, [''])
+test('conc048', compose(only_compiler_types(['ghc']), 
+                        omit_ways(['ghci'])), compile_and_run, [''])
+
+test('conc049', only_compiler_types(['ghc']), compile_and_run, ['-package stm'])
+test('conc050', compose(only_compiler_types(['ghc']), extra_run_opts('10000')), compile_and_run, ['-package stm'])
+
+test('conc052', normal, compile_and_run, ['-package stm'])
+
+test('conc053', compose(only_ways(['threaded1','threaded2']),
+                       skip_if_platform('i386-unknown-mingw32')),
+                compile_and_run, ['-package stm'])
+test('conc054', normal, compile_and_run, ['-package stm'])
+test('conc055', exit_code(1), compile_and_run, ['-package stm'])
+test('conc056', only_ways(['threaded1','threaded2']),
+                compile_and_run, ['-package stm -package network'])
+
+test('conc060', normal, compile_and_run, ['-package stm'])
+test('conc061', normal, compile_and_run, ['-package stm'])
+test('conc062', normal, compile_and_run, ['-package stm'])
+test('conc063', normal, compile_and_run, ['-package stm'])
diff --git a/tests/conc046.hs b/tests/conc046.hs
new file mode 100644 (file)
index 0000000..1cff81f
--- /dev/null
@@ -0,0 +1,68 @@
+module Main where
+
+import GHC.Conc
+import Control.Concurrent
+import Control.Exception
+
+inittvars :: STM (TVar String, TVar String)
+inittvars = do v1 <- newTVar "Hello "
+              v2 <- newTVar "world\n"
+               return (v1, v2)
+
+stmops :: TVar String -> TVar String -> STM String
+stmops v1 v2 = do s1 <- readTVar v1
+                 s2 <- readTVar v2
+                 return (s1 ++ s2)
+
+stmupdates :: TVar String -> TVar String -> STM ()
+stmupdates v1 v2 = do writeTVar v1 "About to throw exception"
+                      throwDyn "Exn holding string"
+
+internalexn :: TVar String -> TVar String -> STM ()
+internalexn v1 v2 = catchSTM ( do writeTVar v1 "About to throw exception"
+                                  throwDyn "Exn holding string" )
+                             (\_ -> writeTVar v1 "Reached handler ")
+
+internalexn2 :: TVar String -> TVar String -> STM ()
+internalexn2 v1 v2 = catchSTM ( do writeTVar v1 "Hello " )
+                              (\_ -> writeTVar v1 "Reached handler2 ")
+
+-- Exception handling within / around memory transactions
+main = do putStr "Before\n"
+          (sv1, sv2) <- atomically ( inittvars )
+
+          putStr "Reading from svars:            "
+         x <- atomically ( stmops sv1 sv2 )
+         putStr x 
+
+          putStr "Abandoning update with exception\n"
+         Control.Exception.catch (atomically ( stmupdates sv1 sv2 )) 
+                     (\_ -> putStr "Abandoned\n")
+
+          putStr "Reading from svars:            "
+         x <- atomically ( stmops sv1 sv2 )
+         putStr x 
+
+          putStr "Atomic block with internal exception\n"
+          atomically ( internalexn sv1 sv2 )
+
+          putStr "Reading from svars:            "
+         x <- atomically ( stmops sv1 sv2 )
+         putStr x 
+
+          putStr "Atomic block with handler but no exception\n"
+          atomically ( internalexn2 sv1 sv2 )
+
+          putStr "Reading from svars:            "
+         x <- atomically ( stmops sv1 sv2 )
+         putStr x 
+
+         return ()
+
+
+
+
+
+
+
+         
diff --git a/tests/conc046.stderr b/tests/conc046.stderr
new file mode 100644 (file)
index 0000000..e69de29
diff --git a/tests/conc046.stdout b/tests/conc046.stdout
new file mode 100644 (file)
index 0000000..a37cfb2
--- /dev/null
@@ -0,0 +1,9 @@
+Before\r
+Reading from svars:            Hello world\r
+Abandoning update with exception\r
+Abandoned\r
+Reading from svars:            Hello world\r
+Atomic block with internal exception\r
+Reading from svars:            Reached handler world\r
+Atomic block with handler but no exception\r
+Reading from svars:            Hello world\r
diff --git a/tests/conc047.hs b/tests/conc047.hs
new file mode 100644 (file)
index 0000000..3c1e232
--- /dev/null
@@ -0,0 +1,50 @@
+module Main where
+
+import GHC.Conc
+import Control.Exception
+import IO
+import Foreign.StablePtr
+import System.IO
+
+inittvar :: STM (TVar String)
+inittvar = newTVar "Hello world"
+
+deadlock0 :: STM String
+deadlock0 = retry
+
+deadlock1 :: TVar String -> STM String
+deadlock1 v1 = do s1 <- readTVar v1
+                  retry
+
+-- Basic single-threaded operations with retry
+main = do newStablePtr stdout
+          putStr "Before\n"
+          t1 <- atomically ( newTVar 0 )
+
+          -- Atomic block that contains a retry but does not perform it
+          r <- atomically ( do r1 <- readTVar t1
+                               if (r1 /= 0) then retry else return ()
+                               return r1 )
+          putStr ("Survived unused retry\n")
+
+          -- Atomic block that retries after reading 0 TVars
+          s1 <- Control.Exception.catch (atomically retry )
+                   (\e -> return ("Caught: " ++ (show e) ++ "\n"))
+          putStr s1
+
+          -- Atomic block that retries after reading 1 TVar
+          t1 <- atomically ( inittvar )
+          s1 <- Control.Exception.catch (atomically ( deadlock1 t1 ))
+                   (\e -> return ("Caught: " ++ (show e) ++ "\n"))
+          putStr s1
+          
+
+         return ()
+
+
+
+
+
+
+
+         
diff --git a/tests/conc047.stderr b/tests/conc047.stderr
new file mode 100644 (file)
index 0000000..e69de29
diff --git a/tests/conc047.stdout b/tests/conc047.stdout
new file mode 100644 (file)
index 0000000..c319cd3
--- /dev/null
@@ -0,0 +1,4 @@
+Before\r
+Survived unused retry\r
+Caught: thread blocked indefinitely\r
+Caught: thread blocked indefinitely\r
diff --git a/tests/conc048.hs b/tests/conc048.hs
new file mode 100644 (file)
index 0000000..316aab1
--- /dev/null
@@ -0,0 +1,96 @@
+module Main where
+
+import GHC.Conc
+import Control.Concurrent
+import Control.Exception
+import IO
+import Foreign.StablePtr
+import System.IO
+
+-- Create two tvars each holding 0
+initTVars :: STM (TVar Int, TVar Int)
+initTVars = do v1 <- newTVar 0
+              v2 <- newTVar 0
+               return (v1, v2)
+
+-- Increment v1, retry
+optionOne :: TVar Int -> TVar Int -> STM ()
+optionOne v1 v2 = do x <- readTVar v1
+                     writeTVar v1 (x + 10)
+                     retry
+
+-- Increment v2, don't retry
+optionTwo :: TVar Int -> TVar Int -> STM ()
+optionTwo v1 v2 = do x <- readTVar v2
+                     writeTVar v2 (x + 10)
+
+-- Combine options one and two.  We should be left with optionTwo because
+-- optionOne attempts to retry while valid.
+elseTestA :: TVar Int -> TVar Int -> STM ()
+elseTestA v1 v2 = (optionOne v1 v2) `orElse` (optionTwo v1 v2)
+
+-- Combine options one and two.  We should be left with optionTwo because
+-- optionOne attempts to retry while valid.
+elseTestB :: TVar Int -> TVar Int -> STM ()
+elseTestB v1 v2 = (optionTwo v1 v2) `orElse` (optionOne v1 v2)
+
+-- Combine options two and one.  We should be left with optionTwo because
+-- it completes successfully.
+elseTestC :: TVar Int -> TVar Int -> STM ()
+elseTestC v1 v2 = (optionTwo v1 v2) `orElse` (optionTwo v1 v2)
+
+-- Nested use of `orElse`: combine (optionOne and OptionOne) with optionTwo
+elseTestD :: TVar Int -> TVar Int -> STM ()
+elseTestD v1 v2 = ((optionOne v1 v2) `orElse` (optionOne v1 v2)) `orElse` (optionTwo v1 v2)
+
+-- Nested use of `orElse`: combine (optionOne and optionTwo) with optionTwo
+elseTestE :: TVar Int -> TVar Int -> STM ()
+elseTestE v1 v2 = ((optionOne v1 v2) `orElse` (optionTwo v1 v2)) `orElse` (optionTwo v1 v2)
+
+-- Combine options one and one.  Retry should propagate.
+elseTestZ :: TVar Int -> TVar Int -> STM ()
+elseTestZ v1 v2 = (optionOne v1 v2) `orElse` (optionOne v1 v2)
+
+-- return (v1, v2)
+snapshot :: TVar Int -> TVar Int -> STM (Int, Int)
+snapshot v1 v2 = do s1 <- readTVar v1
+                    s2 <- readTVar v2
+                    return (s1, s2)
+
+main :: IO ()
+main = do newStablePtr stdout
+          iteration 10
+
+iteration :: Int -> IO ()
+iteration n = 
+       do (sv1, sv2) <- atomically ( initTVars )
+
+          atomically ( elseTestA sv1 sv2 )
+          vs <- atomically ( snapshot sv1 sv2 )
+          print vs
+
+          atomically ( elseTestB sv1 sv2 )
+          vs <- atomically ( snapshot sv1 sv2 )
+          print vs
+
+          atomically ( elseTestC sv1 sv2 )
+          vs <- atomically ( snapshot sv1 sv2 )
+          print vs
+
+          atomically ( elseTestD sv1 sv2 )
+          vs <- atomically ( snapshot sv1 sv2 )
+          print vs
+
+          atomically ( elseTestE sv1 sv2 )
+          vs <- atomically ( snapshot sv1 sv2 )
+          print vs
+
+          Control.Exception.catch (atomically ( elseTestZ sv1 sv2 ))
+                 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+          vs <- atomically ( snapshot sv1 sv2 )
+          print vs
+
+          if (n == 0) then return () else iteration (n - 1)
+
+
+
diff --git a/tests/conc048.stderr b/tests/conc048.stderr
new file mode 100644 (file)
index 0000000..e69de29
diff --git a/tests/conc048.stdout b/tests/conc048.stdout
new file mode 100644 (file)
index 0000000..da8d256
--- /dev/null
@@ -0,0 +1,77 @@
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
+(0,10)\r
+(0,20)\r
+(0,30)\r
+(0,40)\r
+(0,50)\r
+Caught: thread blocked indefinitely\r
+(0,50)\r
diff --git a/tests/conc049.hs b/tests/conc049.hs
new file mode 100644 (file)
index 0000000..45c005b
--- /dev/null
@@ -0,0 +1,146 @@
+-- STM stress test
+
+{-# OPTIONS -fffi #-}
+module Main (main) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.Random
+import Data.Array
+import GHC.Conc        ( unsafeIOToSTM )
+import Control.Monad   ( when )
+import System.IO
+import System.IO.Unsafe
+import System.Environment
+import Foreign.C
+
+-- | The number of bank accounts
+n_accounts :: Int
+n_accounts = 7
+
+-- | The number of threads transferring money between accounts
+n_actors :: Int
+n_actors = 10
+
+-- | The max initial number of monetary units in each account
+init_credit :: Int
+init_credit = 5
+
+-- | The maximum size of a transfer
+max_transfer :: Int
+max_transfer = 3
+
+-- | The maximum amount transferred by the source/sink thread
+max_source :: Int
+max_source = 3
+
+max_transactions = 2000 :: Int
+
+type Accounts = Array Int (TVar Int)
+
+thread :: Int -> TVar Int -> Accounts -> IO ()
+thread tid done accounts = loop max_transactions
+ where loop 0 = atomically $ do x <- readTVar done; writeTVar done (x+1)
+       loop n = do
+         src    <- randomRIO (1,n_accounts)
+         dst    <- randomRIO (1,n_accounts)
+         if (src == dst) then loop n else do
+         amount <- randomRIO (1,max_transfer)
+         start tid src dst amount
+         atomically_ tid  $ do
+           let src_acc = accounts ! src
+               dst_acc = accounts ! dst
+           credit_src <- readTVar src_acc
+           when (credit_src < amount) retry
+           writeTVar src_acc (credit_src - amount)    
+           credit_dst <- readTVar dst_acc
+           writeTVar dst_acc (credit_dst + amount)    
+         loop (n-1)
+
+start tid src dst amount = 
+  puts ("start " ++ show tid ++ ' ':show src ++ ' ':show dst ++ ' ':show amount)
+
+main = do
+  hSetBuffering stdout LineBuffering
+
+{-
+  args <- getArgs
+  case args of
+   [n,m] -> let g = read (n ++ ' ':m) in setStdGen g
+   []    -> do g <- getStdGen 
+              print g
+-}
+
+  -- for a deterministic run, we set the random seed explicitly:
+  setStdGen (read "526454551 6356")
+
+  -- HACK: the global commitVar requires atomically, so we want to seq it outside of
+  -- an enclosing atomically (otherwise STM gets very confused).
+  seq commitVar $ return ()
+
+--  print n_actors
+--  print n_accounts
+  amounts <- sequence (take n_accounts (repeat (randomRIO (0,init_credit))))
+--  mapM print amounts
+  tvars <- atomically $ mapM newTVar amounts
+  let accounts = listArray (1,n_accounts) tvars
+  done <- atomically (newTVar 0)
+  sequence [ forkIO (thread id done accounts) | id <- [1..n_actors] ]
+  forkIO $ sourceSinkThread accounts
+  atomically $ do
+    x <- readTVar done
+    when (x < n_actors) retry
+
+sourceThreadId = 0 :: Int
+sourceAccount  = 0 :: Int
+
+-- A thread that alternates between dropping some cash into an account
+-- (source), and removing some cash from an account (sink).
+sourceSinkThread accounts = loop True
+  where loop source = do
+          amount <- randomRIO (1,max_source)
+          acct   <- randomRIO (1,n_accounts)
+          if source
+               then do start sourceThreadId sourceAccount acct amount
+                       transfer acct amount
+               else do start sourceThreadId acct sourceAccount amount
+                       transfer acct (-amount)
+          loop (not source)
+
+       transfer acct amount = do
+         let t = accounts ! acct
+         atomically_ sourceThreadId $ do
+           x <- readTVar t
+           writeTVar t (max 0 (x+amount)) -- never drop below zero, 
+                                          -- and don't block.
+
+-- -----------------------------------------------------------------------------
+-- Our tracing wrapper for atomically
+
+{-# NOINLINE commitVar #-}
+commitVar = unsafePerformIO $ atomically $ newTVar ([] :: [Int])
+
+atomically_ :: Int -> STM a -> IO a
+atomically_ tid stm = do
+  r <- atomically $ do
+    stmTrace ("execute " ++ show tid)
+    r <- stm `orElse` do
+               stmTrace ("retry " ++ show tid)
+               retry
+    c <- readTVar commitVar
+    writeTVar commitVar (tid:c)
+    return r
+
+  atomically $ do
+    c <- readTVar commitVar
+    mapM stmTrace ["commit " ++ show tid | tid <- reverse c ]
+    writeTVar commitVar []
+  return r
+
+stmTrace s = unsafeIOToSTM (puts s)
+
+puts :: String -> IO ()
+puts s = throwErrnoIfMinus1_ "puts" $ withCString s c_puts
+
+foreign import ccall unsafe {-"puts"-} "strlen"
+  c_puts :: CString -> IO CInt
diff --git a/tests/conc050.hs b/tests/conc050.hs
new file mode 100644 (file)
index 0000000..ebb8209
--- /dev/null
@@ -0,0 +1,219 @@
+{-
+  $Id: conc050.hs,v 1.1 2005/03/21 13:59:36 simonmar Exp $
+
+  Implements a simple directory service that handles
+  insert and delete commands using STMs.
+-}
+
+module Main
+where
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.Environment
+import Control.Monad
+
+type Key = Int 
+
+type Value = Int
+
+type DirectoryEntry = (Key, Value)
+
+type DirectoryEntryList = [DirectoryEntry]
+
+-- The service handles add and remove commands
+data DirectoryCommand = DirectoryAdd Key Value | DirectoryRemove Key
+
+type DirectoryChannel = TChan DirectoryCommand
+
+type DirectoryTable = TVar DirectoryEntryList
+
+type DirectoryCommandCount = TVar Int
+
+-- The service's state
+data DirectoryState = DirectoryState {
+  chan :: DirectoryChannel, 
+  table :: DirectoryTable, 
+  count :: DirectoryCommandCount }
+
+{-
+  Return True if a DirectoryEntry's key equals
+  the specified key.
+-}
+keyEquals :: Key -> DirectoryEntry -> Bool
+keyEquals k e = (fst e) == k
+
+{-
+  Return True if a DirectoryEntry's key does not equal
+  the specified key.
+-}
+keyNotEquals :: Key -> DirectoryEntry -> Bool
+keyNotEquals k e = (fst e) /= k
+
+{-
+  Print a DirectoryEntryList to stdout.
+-}
+dumpDirectoryEntryList :: DirectoryEntryList -> IO ()
+dumpDirectoryEntryList [] = return ()
+dumpDirectoryEntryList (x:xs)
+ = do putStrLn ((show (fst x)) ++ " " ++ (show (snd x)))
+      dumpDirectoryEntryList xs
+
+{-
+  Print a DirectoryTable to stdout.
+-}
+dumpDirectoryTable :: DirectoryTable -> IO ()
+dumpDirectoryTable t
+ = do l <- atomically (do {l <- readTVar t; writeTVar t l; return l})
+      putStrLn ("table length = " ++ (show (length l)))
+      -- dumpDirectoryEntryList l
+
+{-
+  Add a DirectoryEntry to a DirectoryTable verifying
+  that the key does not already exist in the table.
+-}
+addDirectoryTable :: DirectoryTable -> DirectoryEntry -> IO ()
+addDirectoryTable t e@(key,value)
+ = do atomically (do l <- readTVar t
+                     if filter (keyEquals key) l == [] 
+                       then writeTVar t (e:l)
+                       else writeTVar t l)
+      -- putStrLn ("added (" ++ (show (fst e)) ++ "," ++ (show (snd e)) ++ ")")
+
+{-
+  Insert a DirectoryCommand into a DirectoryChannel.
+-}
+postCommand :: DirectoryChannel -> DirectoryCommand -> IO ()
+postCommand c cmd = atomically (writeTChan c cmd)
+
+{-
+  Remove a DirectoryEntry from a DirectoryTable.
+-}
+removeDirectoryTable :: DirectoryTable -> Key -> IO ()
+removeDirectoryTable t k
+ = atomically (do l <- readTVar t 
+                  let newl = filter (keyNotEquals k) l
+                  writeTVar t newl)
+      -- putStrLn ("removed " ++ (show k))
+
+{-
+  Find a DirectoryEntry in a DirectoryTable.
+-}
+findDirectoryTable :: DirectoryTable -> Key -> IO DirectoryEntryList 
+findDirectoryTable t k
+ = do l <- atomically (do l <- readTVar t 
+                          writeTVar t l 
+                          return l)
+      let fl = filter (keyEquals k) l
+      return fl
+
+{-
+  Increment the DirectoryCommandCount.
+-}
+incDirectoryCommandCount :: DirectoryCommandCount -> IO ()
+incDirectoryCommandCount cnt
+ = atomically (do i <- readTVar cnt; writeTVar cnt (i+1))
+
+{-
+  Read the DirectoryCommandCount.
+-}
+readDirectoryCommandCount :: DirectoryCommandCount -> IO Int
+readDirectoryCommandCount cnt
+ = do i <- atomically (do i <- readTVar cnt
+                          writeTVar cnt i
+                          return i)
+      return i
+
+{-
+  Process that constantly searches the DirectoryTable
+  for a DirectoryKey of 1 and prints whether it found it.
+-}
+directoryFinder :: DirectoryState -> TVar Bool -> IO ()
+directoryFinder state done
+ = do cc <- readDirectoryCommandCount cnt
+      l <- findDirectoryTable t 1
+{-
+      if l /= [] then 
+         putStr "found"
+       else 
+         putStr "not found"
+      putStrLn (" " ++ (show cc))
+-}
+
+      b <- atomically (readTVar done)
+      if b then return ()
+          else directoryFinder state done
+   where
+     t = table state
+     cnt = count state
+
+{-
+  Process that constantly prints the contents of
+  the DirectoryTable.
+-}
+directoryDumper :: DirectoryState -> IO ()
+directoryDumper state
+ = do let t = table state
+      dumpDirectoryTable t
+      directoryDumper state
+
+{-
+  Process that reads commands from the DirectoryChannel
+  and executes them.
+-}
+directoryListener :: Int -> DirectoryState -> TVar Bool -> IO ()
+directoryListener 0 state done = atomically (writeTVar done True)
+directoryListener n state done
+ = do cmd <- atomically (do {cmd <- readTChan c; return cmd})
+      case cmd of
+        (DirectoryAdd k v) -> addDirectoryTable t (k,v)
+        (DirectoryRemove k) -> removeDirectoryTable t k
+      incDirectoryCommandCount cnt
+      directoryListener (n-1) state done
+   where
+     c = chan state
+     t = table state
+     cnt = count state
+
+{-
+  Process that constantly posts DirectoryAdd
+  commands to the DirectoryChannel.
+-}
+directoryPoster1 :: Int -> DirectoryState -> IO ()
+directoryPoster1 0 state = return ()
+directoryPoster1 n state
+ = do let c = chan state
+      postCommand c (DirectoryAdd 1 2)
+      directoryPoster1 (n-1) state
+
+{-
+  Process that constantly posts DirectoryRemove
+  commands to the DirectoryChannel.
+-}
+directoryPoster2 :: Int -> DirectoryState -> IO ()
+directoryPoster2 0 state = return ()
+directoryPoster2 n state
+ = do let c = chan state
+      postCommand c (DirectoryRemove 1)
+      directoryPoster2 (n-1) state
+
+{-
+  The DirectoryService main process.
+-}
+directoryService
+ = do [s] <- getArgs
+      let n = read s :: Int
+
+      c <- atomically (newTChan)
+      t <- atomically (newTVar [])
+      cnt <- atomically (newTVar 0)
+      let state = DirectoryState c t cnt
+
+      done <- atomically (newTVar False)
+      forkIO (directoryListener (n*2) state done)
+      forkIO (directoryPoster1 n state)
+      forkIO (directoryPoster2 n state)
+      directoryFinder state done
+      -- directoryDumper state
+
+main
+  = directoryService
diff --git a/tests/conc052.hs b/tests/conc052.hs
new file mode 100644 (file)
index 0000000..5c27368
--- /dev/null
@@ -0,0 +1,70 @@
+-- STM stress test
+
+{-# OPTIONS -fffi #-}
+module Main (main) where
+
+import Foreign
+import Control.Concurrent
+import Control.Exception
+import GHC.Conc -- Control.Concurrent.STM
+import System.Random
+import Data.Array
+import Data.List
+import GHC.Conc        ( unsafeIOToSTM )
+import Control.Monad   ( when )
+import System.IO
+import System.IO.Unsafe
+import System.Environment
+import Foreign.C
+
+-- | 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 = 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)
+  putStr("Before: ")
+  mapM (\v -> putStr ((show v) ++ " " )) init_vals
+  putStr("\nAfter: ")
+  mapM (\v -> putStr ((show v) ++ " " )) (sort fin_vals)
+  putStr("\n")
+  if ((sort fin_vals) == init_vals) then return () else throwDyn "Mismatch"
+
+
diff --git a/tests/conc052.stderr b/tests/conc052.stderr
new file mode 100644 (file)
index 0000000..e69de29
diff --git a/tests/conc052.stdout b/tests/conc052.stdout
new file mode 100644 (file)
index 0000000..e0be441
--- /dev/null
@@ -0,0 +1,2 @@
+Before: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 \r
+After: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 \r
diff --git a/tests/conc053.hs b/tests/conc053.hs
new file mode 100644 (file)
index 0000000..4428e09
--- /dev/null
@@ -0,0 +1,22 @@
+-- !!! test threadDelay, Random, and QSemN.
+
+-- Variation of conc023, testing STM timeouts instead of IO
+
+import Random
+import Control.Concurrent
+import Control.Exception
+import Control.Concurrent.STM
+
+n = 5000  -- no. of threads
+m = 3000  -- maximum delay
+
+main = do
+   s <- newQSemN n
+   (is :: [Int]) <- sequence (take n (repeat (getStdRandom (randomR (1,m)))))
+   mapM (fork_sleep s) is
+   waitQSemN s n
+   where
+       fork_sleep s i = forkIO (do waitQSemN s 1
+                                   t <- registerDelay (i*1000)
+                                   atomically $ (readTVar t >>= check)
+                                   signalQSemN s 1)
diff --git a/tests/conc054.hs b/tests/conc054.hs
new file mode 100644 (file)
index 0000000..38ba551
--- /dev/null
@@ -0,0 +1,9 @@
+-- !!! testing newTVarIO
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.IO.Unsafe
+
+var = unsafePerformIO $ newTVarIO 3
+
+main = do x <- atomically $ readTVar var; print x
diff --git a/tests/conc054.stdout b/tests/conc054.stdout
new file mode 100644 (file)
index 0000000..00750ed
--- /dev/null
@@ -0,0 +1 @@
+3
diff --git a/tests/conc055.hs b/tests/conc055.hs
new file mode 100644 (file)
index 0000000..22686eb
--- /dev/null
@@ -0,0 +1,7 @@
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.IO.Unsafe
+
+var = unsafePerformIO $ atomically $ newTVar 3
+
+main = do x <- atomically $ readTVar var; print x
diff --git a/tests/conc055.stderr b/tests/conc055.stderr
new file mode 100644 (file)
index 0000000..ccf3e56
--- /dev/null
@@ -0,0 +1,2 @@
+conc055: Control.Concurrent.STM.atomically was nested
+
diff --git a/tests/conc056.hs b/tests/conc056.hs
new file mode 100644 (file)
index 0000000..f7414a4
--- /dev/null
@@ -0,0 +1,25 @@
+-- Exposed a bug in 6.4.1, fixed in rev. 1.16 of ghc/rts/Exception.cmm
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Exception
+
+inc :: TVar Int -> STM ()
+inc tv = do
+  v <- readTVar tv
+  writeTVar tv (v + 1)
+
+bad :: MVar () -> IO ()
+bad m = do { evaluate (1 `quot` 0); return () }
+        `finally` putMVar m ()
+
+main :: IO ()
+main = do
+  tv <- atomically (newTVar 0)
+  m <- newEmptyMVar
+  forkOS (sequence_ $ repeat $ atomically (inc tv))
+  forkOS (bad m)
+  takeMVar m
+  threadDelay 100000 -- allow time for the exception to be printed
+
diff --git a/tests/conc056.stderr b/tests/conc056.stderr
new file mode 100644 (file)
index 0000000..f0f430f
--- /dev/null
@@ -0,0 +1,2 @@
+conc056: divide by zero
+
diff --git a/tests/conc060.hs b/tests/conc060.hs
new file mode 100644 (file)
index 0000000..fb0018b
--- /dev/null
@@ -0,0 +1,67 @@
+module Main where
+
+import GHC.Conc
+import Control.Exception
+
+-- Create trivial invariants using a single TVar
+main = do
+  putStr "\nStarting\n"
+  x <- atomically ( newTVar 42 )
+
+  putStr "\nAdding trivially true invariant (no TVar access)\n"
+  atomically ( alwaysSucceeds ( return 1 ) ) 
+
+  putStr "\nAdding trivially true invariant (no TVar access)\n"
+  atomically ( always ( return True ) ) 
+
+  putStr "\nAdding a trivially true invariant (TVar access)\n"
+  atomically ( alwaysSucceeds ( readTVar x ) ) 
+
+  putStr "\nAdding an invraiant that's false when attemted to be added\n"
+  Control.Exception.catch (atomically ( do writeTVar x 100
+                                           alwaysSucceeds ( do v <- readTVar x 
+                                                               if (v == 100) then throwDyn "URK" else return () )
+                                           writeTVar x 0 ) )
+      (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+  putStr "\nWriting to a TVar watched by a trivially true invariant\n"
+  atomically ( writeTVar x 17 )
+
+  putStr "\nAdding a second trivially true invariant (same TVar access)\n"
+  atomically ( alwaysSucceeds ( readTVar x ) ) 
+
+  putStr "\nWriting to a TVar watched by both trivially true invariants\n"
+  atomically ( writeTVar x 18 )
+
+  putStr "\nAdding a trivially false invariant (no TVar access)\n"
+  Control.Exception.catch (atomically ( alwaysSucceeds ( throwDyn "Exn raised in invariant" ) ) )
+      (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+  putStr "\nAdding a trivially false invariant (no TVar access)\n"
+  Control.Exception.catch (atomically ( always ( throwDyn "Exn raised in invariant" ) ) )
+      (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+  putStr "\nAdding a trivially false invariant (no TVar access)\n"
+  Control.Exception.catch (atomically ( always ( return False ) ) )
+      (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+  putStr "\nAdding a trivially false invariant (with TVar access)\n"
+  Control.Exception.catch (atomically ( 
+                alwaysSucceeds ( do t <- readTVar x
+                                    throwDyn "Exn raised in invariant" ) ) )
+      (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+  putStr "\nAdding a third invariant true if TVar != 42\n"
+  atomically ( alwaysSucceeds ( do t <- readTVar x
+                                   if (t == 42) then throwDyn "Exn raised in invariant" else return () ) )
+
+  putStr "\nViolating third invariant by setting TVar to 42\n"
+  Control.Exception.catch (atomically ( writeTVar x 42 ) )
+      (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+  putStr "\nChecking final TVar contents\n"
+  t <- atomically ( readTVar x )
+  putStr ("Final value = " ++ (show t) ++ "\n")
+
+  putStr "\nDone\n"
+         
diff --git a/tests/conc060.stdout b/tests/conc060.stdout
new file mode 100644 (file)
index 0000000..be28433
--- /dev/null
@@ -0,0 +1,39 @@
+\r
+Starting\r
+\r
+Adding trivially true invariant (no TVar access)\r
+\r
+Adding trivially true invariant (no TVar access)\r
+\r
+Adding a trivially true invariant (TVar access)\r
+\r
+Adding an invraiant that's false when attemted to be added\r
+Caught: exception :: [Char]\r
+\r
+Writing to a TVar watched by a trivially true invariant\r
+\r
+Adding a second trivially true invariant (same TVar access)\r
+\r
+Writing to a TVar watched by both trivially true invariants\r
+\r
+Adding a trivially false invariant (no TVar access)\r
+Caught: exception :: [Char]\r
+\r
+Adding a trivially false invariant (no TVar access)\r
+Caught: exception :: [Char]\r
+\r
+Adding a trivially false invariant (no TVar access)\r
+Caught: Transacional invariant violation\r
+\r
+Adding a trivially false invariant (with TVar access)\r
+Caught: exception :: [Char]\r
+\r
+Adding a third invariant true if TVar != 42\r
+\r
+Violating third invariant by setting TVar to 42\r
+Caught: exception :: [Char]\r
+\r
+Checking final TVar contents\r
+Final value = 18\r
+\r
+Done\r
diff --git a/tests/conc061.hs b/tests/conc061.hs
new file mode 100644 (file)
index 0000000..0bab8e2
--- /dev/null
@@ -0,0 +1,79 @@
+module Main where
+
+import GHC.Conc
+import Control.Concurrent
+import Control.Exception
+
+main = do putStr "Starting\n";
+          t <- atomically (newTVar 42)
+
+          v <- atomically (readTVar t)
+          putStr ("TVar contains " ++ (show v) ++ "\n")
+
+          -- ......................................................................
+          -- Check that we roll back when an exception leaves an atomic block
+
+          putStr ("Raising uncaught exn in atomic block\n");
+          Control.Exception.catch (atomically ( 
+                                     do writeTVar t 17
+                                        throwDyn "Exn raised in a tx" ) )
+           (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+          v <- atomically (readTVar t)
+          putStr ("TVar contains " ++ (show v) ++ "\n")
+
+          -- ......................................................................
+          -- Check that we commit a catchSTM nested tx
+
+          putStr ("Trying a catchSTM without raising an exception\n");
+          Control.Exception.catch (atomically ( 
+                                     catchSTM ( do writeTVar t 17 )
+                                              ( \e -> throw e  ) ) )
+           (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+          v <- atomically (readTVar t)
+          putStr ("TVar contains " ++ (show v) ++ "\n")
+
+          -- ......................................................................
+          -- Check that we roll back when an exception is caught and rethrown in
+          -- an atomic block
+
+          putStr ("Raising caught and rethrown exn in atomic block\n");
+          Control.Exception.catch (atomically ( 
+                                     catchSTM ( do writeTVar t 42
+                                                   throwDyn "Exn raised in a tx" )
+                                              ( \e -> throw e  ) ) )
+           (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+          v <- atomically (readTVar t)
+          putStr ("TVar contains " ++ (show v) ++ "\n")
+
+          -- ......................................................................
+          -- Check that we roll back just the "catchSTM" block when an exception is
+          -- raised in it (but caught later in the same atomic block)
+
+          putStr ("Raising caught and rethrown exn in atomic block\n");
+          v <- atomically ( 
+                    do writeTVar t 0
+                       catchSTM ( do writeTVar t 1
+                                     throwDyn "Exn raised in a tx" )
+                                ( \_ -> return () ) 
+                       readTVar t )
+          putStr ("TVar contained " ++ (show v) ++ " at end of atomic block\n")
+
+          v <- atomically (readTVar t)
+          putStr ("TVar contains " ++ (show v) ++ "\n")
+
+          -- ......................................................................
+          -- Check that 'retry' can propagate through a catchSTM
+
+          putStr ("Testing retry inside catchSTM\n");
+          Control.Exception.catch (atomically ( 
+                                     ( catchSTM ( retry )
+                                                ( \e -> throw e  ) ) 
+                                     `orElse` ( return () ) ) )
+           (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+          v <- atomically (readTVar t)
+          putStr ("TVar contains " ++ (show v) ++ "\n")
+
diff --git a/tests/conc061.stdout b/tests/conc061.stdout
new file mode 100644 (file)
index 0000000..9e98ddf
--- /dev/null
@@ -0,0 +1,15 @@
+Starting\r
+TVar contains 42\r
+Raising uncaught exn in atomic block\r
+Caught: exception :: [Char]\r
+TVar contains 42\r
+Trying a catchSTM without raising an exception\r
+TVar contains 17\r
+Raising caught and rethrown exn in atomic block\r
+Caught: exception :: [Char]\r
+TVar contains 17\r
+Raising caught and rethrown exn in atomic block\r
+TVar contained 0 at end of atomic block\r
+TVar contains 0\r
+Testing retry inside catchSTM\r
+TVar contains 0\r
diff --git a/tests/conc062.hs b/tests/conc062.hs
new file mode 100644 (file)
index 0000000..295b58e
--- /dev/null
@@ -0,0 +1,39 @@
+module Main where
+
+import GHC.Conc
+import Control.Exception
+
+-- Test invariants using multiple TVars
+main = do
+  putStr "\nStarting\n"
+  (x1, x2, x3) <- atomically ( do x1 <- newTVar 0
+                                  x2 <- newTVar 0 
+                                  x3 <- newTVar 0 
+                                  return (x1, x2, x3))
+
+  putStr "\nAttaching invariant\n";
+  atomically ( alwaysSucceeds ( do v1 <- readTVar x1
+                                   v23 <- readTVar (if (v1 >= 0) then x2 else x3)
+                                   if (v23 > v1) then throwDyn "Exn" else return () ) )
+
+  putStr "\nTouching invariant (should keep on same TVars)\n"
+  atomically ( do writeTVar x1 1
+                  writeTVar x2 1 )
+
+  putStr "\nTouching invariant (should move it to other TVars)\n"
+  atomically ( do writeTVar x1 (-1)
+                  writeTVar x3 (-1) )
+
+  putStr "\nTouching invariant (should keep on same TVars)\n"
+  atomically ( do writeTVar x1 (-2)
+                  writeTVar x3 (-3) )
+
+  putStr "\nChecking TVar contents\n"
+  (t1, t2, t3) <- atomically ( do t1 <- readTVar x1
+                                  t2 <- readTVar x2
+                                  t3 <- readTVar x3
+                                  return (t1, t2, t3))
+  putStr ("Contents = (" ++ (show t1) ++ "," ++ (show t2) ++ "," ++ (show t3) ++ ")\n")
+
+  putStr "\nDone\n"
+         
diff --git a/tests/conc062.stdout b/tests/conc062.stdout
new file mode 100644 (file)
index 0000000..6cff439
--- /dev/null
@@ -0,0 +1,15 @@
+\r
+Starting\r
+\r
+Attaching invariant\r
+\r
+Touching invariant (should keep on same TVars)\r
+\r
+Touching invariant (should move it to other TVars)\r
+\r
+Touching invariant (should keep on same TVars)\r
+\r
+Checking TVar contents\r
+Contents = (-2,1,-3)\r
+\r
+Done\r
diff --git a/tests/conc063.hs b/tests/conc063.hs
new file mode 100644 (file)
index 0000000..f98ff68
--- /dev/null
@@ -0,0 +1,54 @@
+module Main where
+
+import GHC.Conc
+import Control.Exception
+import IO
+import Foreign.StablePtr
+import System.IO
+
+-- Test invariants using updates & blocking in invariants
+main = do
+  m <- newEmptyMVar
+  forkIO (do_test m)
+  takeMVar m
+  -- We do the test in a separate thread, because this test relies on
+  -- being able to catch BlockedIndefinitely, and the main thread
+  -- won't receive that exception under GHCi because it is held alive
+  -- by the interrupt (^C) handler thread.
+
+do_test m = do
+  newStablePtr stdout
+
+  putStr "\nStarting\n"
+  (x1, x2, x3) <- atomically ( do x1 <- newTVar 0
+                                  x2 <- newTVar 0 
+                                  x3 <- newTVar 0 
+                                  return (x1, x2, x3))
+
+  putStr "\nAttaching successful invariant that makes an update\n";
+  atomically ( alwaysSucceeds ( writeTVar x1 42 ) ) 
+
+  putStr "\nAttaching successful invariant that uses retry&orelse internally\n";
+  atomically ( alwaysSucceeds ( retry `orElse` return () ) ) 
+
+  putStr "\nAttaching a failed invariant that makes an update\n";
+  Control.Exception.catch (atomically ( do writeTVar x1 17
+                                           alwaysSucceeds ( throwDyn "Exn raised in invariant" ) ) )
+      (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+  putStr "\nAttaching an invariant that blocks\n";
+  forkIO ( do threadDelay 1000000
+              atomically ( writeTVar x1 10 ) 
+              return ()) 
+  atomically ( do alwaysSucceeds ( do v1 <- readTVar x1
+                                      if (v1 == 0) then retry else return () )
+              )
+  
+  putStr "\nAnother update to the TVar with the blocking invariant\n"
+  atomically ( writeTVar x1 20 ) 
+
+  putStr "\nUpdate the TVar to cause the invariant to block again (expect thread blocked indef)\n"
+  Control.Exception.catch (atomically ( writeTVar x1 0 ))
+                 (\e -> putStr ("Caught: " ++ (show e) ++ "\n"))
+
+  putMVar m ()         
diff --git a/tests/conc063.stdout b/tests/conc063.stdout
new file mode 100644 (file)
index 0000000..1538cec
--- /dev/null
@@ -0,0 +1,16 @@
+
+Starting
+
+Attaching successful invariant that makes an update
+
+Attaching successful invariant that uses retry&orelse internally
+
+Attaching a failed invariant that makes an update
+Caught: exception :: [Char]
+
+Attaching an invariant that blocks
+
+Another update to the TVar with the blocking invariant
+
+Update the TVar to cause the invariant to block again (expect thread blocked indef)
+Caught: thread blocked indefinitely