I realized that the previous timeout had problems when called in a masked thread. What happens is that the call to killThread will block because it can't throw the KillThread exception to the timeout thread because that thread is masked. I have to use unsafeUnmask to always unmask the timeout thread. Note that, for some reason, using forkIOUnmasked ... is much slower than using unsafeUnmask $ forkIO .... Any idea why? import GHC.IO (unsafeUnmask) imeout :: Int -> IO a -> IO (Maybe a) timeout n f | n < 0 = fmap Just f | n == 0 = return Nothing | otherwise = do myTid <- myThreadId timeoutEx <- fmap Timeout newUnique uninterruptibleMask $ \restore -> do tid <- unsafeUnmask $ forkIO $ threadDelay n >> throwTo myTid timeoutEx (restore (fmap Just f) >>= \mb -> killThread tid >> return mb) `catch` \e -> case fromException e of Just timeoutEx' | timeoutEx' == timeoutEx -> return Nothing _ -> killThread tid >> throwIO e For some reason this is slightly slower than the previous version which used restore instead of unsafeUnmask. However it's still 13 times faster than the original. 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. Regards, Bas

On Wed, Feb 16, 2011 at 9:27 PM, Bas van Dijk wrote:

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.

Doesn't this version need unsafeUnmask? Cheers! -- Felipe.

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

On 17 February 2011 13:09, Simon Marlow 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

On Thu, Feb 17, 2011 at 11:53 AM, Bas van Dijk wrote:

Then we can use the TimeoutKey as our Unique (Note that a TimeoutKey is actually a newtype for a Unique):

That should be fine. It's not a public API, so changing it like that shouldn't be an issue.

On 18 February 2011 00:56, Johan Tibell wrote:

On Thu, Feb 17, 2011 at 2:43 PM, Bryan O'Sullivan wrote:

...

On Thu, Feb 17, 2011 at 11:53 AM, Bas van Dijk wrote:

...

Then we can use the TimeoutKey as our Unique (Note that a TimeoutKey is actually a newtype for a Unique):

That should be fine. It's not a public API, so changing it like that shouldn't be an issue.

I think this sounds like a good option.

Currently I created a new function registerTimeoutWithKey and wrote registerTimeout in terms of it. I also exported registerTimeoutWithKey from System.Event.Manager and System.Event. This isn't necessary so I can easily change it back. However maybe it's useful on its own. It does require a library proposal so I have to think it over. The changes are only minimal: ------------------------------------------------------------------------ -- Registering interest in timeout events -- | Register a timeout in the given number of microseconds. The -- returned 'TimeoutKey' can be used to later unregister or update the -- timeout. The timeout is automatically unregistered after the given -- time has passed. Note that: -- -- @registerTimeout mgr us cb = 'registerTimeoutWithKey' mgr us $ \_ -> cb@ registerTimeout :: EventManager -> Int -> TimeoutCallback -> IO TimeoutKey registerTimeout mgr us cb = registerTimeoutWithKey mgr us $ \_ -> cb -- | Like 'registerTimeout' but the 'TimeoutCallback' is given the 'TimeoutKey'. registerTimeoutWithKey :: EventManager -> Int -> (TimeoutKey -> TimeoutCallback) -> IO TimeoutKey registerTimeoutWithKey mgr us f = do !key <- newUnique (emUniqueSource mgr) let tk = TK key cb = f tk if us <= 0 then cb else do now <- getCurrentTime let expTime = fromIntegral us / 1000000.0 + now -- We intentionally do not evaluate the modified map to WHNF here. -- Instead, we leave a thunk inside the IORef and defer its -- evaluation until mkTimeout in the event loop. This is a -- workaround for a nasty IORef contention problem that causes the -- thread-delay benchmark to take 20 seconds instead of 0.2. atomicModifyIORef (emTimeouts mgr) $ \f -> let f' = (Q.insert key expTime cb) . f in (f', ()) wakeManager mgr return tk The timeout function is now defined as: newtype Timeout = Timeout TimeoutKey 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 Just mgr <- readIORef eventManager mask $ \restore -> do key <- registerTimeoutWithKey mgr usecs $ \key -> throwTo myTid $ Timeout key let unregTimeout = M.unregisterTimeout mgr key (restore (fmap Just f) >>= \mb -> unregTimeout >> return mb) `catch` \e -> case fromException e of Just (Timeout key') | key' == key -> return Nothing _ -> unregTimeout >> throwIO e Benchmarks are coming... Bas

On 18 February 2011 01:16, Johan Tibell wrote:

On Thu, Feb 17, 2011 at 4:09 PM, Bas van Dijk wrote:

...

Currently I created a new function registerTimeoutWithKey and wrote registerTimeout in terms of it. I also exported registerTimeoutWithKey from System.Event.Manager and System.Event. This isn't necessary so I can easily change it back. However maybe it's useful on its own.

I say only export a more general function (under the old name).

Agreed.

...

It does require a library proposal so I have to think it over.

It doesn't. System.Event isn't a public API. Doesn't mean that you don't have to think it over thought. ;)

