From 3e7c8cf1a4cd9ea86fd7d1dce13e305dd09fb6fe Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Tue, 11 Sep 2012 01:54:42 +0200 Subject: Avoiding X server leaks with XftColor cache This patch is a first complete solution to the long-standing memory leak (on the X server side) caused by repeteadly asking the server to allocate XftColor instances. Despite the fact that we were freeing them, the server didn't seem to care... this was also happening for non-Xft Colors, and solved in the same way we'd done here, i.e., by caching XftColor instances. And additional complication has been that Graphics.X11.Xft doesn't export any function to create and retain an XftColor, nor the necessary datatype constructors to write a compatible version outside the module (there's no way to construct an XftColor instance to pass to the other functions in the library). So, i've created my own lite version of the whole module, until the day it supports XftColor creation. --- src/ColorCache.hs | 64 +++++++++++++++++++++---- src/MinXft.hsc | 139 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/XUtil.hsc | 42 +++++++---------- src/Xmobar.hs | 7 +++ 4 files changed, 218 insertions(+), 34 deletions(-) create mode 100644 src/MinXft.hsc (limited to 'src') diff --git a/src/ColorCache.hs b/src/ColorCache.hs index 9a76a90..6313a98 100644 --- a/src/ColorCache.hs +++ b/src/ColorCache.hs @@ -7,7 +7,7 @@ -- -- Maintainer: jao@gnu.org -- Stability: unstable --- Portability: portable +-- Portability: unportable -- Created: Mon Sep 10, 2012 00:27 -- -- @@ -15,23 +15,25 @@ -- ------------------------------------------------------------------------------ +#if defined XFT + +module ColorCache(withColors, withDrawingColors) where + +import MinXft +import Graphics.X11.Xlib + +#else module ColorCache(withColors) where -#if defined XFT --- import Graphics.X11.Xft #endif + import Data.IORef -import Graphics.X11.Xlib import System.IO.Unsafe (unsafePerformIO) import Control.Monad.Trans (MonadIO, liftIO) import Control.Exception (SomeException, handle) -data DynPixel = DynPixel { allocated :: Bool - , pixel :: Pixel - } +data DynPixel = DynPixel Bool Pixel --- | Get the Pixel value for a named color: if an invalid name is --- given the black pixel will be returned. initColor :: Display -> String -> IO DynPixel initColor dpy c = handle black $ (initColor' dpy c) where @@ -63,4 +65,46 @@ initColor' dpy c = do withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a withColors d cs f = do ps <- mapM (liftIO . initColor d) cs - f $ map pixel ps + f $ map (\(DynPixel _ pixel) -> pixel) ps + +#ifdef XFT + +type AXftColorCache = [(String, AXftColor)] +{-# NOINLINE xftColorCache #-} +xftColorCache :: IORef AXftColorCache +xftColorCache = unsafePerformIO $ newIORef [] + +getXftCachedColor :: String -> IO (Maybe AXftColor) +getXftCachedColor name = lookup name `fmap` readIORef xftColorCache + +putXftCachedColor :: String -> AXftColor -> IO () +putXftCachedColor name cptr = + modifyIORef xftColorCache $ \c -> (name, cptr) : c + +initAXftColor' :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor' d v cm c = do + cc <- getXftCachedColor c + c' <- case cc of + Just col -> return col + _ -> do c'' <- mallocAXftColor d v cm c + putXftCachedColor c c'' + return c'' + return c' + +initAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +initAXftColor d v cm c = handle black $ (initAXftColor' d v cm c) + where + black :: SomeException -> IO AXftColor + black = (const $ initAXftColor' d v cm "black") + +withDrawingColors :: -- MonadIO m => + Display -> Drawable -> String -> String + -> (AXftDraw -> AXftColor -> AXftColor -> IO ()) -> IO () +withDrawingColors dpy drw fc bc f = do + let screen = defaultScreenOfDisplay dpy + colormap = defaultColormapOfScreen screen + visual = defaultVisualOfScreen screen + fc' <- initAXftColor dpy visual colormap fc + bc' <- initAXftColor dpy visual colormap bc + withAXftDraw dpy drw visual colormap $ \draw -> f draw fc' bc' +#endif diff --git a/src/MinXft.hsc b/src/MinXft.hsc new file mode 100644 index 0000000..478b94a --- /dev/null +++ b/src/MinXft.hsc @@ -0,0 +1,139 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +------------------------------------------------------------------------------ +-- | +-- Module: MinXft +-- Copyright: (c) 2012 Jose Antonio Ortega Ruiz +-- (c) Clemens Fruhwirth 2007 +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: jao@gnu.org +-- Stability: unstable +-- Portability: unportable +-- Created: Mon Sep 10, 2012 18:12 +-- +-- +-- Pared down Xft library, based on Graphics.X11.Xft and providing +-- explicit management of XftColors, so that they can be cached. +-- +-- Most of the code is lifted from Clemens's. +-- +------------------------------------------------------------------------------ + +module MinXft ( AXftColor + , AXftDraw + , AXftFont + , mallocAXftColor + , freeAXftColor + , withAXftDraw + , drawXftString + , drawXftRect + , openAXftFont + , closeAXftFont + , xftTxtExtents + , xft_ascent + , xft_descent + , xft_height + ) + +where + +import Graphics.X11 +import Graphics.X11.Xlib.Types +import Graphics.X11.Xrender + +import Foreign +import Foreign.C.Types +import Foreign.C.String +import Codec.Binary.UTF8.String as UTF8 + +#include + +-- Color Handling + +newtype AXftColor = AXftColor (Ptr AXftColor) + +foreign import ccall "XftColorAllocName" + cXftColorAllocName :: Display -> Visual -> Colormap -> CString -> AXftColor -> IO (#type Bool) + +-- this is the missing bit in X11.Xft, not implementable from the +-- outside because XftColor does not export a constructor. +mallocAXftColor :: Display -> Visual -> Colormap -> String -> IO AXftColor +mallocAXftColor d v cm n = do + color <- mallocBytes (#size XftColor) + withCAString n $ \str -> cXftColorAllocName d v cm str (AXftColor color) + return (AXftColor color) + +foreign import ccall "XftColorFree" + freeAXftColor :: Display -> Visual -> Colormap -> AXftColor -> IO () + +-- Font handling + +newtype AXftFont = AXftFont (Ptr AXftFont) + +xft_ascent :: AXftFont -> IO Int +xft_ascent (AXftFont p) = peekCUShort p #{offset XftFont, ascent} + +xft_descent :: AXftFont -> IO Int +xft_descent (AXftFont p) = peekCUShort p #{offset XftFont, descent} + +xft_height :: AXftFont -> IO Int +xft_height (AXftFont p) = peekCUShort p #{offset XftFont, height} + +foreign import ccall "XftTextExtentsUtf8" + cXftTextExtentsUtf8 :: Display -> AXftFont -> CString -> CInt -> Ptr XGlyphInfo -> IO () + +xftTxtExtents :: Display -> AXftFont -> String -> IO XGlyphInfo +xftTxtExtents d f string = + withArrayLen (map fi (UTF8.encode string)) $ + \len str_ptr -> alloca $ + \cglyph -> do + cXftTextExtentsUtf8 d f str_ptr (fi len) cglyph + peek cglyph + +foreign import ccall "XftFontOpenName" + c_xftFontOpen :: Display -> CInt -> CString -> IO AXftFont + +openAXftFont :: Display -> Screen -> String -> IO AXftFont +openAXftFont dpy screen name = + withCAString name $ + \cname -> c_xftFontOpen dpy (fi (screenNumberOfScreen screen)) cname + +foreign import ccall "XftFontClose" + closeAXftFont :: Display -> AXftFont -> IO () + +-- Drawing + +fi :: (Integral a, Num b) => a -> b +fi = fromIntegral + +newtype AXftDraw = AXftDraw (Ptr AXftDraw) + +foreign import ccall "XftDrawCreate" + c_xftDrawCreate :: Display -> Drawable -> Visual -> Colormap -> IO AXftDraw + +foreign import ccall "XftDrawDestroy" + c_xftDrawDestroy :: AXftDraw -> IO () + +withAXftDraw :: Display -> Drawable -> Visual -> Colormap -> (AXftDraw -> IO a) -> IO a +withAXftDraw d p v c act = do + draw <- c_xftDrawCreate d p v c + a <- act draw + c_xftDrawDestroy draw + return a + +foreign import ccall "XftDrawStringUtf8" + cXftDrawStringUtf8 :: AXftDraw -> AXftColor -> AXftFont -> CInt -> CInt -> Ptr (#type FcChar8) -> CInt -> IO () + +drawXftString :: (Integral a1, Integral a) => + AXftDraw -> AXftColor -> AXftFont -> a -> a1 -> String -> IO () +drawXftString d c f x y string = + withArrayLen (map fi (UTF8.encode string)) + (\len ptr -> cXftDrawStringUtf8 d c f (fi x) (fi y) ptr (fi len)) + +foreign import ccall "XftDrawRect" + cXftDrawRect :: AXftDraw -> AXftColor -> CInt -> CInt -> CUInt -> CUInt -> IO () + +drawXftRect :: (Integral a3, Integral a2, Integral a1, Integral a) => + AXftDraw -> AXftColor -> a -> a1 -> a2 -> a3 -> IO () +drawXftRect draw color x y width height = + cXftDrawRect draw color (fi x) (fi y) (fi width) (fi height) diff --git a/src/XUtil.hsc b/src/XUtil.hsc index 7683387..21dcf3e 100644 --- a/src/XUtil.hsc +++ b/src/XUtil.hsc @@ -2,8 +2,8 @@ ----------------------------------------------------------------------------- -- | -- Module : XUtil --- Copyright : (C) 2007 Andrea Rossato --- (C) 2011, 2012 Jose Antonio Ortega Ruiz +-- Copyright : (C) 2011, 2012 Jose Antonio Ortega Ruiz +-- (C) 2007 Andrea Rossato -- License : BSD3 -- -- Maintainer : jao@gnu.org @@ -48,11 +48,11 @@ import qualified System.IO as UTF8 (readFile,hGetLine) #endif #if defined XFT import Data.List -import Graphics.X11.Xft +import MinXft import Graphics.X11.Xrender #endif -import ColorCache (withColors) +import ColorCache readFileSafe :: FilePath -> IO String #if defined XFT || defined UTF8 @@ -72,7 +72,7 @@ hGetLineSafe = hGetLine data XFont = Core FontStruct | Utf8 FontSet #ifdef XFT - | Xft XftFont + | Xft AXftFont #endif -- | When initFont gets a font name that starts with 'xft:' it switchs @@ -118,11 +118,11 @@ initUtf8Font d s = do fallBack = const $ createFontSet d miscFixedFont #ifdef XFT -initXftFont :: Display -> String -> IO XftFont +initXftFont :: Display -> String -> IO AXftFont initXftFont d s = do setupLocale - f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s) - addFinalizer f (xftFontClose d f) + f <- openAXftFont d (defaultScreenOfDisplay d) (drop 4 s) + addFinalizer f (closeAXftFont d f) return f #endif @@ -131,7 +131,7 @@ textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s #ifdef XFT textWidth dpy (Xft xftdraw) s = do - gi <- xftTextExtents dpy xftdraw s + gi <- xftTxtExtents dpy xftdraw s return $ xglyphinfo_xOff gi #endif @@ -146,8 +146,8 @@ textExtents (Utf8 fs) s = do return (ascent, descent) #ifdef XFT textExtents (Xft xftfont) _ = do - ascent <- fi `fmap` xftfont_ascent xftfont - descent <- fi `fmap` xftfont_descent xftfont + ascent <- fi `fmap` xft_ascent xftfont + descent <- fi `fmap` xft_descent xftfont return (ascent, descent) #endif @@ -168,20 +168,14 @@ printString d p (Utf8 fs) gc fc bc x y s = #ifdef XFT printString dpy drw fs@(Xft font) _ fc bc x y s = do - let screen = defaultScreenOfDisplay dpy - colormap = defaultColormapOfScreen screen - visual = defaultVisualOfScreen screen (a,d) <- textExtents fs s - gi <- xftTextExtents dpy font s - withXftDraw dpy drw visual colormap $ \draw -> - (withXftColorName dpy visual colormap bc $ \color -> - xftDrawRect draw color (x + 1 - fi (xglyphinfo_x gi)) - (y - (a + d) + 1) - (xglyphinfo_xOff gi) - (a + d) - ) >> - (withXftColorName dpy visual colormap fc $ \color -> - xftDrawString draw color font x (y - 2) s) + gi <- xftTxtExtents dpy font s + withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' -> + (drawXftRect draw bc' (x + 1 - fi (xglyphinfo_x gi)) + (y - (a + d) + 1) + (xglyphinfo_xOff gi) + (a + d)) >> + (drawXftString draw fc' font x (y - 2) s) #endif diff --git a/src/Xmobar.hs b/src/Xmobar.hs index 3d17fad..f8db6a5 100644 --- a/src/Xmobar.hs +++ b/src/Xmobar.hs @@ -51,6 +51,10 @@ import Window import XUtil import ColorCache +#ifdef XFT +import Graphics.X11.Xft +#endif + #ifdef DBUS import IPC.DBus #endif @@ -78,6 +82,9 @@ runX xc f = runReaderT f xc -- | Starts the main event loop and threads startLoop :: XConf -> TMVar SignalType -> [[(Maybe ThreadId, TVar String)]] -> IO () startLoop xcfg@(XConf _ _ w _ _) sig vs = do +#ifdef XFT + xftInitFtLibrary +#endif tv <- atomically $ newTVar [] _ <- forkIO (checker tv [] vs sig `catch` \(SomeException _) -> void (putStrLn "Thread checker failed")) -- cgit v1.2.3