diff --git a/Control/AutoUpdate.hs b/Control/AutoUpdate.hs --- a/Control/AutoUpdate.hs +++ b/Control/AutoUpdate.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RecordWildCards #-} - -- | A common problem is the desire to have an action run at a scheduled -- interval, but only if it is needed. For example, instead of having -- every web request result in a new @getCurrentTime@ call, we'd like to @@ -25,9 +22,9 @@ import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar, - takeMVar, tryPutMVar, tryTakeMVar) -import Control.Exception (SomeException, catch, throw) -import Control.Monad (forever, void) + takeMVar, tryPutMVar) +import Control.Exception (SomeException, catch, throw, mask_, try) +import Control.Monad (void) import Data.IORef (newIORef, readIORef, writeIORef) -- | Default value for creating an @UpdateSettings@. @@ -82,48 +79,84 @@ -- Since 0.1.0 mkAutoUpdate :: UpdateSettings a -> IO (IO a) mkAutoUpdate us = do - -- The current value, if available. - currRef <- newIORef Nothing - -- A baton to tell the worker thread to generate a new value. needsRunning <- newEmptyMVar - -- The last value generated, to allow for blocking semantics when currRef - -- is Nothing. - lastValue <- newEmptyMVar + -- The initial response variable. Response variables allow the requesting + -- thread to block until a value is generated by the worker thread. + responseVar0 <- newEmptyMVar - -- fork the worker thread immediately... - void $ forkIO $ forever $ do - -- but block until a value is actually needed - takeMVar needsRunning + -- 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 - -- new value requested, so run the updateAction - a <- catchSome $ updateAction us + -- 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" - -- we got a new value, update currRef and lastValue - writeIORef currRef $ Just a - void $ tryTakeMVar lastValue - putMVar lastValue a + -- 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. + mask_ $ void $ 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 = do + -- block until a value is actually needed + takeMVar needsRunning - -- delay until we're needed again - threadDelay $ updateFreq us + -- new value requested, so run the updateAction + a <- catchSome $ updateAction us - -- delay's over, clear out currRef and lastValue so that demanding the - -- value again forces us to start work - writeIORef currRef Nothing - void $ takeMVar lastValue + -- 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' + + -- Kick off the loop, with the initial responseVar0 variable. + loop responseVar0 + return $ do mval <- readIORef currRef case mval of - -- we have a current value, use it - Just val -> return val - Nothing -> do + Left responseVar -> do -- no current value, force the worker thread to run... void $ tryPutMVar needsRunning () -- and block for the result from the worker - readMVar lastValue + 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 diff --git a/auto-update.cabal b/auto-update.cabal --- a/auto-update.cabal +++ b/auto-update.cabal @@ -1,5 +1,5 @@ name: auto-update -version: 0.1.1.4 +version: 0.1.1.5 synopsis: Efficiently run periodic, on-demand actions description: A common problem is the desire to have an action run at a scheduled interval, but only if it is needed. For example, instead of having every web request result in a new @getCurrentTime@ call, we'd like to have a single worker thread run every second, updating an @IORef@. However, if the request frequency is less than once per second, this is a pessimization, and worse, kills idle GC. @@ -16,6 +16,7 @@ cabal-version: >=1.10 library + ghc-options: -Wall exposed-modules: Control.AutoUpdate Control.Reaper other-modules: Control.AutoUpdate.Util