Commit 4ee8c273 authored by Jost Berthold's avatar Jost Berthold Committed by Austin Seipp
Browse files

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
parent b9be82d4
......@@ -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
......
......@@ -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
......
......@@ -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)
......
-- 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)
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
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment