@@ -27,11 +27,12 @@ import Control.Applicative ((<$>), (<*>))
2727import Control.AutoUpdate.Util (atomicModifyIORef')
2828import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay)
2929import Control.Exception (Exception, SomeException
30− ,assert, fromException, handle,throwIO, throwTo)
31−import Control.Monad (forever, join)
32−import Data.IORef (IORef, newIORef)
30+ ,assert, fromException, handle,throwIO, throwTo, throw, try, catch)
31+import Control.Monad (forever, join, void)
32+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
3333import Data.Typeable (Typeable)
3434import System.IO.Unsafe (unsafePerformIO)
35+import Prelude hiding (catch)
3536
3637-- | Default value for creating an @UpdateSettings@.
3738--
@@ -93,69 +94,28 @@ data Status a = AutoUpdated
9394-- Since 0.1.0
9495mkAutoUpdate :: UpdateSettings a -> IO (IO a)
9596mkAutoUpdate us = do
96− istatus <- newIORef $ ManualUpdates 0
97− return $! getCurrent us istatus
97+ used <- newIORef False
98+ ref <- newIORef $ error "mkAutoUpdate"
99+ writeIORef ref $ unsafePerformIO $ start us used ref
100+ return $ do
101+ writeIORef used True
102+ readIORef ref
98103
99−data Action a = Return a | Manual
100−
101−data Replaced = Replaced deriving (Show, Typeable)
102−instance Exception Replaced
103−
104−-- | Get the current value, either fed from an auto-update thread, or
105−-- computed manually in the current thread.
106−--
107−-- Since 0.1.0
108−getCurrent :: UpdateSettings a
109− -> IORef (Status a) -- ^ mutable state
110− -> IO a
111−getCurrent settings@UpdateSettings{..} istatus = do
112− ea <- atomicModifyIORef' istatus increment
113− case ea of
114− Return a -> return a
115− Manual -> updateAction
116− where
117− increment (AutoUpdated a cnt tid) = (AutoUpdated a (cnt + 1) tid, Return a)
118− increment (ManualUpdates i)
119− | i > updateSpawnThreshold =
120− let (a, tid) =
121− unsafePerformIO $ (,)
122− <$> updateAction
123− <*> forkIO (spawn settings istatus)
124− in (AutoUpdated a (i + 1) tid, Return a)
125− | otherwise = (ManualUpdates (i + 1), Manual)
126−
127−spawn :: UpdateSettings a -> IORef (Status a) -> IO ()
128−spawn UpdateSettings{..} istatus = handle (onErr istatus) $ forever $ do
129− threadDelay updateFreq
104+start settings@UpdateSettings{..} used ref = do
130105 a <- updateAction
131− join $ atomicModifyIORef' istatus $ turnToManual a
132− where
133− -- Normal case.
134− turnToManual a (AutoUpdated _ cnt tid)
135− | cnt >= 1 = (AutoUpdated a 0 tid, return ())
136− | otherwise = (ManualUpdates 0, stop)
137− -- This case must not happen.
138− turnToManual _ (ManualUpdates i) = assert False (ManualUpdates i, stop)
139−
140−onErr :: IORef (Status a) -> SomeException -> IO ()
141−onErr istatus ex = case fromException ex of
142− Just Replaced -> return () -- this thread is terminated
143− Nothing -> do
144− tid <- myThreadId
145− atomicModifyIORef' istatus $ clear tid
146− throwIO ex
147− where
148− -- In the race condition described above,
149− -- suppose thread A is running, and is killed by thread B.
150− -- Thread B then updates the IORef to refer to thread B.
151− -- Then thread A's exception handler fires.
152− -- We don't want to modify the IORef at all,
153− -- since it refers to thread B already.
154− -- Solution: only switch back to manual updates
155− -- if the IORef is pointing at the current thread.
156− clear tid (AutoUpdated _ _ tid') | tid == tid' = (ManualUpdates 0, ())
157− clear _ status = (status, ())
106+ void $ forkIO $
107+ let loop = do
108+ threadDelay updateFreq
109+ used' <- readIORef used
110+ if used'
111+ then do
112+ writeIORef used False
113+ a <- catchSome updateAction
114+ writeIORef ref a
115+ loop
116+ else writeIORef ref $ unsafePerformIO $ start settings used ref
117+ in loop
118+ return a
158119
159−-- | Throw an error to kill a thread.
160−stop :: IO a
161−stop = throwIO Replaced
120+catchSome :: IO a -> IO a
121+catchSome act = catch act $ \e -> return $ throw (e :: SomeException)