diff --git a/Control/Concurrent/STM/Delay.hs b/Control/Concurrent/STM/Delay.hs --- a/Control/Concurrent/STM/Delay.hs +++ b/Control/Concurrent/STM/Delay.hs @@ -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 diff --git a/stm-delay.cabal b/stm-delay.cabal --- a/stm-delay.cabal +++ b/stm-delay.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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"