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

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)