@@ -23,7 +23,7 @@ module Control.AutoUpdate (
23import Control.Concurrent (forkIO, threadDelay)
23import 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)
26−import Control.Exception (SomeException, catch, throw)
26+import Control.Exception (SomeException, catch, throw, mask_, try)
27import Control.Monad (forever, void)
27import Control.Monad (forever, void)
28import Data.IORef (newIORef, readIORef, writeIORef)
28import Data.IORef (newIORef, readIORef, writeIORef)
@@ -89,8 +89,33 @@ mkAutoUpdate us = do
89 -- is Nothing.
89 -- is Nothing.
90 lastValue <- newEmptyMVar
90 lastValue <- newEmptyMVar
92+ -- 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
94+ -- worker thread exiting only occurs if an async exception is thrown, which
95+ -- should only occur if there are no references to needsRunning left.
96+ -- However, this handler will make error messages much clearer if there's a
97+ -- bug in the implementation.
98+ let fillRefOnExit f = do
101+ Left e -> writeIORef currRef $ error $
102+ "Control.AutoUpdate.mkAutoUpdate: worker thread exited with exception: "
103+ ++ (show (e :: SomeException))
104+ Right () -> writeIORef currRef $ error $
105+ "Control.AutoUpdate.mkAutoUpdate: worker thread exited normally, "
106+ ++ "which should be impossible due to usage of forever"
92− -- fork the worker thread immediately...
108+ -- fork the worker thread immediately. Note that we mask async exceptions,
109+ -- but *not* in an uninterruptible manner. This will allow a
110+ -- BlockedIndefinitelyOnMVar exception to still be thrown, which will take
111+ -- down this thread when all references to the returned function are
112+ -- garbage collected, and therefore there is no thread that can fill the
113+ -- needsRunning MVar.
115+ -- 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,
117+ -- only RTS exceptions.
93− void $ forkIO $ forever $ do
118+ mask_ $ void $ forkIO $ fillRefOnExit $ forever $ do
94 -- but block until a value is actually needed
119 -- but block until a value is actually needed
95 takeMVar needsRunning
120 takeMVar needsRunning