...
 
Commits (5)
env:
- 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
# This Travis job script has been generated by a script via
#
# runghc make_travis_yml_2.hs 'stm.cabal'
#
# For more information, see https://github.com/hvr/multi-ghc-travis
#
language: c
sudo: false
git:
submodules: false # whether to recursively clone submodules
cache:
directories:
- $HOME/.cabal/packages
- $HOME/.cabal/store
before_cache:
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
# remove files that are regenerated by 'cabal update'
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar
- rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx
- rm -rfv $HOME/.cabal/packages/head.hackage
matrix:
allow_failures:
- env: GHCVER=head CABALVER=head
include:
- compiler: "ghc-7.0.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.0.1], sources: [hvr-ghc]}}
- compiler: "ghc-7.0.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.0.2], sources: [hvr-ghc]}}
- compiler: "ghc-7.0.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.0.3], sources: [hvr-ghc]}}
- compiler: "ghc-7.0.4"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.0.4], sources: [hvr-ghc]}}
- compiler: "ghc-7.2.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.2.1], sources: [hvr-ghc]}}
- compiler: "ghc-7.2.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.2.2], sources: [hvr-ghc]}}
- compiler: "ghc-7.4.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.4.1], sources: [hvr-ghc]}}
- compiler: "ghc-7.4.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.4.2], sources: [hvr-ghc]}}
- compiler: "ghc-7.6.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.6.1], sources: [hvr-ghc]}}
- compiler: "ghc-7.6.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.6.2], sources: [hvr-ghc]}}
- compiler: "ghc-7.6.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.6.3], sources: [hvr-ghc]}}
- compiler: "ghc-7.8.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.1], sources: [hvr-ghc]}}
- compiler: "ghc-7.8.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.2], sources: [hvr-ghc]}}
- compiler: "ghc-7.8.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.3], sources: [hvr-ghc]}}
- compiler: "ghc-7.8.4"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}}
- compiler: "ghc-7.10.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.1], sources: [hvr-ghc]}}
- compiler: "ghc-7.10.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.2], sources: [hvr-ghc]}}
- compiler: "ghc-7.10.3"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}}
- compiler: "ghc-8.0.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.1], sources: [hvr-ghc]}}
- compiler: "ghc-8.0.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}}
- compiler: "ghc-8.2.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.1], sources: [hvr-ghc]}}
- compiler: "ghc-8.2.2"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}}
- compiler: "ghc-8.4.1"
# env: TEST=--disable-tests BENCH=--disable-benchmarks
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.4.1], sources: [hvr-ghc]}}
before_install:
- 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
- HC=${CC}
- HCPKG=${HC/ghc/ghc-pkg}
- unset CC
- ROOTDIR=$(pwd)
- mkdir -p $HOME/.local/bin
- "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH"
- HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
- echo $HCNUMVER
install:
- travis_retry cabal update
- cabal --version
- echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
- BENCH=${BENCH---enable-benchmarks}
- TEST=${TEST---enable-tests}
- HADDOCK=${HADDOCK-true}
- INSTALLED=${INSTALLED-true}
- GHCHEAD=${GHCHEAD-false}
- travis_retry cabal update -v
- "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
- rm -fv cabal.project cabal.project.local
- grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
- "printf 'packages: \".\"\\n' > cabal.project"
- cat cabal.project
- if [ -f "./configure.ac" ]; then
(cd "." && autoreconf -i);
fi
- rm -f cabal.project.freeze
- cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all
- cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all
- rm -rf .ghc.environment.* "."/dist
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
# Here starts the actual work to be performed for the package under test;
# any command which exits with a non-zero exit code causes the build to fail.
script:
- 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 install "dist/$SRC_TGZ";
else
echo "expected '$SRC_TGZ' not found";
exit 1;
fi
- cabal install random
- tests/runtests.sh
# test that source-distributions can be generated
- (cd "." && cabal sdist)
- mv "."/dist/stm-*.tar.gz ${DISTDIR}/
- cd ${DISTDIR} || false
- find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
- "printf 'packages: stm-*/*.cabal\\n' > cabal.project"
- cat cabal.project
# this builds all libraries and executables (without tests/benchmarks)
- cabal new-build -w ${HC} --disable-tests --disable-benchmarks all
# Build with installed constraints for packages in global-db
- if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi
# build & run tests, build benchmarks
- cabal new-build -w ${HC} ${TEST} ${BENCH} all
# cabal check
- (cd stm-* && cabal check)
# haddock
- rm -rf ./dist-newstyle
- if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
# REGENDATA ["stm.cabal"]
# EOF
......@@ -39,6 +39,7 @@ module Control.Concurrent.STM.TBQueue (
tryPeekTBQueue,
writeTBQueue,
unGetTBQueue,
lengthTBQueue,
isEmptyTBQueue,
isFullTBQueue,
) where
......@@ -52,14 +53,15 @@ import GHC.Conc
--
-- @since 2.4
data TBQueue a
= TBQueue _UPK_(TVar Int) -- CR: read capacity
_UPK_(TVar [a]) -- R: elements waiting to be read
_UPK_(TVar Int) -- CW: write capacity
_UPK_(TVar [a]) -- W: elements written (head is most recent)
= TBQueue _UPK_(TVar Int) -- CR: read capacity
_UPK_(TVar [a]) -- R: elements waiting to be read
_UPK_(TVar Int) -- CW: write capacity
_UPK_(TVar [a]) -- W: elements written (head is most recent)
_UPK_(Int) -- CAP: initial capacity
deriving Typeable
instance Eq (TBQueue a) where
TBQueue a _ _ _ == TBQueue b _ _ _ = a == b
TBQueue a _ _ _ _ == TBQueue b _ _ _ _ = a == b
-- Total channel capacity remaining is CR + CW. Reads only need to
-- access CR, writes usually need to access only CW but sometimes need
......@@ -83,7 +85,7 @@ newTBQueue size = do
write <- newTVar []
rsize <- newTVar 0
wsize <- newTVar size
return (TBQueue rsize read wsize write)
return (TBQueue rsize read wsize write size)
-- |@IO@ version of 'newTBQueue'. This is useful for creating top-level
-- 'TBQueue's using 'System.IO.Unsafe.unsafePerformIO', because using
......@@ -95,11 +97,11 @@ newTBQueueIO size = do
write <- newTVarIO []
rsize <- newTVarIO 0
wsize <- newTVarIO size
return (TBQueue rsize read wsize write)
return (TBQueue rsize read wsize write size)
-- |Write a value to a 'TBQueue'; blocks if the queue is full.
writeTBQueue :: TBQueue a -> a -> STM ()
writeTBQueue (TBQueue rsize _read wsize write) a = do
writeTBQueue (TBQueue rsize _read wsize write _size) a = do
w <- readTVar wsize
if (w /= 0)
then do writeTVar wsize $! w - 1
......@@ -114,7 +116,7 @@ writeTBQueue (TBQueue rsize _read wsize write) a = do
-- |Read the next value from the 'TBQueue'.
readTBQueue :: TBQueue a -> STM a
readTBQueue (TBQueue rsize read _wsize write) = do
readTBQueue (TBQueue rsize read _wsize write _size) = do
xs <- readTVar read
r <- readTVar rsize
writeTVar rsize $! r + 1
......@@ -143,16 +145,17 @@ tryReadTBQueue c = fmap Just (readTBQueue c) `orElse` return Nothing
--
-- @since 2.4.5
flushTBQueue :: TBQueue a -> STM [a]
flushTBQueue (TBQueue rsize read wsize write) = do
flushTBQueue (TBQueue rsize read wsize write size) = do
xs <- readTVar read
ys <- readTVar write
r <- readTVar rsize
w <- readTVar wsize
writeTVar read []
writeTVar write []
writeTVar rsize 0
writeTVar wsize (r + w)
return (xs ++ reverse ys)
if null xs && null ys
then return []
else do
writeTVar read []
writeTVar write []
writeTVar rsize 0
writeTVar wsize size
return (xs ++ reverse ys)
-- | Get the next value from the @TBQueue@ without removing it,
-- retrying if the channel is empty.
......@@ -176,7 +179,7 @@ tryPeekTBQueue c = do
-- |Put a data item back onto a channel, where it will be the next item read.
-- Blocks if the queue is full.
unGetTBQueue :: TBQueue a -> a -> STM ()
unGetTBQueue (TBQueue rsize read wsize _write) a = do
unGetTBQueue (TBQueue rsize read wsize _write _size) a = do
r <- readTVar rsize
if (r > 0)
then do writeTVar rsize $! r - 1
......@@ -188,9 +191,18 @@ unGetTBQueue (TBQueue rsize read wsize _write) a = do
xs <- readTVar read
writeTVar read (a:xs)
-- |Return the length of a 'TBQueue'.
--
-- @Since FIXME
lengthTBQueue :: TBQueue a -> STM Int
lengthTBQueue (TBQueue rsize _read wsize _write size) = do
r <- readTVar rsize
w <- readTVar wsize
return $! size - r - w
-- |Returns 'True' if the supplied 'TBQueue' is empty.
isEmptyTBQueue :: TBQueue a -> STM Bool
isEmptyTBQueue (TBQueue _rsize read _wsize write) = do
isEmptyTBQueue (TBQueue _rsize read _wsize write _size) = do
xs <- readTVar read
case xs of
(_:_) -> return False
......@@ -203,7 +215,7 @@ isEmptyTBQueue (TBQueue _rsize read _wsize write) = do
--
-- @since 2.4.3
isFullTBQueue :: TBQueue a -> STM Bool
isFullTBQueue (TBQueue rsize _read wsize _write) = do
isFullTBQueue (TBQueue rsize _read wsize _write _size) = do
w <- readTVar wsize
if (w > 0)
then return False
......
......@@ -25,14 +25,20 @@
--
-- This module only defines the 'STM' monad; you probably want to
-- import "Control.Concurrent.STM" (which exports "Control.Monad.STM").
--
-- Note that invariant checking (namely the @always@ and @alwaysSucceeds@
-- functions) has been removed. See ticket [#14324](https://ghc.haskell.org/trac/ghc/ticket/14324) and
-- the [removal proposal](https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0011-deprecate-stm-invariants.rst).
-- Existing users are encouraged to encapsulate their STM operations in safe
-- abstractions which can perform the invariant checking without help from the
-- runtime system.
-----------------------------------------------------------------------------
module Control.Monad.STM (
STM,
atomically,
#ifdef __GLASGOW_HASKELL__
always,
alwaysSucceeds,
retry,
orElse,
check,
......
# Changelog for [`stm` package](http://hackage.haskell.org/package/stm)
## 2.5.0.0 *TBA*
* Removed `alwaysSucceeds` and `always`, GHC's invariant checking primitives. (GHC #14324)
## 2.4.5.0 *Feb 2018*
* Fix space leak in `TBQueue` (gh-2, GHC#14494)
......
name: stm
version: 2.4.5.0
version: 2.5.0.0
-- don't forget to update changelog.md file!
license: BSD3
license-file: LICENSE
......@@ -10,7 +10,7 @@ synopsis: Software Transactional Memory
category: Concurrency
build-type: Simple
cabal-version: >=1.10
tested-with: GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.*
tested-with: GHC==8.6.*, GHC==8.4.*, GHC==8.2.*, GHC==8.0.*, GHC==7.10.*, GHC==7.8.*, GHC==7.6.*, GHC==7.4.*, GHC==7.2.*, GHC==7.0.*
description:
Software Transactional Memory, or STM, is an abstraction for
concurrent communication. The main benefits of STM are
......
module Main where
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Control.Applicative
import Prelude -- for AMP compat
data A = A String deriving (Eq, Show)
data E = E {
a :: TVar [Int],
b :: TVar A,
c :: TVar [Int]
}
consistency_1 :: E -> STM Bool
consistency_1 = \e -> do
_ <- readTVar $ c e
return True
installSanityChecks :: E -> IO ()
installSanityChecks e = do
x e
fail "You should see this failure"
x :: E -> IO ()
x e = do
-- This unexpected succeeds
atomically $ installCheck consistency_1
-- error "derp2"
where
installCheck check = always $ check e
main :: IO ()
main = do
state <- initialize
installSanityChecks state
initialize :: IO E
initialize = E <$> newTVarIO [] <*> newTVarIO (A "USD") <*> newTVarIO []
T14171: user error (You should see this failure)
import Control.Concurrent.STM
main = do
x <- atomically $ do
v <- newTVar 0
always $ return True -- remove this line and all is fine
return v
atomically (readTVar x) >>= print
import Control.Monad
import GHC.Conc
import System.IO
modifyTVar :: TVar Integer -> (Integer -> Integer) -> STM ()
modifyTVar t f = readTVar t >>= writeTVar t . f
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
t <- newTVarIO 0
let f = atomically $ do always (liftM2 (<=) (readTVar t) (return 5))
modifyTVar t succ
putStrLn "f1"
f
putStrLn "f2"
f
putStrLn "v"
v <- atomically $ readTVar t
print v
......@@ -19,14 +19,8 @@ test('stm055', exit_code(1), compile_and_run, ['-package stm'])
test('stm056', only_ways(['threaded1','threaded2']),
compile_and_run, ['-package stm'])
test('stm060', normal, compile_and_run, ['-package stm'])
test('stm061', normal, compile_and_run, ['-package stm'])
test('stm062', normal, compile_and_run, ['-package stm'])
test('stm063', when(fast(),skip), compile_and_run, ['-package stm'])
test('T2411', ignore_stdout, compile_and_run, ['-package stm'])
test('T3049', normal, compile_and_run, ['-package stm'])
test('T4057', normal, compile_and_run, ['-package stm'])
test('stm064', normal, compile_and_run, ['-package stm'])
test('stm065', normal, compile_and_run, ['-package stm'])
test('cloneTChan001', normal, compile_and_run, ['-package stm'])
test('T14171', exit_code(1), compile_and_run, ['-package stm'])
{-# LANGUAGE ScopedTypeVariables #-}
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 invariant that's false when attempted to be added\n"
Control.Exception.catch (atomically ( do writeTVar x 100
alwaysSucceeds ( do v <- readTVar x
if (v == 100) then throw (ErrorCall "URK") else return () )
writeTVar x 0 ) )
(\(e::SomeException) -> 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 ( throw (ErrorCall "Exn raised in invariant") ) ) )
(\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
putStr "\nAdding a trivially false invariant (no TVar access)\n"
Control.Exception.catch (atomically ( always ( throw (ErrorCall "Exn raised in invariant") ) ) )
(\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
putStr "\nAdding a trivially false invariant (no TVar access)\n"
Control.Exception.catch (atomically ( always ( return False ) ) )
(\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
putStr "\nAdding a trivially false invariant (with TVar access)\n"
Control.Exception.catch (atomically (
alwaysSucceeds ( do t <- readTVar x
throw (ErrorCall "Exn raised in invariant") ) ) )
(\(e::SomeException) -> 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 throw (ErrorCall "Exn raised in invariant") else return () ) )
putStr "\nViolating third invariant by setting TVar to 42\n"
Control.Exception.catch (atomically ( writeTVar x 42 ) )
(\(e::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
putStr "\nChecking final TVar contents\n"
t <- atomically ( readTVar x )
putStr ("Final value = " ++ (show t) ++ "\n")
putStr "\nDone\n"
Starting
Adding trivially true invariant (no TVar access)
Adding trivially true invariant (no TVar access)
Adding a trivially true invariant (TVar access)
Adding an invariant that's false when attempted to be added
Caught: URK
Writing to a TVar watched by a trivially true invariant
Adding a second trivially true invariant (same TVar access)
Writing to a TVar watched by both trivially true invariants
Adding a trivially false invariant (no TVar access)
Caught: Exn raised in invariant
Adding a trivially false invariant (no TVar access)
Caught: Exn raised in invariant
Adding a trivially false invariant (no TVar access)
Caught: Transactional invariant violation
Adding a trivially false invariant (with TVar access)
Caught: Exn raised in invariant
Adding a third invariant true if TVar != 42
Violating third invariant by setting TVar to 42
Caught: Exn raised in invariant
Checking final TVar contents
Final value = 18
Done
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 throw (ErrorCall "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"
Starting
Attaching invariant
Touching invariant (should keep on same TVars)
Touching invariant (should move it to other TVars)
Touching invariant (should keep on same TVars)
Checking TVar contents
Contents = (-2,1,-3)
Done
{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import GHC.Conc
import Control.Exception
import Foreign.StablePtr
import System.IO
import Control.Concurrent.MVar
-- Test invariants using updates & blocking in invariants
main = do
m <- newEmptyMVar
forkIO (do_test 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.
newStablePtr m
-- the MVar m must be kept alive, otherwise when the subthread is
-- BlockedIndefinitely, the MVar will be unreachable and the main
-- thread will also be considered to be BlockedIndefinitely.
takeMVar m
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 ( throw (ErrorCall "Exn raised in invariant") ) ) )
(\(e::SomeException) -> 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::SomeException) -> putStr ("Caught: " ++ (show e) ++ "\n"))
putMVar m ()
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: Exn raised in invariant
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 in an STM transaction