Hello *,
I've been experimenting with an alternative implementation of
'System.Timeout.timeout'[1] which avoids the overhead of spawning a new
thread for each invocation.
Part of my motivation is to see if I can implement a faster version of
threadWaitReadTimeout :: Int -> Fd -> IO Bool
threadWaitReadTimeout to = liftM (maybe False (const True))
. timeout to . threadWaitRead
and thus exploit GHC's event notification system instead of having to
reimplement a timeout-manager myself (like popular HTTP server libraries
such as Snap or Warp do currently).
The following Haskell program shows a proof-of-concept implementation
derived directly from 'System.Timeout.timeout' together with a Criterion
benchmark comparing the performance between the original and the
alternative 'timeout' function wrapping a 'readMVar' call.
{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
-- ghc -threaded --make -O2 -rtsopts -Wall timeout2.hs && ./timeout2 +RTS -A4m -N4
import Control.Concurrent
import Control.Exception
import Criterion.Main
import Data.Typeable
import Data.Unique (Unique, newUnique)
import qualified GHC.Event as E
import System.Timeout (timeout)
newtype Timeout2 = Timeout2 Unique deriving (Eq,Typeable)
instance Exception Timeout2
instance Show Timeout2 where show _ = "<<timeout2>>"
-- | Alternative implementation of 'System.Timeout.timeout' using
-- 'GHC.Event.registerTimeout' directly instead of spawning a
-- watchdog-thread.
timeout2 :: Int -> IO a -> IO (Maybe a)
timeout2 to f
| to < 0 = fmap Just f
| to == 0 = return Nothing
| otherwise = do
tid <- myThreadId
ex <- fmap Timeout2 newUnique
Just em <- E.getSystemEventManager -- FIXME
handleJust (\e -> if e == ex then Just () else Nothing)
(\_ -> return Nothing)
(bracket (E.registerTimeout em to (throwTo tid ex))
(E.unregisterTimeout em)
(\_ -> fmap Just f))
main :: IO ()
main = do
mv <- newMVar ()
defaultMain [ bench "id" $ readMVar mv
, bench "timeout_1ms" $ readMVarTO 1000 mv
, bench "timeout2_1ms" $ readMVarTO2 1000 mv
, bench "timeout_100us" $ readMVarTO 100 mv
, bench "timeout2_100us" $ readMVarTO2 100 mv
, bench "timeout_10us" $ readMVarTO 10 mv
, bench "timeout2_10us" $ readMVarTO2 10 mv
, bench "timeout_1us" $ readMVarTO 1 mv
, bench "timeout2_1us" $ readMVarTO2 1 mv
]
where
readMVarTO to = timeout to . readMVar
readMVarTO2 to = timeout2 to . readMVar
On a i7-3770 with GHC-7.6.2/Linux/64bit ran with "+RTS -A4m -N4", the
benchmark shows a 15x improvement for the new implementation (below 1
uS) compared to the original implementation (~13 uS):
,----
| benchmarking id
| mean: 22.60933 ns, lb 22.50331 ns, ub 22.73515 ns, ci 0.950
| std dev: 591.0383 ps, lb 509.6189 ps, ub 663.2670 ps, ci 0.950
| found 17 outliers among 100 samples (17.0%)
| 17 (17.0%) high mild
| variance introduced by outliers: 19.992%
| variance is moderately inflated by outliers
|
| benchmarking timeout_1ms
| mean: 13.79584 us, lb 13.62939 us, ub 13.92814 us, ci 0.950
| std dev: 756.3080 ns, lb 524.7628 ns, ub 1.068547 us, ci 0.950
| found 14 outliers among 100 samples (14.0%)
| 4 (4.0%) low severe
| 5 (5.0%) high mild
| 5 (5.0%) high severe
| variance introduced by outliers: 52.484%
| variance is severely inflated by outliers
|
| benchmarking timeout2_1ms
| mean: 879.8152 ns, lb 874.5223 ns, ub 885.9759 ns, ci 0.950
| std dev: 29.31963 ns, lb 25.65941 ns, ub 32.98116 ns, ci 0.950
| found 9 outliers among 100 samples (9.0%)
| 9 (9.0%) high mild
| variance introduced by outliers: 28.734%
| variance is moderately inflated by outliers
| ...
`----
Alas there's a race-condition hidden somewhere I'm struggling with; When
the timeout is set low enough, the internal 'Timeout2' exceptions leaks
outside the 'timeout2' wrapper:
,----
| ...
| benchmarking timeout2_10us
| newtimeout: <<timeout2>>
`----
I've tried rewriting the code but couldn't figure out a way to keep the
exception from escaping 'timeout2'. Does the race-condition actually lie
in the 'timeout2' implementation -- and if so, is it possible to rewrite
'timeout2' to solve it?
[1]:
http://hackage.haskell.org/packages/archive/base/latest/doc/html/System-Timeout.html#v:timeout
cheers,
hvr
_______________________________________________
Glasgow-haskell-users mailing list
Glasgow-haskell-users@haskell.org
http://www.haskell.org/mailman/listinfo/glasgow-haskell-users
