stm-delay-0.1.1.1/0000755000000000000000000000000012405234625011740 5ustar0000000000000000stm-delay-0.1.1.1/stm-delay.cabal0000644000000000000000000000444712405234625014634 0ustar0000000000000000name: stm-delay version: 0.1.1.1 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] 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.8 source-repository head type: git location: git://github.com/joeyadams/haskell-stm-delay.git library exposed-modules: Control.Concurrent.STM.Delay ghc-options: -Wall -fwarn-tabs build-depends: base >= 4.3 && < 5 , stm -- 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 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 , stm , stm-delay test-suite test-threaded type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs 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 , stm , stm-delay stm-delay-0.1.1.1/Setup.hs0000644000000000000000000000005612405234625013375 0ustar0000000000000000import Distribution.Simple main = defaultMain stm-delay-0.1.1.1/LICENSE0000644000000000000000000000276212405234625012754 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.1/test/0000755000000000000000000000000012405234625012717 5ustar0000000000000000stm-delay-0.1.1.1/test/Main.hs0000644000000000000000000000472212405234625014144 0ustar0000000000000000{-# LANGUAGE CPP #-} import Control.Concurrent import Control.Concurrent.STM import Control.Concurrent.STM.Delay main = trivial 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 threadDelay 50000 False <- wait updateDelay delay 200000 threadDelay 60000 False <- wait 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 True <- wait -- '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 False <- wait threadDelay 100000 False <- wait updateDelay delay 100000 threadDelay 90000 False <- wait threadDelay 10010 True <- wait -- 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 () stm-delay-0.1.1.1/Control/0000755000000000000000000000000012405234625013360 5ustar0000000000000000stm-delay-0.1.1.1/Control/Concurrent/0000755000000000000000000000000012405234625015502 5ustar0000000000000000stm-delay-0.1.1.1/Control/Concurrent/STM/0000755000000000000000000000000012405234625016145 5ustar0000000000000000stm-delay-0.1.1.1/Control/Concurrent/STM/Delay.hs0000644000000000000000000002226712405234625017550 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | -- 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 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) , 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 getDelayImpl t0 = do Conc.ensureIOManagerIsRunning 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 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 -- | 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 -- | 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. -}