Race-condition in alternative 'System.Timeout.timeout' implementation

[Bertram Felgenhauer]

Bertram Felgenhauer wrote:
> Dear Herbert,
> > I've been experimenting with an alternative implementation of
> > 'System.Timeout.timeout'[1] which avoids the overhead of spawning a new
> > thread for each invocation.
> 
> (I have more to say on this, but will postpone it until later. A lot
> of it has already been said in the earlier thread anyway.)

The main trouble with the IO manager based approach is that even
after unregisterTimeout finished, the timeout may still be invoked.
It's possible to protect against the exception arriving after 'timeout'
has returned using an MVar, using a timeout handler like

    E.registerTimeout em to $ do
        t <- tryTakeMVar m
        when (isJust t) (throwTo tid ex)

Similarly the main thread can use tryTakeMVar to check whether the
timeout exception is about to arrive or not.

If no such exception is pending, everything is fine.

However, if the exception is pending, we have another problem: It is
thrown by a different thread, so we don't know when it will arrive.
In the meantime, *other* asynchronous exceptions (for example from
different timeout calls, but also unrelated throwTo/killThread calls)
may arrive that should *all* be propagated to the caller.

It's fairly straight-forward to collect the arriving exceptions in a
list, waiting for the expected Timeout one to arrive. But we cannot
raise more than one exception synchronously at a time. This is
fatal: While it ispossible to spawn a thread to re-throw the
exceptions, this breaks the guarantees of synchronous delivery
that 'throwTo' has (in ghc), for code outside of the timeout call:

    A: starts executing  timeout foo            
                    B: killThread A
    A: receives exception X, ThreadKilled and Timeout simultaneously.
    A: spawns thread K for throwing ThreadKilled, re-raises X
    A: catches and handles 'X'
    A: killThread B
                    B: receives ThreadKilled, dies
                                    K: re-throws ThreadKilled to A
    A: receives ThreadKilled, dies

Without the delayed delivery of the 'ThreadKilled' exception of A,
only one of the threads A and B would ever die.

A possible solution might be a primitive operation that raises multiple
exception at once (it would have to raise one of them and enqueue the
other ones in the TSO's message queue.) Probably not worth the effort.

A related, but less nasty problem also affects System.Timeout.timeout
currently: http://hackage.haskell.org/trac/ghc/ticket/7719

Best regards,

Bertram

-- Best effort implementation using the event manager, taking the
-- comments above into account, and lacking a proper way of raising
-- multiple exceptions synchronously.
--
-- The code is quite complicated, so there may be other flaws still.

timeout2 :: Int -> IO a -> IO (Maybe a)
timeout2 to f
    | to <  0    = fmap Just f
    | to == 0    = return Nothing
    | otherwise  = do
        tid <- myThreadId
        ex  <- fmap Timeout2 newUnique
        Just em <- E.getSystemEventManager -- FIXME
        m <- newMVar ()
        let -- timeout handler: deliver timeout exception if m is still full
            timeout = do
                t <- tryTakeMVar m
                when (isJust t) $ do
                    throwTo tid ex
                    -- keep m alive, to prevent 'takeMVar m' from raising
                    -- 'blocked indefinitely' exceptions in the main thread
                    m `seq` return ()
            -- loop, collecting exceptions until the right one arrives.
            loop es e
                | fromException e == Just ex =
                    case reverse es of
                        [] -> return ()
                        [e] -> throwIO e
                        e:es ->
                            -- we have collected more than one exception,
                            -- so employ outside help for delivery
                            forkIO (mapM_ (throwTo tid) es) >> throwIO e
                | otherwise = do
                    -- 'takeMVar m' blocks until an exception arrives
                    takeMVar m `catch` loop (e:es)
                    error "not reached"
        mask $ \restore -> do
             hdl <- E.registerTimeout em to timeout
             r <- restore (fmap Just f) `catch` \e -> do
                E.unregisterTimeout em hdl
                t <- tryTakeMVar m
                case t of
                    Just _ ->
                        -- timeout prevented, simply re-raise e
                        throwIO (e :: SomeException)
                    Nothing ->
                        -- have to wait for the timeout exception
                        loop [] e >> return Nothing
             when (isJust r) $ do
                 -- our computation was successful, but we still have
                 -- to clean up the timeout handler
                 E.unregisterTimeout em hdl
                 t <- tryTakeMVar m
                 case t of
                     Just _ ->
                         -- timeout prevented
                         return ()
                     Nothing ->
                         -- wait for timeout exception
                         takeMVar m `catch` loop []
                         error "not reached"
             return r