[commit: ghc] ghc-7.8: interruptible() was not returning true for BlockedOnSTM (#9379) (c1042cc)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.8
Link       : http://ghc.haskell.org/trac/ghc/changeset/c1042cc19b688e56c5f28e600bc963365c029fbb/ghc

>---------------------------------------------------------------

commit c1042cc19b688e56c5f28e600bc963365c029fbb
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Thu Jul 31 10:00:16 2014 +0100

    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)


>---------------------------------------------------------------

c1042cc19b688e56c5f28e600bc963365c029fbb
 rts/HeapStackCheck.cmm                         | 25 ++++++++++++++++++-------
 rts/RaiseAsync.h                               |  1 +
 testsuite/tests/concurrent/should_run/T9379.hs | 17 +++++++++++++++++
 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 12bcfb2..f090bff 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 1f61b8c..3da9e7b 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 0000000..49e6d1e
--- /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 0b502c3..3fcc2b1 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