[Haskell-cafe] Faster timeout but is it correct?
Bas van Dijk
v.dijk.bas at gmail.com
Fri Feb 18 01:09:14 CET 2011
On 18 February 2011 00:56, Johan Tibell <johan.tibell at gmail.com> wrote:
> On Thu, Feb 17, 2011 at 2:43 PM, Bryan O'Sullivan <bos at serpentine.com> wrote:
>> On Thu, Feb 17, 2011 at 11:53 AM, Bas van Dijk <v.dijk.bas at gmail.com> 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
-> (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
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', ())
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...
More information about the Libraries