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

[Simon Marlow]

On 16/02/2011 23:27, Bas van Dijk wrote:
> 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

If this version works, it's definitely preferable to your first 
proposal.  It relies on unregisterTimeout not being interruptible - 
otherwise you're back to uninterruptibleMask again.

Cheers,
	Simon