Why is it not public? It is listed in the base API docs: http://hackage.haskell.org/packages/archive/base/latest/doc/html/System-Even... Bas

On 18 February 2011 01:28, Johan Tibell wrote:

On Thu, Feb 17, 2011 at 4:19 PM, Bas van Dijk wrote:

...

Why is it not public? It is listed in the base API docs:

http://hackage.haskell.org/packages/archive/base/latest/doc/html/System-Even...

Because it's not explicitly designed to be.

Ok, that will make changing it a bit easier. Thanks, Bas

On Thu, Feb 17, 2011 at 5:01 PM, Bas van Dijk wrote:

willTimeout/old         24.34945 us    1.0 x willTimeout/new         26.91964 us    0.9 x (large std dev: 5 us) willTimeout/event       12.94273 us    1.9 x  :-)

wontTimeout/old         16.25766 us    1.0 x wontTimeout/new         637.8685 ns   25.5 x  :-) wontTimeout/event       1.565311 us   10.4 x  :-)

I find this very surprising. Both new and event eventually ends up using the event manager in the end. One via threadDelay (which calls registerTimeout) and one directly via registerTimeout. The difference should be that "new" also spawns a thread. Johan

I have some more results: The willTimeout and wontTimeout benchmarks are a bit unfair: willTimeout = shouldTimeout $ timeout 1 (threadDelay oneSec) wontTimeout = shouldNotTimeout $ timeout oneSec (return ()) Nobody ever writes code like this. So I wrote some benchmarks that hopefully better reflect some real-world code: busyWillTimeout = do r <- newIORef 10000000 shouldTimeout $ timeout 100 $ busy r n <- readIORef r when (n==0) $ error "n == 0 !!!" busyWontTimeout = do r <- newIORef 1000 shouldNotTimeout $ timeout oneSec $ busy r n <- readIORef r when (n/=0) $ error "n /= 0 !!!" busy r = do n <- readIORef r if n == 0 then return () else writeIORef r (n - 1) >> busy r shouldTimeout :: IO (Maybe a) -> IO () shouldTimeout m = do mb <- m case mb of Nothing -> return () _ -> error "Should have timed out!" shouldNotTimeout :: IO (Maybe a) -> IO a shouldNotTimeout m = do mb <- m case mb of Just x -> return x _ -> error "Should not have timed out!" The busyWontTimeout is the most representative benchmark. It performs a busy computation and gives it enough time to complete. This time I ren the benchmarks with +RTS -N2: willTimeout/old 22.78159 us 1.0 x willTimeout/new 22.34967 us 1.0 x willTimeout/event 10.05289 us 2.3 x busyWillTimeout/old 10.58061 ms 1.0 x (std dev: 4.6) busyWillTimeout/new 11.89530 ms 0.9 x (std dev: 4.6) busyWillTimeout/event 9.983601 ms 1.1 x (std dev: 1.2) wontTimeout/old 13.78843 us 1.0 x wontTimeout/new 832.4918 ns 16.6 x wontTimeout/event 1.042921 us 13.2 x busyWontTimeout/old 57.10021 us 1.0 x busyWontTimeout/new 56.85652 us 1.0 x busyWontTimeout/event 35.67142 us 1.6 x The willTimeout benchmark is slightly faster with -N2 while the wontTimeout is slightly slower. All timeouts score similarly in the busyWillTimeout benchmark. The most representative busyWontTimeout benchmark is the interesting one. Both the old and new score similarly while the event-manager based timeout is a modest 1.6 x faster. Since this is the most representative benchmark I'm beginning to favour this implementation. While writing this email I was doing another run of the benchmarks. Suddenly the willTimeout/new benchmark crashed with the message: benchmarking willTimeout/new collecting 100 samples, 211 iterations each, in estimated 654.8272 ms bench_timeouts_threaded: <<timeout>> Oops! That "<<timeout>>" is the Timeout exception not getting caught by my exception handler while it should. This is a major bug. I believe it is caused by this piece of code: ... uninterruptibleMask $ \restore -> do tid <- unsafeUnmask $ forkIO $ do tid <- myThreadId threadDelay n throwTo myTid $ Timeout tid ... While I uninterruptibly mask asynchronous exceptions I need to temporarily unmask them so that the forked thread can be killed lateron. I think the bug is that I first call unsafeUnmask and then fork the thread which throws the Timeout exception. I can imagine there's a brief period after the forkIO call where we're still in the unmasked state. If the timeout thread then immediately throws the Timeout exception (which is the case in the willTimeout benchmark) it will be received by our thread and won't get caught. The solution is probably to reverse the order of: "unsafeUnmask $ forkIO" to "forkIO $ unsafeUnmask". Or just use "forkIOUnmasked". The reason I didn't used that in the first place was that it was much slower for some reason. So, since the new implementation is not really faster in a representative benchmark and above all is buggy, I'm planning to ditch it in favour of the event-manager based timeout. Thanks for reading my rambling, Bas

