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

[Bas van Dijk]

On 16 February 2011 20:26, Bas van Dijk <v.dijk.bas at gmail.com> wrote:
> The patch and benchmarks attached to the ticket are updated. Hopefully
> this is the last change I had to make so I can stop spamming.

And the spamming continues...

I started working on a hopefully even more efficient timeout that uses
the new GHC event manager.

The idea is that instead of forking a thread which delays for the
timeout period after which it throws a Timeout exception, I register a
timeout with the event manager. When the timeout fires the event
manager will throw the Timeout exception.

I haven't gotten around testing and benchmarking this yet. I hope to
do that tomorrow evening.

The code is currently living in the System.Event.Thread module:

module System.Event.Thread where
...
import Data.Typeable
import Text.Show (Show, show)
import GHC.Conc.Sync (myThreadId, throwTo)
import GHC.IO (throwIO,unsafePerformIO )
import GHC.Exception (Exception, fromException)
import Control.Exception.Base (catch)

-- I'm currently using the Unique from System.Event
-- because I got a circular import error when using Data.Unique:
import System.Event.Unique (UniqueSource, newSource, Unique, newUnique)

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

newtype Timeout = Timeout Unique deriving Eq
INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout")

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

instance Exception Timeout

timeout :: Int -> IO a -> IO (Maybe a)
timeout usecs f
    | usecs <  0 = fmap Just f
    | usecs == 0 = return Nothing
    | otherwise  = do
        myTid <- myThreadId
        uniq <- newUnique uniqSource
        let timeoutEx = Timeout uniq
        Just mgr <- readIORef eventManager
        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