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

27 Feb 2013

      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))

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

Bertram Felgenhauer