diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,19 @@ # ChangeLog for time-manager +## 0.3.0 + +* New architecture. The backend is switched from the designated thread + to GHC's System TimerManager. From this version, this library is + just wrapper APIs of GHC's System TimerManager. Unlike v0.2 or + earlier, callbacks are executed at the exact time. System + TimerManager uses a PSQ (a tree) while v0.2 or earlier uses a list. + So, this version hopefully scales better. +* Deprecated functions: `stopManager`, `killManager` and `withManager'`. +* `tickle` sets the specified timeout from now. +* `pause` is now identical to `cancel`. +* `resume` is now re-registration of timeout. +* The signature of `withHandle` is changed. + ## 0.2.4 * Providing `isAllGone`. diff --git a/System/ThreadManager.hs b/System/ThreadManager.hs --- a/System/ThreadManager.hs +++ b/System/ThreadManager.hs @@ -132,11 +132,12 @@ -- | Fork a managed thread with a handle created by a timeout manager. forkManagedTimeout :: ThreadManager -> String -> (T.Handle -> IO ()) -> IO () forkManagedTimeout (ThreadManager timmgr var) label io = - void $ forkIO $ E.handle ignore $ do + void $ forkIO $ do labelMe label E.bracket (setup var) (clear var) $ \(_n, wtid, ref) -> - -- 'TimeoutThread' is ignored by 'withHandle'. - void $ T.withHandle timmgr (lockAndKill wtid ref T.TimeoutThread) io + E.handle ignore $ T.withHandle timmgr (lockAndKill wtid ref ex) io + where + ex = KilledByThreadManager Nothing -- | Fork a managed thread with a cleanup function. forkManagedFinally :: ThreadManager -> String -> IO () -> IO () -> IO () @@ -209,7 +210,7 @@ labelThread tid l withHandle - :: ThreadManager -> T.TimeoutAction -> (T.Handle -> IO a) -> IO (Maybe a) + :: ThreadManager -> T.TimeoutAction -> (T.Handle -> IO a) -> IO a withHandle (ThreadManager timmgr _) = T.withHandle timmgr #if __GLASGOW_HASKELL__ < 908 diff --git a/System/TimeManager.hs b/System/TimeManager.hs --- a/System/TimeManager.hs +++ b/System/TimeManager.hs @@ -1,7 +1,13 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +-- | Timeout manager. Since v0.3.0, timeout manager is a wrapper of +-- GHC System TimerManager. +-- +-- Users of old version should check the current semantics. module System.TimeManager ( -- ** Types Manager, @@ -37,117 +43,94 @@ import Control.Concurrent (mkWeakThreadId, myThreadId) import qualified Control.Exception as E -import Control.Monad (void) -import Control.Reaper import Data.IORef (IORef) import qualified Data.IORef as I -import Data.Typeable (Typeable) -import System.IO.Unsafe import System.Mem.Weak (deRefWeak) +#if defined(mingw32_HOST_OS) +import qualified GHC.Event.Windows as EV +#else +import qualified GHC.Event as EV +#endif + ---------------------------------------------------------------- -- | A timeout manager -data Manager = Manager (Reaper [Handle] Handle) | NoManager +newtype Manager = Manager Int --- | No manager. +-- | A manager whose timeout value is 0 (no callbacks are fired). defaultManager :: Manager -defaultManager = NoManager +defaultManager = Manager 0 --- | An action to be performed on timeout. +isNoManager :: Manager -> Bool +isNoManager (Manager 0) = True +isNoManager _ = False + +---------------------------------------------------------------- + +-- | An action (callback) to be performed on timeout. type TimeoutAction = IO () +---------------------------------------------------------------- + -- | A handle used by a timeout manager. data Handle = Handle - { handleManager :: Manager - , handleActionRef :: IORef TimeoutAction - , handleStateRef :: IORef State + { handleTimeout :: Int + , handleAction :: TimeoutAction + , handleKeyRef :: ~(IORef EV.TimeoutKey) } -{-# NOINLINE emptyAction #-} -emptyAction :: IORef TimeoutAction -emptyAction = unsafePerformIO $ I.newIORef (return ()) - -{-# NOINLINE emptyState #-} -emptyState :: IORef State -emptyState = unsafePerformIO $ I.newIORef Inactive - +-- | Dummy 'Handle'. emptyHandle :: Handle emptyHandle = Handle - { handleManager = NoManager - , handleActionRef = emptyAction - , handleStateRef = emptyState + { handleTimeout = 0 + , handleAction = return () + , handleKeyRef = error "time-manager: Handle.handleKeyRef not set" } -data State - = Active -- Manager turns it to Inactive. - | Inactive -- Manager removes it with timeout action. - | Paused -- Manager does not change it. +isEmptyHandle :: Handle -> Bool +isEmptyHandle Handle{..} = handleTimeout == 0 ---------------------------------------------------------------- --- | Creating timeout manager which works every N microseconds --- where N is the first argument. +-- | Creating timeout manager with a timeout value in microseconds. +-- +-- Setting the timeout to zero or lower (<= 0) will produce a +-- `defaultManager`. initialize :: Int -> IO Manager -initialize timeout - | timeout <= 0 = return NoManager -initialize timeout = - Manager - <$> mkReaper - defaultReaperSettings - { -- Data.Set cannot be used since 'partition' cannot be used - -- with 'readIORef`. So, let's just use a list. - reaperAction = mkListAction prune - , reaperDelay = timeout - , reaperThreadName = "WAI timeout manager (Reaper)" - } - where - prune m@Handle{..} = do - state <- I.atomicModifyIORef' handleStateRef (\x -> (inactivate x, x)) - case state of - Inactive -> do - onTimeout <- I.readIORef handleActionRef - onTimeout `E.catch` ignoreSync - return Nothing - _ -> return $ Just m - - inactivate Active = Inactive - inactivate x = x +initialize = pure . Manager . max 0 ---------------------------------------------------------------- --- | Stopping timeout manager with onTimeout fired. +-- | Obsoleted since version 0.3.0 +-- Is now equivalent to @pure ()@. stopManager :: Manager -> IO () -stopManager NoManager = return () -stopManager (Manager mgr) = E.mask_ (reaperStop mgr >>= mapM_ fire) - where - fire Handle{..} = do - onTimeout <- I.readIORef handleActionRef - onTimeout `E.catch` ignoreSync +stopManager _ = return () +{-# DEPRECATED stopManager "This function does nothing since version 0.3.0" #-} --- | Killing timeout manager immediately without firing onTimeout. +-- | Obsoleted since version 0.3.0 +-- Is now equivalent to @pure ()@. killManager :: Manager -> IO () -killManager NoManager = return () -killManager (Manager mgr) = reaperKill mgr +killManager _ = return () +{-# DEPRECATED killManager "This function does nothing since version 0.3.0" #-} ---------------------------------------------------------------- -- | Registering a timeout action and unregister its handle -- when the body action is finished. --- 'Nothing' is returned on timeout. -withHandle :: Manager -> TimeoutAction -> (Handle -> IO a) -> IO (Maybe a) -withHandle mgr onTimeout action = - E.handle ignore $ E.bracket (register mgr onTimeout) cancel $ \th -> - Just <$> action th - where - ignore TimeoutThread = return Nothing +withHandle :: Manager -> TimeoutAction -> (Handle -> IO a) -> IO a +withHandle mgr onTimeout action + | isNoManager mgr = action emptyHandle + | otherwise = E.bracket (register mgr onTimeout) cancel action -- | Registering a timeout action of killing this thread and -- unregister its handle when the body action is killed or finished. withHandleKillThread :: Manager -> TimeoutAction -> (Handle -> IO ()) -> IO () -withHandleKillThread mgr onTimeout action = - E.handle ignore $ E.bracket (registerKillThread mgr onTimeout) cancel action +withHandleKillThread mgr onTimeout action + | isNoManager mgr = action emptyHandle + | otherwise = + E.handle ignore $ E.bracket (registerKillThread mgr onTimeout) cancel action where ignore TimeoutThread = return () @@ -155,44 +138,64 @@ -- | Registering a timeout action. register :: Manager -> TimeoutAction -> IO Handle -register NoManager _ = return emptyHandle -register m@(Manager mgr) !onTimeout = do - actionRef <- I.newIORef onTimeout - stateRef <- I.newIORef Active - let h = - Handle - { handleManager = m - , handleActionRef = actionRef - , handleStateRef = stateRef - } - reaperAdd mgr h - return h +register mgr@(Manager timeout) onTimeout + | isNoManager mgr = return emptyHandle + | otherwise = do + sysmgr <- getTimerManager + key <- EV.registerTimeout sysmgr timeout onTimeout + keyref <- I.newIORef key + let h = + Handle + { handleTimeout = timeout + , handleAction = onTimeout + , handleKeyRef = keyref + } + return h --- | Removing the 'Handle' from the 'Manager' immediately. +-- | Unregistering the timeout. cancel :: Handle -> IO () -cancel Handle{..} = case handleManager of - NoManager -> return () - Manager mgr -> void $ reaperModify mgr filt - where - -- It's very important that this function forces the whole workload so we - -- don't retain old handles, otherwise disasterous leaks occur. - filt [] = [] - filt (h@(Handle _ _ ref) : hs) - | handleStateRef == ref = hs - | otherwise = - let !hs' = filt hs - in h : hs' +cancel hd | isEmptyHandle hd = return () +cancel Handle{..} = do + mgr <- getTimerManager + key <- I.readIORef handleKeyRef + EV.unregisterTimeout mgr key +-- | Extending the timeout. +tickle :: Handle -> IO () +tickle h | isEmptyHandle h = return () +tickle Handle{..} = do + mgr <- getTimerManager + key <- I.readIORef handleKeyRef +#if defined(mingw32_HOST_OS) + EV.updateTimeout mgr key $ fromIntegral (handleTimeout `div` 1000000) +#else + EV.updateTimeout mgr key handleTimeout +#endif + +-- | This is identical to 'cancel'. +-- To resume timeout with the same 'Handle', 'resume' MUST be called. +-- Don't call 'tickle' for resumption. +pause :: Handle -> IO () +pause = cancel + +-- | Resuming the timeout. +resume :: Handle -> IO () +resume h | isEmptyHandle h = return () +resume Handle{..} = do + mgr <- getTimerManager + key <- EV.registerTimeout mgr handleTimeout handleAction + I.writeIORef handleKeyRef key + ---------------------------------------------------------------- -- | The asynchronous exception thrown if a thread is registered via -- 'registerKillThread'. data TimeoutThread = TimeoutThread - deriving (Typeable) instance E.Exception TimeoutThread where toException = E.asyncExceptionToException fromException = E.asyncExceptionFromException + instance Show TimeoutThread where show TimeoutThread = "Thread killed by timeout manager" @@ -210,62 +213,33 @@ mtid <- deRefWeak wtid case mtid of Nothing -> return () + -- FIXME: forkIO to prevent blocking TimerManger Just tid' -> E.throwTo tid' TimeoutThread ---------------------------------------------------------------- --- | Setting the state to active. --- 'Manager' turns active to inactive repeatedly. -tickle :: Handle -> IO () -tickle Handle{..} = I.writeIORef handleStateRef Active - --- | Setting the state to paused. --- 'Manager' does not change the value. -pause :: Handle -> IO () -pause Handle{..} = I.writeIORef handleStateRef Paused - --- | Setting the paused state to active. --- This is an alias to 'tickle'. -resume :: Handle -> IO () -resume = tickle - ----------------------------------------------------------------- - -- | Call the inner function with a timeout manager. --- 'stopManager' is used after that. withManager :: Int -- ^ timeout in microseconds -> (Manager -> IO a) -> IO a -withManager timeout f = - E.bracket - (initialize timeout) - stopManager - f +withManager timeout f = initialize timeout >>= f -- | Call the inner function with a timeout manager. --- 'killManager' is used after that. +-- This is identical to 'withManager'. withManager' :: Int -- ^ timeout in microseconds -> (Manager -> IO a) -> IO a -withManager' timeout f = - E.bracket - (initialize timeout) - killManager - f - ----------------------------------------------------------------- - -isAsyncException :: E.Exception e => e -> Bool -isAsyncException e = - case E.fromException (E.toException e) of - Just (E.SomeAsyncException _) -> True - Nothing -> False +withManager' = withManager +{-# DEPRECATED withManager' "This function is the same as 'withManager' since version 0.3.0" #-} -ignoreSync :: E.SomeException -> IO () -ignoreSync se - | isAsyncException se = E.throwIO se - | otherwise = return () +#if defined(mingw32_HOST_OS) +getTimerManager :: IO EV.Manager +getTimerManager = EV.getSystemManager +#else +getTimerManager :: IO EV.TimerManager +getTimerManager = EV.getSystemTimerManager +#endif diff --git a/time-manager.cabal b/time-manager.cabal --- a/time-manager.cabal +++ b/time-manager.cabal @@ -1,26 +1,31 @@ -Name: time-manager -Version: 0.2.4 -Synopsis: Scalable timer -License: MIT -License-file: LICENSE -Author: Michael Snoyman and Kazu Yamamoto -Maintainer: kazu@iij.ad.jp -Homepage: http://github.com/yesodweb/wai -Category: System -Build-Type: Simple -Cabal-Version: >=1.10 -Stability: Stable -Description: Scalable timer functions provided by a timer manager - and thread management functions to prevent thread - leak by a thread manager. -Extra-Source-Files: ChangeLog.md +cabal-version: >=1.10 +name: time-manager +version: 0.3.0 +license: MIT +license-file: LICENSE +maintainer: kazu@iij.ad.jp +author: Michael Snoyman and Kazu Yamamoto +stability: Stable +homepage: http://github.com/yesodweb/wai +synopsis: Scalable timer +description: + Scalable timer functions provided by a timer manager + and thread management functions to prevent thread + leak by a thread manager. -Library - Build-Depends: base >= 4.12 && < 5 - , auto-update >= 0.2 && < 0.3 - , containers - , stm - Default-Language: Haskell2010 - Exposed-modules: System.TimeManager - Exposed-modules: System.ThreadManager - Ghc-Options: -Wall +category: System +build-type: Simple +extra-source-files: ChangeLog.md + +library + exposed-modules: + System.TimeManager + System.ThreadManager + + default-language: Haskell2010 + default-extensions: Strict StrictData + ghc-options: -Wall + build-depends: + base >=4.12 && <5, + containers, + stm