From e662431a5cef5eacd68b987610f2d434fa687844 Mon Sep 17 00:00:00 2001 From: Tomas Janousek Date: Sat, 22 Feb 2020 22:06:48 +0000 Subject: Timer coalescing: gracefully uncoalesce slow timers The first implementation assumed all timers (monitors) are fast and frequent (which happens to be the case in my configuration). This meant that a single on-line weather monitor could block the entire xmobar instance for a long time due to the refresh pausing (meant to reduce power consumption). This commit attempts to fix that by limiting the refresh pause time and using the old periodic sleep method for these slow timers (monitors). --- src/Xmobar/App/Timer.hs | 122 +++++++++++++++++++++++++++++++++++++----------- 1 file changed, 96 insertions(+), 26 deletions(-) (limited to 'src/Xmobar/App') diff --git a/src/Xmobar/App/Timer.hs b/src/Xmobar/App/Timer.hs index d67695d..8464fb7 100644 --- a/src/Xmobar/App/Timer.hs +++ b/src/Xmobar/App/Timer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} ------------------------------------------------------------------------------ -- | -- Module: Xmobar.App.Timer @@ -11,16 +12,23 @@ -- ------------------------------------------------------------------------------ -module Xmobar.App.Timer (doEveryTenthSeconds, withTimer) where +module Xmobar.App.Timer + ( doEveryTenthSeconds + , tenthSeconds + , withTimer + ) where +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (withAsync) import Control.Concurrent.STM -import Control.Exception (bracket, bracket_) -import Control.Monad (forever, forM, forM_, guard) +import Control.Exception +import Control.Monad (forever, forM, guard) +import Data.Foldable (foldrM) import Data.IORef import Data.Int (Int64) import Data.Map (Map) import qualified Data.Map as M +import Data.Maybe (isJust) import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Unique import System.IO.Unsafe (unsafePerformIO) @@ -29,7 +37,12 @@ newtype Timer = Timer (TVar Periods) type Periods = Map Unique Period -data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar (TMVar ()) } +data Tick = Tick (TMVar ()) | TimeOut + +data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar Tick } + +data TimeOutException = TimeOutException deriving Show +instance Exception TimeOutException {-# NOINLINE timer #-} timer :: IORef (Maybe Timer) @@ -50,24 +63,48 @@ newPeriod r = do -- | Perform a given action every N tenths of a second. -- --- The timer is aligned with other timers to minimize the number of wakeups --- and unnecessary redraws. +-- The timer is aligned (coalesced) with other timers to minimize the number +-- of wakeups and unnecessary redraws. If the action takes too long (one +-- second or when the next timer is due), coalescing is disabled for it and it +-- falls back to periodic sleep. doEveryTenthSeconds :: Int -> IO () -> IO () doEveryTenthSeconds r action = do Just t <- readIORef timer - doEveryTenthSeconds' t r action + doEveryTenthSecondsCoalesced t r action `catch` \TimeOutException -> + doEveryTenthSecondsSleeping r action -doEveryTenthSeconds' :: Timer -> Int -> IO () -> IO () -doEveryTenthSeconds' (Timer periodsVar) r action = do +-- | Perform a given action every N tenths of a second, +-- coalesce with other timers using a given Timer instance. +doEveryTenthSecondsCoalesced :: Timer -> Int -> IO () -> IO () +doEveryTenthSecondsCoalesced (Timer periodsVar) r action = do (u, p) <- newPeriod (fromIntegral r) - bracket_ (push u p) (pop u) $ forever $ - bracket (atomically $ takeTMVar $ tick p) - (\doneVar -> atomically $ putTMVar doneVar ()) - (const action) + bracket_ (push u p) (pop u) $ forever $ bracket (wait p) done $ const action where push u p = atomically $ modifyTVar periodsVar (M.insert u p) pop u = atomically $ modifyTVar periodsVar (M.delete u) + wait p = atomically (takeTMVar $ tick p) >>= \case + Tick doneVar -> return doneVar + TimeOut -> throwIO TimeOutException + done doneVar = atomically $ putTMVar doneVar () + +-- | Perform a given action every N tenths of a second, +-- making no attempt to synchronize with other timers. +doEveryTenthSecondsSleeping :: Int -> IO () -> IO () +doEveryTenthSecondsSleeping r action = go + where go = action >> tenthSeconds r >> go + +-- | Sleep for a given amount of tenths of a second. +-- +-- (Work around the Int max bound: since threadDelay takes an Int, it +-- is not possible to set a thread delay grater than about 45 minutes. +-- With a little recursion we solve the problem.) +tenthSeconds :: Int -> IO () +tenthSeconds s | s >= x = do threadDelay (x * 100000) + tenthSeconds (s - x) + | otherwise = threadDelay (s * 100000) + where x = (maxBound :: Int) `div` 100000 + -- | Start the timer coordination thread. withTimer :: (IO () -> IO ()) -> IO a -> IO a withTimer pauseRefresh action = do @@ -80,19 +117,25 @@ withTimer pauseRefresh action = do timerLoop :: (IO () -> IO ()) -> TVar Periods -> IO () timerLoop pauseRefresh periodsVar = forever $ do - t <- now - toFire <- atomically $ do + tNow <- now + (toFire, tMaybeNext) <- atomically $ do periods <- readTVar periodsVar - writeTVar periodsVar (advanceTimers t periods) - return (timersToFire t periods) + let toFire = timersToFire tNow periods + let periods' = advanceTimers tNow periods + let tMaybeNext = nextFireTime periods' + writeTVar periodsVar periods' + return (toFire, tMaybeNext) pauseRefresh $ do - -- Fire timers ... - doneVars <- atomically $ forM toFire $ \p -> do - doneVar <- newEmptyTMVar - putTMVar (tick p) doneVar - return doneVar - -- ... and wait for them to avoid unnecessary redraws. - atomically $ forM_ doneVars takeTMVar + -- To avoid multiple refreshes, pause refreshing for up to 1 second, + -- fire timers and wait for them to finish (update their text). + -- Those that need more time (e.g. weather monitors) will be dropped + -- from timer coalescing and will fall back to periodic sleep. + timeoutVar <- registerDelay $ case tMaybeNext of + Just tNext -> fromIntegral ((tNext - tNow) `max` 10) * 100000 + Nothing -> 1000000 + fired <- fireTimers toFire + timeouted <- waitForTimers timeoutVar fired + timeoutTimers timeouted periodsVar delayUntilNextFire periodsVar advanceTimers :: Int64 -> Periods -> Periods @@ -101,14 +144,41 @@ advanceTimers t = M.map advance advance p | next p <= t = p { next = t - t `mod` rate p + rate p } | otherwise = p -timersToFire :: Int64 -> Periods -> [Period] -timersToFire t periods = [ p | p <- M.elems periods, next p <= t ] +timersToFire :: Int64 -> Periods -> [(Unique, Period)] +timersToFire t periods = [ (u, p) | (u, p) <- M.toList periods, next p <= t ] nextFireTime :: Periods -> Maybe Int64 nextFireTime periods | M.null periods = Nothing | otherwise = Just $ minimum [ next p | p <- M.elems periods ] +fireTimers :: [(Unique, Period)] -> IO [(Unique, TMVar ())] +fireTimers toFire = atomically $ forM toFire $ \(u, p) -> do + doneVar <- newEmptyTMVar + putTMVar (tick p) (Tick doneVar) + return (u, doneVar) + +waitForTimers :: TVar Bool -> [(Unique, TMVar ())] -> IO [Unique] +waitForTimers timeoutVar fired = atomically $ do + timeoutOver <- readTVar timeoutVar + dones <- forM fired $ \(u, doneVar) -> do + done <- isJust <$> tryReadTMVar doneVar + return (u, done) + guard $ timeoutOver || all snd dones + return [u | (u, False) <- dones] + +-- | Handle slow timers (drop and signal them to stop coalescing). +timeoutTimers :: [Unique] -> TVar Periods -> IO () +timeoutTimers timers periodsVar = atomically $ do + periods <- readTVar periodsVar + periods' <- foldrM timeoutTimer periods timers + writeTVar periodsVar periods' + +timeoutTimer :: Unique -> Periods -> STM Periods +timeoutTimer u periods = do + putTMVar (tick (periods M.! u)) TimeOut + return $ u `M.delete` periods + delayUntilNextFire :: TVar Periods -> IO () delayUntilNextFire periodsVar = do tMaybeNext <- fmap nextFireTime $ readTVarIO periodsVar -- cgit v1.2.3