[GHC] #5553: sendWakeup error in simple test program with MVars and killThread

[GHC]

#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