@@ -24,7 +24,7 @@ import Control.Concurrent (forkIO, threadDelay)
24import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
24import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
25 takeMVar, tryPutMVar, tryTakeMVar)
25 takeMVar, tryPutMVar, tryTakeMVar)
26import Control.Exception (SomeException, catch, throw, mask_, try)
26import Control.Exception (SomeException, catch, throw, mask_, try)
27−import Control.Monad (forever, void)
27+import Control.Monad (void)
28import Data.IORef (newIORef, readIORef, writeIORef)
28import Data.IORef (newIORef, readIORef, writeIORef)
30-- | Default value for creating an @UpdateSettings@.
30-- | Default value for creating an @UpdateSettings@.
@@ -79,15 +79,17 @@ data UpdateSettings a = UpdateSettings
79-- Since 0.1.0
79-- Since 0.1.0
80mkAutoUpdate :: UpdateSettings a -> IO (IO a)
80mkAutoUpdate :: UpdateSettings a -> IO (IO a)
81mkAutoUpdate us = do
81mkAutoUpdate us = do
82− -- The current value, if available.
83− currRef <- newIORef Nothing
85 -- A baton to tell the worker thread to generate a new value.
82 -- A baton to tell the worker thread to generate a new value.
86 needsRunning <- newEmptyMVar
83 needsRunning <- newEmptyMVar
88− -- The last value generated, to allow for blocking semantics when currRef
85+ -- The initial response variable. Response variables allow the requesting
89− -- is Nothing.
86+ -- thread to block until a value is generated by the worker thread.
90− lastValue <- newEmptyMVar
87+ responseVar0 <- newEmptyMVar
89+ -- The current value, if available. We start off with a Left value
90+ -- indicating no value is available, and the above-created responseVar0 to
91+ -- give a variable to block on.
92+ currRef <- newIORef $ Left responseVar0
92 -- This is used to set a value in the currRef variable when the worker
94 -- This is used to set a value in the currRef variable when the worker
93 -- thread exits. In reality, that value should never be used, since the
95 -- thread exits. In reality, that value should never be used, since the
@@ -103,7 +105,7 @@ mkAutoUpdate us = do
103 ++ (show (e :: SomeException))
105 ++ (show (e :: SomeException))
104 Right () -> writeIORef currRef $ error $
106 Right () -> writeIORef currRef $ error $
105 "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
107 "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
106− ++ "which should be impossible due to usage of forever"
108+ ++ "which should be impossible due to usage of infinite loop"
108 -- fork the worker thread immediately. Note that we mask async exceptions,
110 -- fork the worker thread immediately. Note that we mask async exceptions,
109 -- but *not* in an uninterruptible manner. This will allow a
111 -- but *not* in an uninterruptible manner. This will allow a
@@ -115,37 +117,46 @@ mkAutoUpdate us = do
115 -- Note that since we throw away the ThreadId of this new thread and never
117 -- Note that since we throw away the ThreadId of this new thread and never
116 -- calls myThreadId, normal async exceptions can never be thrown to it,
118 -- calls myThreadId, normal async exceptions can never be thrown to it,
117 -- only RTS exceptions.
119 -- only RTS exceptions.
118− mask_ $ void $ forkIO $ fillRefOnExit $ forever $ do
120+ mask_ $ void $ forkIO $ fillRefOnExit $ do
121+ -- This infinite loop makes up out worker thread. It takes an a
122+ -- responseVar value where the next value should be putMVar'ed to for
123+ -- the benefit of any requesters currently blocked on it.
124+ let loop responseVar = do
119− -- but block until a value is actually needed
125+ -- block until a value is actually needed
120− takeMVar needsRunning
126+ takeMVar needsRunning
128+ -- new value requested, so run the updateAction
129+ a <- catchSome $ updateAction us
122− -- new value requested, so run the updateAction
131+ -- we got a new value, update currRef and lastValue
123− a <- catchSome $ updateAction us
132+ writeIORef currRef $ Right a
133+ putMVar responseVar a
125− -- we got a new value, update currRef and lastValue
135+ -- delay until we're needed again
126− writeIORef currRef $ Just a
136+ threadDelay $ updateFreq us
127− void $ tryTakeMVar lastValue
130− -- delay until we're needed again
138+ -- delay's over. create a new response variable and set currRef
131− threadDelay $ updateFreq us
139+ -- to use it, so that the next requester will block on that
140+ -- variable. Then loop again with the updated response
142+ responseVar' <- newEmptyMVar
143+ writeIORef currRef $ Left responseVar'
133− -- delay's over, clear out currRef and lastValue so that demanding the
146+ -- Kick off the loop, with the initial responseVar0 variable.
134− -- value again forces us to start work
147+ loop responseVar0
135− writeIORef currRef Nothing
136− void $ takeMVar lastValue
138 return $ do
149 return $ do
139 mval <- readIORef currRef
150 mval <- readIORef currRef
140 case mval of
151 case mval of
141− -- we have a current value, use it
152+ Left responseVar -> do
142− Just val -> return val
144 -- no current value, force the worker thread to run...
153 -- no current value, force the worker thread to run...
145 void $ tryPutMVar needsRunning ()
154 void $ tryPutMVar needsRunning ()
147 -- and block for the result from the worker
156 -- and block for the result from the worker
148− readMVar lastValue
157+ readMVar responseVar
158+ -- we have a current value, use it
159+ Right val -> return val
150-- | Turn a runtime exception into an impure exception, so that all @IO@
161-- | Turn a runtime exception into an impure exception, so that all @IO@
151-- actions will complete successfully. This simply defers the exception until
162-- actions will complete successfully. This simply defers the exception until