summaryrefslogtreecommitdiffhomepage
path: root/src/Xmobar/App
diff options
context:
space:
mode:
authorTomas Janousek <tomi@nomi.cz>2020-02-22 22:06:48 +0000
committerTomas Janousek <tomi@nomi.cz>2020-02-22 23:09:49 +0000
commite662431a5cef5eacd68b987610f2d434fa687844 (patch)
tree31c9fd4f7c57490438b565de3ace2d13b171020e /src/Xmobar/App
parent32fc8214c567c7f4a4caad10fab98c760a1685b7 (diff)
downloadxmobar-e662431a5cef5eacd68b987610f2d434fa687844.tar.gz
xmobar-e662431a5cef5eacd68b987610f2d434fa687844.tar.bz2
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).
Diffstat (limited to 'src/Xmobar/App')
-rw-r--r--src/Xmobar/App/Timer.hs122
1 files changed, 96 insertions, 26 deletions
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