[commit: ghc] master: use GHC-7.8.3's values for thread block reason (fixes #9333) (4ee8c27)
git at git.haskell.org
git at git.haskell.org
Mon Jul 28 14:38:11 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/4ee8c27302e6bb3892e7c47a7111b0683d032c07/ghc
>---------------------------------------------------------------
commit 4ee8c27302e6bb3892e7c47a7111b0683d032c07
Author: Jost Berthold <jb.diku at gmail.com>
Date: Mon Jul 28 07:50:13 2014 -0500
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
>---------------------------------------------------------------
4ee8c27302e6bb3892e7c47a7111b0683d032c07
libraries/base/GHC/Conc/Sync.lhs | 18 +++++++-----
testsuite/.gitignore | 1 +
testsuite/tests/concurrent/should_run/all.T | 5 +++-
.../concurrent/should_run/threadstatus-9333.hs | 33 ++++++++++++++++++++++
.../concurrent/should_run/threadstatus-9333.stdout | 9 ++++++
5 files changed, 58 insertions(+), 8 deletions(-)
diff --git a/libraries/base/GHC/Conc/Sync.lhs b/libraries/base/GHC/Conc/Sync.lhs
index 713e0b5..bd60ebd 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 6bb7948..71fa8d0 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 0a66892..017dba1 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 0000000..73cd6b8
--- /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 0000000..7b4f788
--- /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
More information about the ghc-commits
mailing list