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

[Bas van Dijk]

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
                       -> 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