[Haskell-cafe] Faster timeout but is it correct?

[Bertram Felgenhauer]

Bas van Dijk wrote:
> On 19 February 2011 00:04, Bas van Dijk <v.dijk.bas at gmail.com> wrote:
> > So, since the new implementation is not really faster in a
> > representative benchmark and above all is buggy, I'm planning to ditch
> > it in favour of the event-manager based timeout.
> 
> The patch is ready for review:
> 
> http://hackage.haskell.org/trac/ghc/attachment/ticket/4963/faster_timeout.dpatch

(For reference, this is the proposed timeout code:)

| timeout :: Int -> IO a -> IO (Maybe a)
| timeout usecs f
|     | usecs <  0 = fmap Just f
|     | usecs == 0 = return Nothing
|     | otherwise  = do
|         myTid <- myThreadId
|         Just mgr <- readIORef eventManager
|         mask $ \restore -> do
|           key <- registerTimeout mgr usecs $ \key ->
|                    throwTo myTid $ Timeout key
|           let unregTimeout = M.unregisterTimeout mgr key
|           (restore (fmap Just f) >>= \mb -> unregTimeout >> return mb)
|             `catch` \e ->
|                 case fromException e of
|                   Just (Timeout key') | key' == key -> return Nothing
|                   _ -> unregTimeout >> throwIO e

What happens if the timeout triggers while the exception handler is
running? I.e., we have the following sequence of events:

1. registerTimeout
2. (fmap Just f) raises an exception, or the thread gets killed otherwise.
3. We enter the `catch` handler, with the corresponding exception.
4. The timeout expires, and the event Manager runs the IO action, i.e.
   throwTo myTid $ Timeout key
5. And now we have a pending Timeout exception which escapes the 'timeout'.
   The unregTimeout will come too late.

The current implementation avoids this problem, by handling the Timeout
exception in a context where the forked timeout thread has either done
its job or is no longer running.

I suspect the event manager implementation needs to do the same.
Furthermore, in place of the killThread we need to find a different
function that guarantees that the timeout action can no longer be
run. (Look at the event manager and consider what happens if 'step'
and 'unregisterTimeout' from the event manager run concurrently.)

I've stumbled on another problem with the timeout function. Is this
already known? Namely, the current implementation has trouble protecting
against asynchronous exceptions, which can cause Timeout exceptions to
escape from the corresponding 'timeout' call. The following program
demonstrates this issue. (tested on ghc 7.0.1 using the threaded runtime)

{-# LANGUAGE ScopedTypeVariables #-}
import System.Timeout
import Control.Exception
import Control.Concurrent
import Control.Monad
import Prelude hiding (catch)

delay = threadDelay 1000

test = do
    let act = timeout 1 (threadDelay 1) >> delay
        act' = (act `catch` \ThreadKilled -> return ()) >> delay
    tid <- forkIO $
         act' `catch` \(e :: SomeException) ->
             putStr $ "gotcha: " ++ show e ++ "!\n"
    forkIO $ (threadDelay 10) >> killThread tid
    return ()

main = do
    replicateM_ 1000 test
    threadDelay 100000

(Will print  gotcha: <<timeout>>!  for every escaping Timout exception.)
What I believe happens is that the 'killThread' in the timeout function
is interrupted by the 'killThread' from the test program; as a result,
the forked timeout thread continues to run after the timeout function
itself has finished.

Protecting against this seems hard, if not impossible. Even if we
introduce a lock
    lock <- newMVar ()
and let the timeout thread take the lock before throwing the exception
    ...
    forkIO (threadDelay n >> takeMVar lock >> throwTo pid ex)
    ...
when handling the exception we still face a problem: We can use
tryTakeMVar lock  to stop the timeout thread from killing us, and to
detect whether it's already too late for that. However, in that latter
case, we will have to wait for the Timeout exception to arrive, in
order to filter it; that means we will have to catch and remember all
other pending async exception first, filter the Timeout exception, and
then re-raise all the exceptions again.

I suspect that the event manager based implementation will face the
same problem.

Tricky, and I guess guaranteeing that the Timeout exception does not
escape in the preseence of other async exceptions is too much to ask.

Bertram