{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- | An alternative implementation of 'System.Timeout.timeout' for platforms -- (i.e. Windows) where the standard implementation is too expensive. -- -- The implementation provided here is for the special case where only one -- timeout is active at once. A concurrent implementation would be possible -- but is not currently needed. -- module Network.Mux.Timeout ( TimeoutFn , withTimeoutSerial , withTimeoutSerialNative , withTimeoutSerialAlternative ) where import Control.Exception (asyncExceptionFromException, asyncExceptionToException) import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer (MonadTimer, registerDelay) import qualified Control.Monad.Class.MonadTimer as MonadTimer -- | The type of the 'System.Timeout.timeout' function. -- type TimeoutFn m = forall a. DiffTime -> m a -> m (Maybe a) -- | A 'System.Timeout.timeout' that is reasonably efficient for all platforms. -- -- On Unix it uses exactly 'System.Timeout.timeout' and on Windows it uses -- 'withTimeoutSerialAlternative'. -- -- > withTimeoutSerial $ \timeout -> -- > -- now use timeout as one would use System.Timeout.timeout -- > -- but not concurrently! -- -- The implementation has a serial constraint: the body action that calls -- @timeout@ can /only do so from one thread at once/. -- withTimeoutSerial, withTimeoutSerialNative :: forall m b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b #if defined(mingw32_HOST_OS) withTimeoutSerial = withTimeoutSerialAlternative #else withTimeoutSerial :: (TimeoutFn m -> m b) -> m b withTimeoutSerial = (TimeoutFn m -> m b) -> m b forall (m :: * -> *) b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b withTimeoutSerialNative #endif -- | This version simply passes the native platform's 'MonadTimer.timeout'. -- withTimeoutSerialNative :: (TimeoutFn m -> m b) -> m b withTimeoutSerialNative TimeoutFn m -> m b body = TimeoutFn m -> m b body TimeoutFn m forall (m :: * -> *) a. MonadTimer m => DiffTime -> m a -> m (Maybe a) MonadTimer.timeout -- | An alternative implementation of 'System.Timeout.timeout' for platforms -- where the standard implementation is too expensive. -- -- > withTimeoutSerial $ \timeout -> -- > -- now use timeout as one would use System.Timeout.timeout -- > -- but not concurrently! -- -- This implementation has a serial constraint: the body action that calls -- @timeout@ can /only do so from one thread at once/. -- -- Further details for the curious: -- -- the problem with @System.Timeout.timeout@ is that (as of base 4.12) it has -- two implementations, one for Unix with the threaded RTS, and one for all -- other configurations. -- -- The Unix threaded RTS implementation is rather clever and very fast. In the -- normal case of no timeout, it only has to allocate a timer entry. Only in -- the case the timeout occurs does it allocate a 'forkIO' thread to do the -- potentially-blocking operation of sending the asynchronous exception to -- interrupt the action under timeout. -- -- The implementation for all other configurations has to allocate a 'forkIO' -- thread up front, whether or not the timeout fires. This is fine for many -- applications but not for network timers which have to be created and -- altered\/cancelled with very high frequency. -- -- The implementation here only relies upon 'threadDelay' which has an -- efficient implementation on all platforms. It uses a separate monitoring -- thread which will throw an exception to terminate the action if the -- timeout expires. This is why it uses the \"with\" style: because it keeps -- a monitoring thread over a region of execution that may use many timeouts. -- The cost of allocating this thread is amortised over all the timeouts used. -- -- This implementation is simplified by the constraint that the timeouts only -- be used serially. In addition, it has the limitation that timeouts may not -- always be detected promptly: e.g. a 10s timeout on an action that finishes -- immediately, followed by a 5s timeout on an action will only actually be -- interrupted after 10s. So it's possible that action with the 5s timeout runs -- for up to 10s. This is ok for many applications provided that the variance -- in timeouts is not too large and the timeouts don't need to be too tight. -- withTimeoutSerialAlternative :: forall m b. (MonadAsync m, MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => (TimeoutFn m -> m b) -> m b withTimeoutSerialAlternative :: (TimeoutFn m -> m b) -> m b withTimeoutSerialAlternative TimeoutFn m -> m b body = do -- State shared between the timeouts and the monitoring thread. MonitorState m monitorState <- m (MonitorState m) forall (m :: * -> *). MonadSTM m => m (MonitorState m) newMonitorState -- Run the monitoring thread but ensure it terminates when the body is done. m () -> (Async m () -> m b) -> m b forall (m :: * -> *) a b. MonadAsync m => m a -> (Async m a -> m b) -> m b withAsync (MonitorState m -> m () forall (m :: * -> *). (MonadFork m, MonadSTM m, MonadMonotonicTime m, MonadTimer m, MonadThrow (STM m)) => MonitorState m -> m () monitoringThread MonitorState m monitorState) ((Async m () -> m b) -> m b) -> (Async m () -> m b) -> m b forall a b. (a -> b) -> a -> b $ \Async m () _ -> -- Run the body and pass it the @timeout@ function. TimeoutFn m -> m b body (MonitorState m -> DiffTime -> m a -> m (Maybe a) forall (m :: * -> *) a. (MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => MonitorState m -> DiffTime -> m a -> m (Maybe a) timeout MonitorState m monitorState) -- | The state shared between the timeouts and the monitoring thread. -- data MonitorState m = MonitorState { -- written by timeout combinator, read and reset by monitoring thread MonitorState m -> TVar m (NextTimeout m) nextTimeoutVar :: !(TVar m (NextTimeout m)), -- written by monitoring thread, read by timeout combinator MonitorState m -> TVar m Time curDeadlineVar :: !(TVar m Time), -- written by timeout combinator, read and reset by monitoring thread MonitorState m -> TVar m Bool deadlineResetVar :: !(TVar m Bool) } data NextTimeout m = NoNextTimeout | NextTimeout !(ThreadId m) -- Which thread to interrupt !Time -- When to interrupt it !(TVar m TimeoutState) -- Synchronisation state newMonitorState :: MonadSTM m => m (MonitorState m) newMonitorState :: m (MonitorState m) newMonitorState = do TVar m (NextTimeout m) nextTimeoutVar <- NextTimeout m -> m (TVar m (NextTimeout m)) forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a) newTVarIO NextTimeout m forall (m :: * -> *). NextTimeout m NoNextTimeout TVar m Time curDeadlineVar <- Time -> m (TVar m Time) forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a) newTVarIO (DiffTime -> Time Time DiffTime 0) TVar m Bool deadlineResetVar <- Bool -> m (TVar m Bool) forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a) newTVarIO Bool False MonitorState m -> m (MonitorState m) forall (m :: * -> *) a. Monad m => a -> m a return MonitorState :: forall (m :: * -> *). TVar m (NextTimeout m) -> TVar m Time -> TVar m Bool -> MonitorState m MonitorState{TVar m Bool TVar m Time TVar m (NextTimeout m) deadlineResetVar :: TVar m Bool curDeadlineVar :: TVar m Time nextTimeoutVar :: TVar m (NextTimeout m) deadlineResetVar :: TVar m Bool curDeadlineVar :: TVar m Time nextTimeoutVar :: TVar m (NextTimeout m) ..} -- | An update to the shared monitor state to set a new timer. -- setNewTimer :: MonadSTM m => MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m () setNewTimer :: MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m () setNewTimer MonitorState{TVar m (NextTimeout m) nextTimeoutVar :: TVar m (NextTimeout m) nextTimeoutVar :: forall (m :: * -> *). MonitorState m -> TVar m (NextTimeout m) nextTimeoutVar, TVar m Time curDeadlineVar :: TVar m Time curDeadlineVar :: forall (m :: * -> *). MonitorState m -> TVar m Time curDeadlineVar, TVar m Bool deadlineResetVar :: TVar m Bool deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool deadlineResetVar} !ThreadId m tid !Time deadline !TVar m TimeoutState stateVar = STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ do TVar m (NextTimeout m) -> NextTimeout m -> STM m () forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m (NextTimeout m) nextTimeoutVar (ThreadId m -> Time -> TVar m TimeoutState -> NextTimeout m forall (m :: * -> *). ThreadId m -> Time -> TVar m TimeoutState -> NextTimeout m NextTimeout ThreadId m tid Time deadline TVar m TimeoutState stateVar) Time curDeadline <- TVar m Time -> STM m Time forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m Time curDeadlineVar -- If the timer deadline has moved backwards, notify the monitor thread -- so it can wake up and grab the next timeout Bool -> STM m () -> STM m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (Time deadline Time -> Time -> Bool forall a. Ord a => a -> a -> Bool < Time curDeadline) (STM m () -> STM m ()) -> STM m () -> STM m () forall a b. (a -> b) -> a -> b $ TVar m Bool -> Bool -> STM m () forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m Bool deadlineResetVar Bool True -- | A potentially blocking wait read side, so can block. -- readNextTimeout :: MonadSTM m => MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState) readNextTimeout :: MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState) readNextTimeout MonitorState{TVar m (NextTimeout m) nextTimeoutVar :: TVar m (NextTimeout m) nextTimeoutVar :: forall (m :: * -> *). MonitorState m -> TVar m (NextTimeout m) nextTimeoutVar, TVar m Time curDeadlineVar :: TVar m Time curDeadlineVar :: forall (m :: * -> *). MonitorState m -> TVar m Time curDeadlineVar, TVar m Bool deadlineResetVar :: TVar m Bool deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool deadlineResetVar} = do STM m (ThreadId m, Time, TVar m TimeoutState) -> m (ThreadId m, Time, TVar m TimeoutState) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (ThreadId m, Time, TVar m TimeoutState) -> m (ThreadId m, Time, TVar m TimeoutState)) -> STM m (ThreadId m, Time, TVar m TimeoutState) -> m (ThreadId m, Time, TVar m TimeoutState) forall a b. (a -> b) -> a -> b $ do NextTimeout m nextTimeout <- TVar m (NextTimeout m) -> STM m (NextTimeout m) forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m (NextTimeout m) nextTimeoutVar case NextTimeout m nextTimeout of NextTimeout m NoNextTimeout -> STM m (ThreadId m, Time, TVar m TimeoutState) forall (m :: * -> *) a. MonadSTM m => STM m a retry NextTimeout ThreadId m tid Time deadline TVar m TimeoutState stateVar -> do -- We've picked up the next timeout so reset to empty TVar m (NextTimeout m) -> NextTimeout m -> STM m () forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m (NextTimeout m) nextTimeoutVar NextTimeout m forall (m :: * -> *). NextTimeout m NoNextTimeout -- Update the current deadline var so the 'setNewTimer' can see what -- the current deadline we're waiting on is, so it can see if it -- ever needs to wake us up if it sets up a new timer with an earlier -- deadline. TVar m Time -> Time -> STM m () forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m Time curDeadlineVar Time deadline TVar m Bool -> Bool -> STM m () forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m Bool deadlineResetVar Bool False (ThreadId m, Time, TVar m TimeoutState) -> STM m (ThreadId m, Time, TVar m TimeoutState) forall (m :: * -> *) a. Monad m => a -> m a return (ThreadId m tid, Time deadline, TVar m TimeoutState stateVar) -- | Three normal states of the timeout, plus one pseudo state. We use these -- states to provide proper communication between the action thread and the -- monitoring thread. -- -- The valid transitions are from 'TimeoutPending' to 'TimeoutCancelled', and -- from 'TimeoutPending' to 'TimeoutFired'. Additionally there is a transition -- from 'TimeoutFired' to 'TimeoutTerminated'. -- data TimeoutState = TimeoutPending | TimeoutCancelled | TimeoutFired | TimeoutTerminated -- | Exception used by 'withTimeoutSerial' to terminate the action when the -- timeout occurs. -- data TimeoutException = TimeoutException deriving Int -> TimeoutException -> ShowS [TimeoutException] -> ShowS TimeoutException -> String (Int -> TimeoutException -> ShowS) -> (TimeoutException -> String) -> ([TimeoutException] -> ShowS) -> Show TimeoutException forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TimeoutException] -> ShowS $cshowList :: [TimeoutException] -> ShowS show :: TimeoutException -> String $cshow :: TimeoutException -> String showsPrec :: Int -> TimeoutException -> ShowS $cshowsPrec :: Int -> TimeoutException -> ShowS Show instance Exception TimeoutException where toException :: TimeoutException -> SomeException toException = TimeoutException -> SomeException forall e. Exception e => e -> SomeException asyncExceptionToException fromException :: SomeException -> Maybe TimeoutException fromException = SomeException -> Maybe TimeoutException forall e. Exception e => SomeException -> Maybe e asyncExceptionFromException -- | The @timeout@ action we pass to the body in 'withTimeoutSerial'. -- timeout :: forall m a. (MonadFork m, MonadMonotonicTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) => MonitorState m -> DiffTime -> m a -> m (Maybe a) timeout :: MonitorState m -> DiffTime -> m a -> m (Maybe a) timeout MonitorState m _ DiffTime delay m a action | DiffTime delay DiffTime -> DiffTime -> Bool forall a. Ord a => a -> a -> Bool < DiffTime 0 = a -> Maybe a forall a. a -> Maybe a Just (a -> Maybe a) -> m a -> m (Maybe a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> m a action timeout MonitorState m _ DiffTime delay m a _ | DiffTime delay DiffTime -> DiffTime -> Bool forall a. Eq a => a -> a -> Bool == DiffTime 0 = Maybe a -> m (Maybe a) forall (m :: * -> *) a. Monad m => a -> m a return Maybe a forall a. Maybe a Nothing timeout MonitorState m monitorState DiffTime delay m a action = -- We have to be very careful with async exceptions of course. ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a) forall (m :: * -> *) b. MonadMask m => ((forall a. m a -> m a) -> m b) -> m b mask (((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)) -> ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a) forall a b. (a -> b) -> a -> b $ \forall a. m a -> m a restore -> do -- Set up the timeout and pass it over to the monitoring thread. -- This overwrites any previous timeout. ThreadId m tid <- m (ThreadId m) forall (m :: * -> *). MonadThread m => m (ThreadId m) myThreadId TVar m TimeoutState timeoutStateVar <- TimeoutState -> m (TVar m TimeoutState) forall (m :: * -> *) a. MonadSTM m => a -> m (TVar m a) newTVarIO TimeoutState TimeoutPending Time now <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime let deadline :: Time deadline = DiffTime -> Time -> Time addTime DiffTime delay Time now MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m () forall (m :: * -> *). MonadSTM m => MonitorState m -> ThreadId m -> Time -> TVar m TimeoutState -> m () setNewTimer MonitorState m monitorState ThreadId m tid Time deadline TVar m TimeoutState timeoutStateVar -- Now we unmask exceptions to run the action. If we get the timeout -- exception then we drop straight down to the outer 'catch' handler. a result <- m a -> m a forall a. m a -> m a restore m a action -- The action completed without us getting an exception, but there's -- a race condition with the monitoringThread to resolve. It could be -- just about to send us an async exception when we drop out of the -- masked region, or worse, outside of the scope of the 'catch' handler. -- -- So we must synchronise with the monitoringThread to ensure that we -- know positively one way or the other whether the timeout exception is -- or is not going to be sent. -- -- We do that by having both this thread and the monitoringThread do -- an STM tx on the timeoutStateVar, to atomically move it into the -- cancelled or fired state, depending on which thread gets there first. -- So this is a race, but it's a race where we can positively establish -- the outcome. If this thread gets there first we move it to the -- cancelled state. If the monitoringThread gets there first it moves it -- to the fired state. -- -- This STM tx is not blocking, so we're guaranteed not to be interrupted -- while we have async exceptions masked. -- Bool timeoutFired <- STM m Bool -> m Bool forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool forall a b. (a -> b) -> a -> b $ do TimeoutState st <- TVar m TimeoutState -> STM m TimeoutState forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m TimeoutState timeoutStateVar case TimeoutState st of TimeoutState TimeoutFired -> Bool -> STM m Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool True TimeoutState TimeoutPending -> TVar m TimeoutState -> TimeoutState -> STM m () forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m TimeoutState timeoutStateVar TimeoutState TimeoutCancelled STM m () -> STM m Bool -> STM m Bool forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Bool -> STM m Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool False TimeoutState _ -> TimeoutAssertion -> STM m Bool forall (m :: * -> *) e a. (MonadSTM m, MonadThrow (STM m), Exception e) => e -> STM m a throwSTM TimeoutAssertion TimeoutImpossibleTimeoutState -- If we established that the monitoring thread is definitely not firing -- the timeout exception then we're done. -- -- If on the other hand we lost the race and the monitoring thread is -- about to come for us then it's crucial that we block and wait for -- our own demise, otherwise we could escape the scope of the outer -- 'catch' handler. -- -- We do that blocking wait with another STM tx on the timeoutStateVar, -- this time waiting for the monitoring thread to set it to the -- TimeoutTerminated state. But the monitoring thread only sets it to -- that state /after/ raising the async exception in this thread. So -- we will never actually reach that terminated state. -- -- Note also that blocking STM txs are points where async exceptions that -- are pending (due to our masked state) can be raised. Hence there is no -- need for us to unmask for this bit. -- if Bool -> Bool not Bool timeoutFired then Maybe a -> m (Maybe a) forall (m :: * -> *) a. Monad m => a -> m a return (a -> Maybe a forall a. a -> Maybe a Just a result) else STM m (Maybe a) -> m (Maybe a) forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m (Maybe a) -> m (Maybe a)) -> STM m (Maybe a) -> m (Maybe a) forall a b. (a -> b) -> a -> b $ do TimeoutState st <- TVar m TimeoutState -> STM m TimeoutState forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m TimeoutState timeoutStateVar case TimeoutState st of TimeoutState TimeoutFired -> STM m (Maybe a) forall (m :: * -> *) a. MonadSTM m => STM m a retry TimeoutState TimeoutTerminated -> TimeoutAssertion -> STM m (Maybe a) forall (m :: * -> *) e a. (MonadSTM m, MonadThrow (STM m), Exception e) => e -> STM m a throwSTM TimeoutAssertion TimeoutImpossibleReachedTerminated TimeoutState _ -> TimeoutAssertion -> STM m (Maybe a) forall (m :: * -> *) e a. (MonadSTM m, MonadThrow (STM m), Exception e) => e -> STM m a throwSTM TimeoutAssertion TimeoutImpossibleTimeoutState m (Maybe a) -> (TimeoutException -> m (Maybe a)) -> m (Maybe a) forall (m :: * -> *) e a. (MonadCatch m, Exception e) => m a -> (e -> m a) -> m a `catch` \TimeoutException TimeoutException -> Maybe a -> m (Maybe a) forall (m :: * -> *) a. Monad m => a -> m a return Maybe a forall a. Maybe a Nothing monitoringThread :: (MonadFork m, MonadSTM m, MonadMonotonicTime m, MonadTimer m, MonadThrow (STM m)) => MonitorState m -> m () monitoringThread :: MonitorState m -> m () monitoringThread monitorState :: MonitorState m monitorState@MonitorState{TVar m Bool deadlineResetVar :: TVar m Bool deadlineResetVar :: forall (m :: * -> *). MonitorState m -> TVar m Bool deadlineResetVar} = do ThreadId m threadId <- m (ThreadId m) forall (m :: * -> *). MonadThread m => m (ThreadId m) myThreadId ThreadId m -> String -> m () forall (m :: * -> *). MonadThread m => ThreadId m -> String -> m () labelThread ThreadId m threadId String "timeout-monitoring-thread" m () -> m () forall (f :: * -> *) a b. Applicative f => f a -> f b forever (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ do -- Grab the next timeout to consider (ThreadId m tid, Time deadline, TVar m TimeoutState timeoutStateVar) <- MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState) forall (m :: * -> *). MonadSTM m => MonitorState m -> m (ThreadId m, Time, TVar m TimeoutState) readNextTimeout MonitorState m monitorState -- Work out how long to wait for and do so. For already-expired timeouts -- this is in the past, leading to a negative delay. Time now <- m Time forall (m :: * -> *). MonadMonotonicTime m => m Time getMonotonicTime let delay :: DiffTime delay = Time -> Time -> DiffTime diffTime Time deadline Time now Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when (DiffTime delay DiffTime -> DiffTime -> Bool forall a. Ord a => a -> a -> Bool > DiffTime 0) (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ do TVar m Bool timerExpired <- DiffTime -> m (TVar m Bool) forall (m :: * -> *). MonadTimer m => DiffTime -> m (TVar m Bool) registerDelay DiffTime delay STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ -- Wait for either the timer to expire (TVar m Bool -> STM m Bool forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m Bool timerExpired STM m Bool -> (Bool -> STM m ()) -> STM m () forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Bool -> STM m () forall (m :: * -> *). MonadSTM m => Bool -> STM m () check) STM m () -> STM m () -> STM m () forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a `orElse` -- or to be notified that the timer deadline moved backwards (TVar m Bool -> STM m Bool forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m Bool deadlineResetVar STM m Bool -> (Bool -> STM m ()) -> STM m () forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= Bool -> STM m () forall (m :: * -> *). MonadSTM m => Bool -> STM m () check) -- Having woken up, we check to see if we need to send the timeout -- exception. If the timeoutStateVar we grabbed is still in the pending -- state after we have waited for the deadline then clearly it went over -- and we will send the timeout exception. -- -- As described above, there is a race between the timeout and the action -- completing and we have to establish which happens first. So this is -- the other side of that race. Here if we win the race we move to the -- TimeoutFired state. Bool cancelled <- STM m Bool -> m Bool forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m Bool -> m Bool) -> STM m Bool -> m Bool forall a b. (a -> b) -> a -> b $ do TimeoutState st <- TVar m TimeoutState -> STM m TimeoutState forall (m :: * -> *) a. MonadSTM m => TVar m a -> STM m a readTVar TVar m TimeoutState timeoutStateVar case TimeoutState st of TimeoutState TimeoutPending -> TVar m TimeoutState -> TimeoutState -> STM m () forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m TimeoutState timeoutStateVar TimeoutState TimeoutFired STM m () -> STM m Bool -> STM m Bool forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> Bool -> STM m Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool False TimeoutState TimeoutCancelled -> Bool -> STM m Bool forall (m :: * -> *) a. Monad m => a -> m a return Bool True TimeoutState _ -> TimeoutAssertion -> STM m Bool forall (m :: * -> *) e a. (MonadSTM m, MonadThrow (STM m), Exception e) => e -> STM m a throwSTM TimeoutAssertion TimeoutImpossibleMonitorState -- If it turns out that the timeout was cancelled before the timeout -- expired then we do nothing and go back to the start. -- -- But if it was not cancelled then we will send it the asynchronous -- exception. As described above there is a corner case where we won -- the race very narrowly and so the other thread has to block and wait -- for us to send the asynchronous exception. The way we make it block to -- wait for us -- without any concern that it might be classed as being -- blocked indefinitely -- is to make it wait for a state change that we -- will only perform /after/ we have raised the exception in the target -- thread. -- Bool -> m () -> m () forall (f :: * -> *). Applicative f => Bool -> f () -> f () unless Bool cancelled (m () -> m ()) -> m () -> m () forall a b. (a -> b) -> a -> b $ do ThreadId m -> TimeoutException -> m () forall (m :: * -> *) e. (MonadFork m, Exception e) => ThreadId m -> e -> m () throwTo ThreadId m tid TimeoutException TimeoutException -- Set the state the other thread may be waiting for /after/ raising the -- exception in the other thread. STM m () -> m () forall (m :: * -> *) a. (MonadSTM m, HasCallStack) => STM m a -> m a atomically (STM m () -> m ()) -> STM m () -> m () forall a b. (a -> b) -> a -> b $ TVar m TimeoutState -> TimeoutState -> STM m () forall (m :: * -> *) a. MonadSTM m => TVar m a -> a -> STM m () writeTVar TVar m TimeoutState timeoutStateVar TimeoutState TimeoutTerminated -- | These are all \"impossible\" errors. -- data TimeoutAssertion = TimeoutImpossibleReachedTerminated | TimeoutImpossibleTimeoutState | TimeoutImpossibleMonitorState deriving Int -> TimeoutAssertion -> ShowS [TimeoutAssertion] -> ShowS TimeoutAssertion -> String (Int -> TimeoutAssertion -> ShowS) -> (TimeoutAssertion -> String) -> ([TimeoutAssertion] -> ShowS) -> Show TimeoutAssertion forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [TimeoutAssertion] -> ShowS $cshowList :: [TimeoutAssertion] -> ShowS show :: TimeoutAssertion -> String $cshow :: TimeoutAssertion -> String showsPrec :: Int -> TimeoutAssertion -> ShowS $cshowsPrec :: Int -> TimeoutAssertion -> ShowS Show instance Exception TimeoutAssertion