use GHC-7.8.3's values for thread block reason (fixes #9333)

Summary:
For now, BlockedOnMVar and BlockedOnMVarRead are not distinguished.
Making the distinction would mean to change an exported datatype
(API change). Code for this change is included but commented out.

The patch adds a test for the threadstatus, which retrieves status
BlockedOnMVar for two threads blocked on writing and reading an MVar.

Test Plan: ran validate, including the new test

Reviewers: simonmar, austin, ezyang

Reviewed By: austin, ezyang

Subscribers: phaskell, simonmar, relrod, carter

Differential Revision: https://phabricator.haskell.org/D83

3 files changed, 46 insertions, 1 deletions

diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T
index 0a66892d82..017dba172e 100644
--- a/testsuite/tests/concurrent/should_run/all.T
+++ b/testsuite/tests/concurrent/should_run/all.T
@@ -83,12 +83,15 @@ test('tryReadMVar2', normal, compile_and_run, [''])
 test('T7970', normal, compile_and_run, [''])
 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, [''])
+
 # -----------------------------------------------------------------------------
 # These tests we only do for a full run
 
 def f( name, opts ):
   if config.fast:
-  	opts.skip = 1
+     opts.skip = 1
 
 setTestOpts(f)
 
diff --git a/testsuite/tests/concurrent/should_run/threadstatus-9333.hs b/testsuite/tests/concurrent/should_run/threadstatus-9333.hs
new file mode 100644
index 0000000000..73cd6b895d
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/threadstatus-9333.hs
@@ -0,0 +1,33 @@
+-- test for threadstatus, checking (mvar read, mvar block reasons)
+-- created together with fixing GHC ticket #9333
+
+module Main where
+
+import Control.Concurrent
+import GHC.Conc
+import GHC.Conc.Sync
+
+main = do
+  -- create MVars to block on
+  v1 <- newMVar "full"
+  v2 <- newEmptyMVar
+  -- create a thread which fills both MVars
+  parent <- myThreadId
+  putStrLn "p: forking child thread"
+  child <- forkIO $
+           do putStrLn "c: filling full MVar" -- should block
+              putMVar v1 "filled full var"
+              yield
+              putStrLn "c: filling empty MVar (expect parent to be blocked)"
+              stat2 <- threadStatus parent
+              putStrLn ("c: parent is " ++ show stat2)
+              putMVar v2 "filled empty var"
+  yield
+  putStrLn "p: emptying full MVar (expect child to be blocked on it)"
+  stat1 <- threadStatus child
+  putStrLn ("p: child is " ++ show stat1)
+  s1 <- takeMVar v1 -- should unblock child
+  putStrLn ("p: from MVar: " ++ s1)
+  putStrLn "p: reading empty MVar"
+  s2 <- readMVar v2 -- should block
+  putStrLn ("p: from MVar: " ++ s2)
diff --git a/testsuite/tests/concurrent/should_run/threadstatus-9333.stdout b/testsuite/tests/concurrent/should_run/threadstatus-9333.stdout
new file mode 100644
index 0000000000..7b4f788615
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/threadstatus-9333.stdout
@@ -0,0 +1,9 @@
+p: forking child thread
+c: filling full MVar
+p: emptying full MVar (expect child to be blocked on it)
+p: child is ThreadBlocked BlockedOnMVar
+p: from MVar: full
+p: reading empty MVar
+c: filling empty MVar (expect parent to be blocked)
+c: parent is ThreadBlocked BlockedOnMVar
+p: from MVar: filled empty var