diff options
author | Simon Marlow <marlowsd@gmail.com> | 2014-07-31 10:00:16 +0100 |
---|---|---|
committer | Austin Seipp <austin@well-typed.com> | 2014-08-04 08:20:29 -0500 |
commit | c1042cc19b688e56c5f28e600bc963365c029fbb (patch) | |
tree | 0c812e8af56f0ad840021aaab102334f73064ac8 | |
parent | 0a275059e2e909c99857de9fe640070d4ed797c0 (diff) | |
download | haskell-c1042cc19b688e56c5f28e600bc963365c029fbb.tar.gz |
interruptible() was not returning true for BlockedOnSTM (#9379)
Summary:
There's an knock-on fix in HeapStackCheck.c which is potentially
scary, but I'm pretty confident is OK. See comment for details.
Test Plan:
I've run all the STM
tests I can find, including libraries/stm/tests/stm049 with +RTS -N8
and some of the constants bumped to make it more of a stress test.
Reviewers: hvr, rwbarton, austin
Subscribers: simonmar, relrod, ezyang, carter
Differential Revision: https://phabricator.haskell.org/D104
GHC Trac Issues: #9379
(cherry picked from commit 9d9a55469719908bbd5cd3277e0ac79c0588dc55)
-rw-r--r-- | rts/HeapStackCheck.cmm | 25 | ||||
-rw-r--r-- | rts/RaiseAsync.h | 1 | ||||
-rw-r--r-- | testsuite/tests/concurrent/should_run/T9379.hs | 17 | ||||
-rw-r--r-- | testsuite/tests/concurrent/should_run/all.T | 2 |
4 files changed, 38 insertions, 7 deletions
diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index 12bcfb26df..f090bff5ad 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -681,13 +681,24 @@ stg_block_async_void STM-specific waiting -------------------------------------------------------------------------- */ -stg_block_stmwait_finally -{ - ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr"); - jump StgReturn [R1]; -} - stg_block_stmwait { - BLOCK_BUT_FIRST(stg_block_stmwait_finally); + // When blocking on an MVar we have to be careful to only release + // the lock on the MVar at the very last moment (using + // BLOCK_BUT_FIRST()), since when we release the lock another + // Capability can wake up the thread, which modifies its stack and + // other state. This is not a problem for STM, because STM + // wakeups are non-destructive; the waker simply calls + // tryWakeupThread() which sends a message to the owner + // Capability. So the moment we release this lock we might start + // getting wakeup messages, but that's perfectly harmless. + // + // Furthermore, we *must* release these locks, just in case an + // exception is raised in this thread by + // maybePerformBlockedException() while exiting to the scheduler, + // which will abort the transaction, which needs to obtain a lock + // on all the TVars to remove the thread from the queues. + // + ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr"); + BLOCK_GENERIC; } diff --git a/rts/RaiseAsync.h b/rts/RaiseAsync.h index 1f61b8c72d..3da9e7bc09 100644 --- a/rts/RaiseAsync.h +++ b/rts/RaiseAsync.h @@ -52,6 +52,7 @@ interruptible(StgTSO *t) { switch (t->why_blocked) { case BlockedOnMVar: + case BlockedOnSTM: case BlockedOnMVarRead: case BlockedOnMsgThrowTo: case BlockedOnRead: diff --git a/testsuite/tests/concurrent/should_run/T9379.hs b/testsuite/tests/concurrent/should_run/T9379.hs new file mode 100644 index 0000000000..49e6d1eaed --- /dev/null +++ b/testsuite/tests/concurrent/should_run/T9379.hs @@ -0,0 +1,17 @@ +import Control.Exception +import Control.Concurrent +import Control.Concurrent.STM +import Foreign.StablePtr + +main :: IO () +main = do + tv <- atomically $ newTVar True + _ <- newStablePtr tv + t <- mask_ $ forkIO (blockSTM tv) + killThread t + +blockSTM :: TVar Bool -> IO () +blockSTM tv = do + atomically $ do + v <- readTVar tv + check $ not v diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T index 0b502c3bc7..3fcc2b110f 100644 --- a/testsuite/tests/concurrent/should_run/all.T +++ b/testsuite/tests/concurrent/should_run/all.T @@ -82,6 +82,8 @@ test('tryReadMVar2', normal, compile_and_run, ['']) test('T7970', normal, compile_and_run, ['']) +test('T9379', normal, compile_and_run, ['']) + # ----------------------------------------------------------------------------- # These tests we only do for a full run |