[commit: ghc] ghc-7.8: Fix missing unlockClosure() call in tryReadMVar (#9148) (cef8556)

[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/cef85568cbf44b3e178a523a3febbdccb18a4a1a/ghc

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

commit cef85568cbf44b3e178a523a3febbdccb18a4a1a
Author: Simon Marlow <marlowsd at gmail.com>
Date:   Fri May 30 08:47:26 2014 +0100

    Fix missing unlockClosure() call in tryReadMVar (#9148)
    
    (cherry picked from commit 96a95f0513de785a185fd8a46c7ed2643f698295)


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

cef85568cbf44b3e178a523a3febbdccb18a4a1a
 rts/PrimOps.cmm                                       |  1 +
 testsuite/tests/concurrent/should_run/all.T           |  1 +
 testsuite/tests/concurrent/should_run/tryReadMVar2.hs | 15 +++++++++++++++
 3 files changed, 17 insertions(+)

diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index db65a4a..72d6e69 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -1641,6 +1641,7 @@ stg_tryReadMVarzh ( P_ mvar, /* :: MVar a */ )
     LOCK_CLOSURE(mvar, info);
 
     if (StgMVar_value(mvar) == stg_END_TSO_QUEUE_closure) {
+        unlockClosure(mvar, info);
         return (0, stg_NO_FINALIZER_closure);
     }
 
diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T
index d4e76c6..0b502c3 100644
--- a/testsuite/tests/concurrent/should_run/all.T
+++ b/testsuite/tests/concurrent/should_run/all.T
@@ -78,6 +78,7 @@ test('readMVar1', normal, compile_and_run, [''])
 test('readMVar2', normal, compile_and_run, [''])
 test('readMVar3', normal, compile_and_run, [''])
 test('tryReadMVar1', normal, compile_and_run, [''])
+test('tryReadMVar2', normal, compile_and_run, [''])
 
 test('T7970', normal, compile_and_run, [''])
 
diff --git a/testsuite/tests/concurrent/should_run/tryReadMVar2.hs b/testsuite/tests/concurrent/should_run/tryReadMVar2.hs
new file mode 100644
index 0000000..13b8a45
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/tryReadMVar2.hs
@@ -0,0 +1,15 @@
+module Main where
+
+import Control.Concurrent
+import Control.Monad
+
+main = do
+    m <- newEmptyMVar
+    done <- newEmptyMVar
+    let q = 200000
+    forkIO (do mapM (\n -> putMVar m n) [1..q]; putMVar done ())
+    forkIO (do replicateM_ q $ readMVar m; putMVar done ())
+    forkIO (do replicateM_ q $ tryReadMVar m; putMVar done ())
+    forkIO (do replicateM_ q $ takeMVar m; putMVar done ())
+    replicateM_ 4 $ takeMVar done
+