Hi Bas,

The solution is probably to reverse the order of: "unsafeUnmask $ forkIO" to "forkIO $ unsafeUnmask". Or just use "forkIOUnmasked". The reason I didn't used that in the first place was that it was much slower for some reason.

The reason is probably that in order for the forkIOUnmaske-d thread to receive an exception (which it must, to be killed), it first has to be activated at least once, to perform the unsafeUnmask. So the worker thread's call to killThread will block. Now if there were a way to specify the exception mask of the newly created thread directly, it should be just as fast as the unsafeUnmask . forkIO version. I have not checked the event manager based implementation in detail, but from your numbers it looks like the best option at this time. Best regards, Bertram

On Mon, Feb 21, 2011 at 12:39 PM, Bas van Dijk wrote:

On 19 February 2011 00:04, Bas van Dijk wrote:

...

So, since the new implementation is not really faster in a representative benchmark and above all is buggy, I'm planning to ditch it in favour of the event-manager based timeout.

The patch is ready for review:

http://hackage.haskell.org/trac/ghc/attachment/ticket/4963/faster_timeout.dp...

Instead of defining registerTimeout :: EventManager -> Int -> (TimeoutKey -> TimeoutCallback) -> IO TimeoutKey include TimeoutKey in the TimeoutCallback type. Someone who better understands the exception masking parts could give you better feedback on that code. Johan

On Mon, Feb 21, 2011 at 3:16 PM, Bas van Dijk wrote:

On 21 February 2011 21:55, Johan Tibell wrote:

...

...include TimeoutKey in the TimeoutCallback type.

Done: http://hackage.haskell.org/trac/ghc/attachment/ticket/4963/faster_timeout.dp...

Could we store a full TimeoutCallback in the PSQ? At the line that reads sequence_ $ map Q.value expired you'll need to pass the PSQ key (which is the Unique) to the callback. Most callbacks will ignore this key but by doing this we 1) decrease the size of the closure we store in the PSQ and 2) make the mechanism more flexible for future use. (There's a small chance that I've read the diff wrong. I haven't applied the patch and look at it in a real diff viewer). Johan

On Tue, Feb 22, 2011 at 2:46 AM, Bas van Dijk wrote:

On 22 February 2011 03:10, Johan Tibell wrote:

...

On Mon, Feb 21, 2011 at 3:16 PM, Bas van Dijk wrote:

...

On 21 February 2011 21:55, Johan Tibell wrote:

...

...include TimeoutKey in the TimeoutCallback type.

Done: http://hackage.haskell.org/trac/ghc/attachment/ticket/4963/faster_timeout.dp...

Could we store a full TimeoutCallback in the PSQ? At the line that reads

     sequence_ $ map Q.value expired

you'll need to pass the PSQ key (which is the Unique) to the callback.

Good point. Something like this:

sequence_ $ map (\(Elem key _ cb) -> cb (TK key)) expired

Yes.

Ok, I will apply it this evening.

Excellent. Thanks for working on this. Johan

I'm curious, is it possible that your new timeout implementation would fix this problem?: doesntWork :: Int -> Int doesntWork x = last $ cycle [x] test :: IO (Maybe Bool) test = timeout 1 $ evaluate $ doesntWork 5 == 5 -- never terminates, even with the timeout

From what I can gather, this problem is caused by a lack of context switches in the code for 'doesntWork' so I doubt that a new implementation of timeout would fix it, but I thought I'd ask :)

It's super annoying, especially when it happens when you're not expecting it. (btw, I've only tested the above code in ghc 6.x, so I have no idea if the behavior is the same in 7) - Job On Mon, Feb 21, 2011 at 3:39 PM, Bas van Dijk wrote:

On 19 February 2011 00:04, Bas van Dijk wrote:

...

So, since the new implementation is not really faster in a representative benchmark and above all is buggy, I'm planning to ditch it in favour of the event-manager based timeout.

The patch is ready for review:

http://hackage.haskell.org/trac/ghc/attachment/ticket/4963/faster_timeout.dp...

Bas

_______________________________________________ Haskell-Cafe mailing list Haskell-Cafe@haskell.org http://www.haskell.org/mailman/listinfo/haskell-cafe