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

[Akio Takano]

Hi Bertram,

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.

- Takano Akio

-- | 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
        handleJust (\e -> if e == ex then Just () else Nothing)
                   (\_ -> return Nothing)
                   (bracket (E.registerTimeout em to timeoutHandler)
                            cleanupTimeout
                            (\_ -> fmap Just f))
-------------- next part --------------
A non-text attachment was scrubbed...
Name: timeout4.hs
Type: application/octet-stream
Size: 4096 bytes
Desc: not available
URL: <http://www.haskell.org/pipermail/glasgow-haskell-users/attachments/20130227/ab2c6b53/attachment.obj>