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)

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