Commit 9d9a5546 authored by Simon Marlow's avatar Simon Marlow
Browse files

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
parent 6483b8ab
......@@ -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;
}
......@@ -52,6 +52,7 @@ interruptible(StgTSO *t)
{
switch (t->why_blocked) {
case BlockedOnMVar:
case BlockedOnSTM:
case BlockedOnMVarRead:
case BlockedOnMsgThrowTo:
case BlockedOnRead:
......
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
......@@ -86,6 +86,8 @@ test('AtomicPrimops', normal, compile_and_run, [''])
# test uses 2 threads and yield, scheduling can vary with threaded2
test('threadstatus-9333', [omit_ways(['threaded2'])], compile_and_run, [''])
test('T9379', normal, compile_and_run, [''])
# -----------------------------------------------------------------------------
# These tests we only do for a full run
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment