summaryrefslogtreecommitdiffhomepage
path: root/XUtil.hsc
diff options
context:
space:
mode:
authorSergei Trofimovich <slyfox@inbox.ru>2009-08-14 21:41:03 +0200
committerSergei Trofimovich <slyfox@inbox.ru>2009-08-14 21:41:03 +0200
commit617c0535db5a67726c4e03cb037a5768a59b4387 (patch)
treec835a7b499ca488e64eeb11480ff5b0c101c0549 /XUtil.hsc
parent0713a41374288b3caa464f7e1c5b6244ccf5c16b (diff)
downloadxmobar-617c0535db5a67726c4e03cb037a5768a59b4387.tar.gz
xmobar-617c0535db5a67726c4e03cb037a5768a59b4387.tar.bz2
fixed "Abnormally high cpu load on X" (11 issue in tracker)
Ignore-this: f9c79a48b39c163b56393723b7215c72 Steps to reproduce are described in http://code.google.com/p/xmobar/issues/detail?id I've noticed large bunch of XAllocNamedColor calls/sec in xmobar ltrace log. This patch introduces simple hackish color cachig. It's more PoC, than real fix. darcs-hash:20090814194103-3eaf8-c48024c380b4372877430fec60daccd5f77f2024.gz
Diffstat (limited to 'XUtil.hsc')
-rw-r--r--XUtil.hsc27
1 files changed, 25 insertions, 2 deletions
diff --git a/XUtil.hsc b/XUtil.hsc
index 3250b26..678ffcb 100644
--- a/XUtil.hsc
+++ b/XUtil.hsc
@@ -33,6 +33,7 @@ module XUtil
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
+import Data.IORef
import Foreign
import Graphics.X11.Xlib hiding (textExtents, textWidth)
import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth)
@@ -187,9 +188,30 @@ initColor :: Display -> String -> IO DynPixel
initColor dpy c = (initColor' dpy c) `catch`
(const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy))
+type ColorCache = [(String, Color)]
+colorCache :: IO (IORef ColorCache)
+colorCache = newIORef []
+
+getCachedColor :: String -> IO (Maybe Color)
+getCachedColor color_name = do
+ ref <- colorCache
+ result <- lookup color_name `fmap` readIORef ref
+ return result
+
+putCachedColor :: String -> Color -> IO ()
+putCachedColor color_name color_id = do
+ ref <- colorCache
+ modifyIORef ref $ \cache -> (color_name,color_id) : cache
+
initColor' :: Display -> String -> IO DynPixel
initColor' dpy c = do
- (c', _) <- allocNamedColor dpy colormap c
+ cached_color <- getCachedColor c
+ c' <- do
+ case cached_color of
+ Just col -> return col
+ _ -> do (c'', _) <- allocNamedColor dpy colormap c
+ putCachedColor c c''
+ return c''
return $ DynPixel True (color_pixel c')
where colormap = defaultColormap dpy (defaultScreen dpy)
@@ -197,7 +219,8 @@ withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a
withColors d cs f = do
ps <- mapM (io . initColor d) cs
r <- f $ map pixel ps
- io $ freeColors d cmap (map pixel $ filter allocated ps) 0
+ -- there is color leak in 'putCachedColor'. might be freed at xmobar shutdown
+ -- io $ freeColors d cmap (map pixel $ filter allocated ps) 0
return r
where
cmap = defaultColormap d (defaultScreen d)