stm-delay 0.1.1.1 → 0.1.1.2
raw patch · 3 files changed
+90/−27 lines, 3 filesdep +asyncdep +timedep ~stm
Dependencies added: async, time
Dependency ranges changed: stm
Files
- Control/Concurrent/STM/Delay.hs +7/−11
- stm-delay.cabal +19/−5
- test/Main.hs +64/−11
Control/Concurrent/STM/Delay.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-} -- | -- Module: Control.Concurrent.STM.Delay -- Copyright: (c) Joseph Adams 2012@@ -32,14 +33,10 @@ import Control.Exception (mask_) import Control.Monad -#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS import qualified GHC.Event as Ev #endif -#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS-import qualified GHC.Conc as Conc-#endif- -- | A 'Delay' is an updatable timer that rings only once. data Delay = Delay { delayVar :: !(TVar Bool)@@ -99,16 +96,15 @@ -- Drivers getDelayImpl :: Int -> IO Delay-#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS+#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS getDelayImpl t0 = do- Conc.ensureIOManagerIsRunning m <- Ev.getSystemEventManager case m of- Nothing -> implThread t0+ Nothing -> implThread t0 Just _ -> do mgr <- Ev.getSystemTimerManager implEvent mgr t0-#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS getDelayImpl t0 = do m <- Ev.getSystemEventManager case m of@@ -118,7 +114,7 @@ getDelayImpl = implThread #endif -#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS+#if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS -- | Use the timeout API in "GHC.Event" via TimerManager --implEvent :: Ev.TimerManager -> Int -> IO Delay implEvent mgr t0 = do@@ -129,7 +125,7 @@ , delayUpdate = Ev.updateTimeout mgr k , delayCancel = Ev.unregisterTimeout mgr k }-#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS+#elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS -- | Use the timeout API in "GHC.Event" implEvent :: Ev.EventManager -> Int -> IO Delay implEvent mgr t0 = do
stm-delay.cabal view
@@ -1,5 +1,5 @@ name: stm-delay-version: 0.1.1.1+version: 0.1.1.2 synopsis: Updatable one-shot timer polled with STM description: This library lets you create a one-shot timer, poll it using STM,@@ -10,8 +10,15 @@ to @threadDelay@ and @registerDelay@. Otherwise, it falls back to forked threads and @threadDelay@. .- [0.1.1]- Add tryWaitDelayIO, improve performance for certain cases of @newDelay@+ [0.1.1.2 (2025-05-08)]+ .+ - Remove a call to ensureIOManagerIsRunning, for consistency with System.Timeout+ .+ - Adjust timings in the testsuite to fix intermittent failure in the non-threaded RTS case.+ .+ [0.1.1 (2014-09-14)]+ .+ - Add tryWaitDelayIO, improve performance for certain cases of @newDelay@ and @updateDelay@, and improve example. homepage: https://github.com/joeyadams/haskell-stm-delay license: BSD3@@ -21,7 +28,7 @@ copyright: Copyright (c) Joseph Adams 2012 category: System build-type: Simple-cabal-version: >= 1.8+cabal-version: >= 1.10 source-repository head type: git@@ -31,10 +38,11 @@ exposed-modules: Control.Concurrent.STM.Delay + default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs build-depends: base >= 4.3 && < 5- , stm+ , stm < 3 -- Need base >= 4.3 for: --@@ -53,6 +61,7 @@ hs-source-dirs: test main-is: Main.hs + default-language: Haskell2010 ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing@@ -60,8 +69,10 @@ -fno-warn-unused-matches build-depends: base >= 4.3 && < 5+ , async , stm , stm-delay+ , time test-suite test-threaded type: exitcode-stdio-1.0@@ -69,6 +80,7 @@ hs-source-dirs: test main-is: Main.hs + default-language: Haskell2010 ghc-options: -Wall -threaded -fno-warn-missing-signatures -fno-warn-name-shadowing@@ -76,5 +88,7 @@ -fno-warn-unused-matches build-depends: base >= 4.3 && < 5+ , async , stm , stm-delay+ , time
test/Main.hs view
@@ -1,11 +1,31 @@ {-# LANGUAGE CPP #-} import Control.Concurrent+import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.Delay+import Control.Monad+import Data.Time.Clock -main = trivial+-- This is the same condition Delay.hs checks. On Windows, and when -threaded is disabled,+-- we fall back to threads, which are much slower.+--+-- Moreover, when -threaded is disabled, timers seem to be less granular, so this test+-- uses a looser tolerance on timings.+hasFastTimers :: Bool+#if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS+hasFastTimers = rtsSupportsBoundThreads+#else+hasFastTimers = False+#endif +main :: IO ()+main = do+ trivial+ replicateConcurrently_ 10 trivial+ bench++trivial :: IO () trivial = do let new t = do delay <- newDelay t@@ -27,17 +47,26 @@ True <- wait (delay, wait) <- new 100000- False <- wait+ False <- wait -- 100000us left threadDelay 50000- False <- wait+ False <- wait -- 50000us left updateDelay delay 200000 threadDelay 60000- False <- wait+ False <- wait -- 140000us left threadDelay 60000- False <- wait -- updateDelay sets the timer based on the current time,- -- so the threadDelay 50000 doesn't count toward our total.- threadDelay 81000+ False <- wait -- 80000us left+ -- updateDelay sets the timer based on the current time,+ -- so the threadDelay 50000 doesn't count toward our total.++ -- In -threaded mode, expect a tighter tolerance for threadDelay timings.+ if hasFastTimers+ then threadDelay 81000 -- wait until 1000us after ring+ else threadDelay 150000 -- wait until 70000us after ring True <- wait+ -- We waited 201000 after setting the delay, so the delay must be expired now.+ -- The only way this could fail is if it takes more than a millisecond+ -- for updateDelay to take an MVar and write a TVar. Context switching+ -- should not take this long. -- 'newDelay n' where n <= 0 times out immediately, -- rather than never timing out.@@ -63,15 +92,21 @@ -- so use a more lenient value for now. -- -- (delay, wait) <- new maxBound- (delay, wait) <- new 2147483647+ (delay, wait) <- new 2147483647 -- 35 minutes, 47 seconds False <- wait threadDelay 100000- False <- wait+ False <- wait -- 35 minutes, 46.9 seconds left updateDelay delay 100000 threadDelay 90000- False <- wait- threadDelay 10010+ False <- wait -- 10000us left+ if hasFastTimers+ then threadDelay 10010 -- wait until 10us after ring+ else threadDelay 60000 -- wait until 50000us after ring True <- wait+ -- We waited 10 microseconds longer than the delay is for, so the delay+ -- must be expired now. The only way this could fail is if it takes+ -- more than 10 microseconds for updateDelay to take an MVar and write a TVar.+ -- This might be conceivable with context switching. -- cancelDelay causes the delay to miss its initial deadline, -- and a subsequent updateDelay has no effect.@@ -93,3 +128,21 @@ False <- wait return ()++bench :: IO ()+bench = do+ startTime <- getCurrentTime++ let count = if hasFastTimers then 1000000 else 20000++ -- Create a bunch of timers of pseudorandom durations (under 2 seconds), and wait for all of them.+ delays <- mapM newDelay $ take count $ iterate (\n -> (n + 349000) `mod` 2000000) 0+ mapM_ (atomically . waitDelay) delays++ -- The operation should not take substantially more than 2 seconds.+ -- On an M4 MacBook this takes 2.5 to 2.6 seconds.+ endTime <- getCurrentTime+ let duration = endTime `diffUTCTime` startTime+ putStrLn $ "Creating and waiting for " ++ show count ++ " delays took " ++ show duration ++ "."+ when (duration > 4.0) $+ fail $ "newDelay and waitDelay are too slow"