Re: Faster timeout but is it correct?

17 Feb 2011


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

Re: Faster timeout but is it correct?

Simon Marlow