stm-delay-0.1.1.2/0000755000000000000000000000000007346545000011741 5ustar0000000000000000stm-delay-0.1.1.2/Control/Concurrent/STM/0000755000000000000000000000000007346545000016146 5ustar0000000000000000stm-delay-0.1.1.2/Control/Concurrent/STM/Delay.hs0000644000000000000000000002230007346545000017535 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} -- | -- Module: Control.Concurrent.STM.Delay -- Copyright: (c) Joseph Adams 2012 -- License: BSD3 -- Maintainer: joeyadams3.14159@gmail.com -- Portability: Requires GHC 7+ -- -- One-shot timer whose duration can be updated. Think of it as an enhanced -- version of 'registerDelay'. -- -- This uses "GHC.Event" when available (GHC 7.2+, @-threaded@, non-Windows OS). -- Otherwise, it falls back to forked threads and 'threadDelay'. module Control.Concurrent.STM.Delay ( -- * Managing delays Delay, newDelay, updateDelay, cancelDelay, -- * Waiting for expiration waitDelay, tryWaitDelay, tryWaitDelayIO, -- * Example -- $example ) where import Control.Concurrent import Control.Concurrent.STM import Control.Exception (mask_) import Control.Monad #if MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS import qualified GHC.Event as Ev #endif -- | A 'Delay' is an updatable timer that rings only once. data Delay = Delay { delayVar :: !(TVar Bool) , delayUpdate :: !(Int -> IO ()) , delayCancel :: !(IO ()) } instance Eq Delay where (==) a b = delayVar a == delayVar b -- | Create a new 'Delay' that will ring in the given number of microseconds. newDelay :: Int -> IO Delay newDelay t | t > 0 = getDelayImpl t -- Special case zero timeout, so user can create an -- already-rung 'Delay' efficiently. | otherwise = do var <- newTVarIO True return Delay { delayVar = var , delayUpdate = \_t -> return () , delayCancel = return () } -- | Set an existing 'Delay' to ring in the given number of microseconds -- (from the time 'updateDelay' is called), rather than when it was going to -- ring. If the 'Delay' has already rung, do nothing. updateDelay :: Delay -> Int -> IO () updateDelay = delayUpdate -- | Set a 'Delay' so it will never ring, even if 'updateDelay' is used later. -- If the 'Delay' has already rung, do nothing. cancelDelay :: Delay -> IO () cancelDelay = delayCancel -- | Block until the 'Delay' rings. If the 'Delay' has already rung, -- return immediately. waitDelay :: Delay -> STM () waitDelay delay = do expired <- tryWaitDelay delay if expired then return () else retry -- | Non-blocking version of 'waitDelay'. -- Return 'True' if the 'Delay' has rung. tryWaitDelay :: Delay -> STM Bool tryWaitDelay = readTVar . delayVar -- | Faster version of @'atomically' . 'tryWaitDelay'@. See 'readTVarIO'. -- -- Since 0.1.1 tryWaitDelayIO :: Delay -> IO Bool tryWaitDelayIO = readTVarIO . delayVar ------------------------------------------------------------------------ -- Drivers getDelayImpl :: Int -> IO Delay #if MIN_VERSION_base(4,7,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS getDelayImpl t0 = do m <- Ev.getSystemEventManager case m of Nothing -> implThread t0 Just _ -> do mgr <- Ev.getSystemTimerManager implEvent mgr t0 #elif MIN_VERSION_base(4,4,0) && !mingw32_HOST_OS && !ghcjs_HOST_OS getDelayImpl t0 = do m <- Ev.getSystemEventManager case m of Nothing -> implThread t0 Just mgr -> implEvent mgr t0 #else getDelayImpl = implThread #endif #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 var <- newTVarIO False k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True return Delay { delayVar = var , delayUpdate = Ev.updateTimeout mgr k , delayCancel = Ev.unregisterTimeout mgr k } #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 var <- newTVarIO False k <- Ev.registerTimeout mgr t0 $ atomically $ writeTVar var True return Delay { delayVar = var , delayUpdate = Ev.updateTimeout mgr k , delayCancel = Ev.unregisterTimeout mgr k } #endif -- | Use threads and threadDelay: -- -- [init] -- Fork a thread to wait the given length of time, then set the TVar. -- -- [delayUpdate] -- Stop the existing thread and (unless the delay has been canceled) -- fork a new thread. -- -- [delayCancel] -- Stop the existing thread, if any. implThread :: Int -> IO Delay implThread t0 = do var <- newTVarIO False let new t = forkTimeoutThread t $ atomically $ writeTVar var True mv <- new t0 >>= newMVar . Just return Delay { delayVar = var , delayUpdate = replaceThread mv . fmap Just . new , delayCancel = replaceThread mv $ return Nothing } replaceThread :: MVar (Maybe TimeoutThread) -> IO (Maybe TimeoutThread) -> IO () replaceThread mv new = join $ mask_ $ do m <- takeMVar mv case m of Nothing -> do -- Don't create a new timer thread after the 'Delay' has -- been canceled. Otherwise, the behavior is inconsistent -- with GHC.Event. putMVar mv Nothing return (return ()) Just tt -> do m' <- stopTimeoutThread tt case m' of Nothing -> do -- Timer already rang (or will ring very soon). -- Don't start a new timer thread, as it would -- waste resources and have no externally -- observable effect. putMVar mv Nothing return $ return () Just kill -> do new >>= putMVar mv return kill ------------------------------------------------------------------------ -- TimeoutThread data TimeoutThread = TimeoutThread !ThreadId !(MVar ()) -- | Fork a thread to perform an action after the given number of -- microseconds. -- -- 'forkTimeoutThread' is non-interruptible. forkTimeoutThread :: Int -> IO () -> IO TimeoutThread forkTimeoutThread t io = do mv <- newMVar () tid <- compat_forkIOUnmasked $ do threadDelay t m <- tryTakeMVar mv -- If m is Just, this thread will not be interrupted, -- so no need for a 'mask' between the tryTakeMVar and the action. case m of Nothing -> return () Just _ -> io return (TimeoutThread tid mv) -- | Prevent the 'TimeoutThread' from performing its action. If it's too late, -- return 'Nothing'. Otherwise, return an action (namely, 'killThread') for -- cleaning up the underlying thread. -- -- 'stopTimeoutThread' has a nice property: it is /non-interruptible/. -- This means that, in an exception 'mask', it will not poll for exceptions. -- See "Control.Exception" for more info. -- -- However, the action returned by 'stopTimeoutThread' /does/ poll for -- exceptions. That's why 'stopTimeoutThread' returns this action rather than -- simply doing it. This lets the caller do it outside of a critical section. stopTimeoutThread :: TimeoutThread -> IO (Maybe (IO ())) stopTimeoutThread (TimeoutThread tid mv) = maybe Nothing (\_ -> Just (killThread tid)) `fmap` tryTakeMVar mv ------------------------------------------------------------------------ -- Compatibility compat_forkIOUnmasked :: IO () -> IO ThreadId #if MIN_VERSION_base(4,4,0) compat_forkIOUnmasked io = forkIOWithUnmask (\_ -> io) #else compat_forkIOUnmasked = forkIOUnmasked #endif ------------------------------------------------------------------------ {- $example Suppose we are managing a network connection, and want to time it out if no messages are received in over five minutes. We'll create a 'Delay', and an action to \"bump\" it: @ let timeoutInterval = 5 * 60 * 1000000 :: 'Int' delay <- 'newDelay' timeoutInterval let bump = 'updateDelay' delay timeoutInterval @ This way, the 'Delay' will ring if it is not bumped for longer than five minutes. Now we fork the receiver thread: @ dead <- 'newEmptyTMVarIO' _ <- 'forkIO' $ ('forever' $ do msg <- recvMessage bump handleMessage msg ) \`finally\` 'atomically' ('putTMVar' dead ()) @ Finally, we wait for the delay to ring, or for the receiver thread to fail due to an exception: @ 'atomically' $ 'waitDelay' delay \`orElse\` 'readTMVar' dead @ Warning: * If /handleMessage/ blocks, the 'Delay' may ring due to @handleMessage@ taking too long, rather than just @recvMessage@ taking too long. * The loop will continue to run until you do something to stop it. It might be simpler to use "System.Timeout" instead: @ m <- 'System.Timeout.timeout' timeoutInterval recvMessage case m of Nothing -> 'fail' \"timed out\" Just msg -> handleMessage msg @ However, using a 'Delay' has the following advantages: * If @recvMessage@ makes a blocking FFI call (e.g. network I/O on Windows), 'System.Timeout.timeout' won't work, since it uses an asynchronous exception, and FFI calls can't be interrupted with async exceptions. The 'Delay' approach lets you handle the timeout in another thread, while the FFI call is still blocked. * 'updateDelay' is more efficient than 'System.Timeout.timeout' when "GHC.Event" is available. -} stm-delay-0.1.1.2/LICENSE0000644000000000000000000000276207346545000012755 0ustar0000000000000000Copyright (c) 2012, Joseph Adams All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Joseph Adams nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. stm-delay-0.1.1.2/Setup.hs0000644000000000000000000000005607346545000013376 0ustar0000000000000000import Distribution.Simple main = defaultMain stm-delay-0.1.1.2/stm-delay.cabal0000644000000000000000000000536307346545000014633 0ustar0000000000000000name: stm-delay 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, and update it to ring at a different time than initially specified. . It uses GHC event manager timeouts when available (GHC 7.2+, @-threaded@, non-Windows OS), yielding performance similar to @threadDelay@ and @registerDelay@. Otherwise, it falls back to forked threads and @threadDelay@. . [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 license-file: LICENSE author: Joey Adams maintainer: joeyadams3.14159@gmail.com copyright: Copyright (c) Joseph Adams 2012 category: System build-type: Simple cabal-version: >= 1.10 source-repository head type: git location: git://github.com/joeyadams/haskell-stm-delay.git library exposed-modules: Control.Concurrent.STM.Delay default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs build-depends: base >= 4.3 && < 5 , stm < 3 -- Need base >= 4.3 for: -- -- * Control.Exception.mask -- -- * forkIOUnmasked -- -- * A threadDelay that doesn't give (-1) magic treatment. -- See http://hackage.haskell.org/trac/ghc/ticket/2892 -- -- * GHC.Event (called System.Event in base 4.3) test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs default-language: Haskell2010 ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-name-shadowing -fno-warn-unused-do-bind -fno-warn-unused-matches build-depends: base >= 4.3 && < 5 , async , stm , stm-delay , time test-suite test-threaded type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs default-language: Haskell2010 ghc-options: -Wall -threaded -fno-warn-missing-signatures -fno-warn-name-shadowing -fno-warn-unused-do-bind -fno-warn-unused-matches build-depends: base >= 4.3 && < 5 , async , stm , stm-delay , time stm-delay-0.1.1.2/test/0000755000000000000000000000000007346545000012720 5ustar0000000000000000stm-delay-0.1.1.2/test/Main.hs0000644000000000000000000001163407346545000014145 0ustar0000000000000000{-# 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 -- 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 return (delay, atomically $ tryWaitDelay delay) -- The delay times out at the right time, and after tryWaitDelay returns -- 'True', 'updateDelay' and 'cancelDelay' have no observable effect. (delay, wait) <- new 100000 False <- wait threadDelay 50000 False <- wait threadDelay 60000 True <- wait updateDelay delay 1000000 True <- wait updateDelay delay (-1) True <- wait cancelDelay delay True <- wait (delay, wait) <- new 100000 False <- wait -- 100000us left threadDelay 50000 False <- wait -- 50000us left updateDelay delay 200000 threadDelay 60000 False <- wait -- 140000us left threadDelay 60000 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. (delay, wait) <- new 0 threadDelay 100 True <- wait (delay, wait) <- new (-1) threadDelay 100 True <- wait -- This fails on Windows without -threaded, as 'threadDelay minBound' -- blocks. It also fails on Linux using GHC 7.0.3 without -threaded. #if !mingw32_HOST_OS && MIN_VERSION_base(4,4,0) (delay, wait) <- new minBound threadDelay 1000 True <- wait #endif -- 'newDelay maxBound' doesn't time out any time soon, -- and updateDelay doesn't wait for the delay to complete. -- -- Using maxBound currently fails on Linux 64-bit (see GHC ticket #7325), -- so use a more lenient value for now. -- -- (delay, wait) <- new maxBound (delay, wait) <- new 2147483647 -- 35 minutes, 47 seconds False <- wait threadDelay 100000 False <- wait -- 35 minutes, 46.9 seconds left updateDelay delay 100000 threadDelay 90000 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. (delay, wait) <- new 100000 False <- wait threadDelay 50000 False <- wait cancelDelay delay False <- wait threadDelay 60000 False <- wait updateDelay delay 10000 False <- wait threadDelay 20000 False <- wait cancelDelay delay False <- wait threadDelay 100000 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"