Commits (3)
env:
# - GHCVER=6.12.3
- GHCVER=7.0.1
- GHCVER=7.0.2
- GHCVER=7.0.3
- GHCVER=7.0.4
- GHCVER=7.2.1
- GHCVER=7.2.2
- GHCVER=7.4.1
- GHCVER=7.4.2
- GHCVER=7.6.1
- GHCVER=7.6.2
- GHCVER=7.6.3
- GHCVER=7.8.1
- GHCVER=head
- GHCVER=7.0.1 CABALVER=1.16
- GHCVER=7.0.2 CABALVER=1.16
- GHCVER=7.0.3 CABALVER=1.16
- GHCVER=7.0.4 CABALVER=1.16
- GHCVER=7.2.1 CABALVER=1.16
- GHCVER=7.2.2 CABALVER=1.16
- GHCVER=7.4.1 CABALVER=1.16
- GHCVER=7.4.2 CABALVER=1.16
- GHCVER=7.6.1 CABALVER=1.16
- GHCVER=7.6.2 CABALVER=1.16
- GHCVER=7.6.3 CABALVER=1.16
- GHCVER=7.8.1 CABALVER=1.18
- GHCVER=7.8.2 CABALVER=1.18
- GHCVER=7.8.3 CABALVER=1.18
- GHCVER=head CABALVER=head
matrix:
allow_failures:
- env: GHCVER=head
- env: GHCVER=head CABALVER=head
before_install:
- sudo add-apt-repository -y ppa:hvr/ghc
- sudo apt-get update
- sudo apt-get install cabal-install-1.18 ghc-$GHCVER
- export PATH=/opt/ghc/$GHCVER/bin:$PATH
- travis_retry sudo add-apt-repository -y ppa:hvr/ghc
- travis_retry sudo apt-get update
- travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
- cabal --version
install:
- cabal-1.18 update
- travis_retry cabal update
script:
- cabal-1.18 configure -v2
- cabal-1.18 build
- cabal-1.18 check
- cabal-1.18 sdist
- export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;
- cabal configure -v2
- cabal build
- cabal check
- cabal sdist
- export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
if [ -f "dist/$SRC_TGZ" ]; then
cabal-1.18 install "dist/$SRC_TGZ";
cabal install "dist/$SRC_TGZ";
else
echo "expected '$SRC_TGZ' not found";
exit 1;
fi
- cabal-1.18 install random
- tests/runtests.sh
\ No newline at end of file
- cabal install random
- tests/runtests.sh
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 701
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
......@@ -9,7 +11,7 @@
-- Module : Control.Concurrent.STM
-- Copyright : (c) The University of Glasgow 2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires STM)
......@@ -25,15 +27,15 @@
-----------------------------------------------------------------------------
module Control.Concurrent.STM (
module Control.Monad.STM,
module Control.Concurrent.STM.TVar,
module Control.Monad.STM,
module Control.Concurrent.STM.TVar,
#ifdef __GLASGOW_HASKELL__
module Control.Concurrent.STM.TMVar,
module Control.Concurrent.STM.TMVar,
module Control.Concurrent.STM.TChan,
module Control.Concurrent.STM.TQueue,
module Control.Concurrent.STM.TBQueue,
#endif
module Control.Concurrent.STM.TArray
module Control.Concurrent.STM.TArray
) where
import Control.Monad.STM
......
......@@ -10,7 +10,7 @@
-- Module : Control.Concurrent.STM.TBQueue
-- Copyright : (c) The University of Glasgow 2012
-- License : BSD-style (see the file libraries/base/LICENSE)
--
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires STM)
......@@ -28,14 +28,14 @@
module Control.Concurrent.STM.TBQueue (
-- * TBQueue
TBQueue,
newTBQueue,
newTBQueueIO,
readTBQueue,
tryReadTBQueue,
peekTBQueue,
tryPeekTBQueue,
writeTBQueue,
TBQueue,
newTBQueue,
newTBQueueIO,
readTBQueue,
tryReadTBQueue,
peekTBQueue,
tryPeekTBQueue,
writeTBQueue,
unGetTBQueue,
isEmptyTBQueue,
isFullTBQueue,
......
......@@ -10,7 +10,7 @@
-- Module : Control.Concurrent.STM.TChan
-- Copyright : (c) The University of Glasgow 2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires STM)
......@@ -22,23 +22,23 @@
module Control.Concurrent.STM.TChan (
#ifdef __GLASGOW_HASKELL__
-- * TChans
TChan,
-- * TChans
TChan,
-- ** Construction
newTChan,
newTChanIO,
newBroadcastTChan,
newBroadcastTChanIO,
newTChanIO,
newBroadcastTChan,
newBroadcastTChanIO,
dupTChan,
cloneTChan,
-- ** Reading and writing
readTChan,
tryReadTChan,
peekTChan,
tryPeekTChan,
writeTChan,
readTChan,
tryReadTChan,
peekTChan,
tryPeekTChan,
writeTChan,
unGetTChan,
isEmptyTChan
#endif
......@@ -126,8 +126,8 @@ readTChan (TChan read _write) = do
case head of
TNil -> retry
TCons a tail -> do
writeTVar read tail
return a
writeTVar read tail
return a
-- | A version of 'readTChan' which does not retry. Instead it
-- returns @Nothing@ if no value is available.
......@@ -167,7 +167,7 @@ tryPeekTChan (TChan read _write) = do
-- everyone else.
dupTChan :: TChan a -> STM (TChan a)
dupTChan (TChan _read write) = do
hole <- readTVar write
hole <- readTVar write
new_read <- newTVar hole
return (TChan new_read write)
......
......@@ -9,7 +9,7 @@
-- Module : Control.Concurrent.STM.TMVar
-- Copyright : (c) The University of Glasgow 2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires STM)
......@@ -21,20 +21,20 @@
module Control.Concurrent.STM.TMVar (
#ifdef __GLASGOW_HASKELL__
-- * TMVars
TMVar,
newTMVar,
newEmptyTMVar,
newTMVarIO,
newEmptyTMVarIO,
takeTMVar,
putTMVar,
readTMVar,
tryReadTMVar,
swapTMVar,
tryTakeTMVar,
tryPutTMVar,
isEmptyTMVar
-- * TMVars
TMVar,
newTMVar,
newEmptyTMVar,
newTMVarIO,
newEmptyTMVarIO,
takeTMVar,
putTMVar,
readTMVar,
tryReadTMVar,
swapTMVar,
tryTakeTMVar,
tryPutTMVar,
isEmptyTMVar
#endif
) where
......@@ -81,7 +81,7 @@ newEmptyTMVarIO = do
return (TMVar t)
-- |Return the contents of the 'TMVar'. If the 'TMVar' is currently
-- empty, the transaction will 'retry'. After a 'takeTMVar',
-- empty, the transaction will 'retry'. After a 'takeTMVar',
-- the 'TMVar' is left empty.
takeTMVar :: TMVar a -> STM a
takeTMVar (TMVar t) = do
......
......@@ -10,7 +10,7 @@
-- Module : Control.Concurrent.STM.TQueue
-- Copyright : (c) The University of Glasgow 2012
-- License : BSD-style (see the file libraries/base/LICENSE)
--
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires STM)
......@@ -32,14 +32,14 @@
module Control.Concurrent.STM.TQueue (
-- * TQueue
TQueue,
newTQueue,
newTQueueIO,
readTQueue,
tryReadTQueue,
peekTQueue,
tryPeekTQueue,
writeTQueue,
TQueue,
newTQueue,
newTQueueIO,
readTQueue,
tryReadTQueue,
peekTQueue,
tryPeekTQueue,
writeTQueue,
unGetTQueue,
isEmptyTQueue,
) where
......
......@@ -9,7 +9,7 @@
-- Module : Control.Concurrent.STM.TVar
-- Copyright : (c) The University of Glasgow 2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires STM)
......@@ -19,16 +19,16 @@
-----------------------------------------------------------------------------
module Control.Concurrent.STM.TVar (
-- * TVars
TVar,
newTVar,
newTVarIO,
readTVar,
readTVarIO,
writeTVar,
modifyTVar,
modifyTVar',
swapTVar,
-- * TVars
TVar,
newTVar,
newTVarIO,
readTVar,
readTVarIO,
writeTVar,
modifyTVar,
modifyTVar',
swapTVar,
#ifdef __GLASGOW_HASKELL__
registerDelay,
#endif
......
......@@ -10,7 +10,7 @@
-- Module : Control.Monad.STM
-- Copyright : (c) The University of Glasgow 2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : non-portable (requires STM)
......@@ -23,19 +23,19 @@
-- and Practice of Parallel Programming/ 2005.
-- <http://research.microsoft.com/Users/simonpj/papers/stm/index.htm>
--
-- This module only defines the 'STM' monad; you probably want to
-- This module only defines the 'STM' monad; you probably want to
-- import "Control.Concurrent.STM" (which exports "Control.Monad.STM").
-----------------------------------------------------------------------------
module Control.Monad.STM (
STM,
atomically,
STM,
atomically,
#ifdef __GLASGOW_HASKELL__
always,
alwaysSucceeds,
retry,
orElse,
check,
retry,
orElse,
check,
#endif
throwSTM,
catchSTM
......
......@@ -4,14 +4,16 @@
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 701
#if __GLASGOW_HASKELL__ >= 709
{-# LANGUAGE Safe #-}
#elif __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
-- #hide
module Control.Sequential.STM (
STM, atomically, throwSTM, catchSTM,
TVar, newTVar, newTVarIO, readTVar, readTVarIO, writeTVar
STM, atomically, throwSTM, catchSTM,
TVar, newTVar, newTVarIO, readTVar, readTVarIO, writeTVar
) where
#if __GLASGOW_HASKELL__ < 705
......@@ -37,15 +39,15 @@ instance Applicative STM where
instance Monad STM where
return = pure
STM m >>= k = STM $ \ r -> do
x <- m r
unSTM (k x) r
x <- m r
unSTM (k x) r
atomically :: STM a -> IO a
atomically (STM m) = do
r <- newIORef (return ())
m r `onException` do
rollback <- readIORef r
rollback
rollback <- readIORef r
rollback
throwSTM :: Exception e => e -> STM a
throwSTM = STM . const . throwIO
......@@ -57,13 +59,13 @@ catchSTM (STM m) h = STM $ \ r -> do
res <- try (m r)
rollback_m <- readIORef r
case res of
Left ex -> do
rollback_m
writeIORef r old_rollback
unSTM (h ex) r
Right a -> do
writeIORef r (rollback_m >> old_rollback)
return a
Left ex -> do
rollback_m
writeIORef r old_rollback
unSTM (h ex) r
Right a -> do
writeIORef r (rollback_m >> old_rollback)
return a
newtype TVar a = TVar (IORef a)
deriving (Eq)
......
......@@ -7,13 +7,13 @@ import Control.Exception
inittvars :: STM (TVar String, TVar String)
inittvars = do v1 <- newTVar "Hello "
v2 <- newTVar "world\n"
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)
s2 <- readTVar v2
return (s1 ++ s2)
stmupdates :: TVar String -> TVar String -> STM ()
stmupdates v1 v2 = do writeTVar v1 "About to throw exception"
......@@ -35,37 +35,29 @@ main = do putStr "Before\n"
(sv1, sv2) <- atomically ( inittvars )
putStr "Reading from svars: "
x <- atomically ( stmops sv1 sv2 )
putStr x
x <- atomically ( stmops sv1 sv2 )
putStr x
putStr "Abandoning update with exception\n"
Control.Exception.catch (atomically ( stmupdates sv1 sv2 ))
Control.Exception.catch (atomically ( stmupdates sv1 sv2 ))
(\(e::ErrorCall) -> putStr "Abandoned\n")
putStr "Reading from svars: "
x <- atomically ( stmops sv1 sv2 )
putStr x
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
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
x <- atomically ( stmops sv1 sv2 )
putStr x
return ()
return ()
......@@ -37,14 +37,6 @@ main = do newStablePtr stdout
s1 <- Control.Exception.catch (atomically ( deadlock1 t1 ))
(\(e::SomeException) -> return ("Caught: " ++ (show e) ++ "\n"))
putStr s1
return ()
return ()
......@@ -10,7 +10,7 @@ import System.IO
-- Create two tvars each holding 0
initTVars :: STM (TVar Int, TVar Int)
initTVars = do v1 <- newTVar 0
v2 <- newTVar 0
v2 <- newTVar 0
return (v1, v2)
-- Increment v1, retry
......@@ -62,7 +62,7 @@ main = do newStablePtr stdout
iteration 10
iteration :: Int -> IO ()
iteration n =
iteration n =
do putStrLn ("Iter " ++ show n)
(sv1, sv2) <- atomically ( initTVars )
......@@ -99,6 +99,3 @@ iteration n =
putStrLn "T7"
if (n == 0) then return () else iteration (n - 1)
......@@ -7,8 +7,8 @@ import Control.Concurrent
import Control.Concurrent.STM
import System.Random
import Data.Array
import GHC.Conc ( unsafeIOToSTM )
import Control.Monad ( when )
import GHC.Conc ( unsafeIOToSTM )
import Control.Monad ( when )
import System.IO
import System.IO.Unsafe
import System.Environment
......@@ -42,22 +42,22 @@ 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 =
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
......@@ -67,8 +67,8 @@ main = do
args <- getArgs
case args of
[n,m] -> let g = read (n ++ ' ':m) in setStdGen g
[] -> do g <- getStdGen
print g
[] -> do g <- getStdGen
print g
-}
-- for a deterministic run, we set the random seed explicitly:
......@@ -98,21 +98,21 @@ sourceAccount = 0 :: Int
-- (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.
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.
-- NB. $! above is necessary to avoid this test getting into a bad
-- state. The sourceSinkThread fills up all the accounts with
......@@ -132,8 +132,8 @@ atomically_ tid stm = do
r <- atomically $ do
stmTrace ("execute " ++ show tid)
r <- stm `orElse` do
stmTrace ("retry " ++ show tid)
retry
stmTrace ("retry " ++ show tid)
retry
c <- readTVar commitVar
writeTVar commitVar (tid:c)
return r
......
......@@ -12,7 +12,7 @@ import Control.Concurrent.STM
import System.Environment
import Control.Monad
type Key = Int
type Key = Int
type Value = Int
......@@ -31,8 +31,8 @@ type DirectoryCommandCount = TVar Int
-- The service's state
data DirectoryState = DirectoryState {
chan :: DirectoryChannel,
table :: DirectoryTable,
chan :: DirectoryChannel,
table :: DirectoryTable,
count :: DirectoryCommandCount }
{-
......@@ -74,7 +74,7 @@ dumpDirectoryTable t
addDirectoryTable :: DirectoryTable -> DirectoryEntry -> IO ()
addDirectoryTable t e@(key,value)
= do atomically (do l <- readTVar t
if filter (keyEquals key) l == []
if filter (keyEquals key) l == []
then writeTVar t (e:l)
else writeTVar t l)
-- putStrLn ("added (" ++ (show (fst e)) ++ "," ++ (show (snd e)) ++ ")")
......@@ -90,7 +90,7 @@ postCommand c cmd = atomically (writeTChan c cmd)
-}
removeDirectoryTable :: DirectoryTable -> Key -> IO ()
removeDirectoryTable t k
= atomically (do l <- readTVar t
= atomically (do l <- readTVar t
let newl = filter (keyNotEquals k) l
writeTVar t newl)
-- putStrLn ("removed " ++ (show k))
......@@ -98,10 +98,10 @@ removeDirectoryTable t k
{-
Find a DirectoryEntry in a DirectoryTable.
-}
findDirectoryTable :: DirectoryTable -> Key -> IO DirectoryEntryList
findDirectoryTable :: DirectoryTable -> Key -> IO DirectoryEntryList
findDirectoryTable t k
= do l <- atomically (do l <- readTVar t
writeTVar t l
= do l <- atomically (do l <- readTVar t
writeTVar t l
return l)
let fl = filter (keyEquals k) l
return fl
......@@ -132,16 +132,16 @@ directoryFinder state done
= do cc <- readDirectoryCommandCount cnt
l <- findDirectoryTable t 1
{-
if l /= [] then
if l /= [] then
putStr "found"
else
else
putStr "not found"
putStrLn (" " ++ (show cc))
-}
b <- atomically (readTVar done)
if b then return ()
else directoryFinder state done
else directoryFinder state done
where
t = table state
cnt = count state
......
......@@ -10,8 +10,8 @@ import GHC.Conc -- Control.Concurrent.STM
import System.Random
import Data.Array
import Data.List
import GHC.Conc ( unsafeIOToSTM )
import Control.Monad ( when )
import GHC.Conc ( unsafeIOToSTM )
import Control.Monad ( when )
import System.IO
import System.IO.Unsafe
import System.Environment
......@@ -35,16 +35,16 @@ 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
i1 <- randomRIO (1,n_elems)
i2 <- randomRIO (1,n_elems)
let e1 = elements ! i1
let e2 = elements ! i2
atomically $ do
atomically $ do
e1_v <- readTVar e1
e2_v <- readTVar e2
writeTVar e1 e2_v
writeTVar e2 e1_v
loop (n-1)
loop (n-1)
await_end :: TVar Int -> IO ()
await_end done = atomically $ do x <- readTVar done
......@@ -66,5 +66,3 @@ main = do
mapM (\v -> putStr ((show v) ++ " " )) (sort fin_vals)
putStr("\n")
if ((sort fin_vals) == init_vals) then return () else throw (ErrorCall "Mismatch")
......@@ -12,7 +12,7 @@ inc tv = do
bad :: MVar () -> IO ()
bad m = do { evaluate (1 `quot` 0); return () }
`finally` putMVar m ()
`finally` putMVar m ()
main :: IO ()
main = do
......@@ -22,4 +22,3 @@ main = do
forkOS (bad m)
takeMVar m
threadDelay 100000 -- allow time for the exception to be printed