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"