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

interruptible() was not returning true for BlockedOnSTM (#9379)

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:

GHC Trac Issues: #9379
parent 6483b8ab
......@@ -681,13 +681,24 @@ stg_block_async_void
STM-specific waiting
-------------------------------------------------------------------------- */
ccall stmWaitUnlock(MyCapability() "ptr", R3 "ptr");
jump StgReturn [R1];
// 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");
......@@ -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