From a454eb87dbc709047a696869a5c63ef4f925abfb Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 6 Oct 2023 14:33:30 +1300 Subject: [PATCH] Performance optimizations, partially-tested as 0.3.0.0 --- CHANGELOG.md | 5 +++ Graphics/Text/Font/Choose.hs | 5 ++- Graphics/Text/Font/Choose/CharSet.hs | 66 ++++++++++++++++------------ Graphics/Text/Font/Choose/FontSet.hs | 7 ++- Graphics/Text/Font/Choose/Pattern.hs | 35 ++++++++++----- cbits/pattern.c | 11 ----- fontconfig-pure.cabal | 4 +- 7 files changed, 79 insertions(+), 54 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a8cbb41..ab2e220 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for fontconfig-pure +## 0.3.0.0 -- 2023-10-01 + +* Addressing segfaults & mainloops. +* Switched underlying CharSet collection to IntSet for efficiency. + ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/Graphics/Text/Font/Choose.hs b/Graphics/Text/Font/Choose.hs index ce305b9..bf92a45 100644 --- a/Graphics/Text/Font/Choose.hs +++ b/Graphics/Text/Font/Choose.hs @@ -1,5 +1,5 @@ -module Graphics.Text.Font.Choose(CharSet, FontSet, ObjectSet, Pattern(..), Binding(..), - Range(..), iRange, StrSet, StrList, Value(..), FontFaceParser(..), +module Graphics.Text.Font.Choose(CharSet, chr, ord, FontSet, ObjectSet, Pattern(..), + Binding(..), Range(..), iRange, StrSet, StrList, Value(..), FontFaceParser(..), Config, configCreate, configSetCurrent, configGetCurrent, configUptoDate, configHome, configEnableHome, @@ -26,6 +26,7 @@ module Graphics.Text.Font.Choose(CharSet, FontSet, ObjectSet, Pattern(..), Bindi ) where import Prelude hiding (init, filter) +import Data.Char (chr, ord) -- For use with CharSet import Graphics.Text.Font.Choose.CharSet (CharSet) import Graphics.Text.Font.Choose.Config (Config, configCreate, diff --git a/Graphics/Text/Font/Choose/CharSet.hs b/Graphics/Text/Font/Choose/CharSet.hs index ae86ffc..1b08a79 100644 --- a/Graphics/Text/Font/Choose/CharSet.hs +++ b/Graphics/Text/Font/Choose/CharSet.hs @@ -1,11 +1,13 @@ module Graphics.Text.Font.Choose.CharSet where -import Data.Set (Set, union) -import qualified Data.Set as Set +import Data.IntSet (IntSet, union) +import qualified Data.IntSet as IntSet import Graphics.Text.Font.Choose.Result (throwNull, throwFalse) +import System.IO.Unsafe (unsafeInterleaveIO) import Data.Word (Word32) import Foreign.Ptr +import Foreign.ForeignPtr (newForeignPtr, withForeignPtr) import Control.Exception (bracket) import Control.Monad (forM) import Foreign.Marshal.Alloc (alloca) @@ -15,29 +17,33 @@ import Data.Char (ord, isHexDigit) import Numeric (readHex) -- | An FcCharSet is a set of Unicode chars. -type CharSet = Set Char +type CharSet = IntSet -parseChar :: String -> Char +parseChar :: String -> Int parseChar str | ((x, _):_) <- readHex str = toEnum x +replaceWild :: Char -> String -> String replaceWild ch ('?':rest) = ch:replaceWild ch rest replaceWild ch (c:cs) = c:replaceWild ch cs replaceWild _ "" = "" +parseWild :: Char -> String -> Int parseWild ch str = parseChar $ replaceWild ch str -- | Utility for parsing "unicode-range" @font-face property. +parseCharSet :: String -> Maybe CharSet parseCharSet ('U':rest) = parseCharSet ('u':rest) -- lowercase initial "u" parseCharSet ('u':'+':cs) | (start@(_:_), '-':ends) <- span isHexDigit cs, (end@(_:_), rest) <- span isHexDigit ends, Just set <- parseCharSet' rest = - Just $ Set.union set $ Set.fromList [parseChar start..parseChar end] + Just $ union set $ IntSet.fromList [parseChar start..parseChar end] | (codepoint@(_:_), rest) <- span isHexDigit cs, Just set <- parseCharSet' rest = - Just $ flip Set.insert set $ parseChar codepoint + Just $ flip IntSet.insert set $ parseChar codepoint | (codepoint@(_:_), rest) <- span (\c -> isHexDigit c || c == '?') cs, Just set <- parseCharSet' rest = - Just $ Set.union set $ Set.fromList [ + Just $ IntSet.union set $ IntSet.fromList [ parseWild '0' codepoint..parseWild 'f' codepoint] parseCharSet _ = Nothing +parseCharSet' :: String -> Maybe CharSet parseCharSet' (',':rest) = parseCharSet rest -parseCharSet' "" = Just Set.empty +parseCharSet' "" = Just IntSet.empty parseCharSet' _ = Nothing ------ @@ -54,30 +60,36 @@ foreign import ccall "FcCharSetDestroy" fcCharSetDestroy :: CharSet_ -> IO () withCharSet :: CharSet -> (CharSet_ -> IO a) -> IO a withCharSet chars cb = withNewCharSet $ \chars' -> do - forM (Set.elems chars) $ \ch' -> - throwFalse <$> (fcCharSetAddChar chars' $ fromIntegral $ ord ch') + forM (IntSet.elems chars) $ \ch' -> + throwFalse <$> (fcCharSetAddChar chars' $ fromIntegral ch') cb chars' foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool thawCharSet :: CharSet_ -> IO CharSet thawCharSet chars' - | chars' == nullPtr = return Set.empty - | otherwise = allocaArray fcCHARSET_MAP_SIZE $ \iter' -> alloca $ \next' -> do - first <- fcCharSetFirstPage chars' iter' next' - let go = do - ch <- fcCharSetNextPage chars' iter' next' - if ch == maxBound then return [] - else do - chs <- go - return (ch:chs) - if first == maxBound then return Set.empty else do - rest <- go - return $ Set.fromList $ map (unsafeChr . fromIntegral) (first:rest) -foreign import ccall "my_FcCharSetFirstPage" fcCharSetFirstPage :: - CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32 -foreign import ccall "my_FcCharSetNextPage" fcCharSetNextPage :: - CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32 -foreign import ccall "my_FcCHARSET_MAP_SIZE" fcCHARSET_MAP_SIZE :: Int + | chars' == nullPtr = return IntSet.empty + | otherwise = do + iter' <- throwNull <$> fcCharSetIterCreate chars' + iter <- newForeignPtr (fcCharSetIterDestroy) iter' + x <- withForeignPtr iter fcCharSetIterStart + let go x' | fcCharSetIterDone x' = return [] + | otherwise = unsafeInterleaveIO $ do + y <- withForeignPtr iter fcCharSetIterNext + xs <- go y + return (x':xs) + ret <- go x + return $ IntSet.fromList $ map (fromIntegral) ret +data CharSetIter' +type CharSetIter_ = Ptr CharSetIter' +foreign import ccall "my_FcCharSetIterCreate" fcCharSetIterCreate :: + CharSet_ -> IO CharSetIter_ +foreign import ccall "&my_FcCharSetIterDestroy" fcCharSetIterDestroy :: + FunPtr (CharSetIter_ -> IO ()) +foreign import ccall "my_FcCharSetIterStart" fcCharSetIterStart :: + CharSetIter_ -> IO Word32 +foreign import ccall "my_FcCharSetIterNext" fcCharSetIterNext :: + CharSetIter_ -> IO Word32 +foreign import ccall "my_FcCharSetIterDone" fcCharSetIterDone :: Word32 -> Bool thawCharSet_ :: IO CharSet_ -> IO CharSet thawCharSet_ cb = bracket (throwNull <$> cb) fcCharSetDestroy thawCharSet diff --git a/Graphics/Text/Font/Choose/FontSet.hs b/Graphics/Text/Font/Choose/FontSet.hs index 7c19b0e..91ea7a9 100644 --- a/Graphics/Text/Font/Choose/FontSet.hs +++ b/Graphics/Text/Font/Choose/FontSet.hs @@ -10,6 +10,7 @@ import Foreign.Marshal.Alloc (allocaBytes) import Foreign.Marshal.Array (peekArray) import Control.Monad (forM) import Control.Exception (bracket) +import System.IO.Unsafe (unsafeInterleaveIO) -- For CSS bindings import Stylist.Parse (StyleSheet(..), parseProperties) @@ -58,7 +59,11 @@ thawFontSet fonts' = do n <- get_fontSet_nfont fonts' if n == 0 then return [] else - forM [0..pred n] (\i -> thawPattern =<< get_fontSet_font fonts' i) + forM [0..pred n] (\i -> thawPattern' =<< get_fontSet_font fonts' i) + where + thawPattern' pat = do + fcPatternReference pat + unsafeInterleaveIO $ thawPattern pat foreign import ccall "get_fontSet_nfont" get_fontSet_nfont :: FontSet_ -> IO Int foreign import ccall "get_fontSet_font" get_fontSet_font :: FontSet_ -> Int -> IO Pattern_ diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs index 7f5c42c..7d930ef 100644 --- a/Graphics/Text/Font/Choose/Pattern.hs +++ b/Graphics/Text/Font/Choose/Pattern.hs @@ -2,6 +2,7 @@ module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset, normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format, Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer, + fcPatternReference, setValue, setValues, unset, getValues, getValues', getValue, getValue', getValue0, parseFontFamily, parseFontFeatures, parseFontVars, parseLength, @@ -16,12 +17,14 @@ import Data.Hashable (Hashable(..)) import GHC.Generics (Generic) import Graphics.Text.Font.Choose.Result (throwFalse, throwNull, throwInt) -import Foreign.Ptr (Ptr) +import Foreign.Ptr (Ptr, FunPtr) +import Foreign.ForeignPtr (ForeignPtr, + newForeignPtr, withForeignPtr, mallocForeignPtrBytes) import Foreign.Marshal.Alloc (alloca, allocaBytes, free) import Foreign.Storable (Storable(..)) import Foreign.C.String (CString, withCString, peekCString) import Debug.Trace (trace) -- For reporting internal errors! -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO) import Control.Monad (forM, join) import Data.Maybe (catMaybes, fromMaybe, mapMaybe) @@ -160,20 +163,23 @@ data PatternIter' type PatternIter_ = Ptr PatternIter' foreign import ccall "size_PatternIter" patIter'Size :: Int thawPattern :: Pattern_ -> IO Pattern -thawPattern pat' = allocaBytes patIter'Size $ \iter' -> do - fcPatternIterStart pat' iter' - ret <- go iter' +thawPattern pat' = do + iter <- mallocForeignPtrBytes patIter'Size + pat <- gcPattern pat' + with2ForeignPtrs pat iter fcPatternIterStart + ret <- go pat iter return $ normalizePattern ret where - go :: PatternIter_ -> IO Pattern - go iter' = do - ok <- fcPatternIterIsValid pat' iter' + go :: ForeignPtr Pattern' -> ForeignPtr PatternIter' -> IO Pattern + go pat iter = unsafeInterleaveIO $ do + ok <- with2ForeignPtrs pat iter fcPatternIterIsValid if ok then do - x <- thawPattern' pat' iter' - ok' <- fcPatternIterNext pat' iter' - xs <- if ok' then go iter' else return [] + x <- with2ForeignPtrs pat iter thawPattern' + ok' <- with2ForeignPtrs pat iter fcPatternIterNext + xs <- if ok' then go pat iter else return [] return (x : xs) else return [] + with2ForeignPtrs a b cb = withForeignPtr a $ \a' -> withForeignPtr b $ cb a' foreign import ccall "FcPatternIterStart" fcPatternIterStart :: Pattern_ -> PatternIter_ -> IO () foreign import ccall "FcPatternIterIsValid" fcPatternIterIsValid :: @@ -208,6 +214,13 @@ thawPattern_ cb = bracket (throwNull <$> cb) fcPatternDestroy thawPattern withNewPattern cb = bracket (throwNull <$> fcPatternCreate) fcPatternDestroy cb foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_ foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO () +foreign import ccall "&FcPatternDestroy" fcPatternDestroy' :: + FunPtr (Pattern_ -> IO ()) + +gcPattern :: Pattern_ -> IO (ForeignPtr Pattern') +gcPattern pat' = do + fcPatternReference pat' + newForeignPtr fcPatternDestroy' pat' ------ --- Pattern diff --git a/cbits/pattern.c b/cbits/pattern.c index 28184bf..8cfb6f7 100644 --- a/cbits/pattern.c +++ b/cbits/pattern.c @@ -1,17 +1,6 @@ #include #include -int my_FcCHARSET_MAP_SIZE() { - return FC_CHARSET_MAP_SIZE; -} - -FcChar32 my_FcCharSetFirstPage(const FcCharSet *a, FcChar32 *map, FcChar32 *next) { - return FcCharSetFirstPage(a, map, next); -} -FcChar32 my_FcCharSetNextPage(const FcCharSet *a, FcChar32 *map, FcChar32 *next) { - return FcCharSetNextPage(a, map, next); -} - FcBool my_FcPatternAdd(FcPattern *p, const char *object, FcBool binding, FcBool append, FcValue *value) { if (binding) { diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal index 277e35f..28c9029 100644 --- a/fontconfig-pure.cabal +++ b/fontconfig-pure.cabal @@ -10,7 +10,7 @@ name: fontconfig-pure -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.0 +version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: Pure-functional language bindings to FontConfig @@ -62,7 +62,7 @@ library Graphics.Text.Font.Choose.Config, Graphics.Text.Font.Choose.Init, Graphics.Text.Font.Choose.Weight - c-sources: cbits/pattern.c + c-sources: cbits/pattern.c, cbits/charsetiter.c -- LANGUAGE extensions used by modules in this package. -- other-extensions: -- 2.30.2