[Haskell-cafe] Debugging concurrent program - no threads apparently running, but RTS still doing something.

[Alistair Bayley]

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"