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

Akio Takano wrote:

Thank you for the explanation. My previous attempt obviously suffers from the race condition you mention.

However it still seems to be possible to implement a compromise, using both the IO manager and a new thread, i.e. forking only when the computation is being timed out. The following implementation is as fast as Herbert's timeout2, at least in the benchmark where the computation rarely times out.

Brilliant! I believe this version will work; the Timeout exception cannot escape the timeout call anymore by the same reasoning as in System.Timeout.timeout (with the bugfix for 7719 which consists solely of adding uninterruptibleMask_ around killThread); the main difference is that the creation of the killing thread is delayed until it is actually needed. (I also love the dual purpose 'killingThreadVar' MVar.) Maybe it's time to reopen #4963? http://hackage.haskell.org/trac/ghc/ticket/4963 Thanks, Bertram

-- | Alternative implementation of 'System.Timeout.timeout' using -- 'GHC.Event.registerTimeout' AND a watchdog-thread. timeout4 :: Int -> IO a -> IO (Maybe a) timeout4 to f | to < 0 = fmap Just f | to == 0 = return Nothing | otherwise = do mainTid <- myThreadId ex <- fmap Timeout2 newUnique Just em <- E.getSystemEventManager -- FIXME killingThreadVar <- newEmptyMVar

let timeoutHandler = (>>return ()) $ forkIO $ do killingTid <- myThreadId success <- tryPutMVar killingThreadVar killingTid when success $ throwTo mainTid ex cleanupTimeout key = uninterruptibleMask_ $ do -- Once the thread is in this uninterruptible block, -- it never receives the exception 'ex' because: -- (1) when we are in the uninterruptible block, -- all attept of throwTo to kill this thread -- will block. -- (2) the killing thread will either fail to fill -- 'killingThreadVar' or get killed before -- this thread exits the block. success <- tryPutMVar killingThreadVar undefined when (not success) $ do killingTid <- takeMVar killingThreadVar -- never blocks killThread killingTid E.unregisterTimeout em key

The unregisterTimeout has no effect if success is not set, so why not use if-then-else?

handleJust (\e -> if e == ex then Just () else Nothing) (\_ -> return Nothing) (bracket (E.registerTimeout em to timeoutHandler) cleanupTimeout (\_ -> fmap Just f))