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

5 files changed, 58 insertions, 8 deletions

diff --git a/libraries/base/GHC/Conc/Sync.lhs b/libraries/base/GHC/Conc/Sync.lhs
index 713e0b5c3b..bd60ebd8fc 100644
--- a/libraries/base/GHC/Conc/Sync.lhs
+++ b/libraries/base/GHC/Conc/Sync.lhs
@@ -448,7 +448,11 @@ runSparks = IO loop
 
 data BlockReason
   = BlockedOnMVar
-        -- ^blocked on on 'MVar'
+        -- ^blocked on 'MVar'
+  {- possibly (see 'threadstatus' below):
+  | BlockedOnMVarRead
+        -- ^blocked on reading an empty 'MVar'
+  -}
   | BlockedOnBlackHole
         -- ^blocked on a computation in progress by another thread
   | BlockedOnException
@@ -480,15 +484,15 @@ threadStatus (ThreadId t) = IO $ \s ->
    case threadStatus# t s of
     (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #)
    where
-        -- NB. keep these in sync with includes/Constants.h
+        -- NB. keep these in sync with includes/rts/Constants.h
      mk_stat 0  = ThreadRunning
      mk_stat 1  = ThreadBlocked BlockedOnMVar
-     mk_stat 2  = ThreadBlocked BlockedOnMVar -- XXX distinguish?
-     mk_stat 3  = ThreadBlocked BlockedOnBlackHole
-     mk_stat 7  = ThreadBlocked BlockedOnSTM
+     mk_stat 2  = ThreadBlocked BlockedOnBlackHole
+     mk_stat 6  = ThreadBlocked BlockedOnSTM
+     mk_stat 10 = ThreadBlocked BlockedOnForeignCall
      mk_stat 11 = ThreadBlocked BlockedOnForeignCall
-     mk_stat 12 = ThreadBlocked BlockedOnForeignCall
-     mk_stat 13 = ThreadBlocked BlockedOnException
+     mk_stat 12 = ThreadBlocked BlockedOnException
+     mk_stat 14 = ThreadBlocked BlockedOnMVar -- possibly: BlockedOnMVarRead
      -- NB. these are hardcoded in rts/PrimOps.cmm
      mk_stat 16 = ThreadFinished
      mk_stat 17 = ThreadDied
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 6bb794860f..71fa8d0662 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -359,6 +359,7 @@ mk/ghcconfig_*_inplace_bin_ghc-stage2.exe.mk
 /tests/concurrent/should_run/throwto003
 /tests/concurrent/should_run/tryReadMVar1
 /tests/concurrent/should_run/tryReadMVar2
+/tests/concurrent/should_run/threadstatus-9333
 /tests/cpranal/should_run/CPRRepeat
 /tests/deSugar/should_run/DsLambdaCase
 /tests/deSugar/should_run/DsMultiWayIf
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