Below is a test case for a threading problem I can't figure out. It
models a socket server (here I've replaced the socket with an MVar, to
keep it simple). The idea is to have a listener which accepts incoming
requests on the socket. When one arrives, it forks a handler thread to
deal with the request, and returns to listening on the socket.
The handler thread is run in parallel with a timeout thread. In the
test case below, the handler takes too long, so the timeout thread
completes and kills the handler.
The problem is that when the main thread ends, the RTS doesn't stop
for another 6 or so seconds. The only thread that runs this long is
the handler (waitFor (secs 8.0)) but it has already been killed. So
I'm scratching my head a bit.
Also, any pointers to better techniques for designing and debugging
concurrent code are appreciated (is there a better way than putStrLn?)
Platform: ghc-6.6, Windows XP.
Thanks,
Alistair
---------------------------------------------------------------------
module Main where
import Prelude hiding (catch)
import Control.Concurrent
import Control.Exception
import System.IO
secs :: Float -> Int
secs n = round (n * 1000000)
-- e.g. waitFor (secs 25)
waitFor n =
debug ("waitFor start " ++ show ((fromIntegral n) / 1000000.0))
>> threadDelay n
>> debug ("waitFor end " ++ show ((fromIntegral n) / 1000000.0))
debug msg = myThreadId >>= ( \t -> putStrLn $ (show t) ++ ": " ++ msg )
-- Thread 1 - start server then send message
main = do
hSetBuffering stdout LineBuffering
blockingInput <- newEmptyMVar -- like a socket; accept on a socket blocks
listnr <- forkIO (listener blockingInput)
putMVar blockingInput "hello"
waitFor (secs 2.0)
debug "main: done"
-- Thread 2 - listener.
-- Blocks on input; when input arrives, starts handler thread.
listener blockingInput = do
msg <- takeMVar blockingInput
serveRequest msg
-- in a real server we'd loop:
--listener blockingInput
debug "listener: done"
-- Start threads 3 and 4 - handler and timeout.
serveRequest msg = do
let acquire = return ()
let release _ = debug "handler release action"
forkIO (runTimeout 0.1 acquire release (handler msg))
return ()
handler msg _ = do
debug ("handler start: " ++ msg)
catch
(waitFor (secs 8.0) >> debug "handler end")
(\e -> debug ("Exception: " ++ (show e)) >> throwIO e)
runTimeout timeout acquire release action = do
handlerTid <- myThreadId
-- Use this to ensure the timeout thread doesn't start before the handler
-- i.e. give the handler a chance to start.
startTimeout <- newEmptyMVar
timeoutTid <- forkIO (runTimeoutThread startTimeout timeout handlerTid)
bracket acquire
( \a -> release a >> killThread timeoutTid )
( \a -> do
debug "runTimeout: start handler action"
putMVar startTimeout True
action a
debug "runTimeout: end handler action"
)
runTimeoutThread startTimeout timeout handlerTid = do
takeMVar startTimeout
debug "runTimeoutThread: start"
waitFor (secs timeout)
killThread handlerTid
debug "runTimeoutThread: end"
_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe
