#5553: sendWakeup error in simple test program with MVars and killThread
-----------------------+----------------------------------------------------
Reporter: bit | Owner:
Type: bug | Status: new
Priority: normal | Component: Runtime System
Version: 7.2.1 | Keywords:
Testcase: | Blockedby:
Os: Linux | Blocking:
Architecture: x86 | Failure: Incorrect result at runtime
-----------------------+----------------------------------------------------
The following test program causes a '''sendWakeup''' error to be printed.
It happens rarely, not on every run of the program.
I'm running GHC 7.2.1 on a fairly old Linux 2.6.27 system.
Running it from the shell in a loop should cause it to eventually display
the error message. I found that by causing CPU activity (such as running
"yes" in another terminal) while the shell loop below is running triggers
the error.
{{{
$ ghc --make -Wall -O -threaded -rtsopts ghc_sendWakeup_bug.hs
$ while [ 1 ]; do ./ghc_sendWakeup_bug 40; done
ghc_sendWakeup_bug: sendWakeup: invalid argument (Bad file descriptor)
}}}
== ghc_sendWakeup_bug.hs ==
{{{
module Main
( startTest
, main
) where
import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
import Control.Concurrent.MVar
import Control.Exception (finally, catch, SomeException, mask_)
import Control.Monad (when, replicateM_, forever)
import Prelude hiding (catch)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)
startClient :: IO ()
startClient = threadDelay (1000 * 10)
startTest :: Int -> IO ()
startTest numClients = do
-- Code adapted from:
-- http://hackage.haskell.org/packages/archive/base/4.4.0.0/doc/html
/Control-Concurrent.html#g:12
children <- newMVar [] :: IO (MVar [MVar ()])
let forkChild :: IO () -> IO ThreadId
forkChild io = do
mvar <- newEmptyMVar
mask_ $ do
modifyMVar_ children (return . (mvar:))
forkIO (io `finally` putMVar mvar ())
waitForChildren :: IO ()
waitForChildren = do
cs <- takeMVar children
case cs of
[] -> return ()
m:ms -> do
putMVar children ms
takeMVar m
waitForChildren
serverThread <- forkIO $ forever (threadDelay 1000000)
replicateM_ numClients (forkChild startClient)
catch waitForChildren (printException "waitForChildren")
catch (killThread serverThread) (printException "killThread")
printException :: String -> SomeException -> IO ()
printException place ex =
hPutStrLn stderr $ "Error in " ++ place ++ ": " ++ show ex
main :: IO ()
main = do
args <- getArgs
when (length args /= 1) $ do
prog <- getProgName
hPutStrLn stderr $ "Usage: " ++ prog ++ " <numClients>"
exitFailure
let numClients = read (args !! 0)
startTest numClients
}}}
--
Ticket URL: <http://hackage.haskell.org/trac/ghc/ticket/5553>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler
_______________________________________________
Glasgow-haskell-bugs mailing list
Glasgow-haskell-bugs@haskell.org
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs
