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

[Bertram Felgenhauer]

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