use GHC-7.8.3's values for thread block reason (fixes #9333)
authorJost Berthold <jb.diku@gmail.com>
Mon, 28 Jul 2014 12:50:13 +0000 (07:50 -0500)
committerAustin Seipp <austin@well-typed.com>
Mon, 28 Jul 2014 14:29:18 +0000 (09:29 -0500)
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

libraries/base/GHC/Conc/Sync.lhs
testsuite/.gitignore
testsuite/tests/concurrent/should_run/all.T
testsuite/tests/concurrent/should_run/threadstatus-9333.hs [new file with mode: 0644]
testsuite/tests/concurrent/should_run/threadstatus-9333.stdout [new file with mode: 0644]

index 713e0b5..bd60ebd 100644 (file)
@@ -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
index 6bb7948..71fa8d0 100644 (file)
@@ -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
index 0a66892..017dba1 100644 (file)
@@ -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 (file)
index 0000000..73cd6b8
--- /dev/null
@@ -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 (file)
index 0000000..7b4f788
--- /dev/null
@@ -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