From 00bb1e62abc1d14273ad7be56606764d08cd2102 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 12 Dec 2024 12:45:01 +0900 Subject: [PATCH 1/9] removing Util.hs --- auto-update/Control/AutoUpdate/Util.hs | 24 ------------------------ auto-update/Control/Reaper.hs | 3 +-- auto-update/auto-update.cabal | 1 - 3 files changed, 1 insertion(+), 27 deletions(-) delete mode 100644 auto-update/Control/AutoUpdate/Util.hs diff --git a/auto-update/Control/AutoUpdate/Util.hs b/auto-update/Control/AutoUpdate/Util.hs deleted file mode 100644 index 7e2348911..000000000 --- a/auto-update/Control/AutoUpdate/Util.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Control.AutoUpdate.Util ( - atomicModifyIORef', -) where - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif - -#if MIN_VERSION_base(4,6,0) -import Data.IORef (atomicModifyIORef') -#else -import Data.IORef (IORef, atomicModifyIORef) --- | Strict version of 'atomicModifyIORef'. This forces both the value stored --- in the 'IORef' as well as the value returned. -atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b -atomicModifyIORef' ref f = do - c <- atomicModifyIORef ref - (\x -> let (a, b) = f x -- Lazy application of "f" - in (a, a `seq` b)) -- Lazy application of "seq" - -- The following forces "a `seq` b", so it also forces "f x". - c `seq` return c -#endif diff --git a/auto-update/Control/Reaper.hs b/auto-update/Control/Reaper.hs index 34db68a75..ef08bae00 100644 --- a/auto-update/Control/Reaper.hs +++ b/auto-update/Control/Reaper.hs @@ -42,11 +42,10 @@ module Control.Reaper ( mkListAction, ) where -import Control.AutoUpdate.Util (atomicModifyIORef') import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) import Control.Exception (mask_) import Control.Reaper.Internal -import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import GHC.Conc.Sync (labelThread) -- | Settings for creating a reaper. This type has two parameters: diff --git a/auto-update/auto-update.cabal b/auto-update/auto-update.cabal index 4316e1c0e..06a00da90 100644 --- a/auto-update/auto-update.cabal +++ b/auto-update/auto-update.cabal @@ -20,7 +20,6 @@ library Control.Debounce.Internal Control.Reaper Control.Reaper.Internal - other-modules: Control.AutoUpdate.Util build-depends: base >= 4.12 && < 5 default-language: Haskell2010 if impl(ghc >= 8) From 756194dcf46a65c249158601ed137262385cac77 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 12 Dec 2024 13:00:29 +0900 Subject: [PATCH 2/9] thread-less AutoUpdate --- auto-update/Control/AutoUpdate.hs | 191 +-------------------- auto-update/Control/AutoUpdate/Internal.hs | 163 ++++++++++++++++++ auto-update/auto-update.cabal | 4 +- 3 files changed, 171 insertions(+), 187 deletions(-) create mode 100644 auto-update/Control/AutoUpdate/Internal.hs diff --git a/auto-update/Control/AutoUpdate.hs b/auto-update/Control/AutoUpdate.hs index 0c67a3be4..a07692df5 100644 --- a/auto-update/Control/AutoUpdate.hs +++ b/auto-update/Control/AutoUpdate.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE CPP #-} - --- | In a multithreaded environment, running actions on a regularly scheduled --- background thread can dramatically improve performance. +-- | In a multithreaded environment, sharing results of actions can dramatically improve performance. -- For example, web servers need to return the current time with each HTTP response. -- For a high-volume server, it's much faster for a dedicated thread to run every -- second, and write the current time to a shared 'IORef', than it is for each @@ -43,187 +40,9 @@ module Control.AutoUpdate ( -- * Creation mkAutoUpdate, mkAutoUpdateWithModify, -) where - -#if __GLASGOW_HASKELL__ < 709 -import Control.Applicative ((<*>)) -#endif -import Control.Concurrent (forkIO, threadDelay) -import Control.Concurrent.MVar ( - newEmptyMVar, - putMVar, - readMVar, - takeMVar, - tryPutMVar, - ) -import Control.Exception ( - SomeException, - catch, - mask_, - throw, - try, - ) -import Control.Monad (void) -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Maybe (fromMaybe) -import GHC.Conc.Sync (labelThread) - --- | Default value for creating an 'UpdateSettings'. --- --- @since 0.1.0 -defaultUpdateSettings :: UpdateSettings () -defaultUpdateSettings = - UpdateSettings - { updateFreq = 1000000 - , updateSpawnThreshold = 3 - , updateAction = return () - , updateThreadName = "AutoUpdate" - } - --- | Settings to control how values are updated. --- --- This should be constructed using 'defaultUpdateSettings' and record --- update syntax, e.g.: --- --- @ --- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' } --- @ --- --- @since 0.1.0 -data UpdateSettings a = UpdateSettings - { updateFreq :: Int - -- ^ Microseconds between update calls. Same considerations as - -- 'threadDelay' apply. - -- - -- Default: 1 second (1000000) - -- - -- @since 0.1.0 - , updateSpawnThreshold :: Int - -- ^ NOTE: This value no longer has any effect, since worker threads are - -- dedicated instead of spawned on demand. - -- - -- Previously, this determined how many times the data must be requested - -- before we decide to spawn a dedicated thread. - -- - -- Default: 3 - -- - -- @since 0.1.0 - , updateAction :: IO a - -- ^ Action to be performed to get the current value. - -- - -- Default: does nothing. - -- - -- @since 0.1.0 - , updateThreadName :: String - -- ^ Label of the thread being forked. - -- - -- Default: @"AutoUpdate"@ - -- - -- @since 0.2.2 - } - --- | Generate an action which will either read from an automatically --- updated value, or run the update action in the current thread. --- --- @since 0.1.0 -mkAutoUpdate :: UpdateSettings a -> IO (IO a) -mkAutoUpdate us = mkAutoUpdateHelper us Nothing - --- | Generate an action which will either read from an automatically --- updated value, or run the update action in the current thread if --- the first time or the provided modify action after that. --- --- @since 0.1.4 -mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) -mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f) - -mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a) -mkAutoUpdateHelper us updateActionModify = do - -- A baton to tell the worker thread to generate a new value. - needsRunning <- newEmptyMVar - - -- The initial response variable. Response variables allow the requesting - -- thread to block until a value is generated by the worker thread. - responseVar0 <- newEmptyMVar - - -- The current value, if available. We start off with a Left value - -- indicating no value is available, and the above-created responseVar0 to - -- give a variable to block on. - currRef <- newIORef $ Left responseVar0 - - -- This is used to set a value in the currRef variable when the worker - -- thread exits. In reality, that value should never be used, since the - -- worker thread exiting only occurs if an async exception is thrown, which - -- should only occur if there are no references to needsRunning left. - -- However, this handler will make error messages much clearer if there's a - -- bug in the implementation. - let fillRefOnExit f = do - eres <- try f - case eres of - Left e -> - writeIORef currRef $ - error $ - "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: " - ++ show (e :: SomeException) - Right () -> - writeIORef currRef $ - error $ - "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, " - ++ "which should be impossible due to usage of infinite loop" - - -- fork the worker thread immediately. Note that we mask async exceptions, - -- but *not* in an uninterruptible manner. This will allow a - -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take - -- down this thread when all references to the returned function are - -- garbage collected, and therefore there is no thread that can fill the - -- needsRunning MVar. - -- - -- Note that since we throw away the ThreadId of this new thread and never - -- calls myThreadId, normal async exceptions can never be thrown to it, - -- only RTS exceptions. - tid <- mask_ $ forkIO $ fillRefOnExit $ do - -- This infinite loop makes up out worker thread. It takes an a - -- responseVar value where the next value should be putMVar'ed to for - -- the benefit of any requesters currently blocked on it. - let loop responseVar maybea = do - -- block until a value is actually needed - takeMVar needsRunning - - -- new value requested, so run the updateAction - a <- catchSome $ fromMaybe (updateAction us) (updateActionModify <*> maybea) - - -- we got a new value, update currRef and lastValue - writeIORef currRef $ Right a - putMVar responseVar a - - -- delay until we're needed again - threadDelay $ updateFreq us - - -- delay's over. create a new response variable and set currRef - -- to use it, so that the next requester will block on that - -- variable. Then loop again with the updated response - -- variable. - responseVar' <- newEmptyMVar - writeIORef currRef $ Left responseVar' - loop responseVar' (Just a) - - -- Kick off the loop, with the initial responseVar0 variable. - loop responseVar0 Nothing - labelThread tid $ updateThreadName us - return $ do - mval <- readIORef currRef - case mval of - Left responseVar -> do - -- no current value, force the worker thread to run... - void $ tryPutMVar needsRunning () +) +where - -- and block for the result from the worker - readMVar responseVar - -- we have a current value, use it - Right val -> return val +-- GHC packages --- | Turn a runtime exception into an impure exception, so that all 'IO' --- actions will complete successfully. This simply defers the exception until --- the value is forced. -catchSome :: IO a -> IO a -catchSome act = Control.Exception.catch act $ \e -> return $ throw (e :: SomeException) +import Control.AutoUpdate.Internal diff --git a/auto-update/Control/AutoUpdate/Internal.hs b/auto-update/Control/AutoUpdate/Internal.hs new file mode 100644 index 000000000..f76399def --- /dev/null +++ b/auto-update/Control/AutoUpdate/Internal.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE RecordWildCards #-} + +module Control.AutoUpdate.Internal ( + -- * Type + UpdateSettings (..), + defaultUpdateSettings, + + -- * Creation + mkAutoUpdate, + mkAutoUpdateWithModify, + + -- * Debugging + mkClosableAutoUpdate, + mkClosableAutoUpdate', + UpdateState (..), +) +where + +-- GHC packages + +import Control.Concurrent.STM +import Control.Monad +import Data.IORef +import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) + +-- | Default value for creating an 'UpdateSettings'. +-- +-- @since 0.1.0 +defaultUpdateSettings :: UpdateSettings () +defaultUpdateSettings = + UpdateSettings + { updateFreq = 1000000 + , updateSpawnThreshold = 3 + , updateAction = return () + , updateThreadName = "AutoUpdate" + } + +-- | Settings to control how values are updated. +-- +-- This should be constructed using 'defaultUpdateSettings' and record +-- update syntax, e.g.: +-- +-- @ +-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' } +-- @ +-- +-- @since 0.1.0 +data UpdateSettings a = UpdateSettings + { updateFreq :: Int + -- ^ Microseconds between update calls. Same considerations as + -- 'threadDelay' apply. + -- + -- Default: 1000000 microseconds (1 second) + -- + -- @since 0.1.0 + , updateSpawnThreshold :: Int + -- ^ Obsoleted field. + -- + -- @since 0.1.0 + , updateAction :: IO a + -- ^ Action to be performed to get the current value. + -- + -- Default: does nothing. + -- + -- @since 0.1.0 + , updateThreadName :: String + -- ^ Label of the thread being forked. + -- + -- Default: @"AutoUpdate"@ + -- + -- @since 0.2.2 + } + +-- | Generate an action which will either read from an automatically +-- updated value, or run the update action in the current thread. +-- +-- @since 0.1.0 +mkAutoUpdate :: UpdateSettings a -> IO (IO a) +mkAutoUpdate settings = fst <$> mkClosableAutoUpdate settings + +-- $setup +-- >>> :set -XNumericUnderscores +-- >>> import Control.Concurrent + +-- | +-- >>> iref <- newIORef (0 :: Int) +-- >>> action = modifyIORef iref (+ 1) >> readIORef iref +-- >>> (getValue, closeState) <- mkClosableAutoUpdate $ defaultUpdateSettings { updateFreq = 200_000, updateAction = action } +-- >>> getValue +-- 1 +-- >>> threadDelay 100_000 >> getValue +-- 1 +-- >>> threadDelay 200_000 >> getValue +-- 2 +-- >>> closeState +mkClosableAutoUpdate :: UpdateSettings a -> IO (IO a, IO ()) +mkClosableAutoUpdate = mkAutoUpdateThings $ \g c _ -> (g, c) + +-- | provide `UpdateState` for debugging +mkClosableAutoUpdate' :: UpdateSettings a -> IO (IO a, IO (), UpdateState a) +mkClosableAutoUpdate' = mkAutoUpdateThings (,,) + +mkAutoUpdateThings + :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b +mkAutoUpdateThings mk settings = do + us <- openUpdateState settings + pure $ mk (getUpdateResult us) (closeUpdateState us) us + +-------------------------------------------------------------------------------- + +{- FOURMOLU_DISABLE -} +data UpdateState a = + UpdateState + { usUpdateAction_ :: IO a + , usLastResult_ :: IORef a + , usIntervalMicro_ :: Int + , usTimeHasCome_ :: TVar Bool + , usDeleteTimeout_ :: IORef (IO ()) + } +{- FOURMOLU_ENABLE -} + +mkDeleteTimeout :: TVar Bool -> Int -> IO (IO ()) +mkDeleteTimeout thc micro = do + mgr <- getSystemTimerManager + key <- registerTimeout mgr micro (atomically $ writeTVar thc True) + pure $ unregisterTimeout mgr key + +openUpdateState :: UpdateSettings a -> IO (UpdateState a) +openUpdateState UpdateSettings{..} = do + thc <- newTVarIO False + UpdateState updateAction + <$> (newIORef =<< updateAction) + <*> pure updateFreq + <*> pure thc + <*> (newIORef =<< mkDeleteTimeout thc updateFreq) + +closeUpdateState :: UpdateState a -> IO () +closeUpdateState UpdateState{..} = do + delete <- readIORef usDeleteTimeout_ + delete + +onceOnTimeHasCome :: UpdateState a -> IO () -> IO () +onceOnTimeHasCome UpdateState{..} action = do + action' <- atomically $ do + timeHasCome <- readTVar usTimeHasCome_ + when timeHasCome $ writeTVar usTimeHasCome_ False + pure $ when timeHasCome action + action' + +getUpdateResult :: UpdateState a -> IO a +getUpdateResult us@UpdateState{..} = do + onceOnTimeHasCome us $ do + writeIORef usLastResult_ =<< usUpdateAction_ + writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_ + readIORef usLastResult_ + +-- | Generate an action which will either read from an automatically +-- updated value, or run the update action in the current thread if +-- the first time or the provided modify action after that. +-- +-- @since 0.1.4 +mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) +mkAutoUpdateWithModify us f = undefined diff --git a/auto-update/auto-update.cabal b/auto-update/auto-update.cabal index 06a00da90..8242eeb08 100644 --- a/auto-update/auto-update.cabal +++ b/auto-update/auto-update.cabal @@ -16,11 +16,13 @@ cabal-version: >=1.10 library ghc-options: -Wall exposed-modules: Control.AutoUpdate + Control.AutoUpdate.Internal Control.Debounce Control.Debounce.Internal Control.Reaper Control.Reaper.Internal - build-depends: base >= 4.12 && < 5 + build-depends: base >= 4.12 && < 5, + stm default-language: Haskell2010 if impl(ghc >= 8) default-extensions: Strict StrictData From 37a360d5fd9bee563ede844d763da13b04df8152 Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Fri, 13 Dec 2024 19:41:50 +0900 Subject: [PATCH 3/9] refactor, re-use mkAutoupdateThings --- auto-update/Control/AutoUpdate/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/auto-update/Control/AutoUpdate/Internal.hs b/auto-update/Control/AutoUpdate/Internal.hs index f76399def..e030414fe 100644 --- a/auto-update/Control/AutoUpdate/Internal.hs +++ b/auto-update/Control/AutoUpdate/Internal.hs @@ -76,7 +76,7 @@ data UpdateSettings a = UpdateSettings -- -- @since 0.1.0 mkAutoUpdate :: UpdateSettings a -> IO (IO a) -mkAutoUpdate settings = fst <$> mkClosableAutoUpdate settings +mkAutoUpdate = mkAutoUpdateThings $ \g _ _ -> g -- $setup -- >>> :set -XNumericUnderscores From 7f44618a7f34a673933d9e4f25268a684f325f4b Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Fri, 13 Dec 2024 20:26:05 +0900 Subject: [PATCH 4/9] move mkAutoUpdateWithModify template --- auto-update/Control/AutoUpdate/Internal.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/auto-update/Control/AutoUpdate/Internal.hs b/auto-update/Control/AutoUpdate/Internal.hs index e030414fe..9611e2d87 100644 --- a/auto-update/Control/AutoUpdate/Internal.hs +++ b/auto-update/Control/AutoUpdate/Internal.hs @@ -78,6 +78,14 @@ data UpdateSettings a = UpdateSettings mkAutoUpdate :: UpdateSettings a -> IO (IO a) mkAutoUpdate = mkAutoUpdateThings $ \g _ _ -> g +-- | Generate an action which will either read from an automatically +-- updated value, or run the update action in the current thread if +-- the first time or the provided modify action after that. +-- +-- @since 0.1.4 +mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) +mkAutoUpdateWithModify us f = undefined + -- $setup -- >>> :set -XNumericUnderscores -- >>> import Control.Concurrent @@ -153,11 +161,3 @@ getUpdateResult us@UpdateState{..} = do writeIORef usLastResult_ =<< usUpdateAction_ writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_ readIORef usLastResult_ - --- | Generate an action which will either read from an automatically --- updated value, or run the update action in the current thread if --- the first time or the provided modify action after that. --- --- @since 0.1.4 -mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) -mkAutoUpdateWithModify us f = undefined From 943bd7cab1b238ee25188a02e5d88fc55db10486 Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Fri, 13 Dec 2024 19:52:18 +0900 Subject: [PATCH 5/9] add prev-value arg to usUpdateAction_ --- auto-update/Control/AutoUpdate/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/auto-update/Control/AutoUpdate/Internal.hs b/auto-update/Control/AutoUpdate/Internal.hs index 9611e2d87..385546127 100644 --- a/auto-update/Control/AutoUpdate/Internal.hs +++ b/auto-update/Control/AutoUpdate/Internal.hs @@ -119,7 +119,7 @@ mkAutoUpdateThings mk settings = do {- FOURMOLU_DISABLE -} data UpdateState a = UpdateState - { usUpdateAction_ :: IO a + { usUpdateAction_ :: a -> IO a , usLastResult_ :: IORef a , usIntervalMicro_ :: Int , usTimeHasCome_ :: TVar Bool @@ -136,7 +136,7 @@ mkDeleteTimeout thc micro = do openUpdateState :: UpdateSettings a -> IO (UpdateState a) openUpdateState UpdateSettings{..} = do thc <- newTVarIO False - UpdateState updateAction + UpdateState (const updateAction) <$> (newIORef =<< updateAction) <*> pure updateFreq <*> pure thc @@ -158,6 +158,6 @@ onceOnTimeHasCome UpdateState{..} action = do getUpdateResult :: UpdateState a -> IO a getUpdateResult us@UpdateState{..} = do onceOnTimeHasCome us $ do - writeIORef usLastResult_ =<< usUpdateAction_ + writeIORef usLastResult_ =<< usUpdateAction_ =<< readIORef usLastResult_ writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_ readIORef usLastResult_ From 2084b9ba3f582433e9d31d0efe578ea1a0107ae1 Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Fri, 13 Dec 2024 20:24:59 +0900 Subject: [PATCH 6/9] extend mkAutoUpdateThings for with-modify --- auto-update/Control/AutoUpdate/Internal.hs | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/auto-update/Control/AutoUpdate/Internal.hs b/auto-update/Control/AutoUpdate/Internal.hs index 385546127..b4117437c 100644 --- a/auto-update/Control/AutoUpdate/Internal.hs +++ b/auto-update/Control/AutoUpdate/Internal.hs @@ -110,8 +110,13 @@ mkClosableAutoUpdate' = mkAutoUpdateThings (,,) mkAutoUpdateThings :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b -mkAutoUpdateThings mk settings = do - us <- openUpdateState settings +mkAutoUpdateThings mk settings@UpdateSettings{..} = + mkAutoUpdateThingsWithModify mk settings (const updateAction) + +mkAutoUpdateThingsWithModify + :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> (a -> IO a) -> IO b +mkAutoUpdateThingsWithModify mk settings update1 = do + us <- openUpdateState settings update1 pure $ mk (getUpdateResult us) (closeUpdateState us) us -------------------------------------------------------------------------------- @@ -133,10 +138,10 @@ mkDeleteTimeout thc micro = do key <- registerTimeout mgr micro (atomically $ writeTVar thc True) pure $ unregisterTimeout mgr key -openUpdateState :: UpdateSettings a -> IO (UpdateState a) -openUpdateState UpdateSettings{..} = do +openUpdateState :: UpdateSettings a -> (a -> IO a) -> IO (UpdateState a) +openUpdateState UpdateSettings{..} update1 = do thc <- newTVarIO False - UpdateState (const updateAction) + UpdateState update1 <$> (newIORef =<< updateAction) <*> pure updateFreq <*> pure thc From 428bb7e22e5c7762cb3c2a2b9689981056ff9115 Mon Sep 17 00:00:00 2001 From: Kei Hibino Date: Fri, 13 Dec 2024 20:37:22 +0900 Subject: [PATCH 7/9] impl mkAutoUpdateWithModify using extended def --- auto-update/Control/AutoUpdate/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/auto-update/Control/AutoUpdate/Internal.hs b/auto-update/Control/AutoUpdate/Internal.hs index b4117437c..aad40e1b1 100644 --- a/auto-update/Control/AutoUpdate/Internal.hs +++ b/auto-update/Control/AutoUpdate/Internal.hs @@ -84,7 +84,7 @@ mkAutoUpdate = mkAutoUpdateThings $ \g _ _ -> g -- -- @since 0.1.4 mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) -mkAutoUpdateWithModify us f = undefined +mkAutoUpdateWithModify us f = mkAutoUpdateThingsWithModify (\g _ _ -> g) us f -- $setup -- >>> :set -XNumericUnderscores From 780bc8a1360f90a1101e55b75c154285f58bb69a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 17 Dec 2024 05:24:40 +0900 Subject: [PATCH 8/9] rescuing Windows Windows does not provide GHC.Event, sigh. --- auto-update/Control/AutoUpdate.hs | 11 +- auto-update/Control/AutoUpdate/Event.hs | 79 ++++++++++++ auto-update/Control/AutoUpdate/Internal.hs | 73 +---------- auto-update/Control/AutoUpdate/Thread.hs | 133 +++++++++++++++++++++ auto-update/Control/AutoUpdate/Types.hs | 49 ++++++++ auto-update/auto-update.cabal | 7 +- 6 files changed, 276 insertions(+), 76 deletions(-) create mode 100644 auto-update/Control/AutoUpdate/Event.hs create mode 100644 auto-update/Control/AutoUpdate/Thread.hs create mode 100644 auto-update/Control/AutoUpdate/Types.hs diff --git a/auto-update/Control/AutoUpdate.hs b/auto-update/Control/AutoUpdate.hs index a07692df5..66b348efb 100644 --- a/auto-update/Control/AutoUpdate.hs +++ b/auto-update/Control/AutoUpdate.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + -- | In a multithreaded environment, sharing results of actions can dramatically improve performance. -- For example, web servers need to return the current time with each HTTP response. -- For a high-volume server, it's much faster for a dedicated thread to run every @@ -43,6 +45,9 @@ module Control.AutoUpdate ( ) where --- GHC packages - -import Control.AutoUpdate.Internal +#ifdef mingw32_HOST_OS +import Control.AutoUpdate.Thread +#else +import Control.AutoUpdate.Event +#endif +import Control.AutoUpdate.Types diff --git a/auto-update/Control/AutoUpdate/Event.hs b/auto-update/Control/AutoUpdate/Event.hs new file mode 100644 index 000000000..8f700d08c --- /dev/null +++ b/auto-update/Control/AutoUpdate/Event.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE RecordWildCards #-} + +module Control.AutoUpdate.Event ( + -- * Creation + mkAutoUpdate, + mkAutoUpdateWithModify, +) +where + +import Control.Concurrent.STM +import Control.Monad +import Data.IORef +import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) + +import Control.AutoUpdate.Internal +import Control.AutoUpdate.Types + +-- | Generate an action which will either read from an automatically +-- updated value, or run the update action in the current thread. +-- +-- @since 0.1.0 +mkAutoUpdate :: UpdateSettings a -> IO (IO a) +mkAutoUpdate = mkAutoUpdateThings $ \g _ _ -> g + +-- | Generate an action which will either read from an automatically +-- updated value, or run the update action in the current thread if +-- the first time or the provided modify action after that. +-- +-- @since 0.1.4 +mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) +mkAutoUpdateWithModify us f = mkAutoUpdateThingsWithModify (\g _ _ -> g) us f + +mkAutoUpdateThings + :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b +mkAutoUpdateThings mk settings@UpdateSettings{..} = + mkAutoUpdateThingsWithModify mk settings (const updateAction) + +mkAutoUpdateThingsWithModify + :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> (a -> IO a) -> IO b +mkAutoUpdateThingsWithModify mk settings update1 = do + us <- openUpdateState settings update1 + pure $ mk (getUpdateResult us) (closeUpdateState us) us + +-------------------------------------------------------------------------------- + +mkDeleteTimeout :: TVar Bool -> Int -> IO (IO ()) +mkDeleteTimeout thc micro = do + mgr <- getSystemTimerManager + key <- registerTimeout mgr micro (atomically $ writeTVar thc True) + pure $ unregisterTimeout mgr key + +openUpdateState :: UpdateSettings a -> (a -> IO a) -> IO (UpdateState a) +openUpdateState UpdateSettings{..} update1 = do + thc <- newTVarIO False + UpdateState update1 + <$> (newIORef =<< updateAction) + <*> pure updateFreq + <*> pure thc + <*> (newIORef =<< mkDeleteTimeout thc updateFreq) + +closeUpdateState :: UpdateState a -> IO () +closeUpdateState UpdateState{..} = do + delete <- readIORef usDeleteTimeout_ + delete + +onceOnTimeHasCome :: UpdateState a -> IO () -> IO () +onceOnTimeHasCome UpdateState{..} action = do + action' <- atomically $ do + timeHasCome <- readTVar usTimeHasCome_ + when timeHasCome $ writeTVar usTimeHasCome_ False + pure $ when timeHasCome action + action' + +getUpdateResult :: UpdateState a -> IO a +getUpdateResult us@UpdateState{..} = do + onceOnTimeHasCome us $ do + writeIORef usLastResult_ =<< usUpdateAction_ =<< readIORef usLastResult_ + writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_ + readIORef usLastResult_ diff --git a/auto-update/Control/AutoUpdate/Internal.hs b/auto-update/Control/AutoUpdate/Internal.hs index aad40e1b1..e6dadafc0 100644 --- a/auto-update/Control/AutoUpdate/Internal.hs +++ b/auto-update/Control/AutoUpdate/Internal.hs @@ -1,14 +1,6 @@ {-# LANGUAGE RecordWildCards #-} module Control.AutoUpdate.Internal ( - -- * Type - UpdateSettings (..), - defaultUpdateSettings, - - -- * Creation - mkAutoUpdate, - mkAutoUpdateWithModify, - -- * Debugging mkClosableAutoUpdate, mkClosableAutoUpdate', @@ -16,75 +8,12 @@ module Control.AutoUpdate.Internal ( ) where --- GHC packages - import Control.Concurrent.STM import Control.Monad import Data.IORef import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) --- | Default value for creating an 'UpdateSettings'. --- --- @since 0.1.0 -defaultUpdateSettings :: UpdateSettings () -defaultUpdateSettings = - UpdateSettings - { updateFreq = 1000000 - , updateSpawnThreshold = 3 - , updateAction = return () - , updateThreadName = "AutoUpdate" - } - --- | Settings to control how values are updated. --- --- This should be constructed using 'defaultUpdateSettings' and record --- update syntax, e.g.: --- --- @ --- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' } --- @ --- --- @since 0.1.0 -data UpdateSettings a = UpdateSettings - { updateFreq :: Int - -- ^ Microseconds between update calls. Same considerations as - -- 'threadDelay' apply. - -- - -- Default: 1000000 microseconds (1 second) - -- - -- @since 0.1.0 - , updateSpawnThreshold :: Int - -- ^ Obsoleted field. - -- - -- @since 0.1.0 - , updateAction :: IO a - -- ^ Action to be performed to get the current value. - -- - -- Default: does nothing. - -- - -- @since 0.1.0 - , updateThreadName :: String - -- ^ Label of the thread being forked. - -- - -- Default: @"AutoUpdate"@ - -- - -- @since 0.2.2 - } - --- | Generate an action which will either read from an automatically --- updated value, or run the update action in the current thread. --- --- @since 0.1.0 -mkAutoUpdate :: UpdateSettings a -> IO (IO a) -mkAutoUpdate = mkAutoUpdateThings $ \g _ _ -> g - --- | Generate an action which will either read from an automatically --- updated value, or run the update action in the current thread if --- the first time or the provided modify action after that. --- --- @since 0.1.4 -mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) -mkAutoUpdateWithModify us f = mkAutoUpdateThingsWithModify (\g _ _ -> g) us f +import Control.AutoUpdate.Types -- $setup -- >>> :set -XNumericUnderscores diff --git a/auto-update/Control/AutoUpdate/Thread.hs b/auto-update/Control/AutoUpdate/Thread.hs new file mode 100644 index 000000000..7cc4e8ac3 --- /dev/null +++ b/auto-update/Control/AutoUpdate/Thread.hs @@ -0,0 +1,133 @@ +module Control.AutoUpdate.Thread ( + -- * Creation + mkAutoUpdate, + mkAutoUpdateWithModify, +) where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.MVar ( + newEmptyMVar, + putMVar, + readMVar, + takeMVar, + tryPutMVar, + ) +import Control.Exception ( + SomeException, + catch, + mask_, + throw, + try, + ) +import Control.Monad (void) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Maybe (fromMaybe) +import GHC.Conc.Sync (labelThread) + +import Control.AutoUpdate.Types + +-- | Generate an action which will either read from an automatically +-- updated value, or run the update action in the current thread. +-- +-- @since 0.1.0 +mkAutoUpdate :: UpdateSettings a -> IO (IO a) +mkAutoUpdate us = mkAutoUpdateHelper us Nothing + +-- | Generate an action which will either read from an automatically +-- updated value, or run the update action in the current thread if +-- the first time or the provided modify action after that. +-- +-- @since 0.1.4 +mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) +mkAutoUpdateWithModify us f = mkAutoUpdateHelper us (Just f) + +mkAutoUpdateHelper :: UpdateSettings a -> Maybe (a -> IO a) -> IO (IO a) +mkAutoUpdateHelper us updateActionModify = do + -- A baton to tell the worker thread to generate a new value. + needsRunning <- newEmptyMVar + + -- The initial response variable. Response variables allow the requesting + -- thread to block until a value is generated by the worker thread. + responseVar0 <- newEmptyMVar + + -- The current value, if available. We start off with a Left value + -- indicating no value is available, and the above-created responseVar0 to + -- give a variable to block on. + currRef <- newIORef $ Left responseVar0 + + -- This is used to set a value in the currRef variable when the worker + -- thread exits. In reality, that value should never be used, since the + -- worker thread exiting only occurs if an async exception is thrown, which + -- should only occur if there are no references to needsRunning left. + -- However, this handler will make error messages much clearer if there's a + -- bug in the implementation. + let fillRefOnExit f = do + eres <- try f + case eres of + Left e -> + writeIORef currRef $ + error $ + "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: " + ++ show (e :: SomeException) + Right () -> + writeIORef currRef $ + error $ + "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, " + ++ "which should be impossible due to usage of infinite loop" + + -- fork the worker thread immediately. Note that we mask async exceptions, + -- but *not* in an uninterruptible manner. This will allow a + -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take + -- down this thread when all references to the returned function are + -- garbage collected, and therefore there is no thread that can fill the + -- needsRunning MVar. + -- + -- Note that since we throw away the ThreadId of this new thread and never + -- calls myThreadId, normal async exceptions can never be thrown to it, + -- only RTS exceptions. + tid <- mask_ $ forkIO $ fillRefOnExit $ do + -- This infinite loop makes up out worker thread. It takes an a + -- responseVar value where the next value should be putMVar'ed to for + -- the benefit of any requesters currently blocked on it. + let loop responseVar maybea = do + -- block until a value is actually needed + takeMVar needsRunning + + -- new value requested, so run the updateAction + a <- catchSome $ fromMaybe (updateAction us) (updateActionModify <*> maybea) + + -- we got a new value, update currRef and lastValue + writeIORef currRef $ Right a + putMVar responseVar a + + -- delay until we're needed again + threadDelay $ updateFreq us + + -- delay's over. create a new response variable and set currRef + -- to use it, so that the next requester will block on that + -- variable. Then loop again with the updated response + -- variable. + responseVar' <- newEmptyMVar + writeIORef currRef $ Left responseVar' + loop responseVar' (Just a) + + -- Kick off the loop, with the initial responseVar0 variable. + loop responseVar0 Nothing + labelThread tid $ updateThreadName us + return $ do + mval <- readIORef currRef + case mval of + Left responseVar -> do + -- no current value, force the worker thread to run... + void $ tryPutMVar needsRunning () + + -- and block for the result from the worker + readMVar responseVar + -- we have a current value, use it + Right val -> return val + +-- | Turn a runtime exception into an impure exception, so that all 'IO' +-- actions will complete successfully. This simply defers the exception until +-- the value is forced. +catchSome :: IO a -> IO a +catchSome act = Control.Exception.catch act $ \e -> return $ throw (e :: SomeException) diff --git a/auto-update/Control/AutoUpdate/Types.hs b/auto-update/Control/AutoUpdate/Types.hs new file mode 100644 index 000000000..e3e59c2cf --- /dev/null +++ b/auto-update/Control/AutoUpdate/Types.hs @@ -0,0 +1,49 @@ +module Control.AutoUpdate.Types where + +-- | Settings to control how values are updated. +-- +-- This should be constructed using 'defaultUpdateSettings' and record +-- update syntax, e.g.: +-- +-- @ +-- let settings = 'defaultUpdateSettings' { 'updateAction' = 'Data.Time.Clock.getCurrentTime' } +-- @ +-- +-- @since 0.1.0 +data UpdateSettings a = UpdateSettings + { updateFreq :: Int + -- ^ Microseconds between update calls. Same considerations as + -- 'threadDelay' apply. + -- + -- Default: 1000000 microseconds (1 second) + -- + -- @since 0.1.0 + , updateSpawnThreshold :: Int + -- ^ Obsoleted field. + -- + -- @since 0.1.0 + , updateAction :: IO a + -- ^ Action to be performed to get the current value. + -- + -- Default: does nothing. + -- + -- @since 0.1.0 + , updateThreadName :: String + -- ^ Label of the thread being forked. + -- + -- Default: @"AutoUpdate"@ + -- + -- @since 0.2.2 + } + +-- | Default value for creating an 'UpdateSettings'. +-- +-- @since 0.1.0 +defaultUpdateSettings :: UpdateSettings () +defaultUpdateSettings = + UpdateSettings + { updateFreq = 1000000 + , updateSpawnThreshold = 3 + , updateAction = return () + , updateThreadName = "AutoUpdate" + } diff --git a/auto-update/auto-update.cabal b/auto-update/auto-update.cabal index 8242eeb08..0b3cec474 100644 --- a/auto-update/auto-update.cabal +++ b/auto-update/auto-update.cabal @@ -16,11 +16,16 @@ cabal-version: >=1.10 library ghc-options: -Wall exposed-modules: Control.AutoUpdate - Control.AutoUpdate.Internal Control.Debounce Control.Debounce.Internal Control.Reaper Control.Reaper.Internal + other-modules: Control.AutoUpdate.Types + if os(windows) + other-modules: Control.AutoUpdate.Thread + else + exposed-modules: Control.AutoUpdate.Internal + other-modules: Control.AutoUpdate.Event build-depends: base >= 4.12 && < 5, stm default-language: Haskell2010 From d16ec9a5d17c8f9db4fb10a64d0f769df2880ded Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 18 Dec 2024 11:34:33 +0900 Subject: [PATCH 9/9] removing duplicated code --- auto-update/Control/AutoUpdate/Event.hs | 47 ++++++++++- auto-update/Control/AutoUpdate/Internal.hs | 90 +--------------------- 2 files changed, 48 insertions(+), 89 deletions(-) diff --git a/auto-update/Control/AutoUpdate/Event.hs b/auto-update/Control/AutoUpdate/Event.hs index 8f700d08c..e2a5e29cd 100644 --- a/auto-update/Control/AutoUpdate/Event.hs +++ b/auto-update/Control/AutoUpdate/Event.hs @@ -4,6 +4,11 @@ module Control.AutoUpdate.Event ( -- * Creation mkAutoUpdate, mkAutoUpdateWithModify, + + -- * Internal + UpdateState (..), + mkClosableAutoUpdate, + mkClosableAutoUpdate', ) where @@ -12,9 +17,10 @@ import Control.Monad import Data.IORef import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) -import Control.AutoUpdate.Internal import Control.AutoUpdate.Types +-------------------------------------------------------------------------------- + -- | Generate an action which will either read from an automatically -- updated value, or run the update action in the current thread. -- @@ -30,6 +36,21 @@ mkAutoUpdate = mkAutoUpdateThings $ \g _ _ -> g mkAutoUpdateWithModify :: UpdateSettings a -> (a -> IO a) -> IO (IO a) mkAutoUpdateWithModify us f = mkAutoUpdateThingsWithModify (\g _ _ -> g) us f +-------------------------------------------------------------------------------- + +{- FOURMOLU_DISABLE -} +data UpdateState a = + UpdateState + { usUpdateAction_ :: a -> IO a + , usLastResult_ :: IORef a + , usIntervalMicro_ :: Int + , usTimeHasCome_ :: TVar Bool + , usDeleteTimeout_ :: IORef (IO ()) + } +{- FOURMOLU_ENABLE -} + +-------------------------------------------------------------------------------- + mkAutoUpdateThings :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b mkAutoUpdateThings mk settings@UpdateSettings{..} = @@ -43,6 +64,30 @@ mkAutoUpdateThingsWithModify mk settings update1 = do -------------------------------------------------------------------------------- +-- $setup +-- >>> :set -XNumericUnderscores +-- >>> import Control.Concurrent + +-- | +-- >>> iref <- newIORef (0 :: Int) +-- >>> action = modifyIORef iref (+ 1) >> readIORef iref +-- >>> (getValue, closeState) <- mkClosableAutoUpdate $ defaultUpdateSettings { updateFreq = 200_000, updateAction = action } +-- >>> getValue +-- 1 +-- >>> threadDelay 100_000 >> getValue +-- 1 +-- >>> threadDelay 200_000 >> getValue +-- 2 +-- >>> closeState +mkClosableAutoUpdate :: UpdateSettings a -> IO (IO a, IO ()) +mkClosableAutoUpdate = mkAutoUpdateThings $ \g c _ -> (g, c) + +-- | provide `UpdateState` for debugging +mkClosableAutoUpdate' :: UpdateSettings a -> IO (IO a, IO (), UpdateState a) +mkClosableAutoUpdate' = mkAutoUpdateThings (,,) + +-------------------------------------------------------------------------------- + mkDeleteTimeout :: TVar Bool -> Int -> IO (IO ()) mkDeleteTimeout thc micro = do mgr <- getSystemTimerManager diff --git a/auto-update/Control/AutoUpdate/Internal.hs b/auto-update/Control/AutoUpdate/Internal.hs index e6dadafc0..bbda5c957 100644 --- a/auto-update/Control/AutoUpdate/Internal.hs +++ b/auto-update/Control/AutoUpdate/Internal.hs @@ -2,96 +2,10 @@ module Control.AutoUpdate.Internal ( -- * Debugging + UpdateState (..), mkClosableAutoUpdate, mkClosableAutoUpdate', - UpdateState (..), ) where -import Control.Concurrent.STM -import Control.Monad -import Data.IORef -import GHC.Event (getSystemTimerManager, registerTimeout, unregisterTimeout) - -import Control.AutoUpdate.Types - --- $setup --- >>> :set -XNumericUnderscores --- >>> import Control.Concurrent - --- | --- >>> iref <- newIORef (0 :: Int) --- >>> action = modifyIORef iref (+ 1) >> readIORef iref --- >>> (getValue, closeState) <- mkClosableAutoUpdate $ defaultUpdateSettings { updateFreq = 200_000, updateAction = action } --- >>> getValue --- 1 --- >>> threadDelay 100_000 >> getValue --- 1 --- >>> threadDelay 200_000 >> getValue --- 2 --- >>> closeState -mkClosableAutoUpdate :: UpdateSettings a -> IO (IO a, IO ()) -mkClosableAutoUpdate = mkAutoUpdateThings $ \g c _ -> (g, c) - --- | provide `UpdateState` for debugging -mkClosableAutoUpdate' :: UpdateSettings a -> IO (IO a, IO (), UpdateState a) -mkClosableAutoUpdate' = mkAutoUpdateThings (,,) - -mkAutoUpdateThings - :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> IO b -mkAutoUpdateThings mk settings@UpdateSettings{..} = - mkAutoUpdateThingsWithModify mk settings (const updateAction) - -mkAutoUpdateThingsWithModify - :: (IO a -> IO () -> UpdateState a -> b) -> UpdateSettings a -> (a -> IO a) -> IO b -mkAutoUpdateThingsWithModify mk settings update1 = do - us <- openUpdateState settings update1 - pure $ mk (getUpdateResult us) (closeUpdateState us) us - --------------------------------------------------------------------------------- - -{- FOURMOLU_DISABLE -} -data UpdateState a = - UpdateState - { usUpdateAction_ :: a -> IO a - , usLastResult_ :: IORef a - , usIntervalMicro_ :: Int - , usTimeHasCome_ :: TVar Bool - , usDeleteTimeout_ :: IORef (IO ()) - } -{- FOURMOLU_ENABLE -} - -mkDeleteTimeout :: TVar Bool -> Int -> IO (IO ()) -mkDeleteTimeout thc micro = do - mgr <- getSystemTimerManager - key <- registerTimeout mgr micro (atomically $ writeTVar thc True) - pure $ unregisterTimeout mgr key - -openUpdateState :: UpdateSettings a -> (a -> IO a) -> IO (UpdateState a) -openUpdateState UpdateSettings{..} update1 = do - thc <- newTVarIO False - UpdateState update1 - <$> (newIORef =<< updateAction) - <*> pure updateFreq - <*> pure thc - <*> (newIORef =<< mkDeleteTimeout thc updateFreq) - -closeUpdateState :: UpdateState a -> IO () -closeUpdateState UpdateState{..} = do - delete <- readIORef usDeleteTimeout_ - delete - -onceOnTimeHasCome :: UpdateState a -> IO () -> IO () -onceOnTimeHasCome UpdateState{..} action = do - action' <- atomically $ do - timeHasCome <- readTVar usTimeHasCome_ - when timeHasCome $ writeTVar usTimeHasCome_ False - pure $ when timeHasCome action - action' - -getUpdateResult :: UpdateState a -> IO a -getUpdateResult us@UpdateState{..} = do - onceOnTimeHasCome us $ do - writeIORef usLastResult_ =<< usUpdateAction_ =<< readIORef usLastResult_ - writeIORef usDeleteTimeout_ =<< mkDeleteTimeout usTimeHasCome_ usIntervalMicro_ - readIORef usLastResult_ +import Control.AutoUpdate.Event