[Haskell-cafe] Faster timeout but is it correct?

[Bas van Dijk]

On 17 February 2011 13:09, Simon Marlow <marlowsd at gmail.com> wrote:
> uninterruptibleMask is quite unsavoury,

Agreed, that's why I called this implementation "fragile" because it
relies on the, not well known semantics, of interruptible operations.

> I don't think we should use it here.

I agree that it looks fishy. However the biggest part of the
computation passed to uninterruptibleMask is running in the restored
state. The only part that is running in uninterruptible masked state
that may potentially block (and thus potentially deadlock) is the
killThread in the exception handler. However since the timeout thread
is running inside unsafeUnmask it is ensured that the ThreadKilled
exception always gets thrown.

> I can see why you used it though: the killThread in the main thread will
> always win over the throwTo in the timeout thread, and that lets you avoid
> the outer exception handler.

Yes, and I think that the removal of the outer exception handler makes
the code run so much faster.

> Hmm, it makes me uncomfortable, but I can't find any actual bugs.  At the
> very least it needs some careful commentary to explain how it works.

Good point, I will add a comment with an explanation how it works.

My brother Roel had an interesting idea how to make the code run even
faster by replacing the Unique with the ThreadId of the timeout
thread. I implemented it and it now runs 19 times faster than the
original compared to the 13 times faster of my previous version.
Here's the new implementation:

newtype Timeout = Timeout ThreadId deriving (Eq, Typeable)

instance Show Timeout where
    show _ = "<<timeout>>"

instance Exception Timeout

timeout :: Int -> IO a -> IO (Maybe a)
timeout n f
    | n <  0    = fmap Just f
    | n == 0    = return Nothing
    | otherwise = do
        myTid <- myThreadId
        uninterruptibleMask $ \restore -> do
          tid <- unsafeUnmask $ forkIO $ do
                    tid <- myThreadId
                    threadDelay n
                    throwTo myTid $ Timeout tid
          (restore (fmap Just f) >>= \mb -> killThread tid >> return mb)
            `catch` \e ->
                case fromException e of
                  Just (Timeout tid') | tid' == tid -> return Nothing
                  _ -> killThread tid >> throwIO e

It relies on ThreadIds being unique, but I believe this is the case
because otherwise the throwTo operation will be nondeterministic,
right?

Obviously, this trick won't work in the event-manager-based version
because I don't fork a thread there. So I have to keep using Uniques
in that version. Speaking of Uniques: what is the best way to create
them? I see 3 options:

* Data.Unique. I tried using it but got a circular import error. Maybe
I can get around that with a boot file.

* System.Event.Unique. This is what I currently use. However I need to
create a UniqSource for the newUnique function which may be a bit
ugly:

uniqSource :: UniqueSource
uniqSource = unsafePerformIO newSource
{-# NOINLINE uniqSource #-}

* Also use System.Event.Unique but get the UniqSource from the
EventManager. This does require that the emUniqueSource function is
exported which it currently isnt't.

Johan what do you think?

import System.Event.Manager   (emUniqueSource)

timeout :: Int -> IO a -> IO (Maybe a)
timeout usecs f
    | usecs <  0 = fmap Just f
    | usecs == 0 = return Nothing
    | otherwise  = do
        myTid <- myThreadId
        Just mgr <- readIORef eventManager
        uniq <- newUnique $ emUniqueSource mgr
        let timeoutEx = Timeout uniq
        mask $ \restore -> do
          reg <- registerTimeout mgr usecs (throwTo myTid timeoutEx)
          let unregTimeout = M.unregisterTimeout mgr reg
          (restore (fmap Just f) >>= \mb -> unregTimeout >> return mb)
            `catch` \e ->
                case fromException e of
                  Just timeoutEx' | timeoutEx' == timeoutEx -> return Nothing
                  _ -> unregTimeout >> throwIO e

Regards,

Bas