@@ -24,7 +24,7 @@ import Control.Concurrent (forkIO, threadDelay)
2424import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar,
2525 takeMVar, tryPutMVar, tryTakeMVar)
2626import Control.Exception (SomeException, catch, throw, mask_, try)
27−import Control.Monad (forever, void)
27+import Control.Monad (void)
2828import Data.IORef (newIORef, readIORef, writeIORef)
2929
3030-- | Default value for creating an @UpdateSettings@.
@@ -79,15 +79,17 @@ data UpdateSettings a = UpdateSettings
7979-- Since 0.1.0
8080mkAutoUpdate :: UpdateSettings a -> IO (IO a)
8181mkAutoUpdate us = do
82− -- The current value, if available.
83− currRef <- newIORef Nothing
84−
8582 -- A baton to tell the worker thread to generate a new value.
8683 needsRunning <- newEmptyMVar
8784
88− -- The last value generated, to allow for blocking semantics when currRef
89− -- is Nothing.
90− lastValue <- newEmptyMVar
85+ -- The initial response variable. Response variables allow the requesting
86+ -- thread to block until a value is generated by the worker thread.
87+ responseVar0 <- newEmptyMVar
88+
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
9193
9294 -- This is used to set a value in the currRef variable when the worker
9395 -- thread exits. In reality, that value should never be used, since the
@@ -103,7 +105,7 @@ mkAutoUpdate us = do
103105 ++ (show (e :: SomeException))
104106 Right () -> writeIORef currRef $ error $
105107 "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"
107109
108110 -- fork the worker thread immediately. Note that we mask async exceptions,
109111 -- but *not* in an uninterruptible manner. This will allow a
@@ -115,37 +117,46 @@ mkAutoUpdate us = do
115117 -- Note that since we throw away the ThreadId of this new thread and never
116118 -- calls myThreadId, normal async exceptions can never be thrown to it,
117119 -- only RTS exceptions.
118− mask_ $ void $ forkIO $ fillRefOnExit $ forever $ do
119− -- but block until a value is actually needed
120− takeMVar needsRunning
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
125+ -- block until a value is actually needed
126+ takeMVar needsRunning
127+
128+ -- new value requested, so run the updateAction
129+ a <- catchSome $ updateAction us
121130
122− -- new value requested, so run the updateAction
123− a <- catchSome $ updateAction us
131+ -- we got a new value, update currRef and lastValue
132+ writeIORef currRef $ Right a
133+ putMVar responseVar a
124134
125− -- we got a new value, update currRef and lastValue
126− writeIORef currRef $ Just a
127− void $ tryTakeMVar lastValue
128− putMVar lastValue a
135+ -- delay until we're needed again
136+ threadDelay $ updateFreq us
129137
130− -- delay until we're needed again
131− threadDelay $ updateFreq us
138+ -- delay's over. create a new response variable and set currRef
139+ -- to use it, so that the next requester will block on that
140+ -- variable. Then loop again with the updated response
141+ -- variable.
142+ responseVar' <- newEmptyMVar
143+ writeIORef currRef $ Left responseVar'
144+ loop responseVar'
132145
133− -- delay's over, clear out currRef and lastValue so that demanding the
134− -- value again forces us to start work
135− writeIORef currRef Nothing
136− void $ takeMVar lastValue
146+ -- Kick off the loop, with the initial responseVar0 variable.
147+ loop responseVar0
137148
138149 return $ do
139150 mval <- readIORef currRef
140151 case mval of
141− -- we have a current value, use it
142− Just val -> return val
143− Nothing -> do
152+ Left responseVar -> do
144153 -- no current value, force the worker thread to run...
145154 void $ tryPutMVar needsRunning ()
146155
147156 -- 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
149160
150161-- | Turn a runtime exception into an impure exception, so that all @IO@
151162-- actions will complete successfully. This simply defers the exception until