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,278 +1,302 @@ -{-# 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 - --- | 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,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,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. --} +{-# 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. +-} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (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. +Copyright (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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/stm-delay.cabal b/stm-delay.cabal --- a/stm-delay.cabal +++ b/stm-delay.cabal @@ -1,80 +1,80 @@ -name: stm-delay -version: 0.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 +name: 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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,95 +1,95 @@ -{-# 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 () +{-# 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 ()