summaryrefslogtreecommitdiffhomepage
path: root/src
diff options
context:
space:
mode:
authorTomas Janousek <tomi@nomi.cz>2019-08-13 21:41:15 +0200
committerTomas Janousek <tomi@nomi.cz>2020-02-22 22:15:44 +0000
commit32fc8214c567c7f4a4caad10fab98c760a1685b7 (patch)
treefc9725cae245446e08ef95fa295a3affbac06fab /src
parent2a71487437ca4afed6f35acc1e16c2e03bfc053c (diff)
downloadxmobar-32fc8214c567c7f4a4caad10fab98c760a1685b7.tar.gz
xmobar-32fc8214c567c7f4a4caad10fab98c760a1685b7.tar.bz2
Implement timer coalescing (noticeably less CPU/power usage)
xmobar currently runs every monitor in its own thread. Monitors that do periodic updates simply sleep and loop. This unfortunately leads to these threads coming out of sync, and xmobar ends up waking up and redrawing for every periodic monitor. In my case, that is 7 times per second, which is enough for xmobar to be at the top of "top" with more than 1% CPU usage, and to have a noticeable impact on battery life. This commit adds a central timer coordination thread which makes sure that periodic updates happen together and that we only redraw once they're all done. Together with PR #409, I managed to lower the idle power draw of my laptop from 4W to 3W.
Diffstat (limited to 'src')
-rw-r--r--src/Xmobar/App/EventLoop.hs43
-rw-r--r--src/Xmobar/App/Main.hs21
-rw-r--r--src/Xmobar/App/Timer.hs130
-rw-r--r--src/Xmobar/Run/Exec.hs5
4 files changed, 177 insertions, 22 deletions
diff --git a/src/Xmobar/App/EventLoop.hs b/src/Xmobar/App/EventLoop.hs
index 3fab3e5..f6ab932 100644
--- a/src/Xmobar/App/EventLoop.hs
+++ b/src/Xmobar/App/EventLoop.hs
@@ -17,7 +17,12 @@
------------------------------------------------------------------------------
-module Xmobar.App.EventLoop (startLoop, startCommand) where
+module Xmobar.App.EventLoop
+ ( startLoop
+ , startCommand
+ , newRefreshLock
+ , refreshLock
+ ) where
import Prelude hiding (lookup)
import Graphics.X11.Xlib hiding (textExtents, textWidth)
@@ -31,7 +36,7 @@ import Control.Monad.Reader
import Control.Concurrent
import Control.Concurrent.Async (Async, async)
import Control.Concurrent.STM
-import Control.Exception (handle, SomeException(..))
+import Control.Exception (bracket_, handle, SomeException(..))
import Data.Bits
import Data.Map hiding (foldr, map, filter)
import Data.Maybe (fromJust, isJust)
@@ -63,15 +68,34 @@ import Xmobar.System.DBus
runX :: XConf -> X () -> IO ()
runX xc f = runReaderT f xc
+newRefreshLock :: IO (TMVar ())
+newRefreshLock = atomically $ newTMVar ()
+
+refreshLock :: TMVar () -> IO a -> IO a
+refreshLock var = bracket_ lock unlock
+ where
+ lock = atomically $ takeTMVar var
+ unlock = atomically $ putTMVar var ()
+
+refreshLockT :: TMVar () -> STM a -> STM a
+refreshLockT var action = do
+ takeTMVar var
+ r <- action
+ putTMVar var ()
+ return r
+
-- | Starts the main event loop and threads
-startLoop :: XConf -> TMVar SignalType -> [[([Async ()], TVar String)]]
- -> IO ()
-startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do
+startLoop :: XConf
+ -> TMVar SignalType
+ -> TMVar ()
+ -> [[([Async ()], TVar String)]]
+ -> IO ()
+startLoop xcfg@(XConf _ _ w _ _ _ _) sig pauser vs = do
#ifdef XFT
xftInitFtLibrary
#endif
tv <- atomically $ newTVar []
- _ <- forkIO (handle (handler "checker") (checker tv [] vs sig))
+ _ <- forkIO (handle (handler "checker") (checker tv [] vs sig pauser))
#ifdef THREADED_RUNTIME
_ <- forkOS (handle (handler "eventer") (eventer sig))
#else
@@ -111,15 +135,16 @@ checker :: TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
+ -> TMVar ()
-> IO ()
-checker tvar ov vs signal = do
- nval <- atomically $ do
+checker tvar ov vs signal pauser = do
+ nval <- atomically $ refreshLockT pauser $ do
nv <- mapM concatV vs
guard (nv /= ov)
writeTVar tvar nv
return nv
atomically $ putTMVar signal Wakeup
- checker tvar nval vs signal
+ checker tvar nval vs signal pauser
where
concatV = fmap concat . mapM (readTVar . snd)
diff --git a/src/Xmobar/App/Main.hs b/src/Xmobar/App/Main.hs
index 29504f4..e0b0329 100644
--- a/src/Xmobar/App/Main.hs
+++ b/src/Xmobar/App/Main.hs
@@ -40,9 +40,10 @@ import Xmobar.X11.Types
import Xmobar.X11.Text
import Xmobar.X11.Window
import Xmobar.App.Opts (recompileFlag, verboseFlag, getOpts, doOpts)
-import Xmobar.App.EventLoop (startLoop, startCommand)
+import Xmobar.App.EventLoop (startLoop, startCommand, newRefreshLock, refreshLock)
import Xmobar.App.Compile (recompile, trace)
import Xmobar.App.Config
+import Xmobar.App.Timer (withTimer)
xmobar :: Config -> IO ()
xmobar conf = withDeferSignals $ do
@@ -53,14 +54,16 @@ xmobar conf = withDeferSignals $ do
cls <- mapM (parseTemplate (commands conf) (sepChar conf))
(splitTemplate (alignSep conf) (template conf))
sig <- setupSignalHandler
- bracket (mapM (mapM $ startCommand sig) cls)
- cleanupThreads
- $ \vars -> do
- (r,w) <- createWin d fs conf
- let ic = Map.empty
- to = textOffset conf
- ts = textOffsets conf ++ replicate (length fl) (-1)
- startLoop (XConf d r w (fs:fl) (to:ts) ic conf) sig vars
+ refLock <- newRefreshLock
+ withTimer (refreshLock refLock) $
+ bracket (mapM (mapM $ startCommand sig) cls)
+ cleanupThreads
+ $ \vars -> do
+ (r,w) <- createWin d fs conf
+ let ic = Map.empty
+ to = textOffset conf
+ ts = textOffsets conf ++ replicate (length fl) (-1)
+ startLoop (XConf d r w (fs:fl) (to:ts) ic conf) sig refLock vars
configFromArgs :: Config -> IO Config
configFromArgs cfg = getArgs >>= getOpts >>= doOpts cfg . fst
diff --git a/src/Xmobar/App/Timer.hs b/src/Xmobar/App/Timer.hs
new file mode 100644
index 0000000..d67695d
--- /dev/null
+++ b/src/Xmobar/App/Timer.hs
@@ -0,0 +1,130 @@
+------------------------------------------------------------------------------
+-- |
+-- Module: Xmobar.App.Timer
+-- Copyright: (c) 2019 Tomáš Janoušek
+-- License: BSD3-style (see LICENSE)
+--
+-- Maintainer: Tomáš Janoušek <tomi@nomi.cz>
+-- Stability: unstable
+--
+-- Timer coalescing for recurring actions.
+--
+------------------------------------------------------------------------------
+
+module Xmobar.App.Timer (doEveryTenthSeconds, withTimer) where
+
+import Control.Concurrent.Async (withAsync)
+import Control.Concurrent.STM
+import Control.Exception (bracket, bracket_)
+import Control.Monad (forever, forM, forM_, guard)
+import Data.IORef
+import Data.Int (Int64)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Time.Clock.POSIX (getPOSIXTime)
+import Data.Unique
+import System.IO.Unsafe (unsafePerformIO)
+
+newtype Timer = Timer (TVar Periods)
+
+type Periods = Map Unique Period
+
+data Period = Period { rate :: Int64, next :: Int64, tick :: TMVar (TMVar ()) }
+
+{-# NOINLINE timer #-}
+timer :: IORef (Maybe Timer)
+timer = unsafePerformIO (newIORef Nothing)
+
+now :: IO Int64
+now = do
+ posix <- getPOSIXTime
+ return $ floor (10 * posix)
+
+newPeriod :: Int64 -> IO (Unique, Period)
+newPeriod r = do
+ u <- newUnique
+ t <- now
+ v <- atomically newEmptyTMVar
+ let t' = t - t `mod` r
+ return (u, Period { rate = r, next = t', tick = v })
+
+-- | 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.
+doEveryTenthSeconds :: Int -> IO () -> IO ()
+doEveryTenthSeconds r action = do
+ Just t <- readIORef timer
+ doEveryTenthSeconds' t r action
+
+doEveryTenthSeconds' :: Timer -> Int -> IO () -> IO ()
+doEveryTenthSeconds' (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)
+ where
+ push u p = atomically $ modifyTVar periodsVar (M.insert u p)
+ pop u = atomically $ modifyTVar periodsVar (M.delete u)
+
+-- | Start the timer coordination thread.
+withTimer :: (IO () -> IO ()) -> IO a -> IO a
+withTimer pauseRefresh action = do
+ periodsVar <- atomically $ newTVar M.empty
+ withAsync (timerLoop pauseRefresh periodsVar) $ \_ ->
+ bracket_
+ (writeIORef timer (Just (Timer periodsVar)))
+ (writeIORef timer Nothing) -- TODO: kill all periods?
+ action
+
+timerLoop :: (IO () -> IO ()) -> TVar Periods -> IO ()
+timerLoop pauseRefresh periodsVar = forever $ do
+ t <- now
+ toFire <- atomically $ do
+ periods <- readTVar periodsVar
+ writeTVar periodsVar (advanceTimers t periods)
+ return (timersToFire t periods)
+ 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
+ delayUntilNextFire periodsVar
+
+advanceTimers :: Int64 -> Periods -> Periods
+advanceTimers t = M.map advance
+ where
+ 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 ]
+
+nextFireTime :: Periods -> Maybe Int64
+nextFireTime periods
+ | M.null periods = Nothing
+ | otherwise = Just $ minimum [ next p | p <- M.elems periods ]
+
+delayUntilNextFire :: TVar Periods -> IO ()
+delayUntilNextFire periodsVar = do
+ tMaybeNext <- fmap nextFireTime $ readTVarIO periodsVar
+ tNow <- now
+ delayVar <- case tMaybeNext of
+ Just tNext -> do
+ -- Work around the Int max bound: threadDelay takes an Int, we can
+ -- only sleep for so long, which is okay, we'll just check timers
+ -- sooner and sleep again.
+ let maxDelay = (maxBound :: Int) `div` 100000
+ delay = (tNext - tNow) `min` fromIntegral maxDelay
+ delayUsec = fromIntegral delay * 100000
+ registerDelay delayUsec
+ Nothing -> atomically $ newTVar False
+ atomically $ do
+ delayOver <- readTVar delayVar
+ tMaybeNext' <- fmap nextFireTime $ readTVar periodsVar
+ -- Return also if a new period is added (it may fire sooner).
+ guard $ delayOver || tMaybeNext /= tMaybeNext'
diff --git a/src/Xmobar/Run/Exec.hs b/src/Xmobar/Run/Exec.hs
index db7e7b4..ad68232 100644
--- a/src/Xmobar/Run/Exec.hs
+++ b/src/Xmobar/Run/Exec.hs
@@ -23,6 +23,7 @@ import Prelude
import Data.Char
import Control.Concurrent
+import Xmobar.App.Timer (doEveryTenthSeconds)
import Xmobar.System.Signal
-- | Work around to the Int max bound: since threadDelay takes an Int, it
@@ -34,10 +35,6 @@ tenthSeconds s | s >= x = do threadDelay (x * 100000)
| otherwise = threadDelay (s * 100000)
where x = (maxBound :: Int) `div` 100000
-doEveryTenthSeconds :: Int -> IO () -> IO ()
-doEveryTenthSeconds r action = go
- where go = action >> tenthSeconds r >> go
-
class Show e => Exec e where
alias :: e -> String
alias e = takeWhile (not . isSpace) $ show e