From 3704f1e1b0223877377e52c8235434d54595bb02 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Sun, 24 Sep 2023 17:27:30 +1300 Subject: [PATCH] Found some more performance optimizations. Use dupablePerformIO where relevant, & it doesn't incur excessive allocation. Ensure amounts of output are dereferenced as quickly as large amounts are. --- Data/Text/Glyphize.hs | 6 +-- Data/Text/Glyphize/Buffer.hs | 62 +++----------------------- Data/Text/Glyphize/Font.hs | 86 ++++++++++++++++++------------------ bench/Main.hs | 38 +++++++++++----- harfbuzz-pure.cabal | 4 +- 5 files changed, 80 insertions(+), 116 deletions(-) diff --git a/Data/Text/Glyphize.hs b/Data/Text/Glyphize.hs index 3114068..fd27933 100644 --- a/Data/Text/Glyphize.hs +++ b/Data/Text/Glyphize.hs @@ -33,7 +33,7 @@ import Data.Text.Glyphize.Font import Data.Text.Glyphize.Buffer import Data.Text.Glyphize.Oom -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) import Foreign.Ptr (Ptr(..)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Alloc (alloca) @@ -76,7 +76,7 @@ guessSegmentProperties = unsafePerformIO . flip withBuffer thawBuffer foreign import ccall "hb_version" hb_version :: Ptr Int -> Ptr Int -> Ptr Int -> IO () -- | Returns the library version as 3 integer components. version :: (Int, Int, Int) -version = unsafePerformIO $ +version = unsafeDupablePerformIO $ alloca $ \a' -> alloca $ \b' -> alloca $ \c' -> do hb_version a' b' c' a <- peek a' @@ -88,4 +88,4 @@ foreign import ccall "hb_version_atleast" versionAtLeast :: Int -> Int -> Int -> foreign import ccall "hb_version_string" hb_version_string :: CString -- | Returns library version as a string with 3 integer components. versionString :: String -versionString = unsafePerformIO $ peekCString hb_version_string +versionString = unsafeDupablePerformIO $ peekCString hb_version_string diff --git a/Data/Text/Glyphize/Buffer.hs b/Data/Text/Glyphize/Buffer.hs index f777359..bbe1cf7 100644 --- a/Data/Text/Glyphize/Buffer.hs +++ b/Data/Text/Glyphize/Buffer.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE MagicHash, UnboxedTuples #-} -{-# LANGUAGE UnliftedFFITypes, DeriveGeneric #-} +{-# LANGUAGE MagicHash, UnliftedFFITypes, DeriveGeneric #-} module Data.Text.Glyphize.Buffer where import qualified Data.Text.Internal.Lazy as Lazy @@ -11,21 +10,19 @@ import Control.Exception (bracket) import Control.DeepSeq (NFData) import Data.Text.Glyphize.Oom (throwFalse, throwNull) +import Data.Text.Glyphize.Array (iterateLazy) import qualified Data.Text.Array as A -import GHC.Exts (ByteArray#, sizeofByteArray#, Int#, realWorld#) +import GHC.Exts (ByteArray#, sizeofByteArray#, Int#) import Data.Word (Word32) import Data.Int (Int32) import Data.Bits ((.|.), (.&.), shiftR, shiftL, testBit) -import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) -import GHC.IO (IO(IO)) +import System.IO.Unsafe (unsafePerformIO) import Foreign.Marshal.Alloc (alloca, allocaBytes) -import Foreign.Marshal.Array (peekArray, copyArray) +import Foreign.Marshal.Array (peekArray) import Foreign.Ptr -import Foreign.ForeignPtr (ForeignPtr, - withForeignPtr, plusForeignPtr, mallocForeignPtrArray) import Foreign.C.String (CString, withCString, peekCString) import Foreign.Storable (Storable(..)) import GHC.Generics (Generic(..)) @@ -490,52 +487,3 @@ foreign import ccall "hb_buffer_get_invisible_glyph" hb_buffer_get_invisible_gly :: Buffer' -> IO Word32 foreign import ccall "hb_buffer_get_replacement_codepoint" hb_buffer_get_replacement_codepoint :: Buffer' -> IO Word32 - ---- Even more optimized peekArray - -clonePtr ptr l = do - ret <- mallocForeignPtrArray l - withForeignPtr ret $ \ptr' -> copyArray ptr ptr' l - return ret -peekLazy :: Storable a => ForeignPtr a -> Int -> [a] -peekLazy = peekLazy' 0 -peekLazy' n fp l - | n < l = x:peekLazy' (succ n) fp l - | otherwise = [] - where x = accursedUnutterablePerformIO $ withForeignPtr fp $ flip peekElemOff n -iterateLazy :: Storable a => Ptr a -> Int -> IO [a] -iterateLazy ptr l = do - fp <- clonePtr ptr l - return $ peekLazy fp $ fromEnum l - --- | This \"function\" has a superficial similarity to 'System.IO.Unsafe.unsafePerformIO' but --- it is in fact a malevolent agent of chaos. It unpicks the seams of reality --- (and the 'IO' monad) so that the normal rules no longer apply. It lulls you --- into thinking it is reasonable, but when you are not looking it stabs you --- in the back and aliases all of your mutable buffers. The carcass of many a --- seasoned Haskell programmer lie strewn at its feet. --- --- Witness the trail of destruction: --- --- * --- --- * --- --- * --- --- * --- --- * --- --- * --- --- * --- --- Do not talk about \"safe\"! You do not know what is safe! --- --- Yield not to its blasphemous call! Flee traveller! Flee or you will be --- corrupted and devoured! --- -{-# INLINE accursedUnutterablePerformIO #-} -accursedUnutterablePerformIO :: IO a -> a -accursedUnutterablePerformIO (IO m) = case m realWorld# of (# _, r #) -> r diff --git a/Data/Text/Glyphize/Font.hs b/Data/Text/Glyphize/Font.hs index feb4c9b..fa0b614 100644 --- a/Data/Text/Glyphize/Font.hs +++ b/Data/Text/Glyphize/Font.hs @@ -14,11 +14,11 @@ import Control.Monad (forM, unless) import Control.Exception (bracket) import Data.Maybe (fromMaybe) -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) import Foreign.ForeignPtr (ForeignPtr(..), withForeignPtr, newForeignPtr, newForeignPtr_) import Foreign.Ptr (Ptr(..), FunPtr(..), nullPtr, nullFunPtr, castPtr) import Foreign.Marshal.Alloc (alloca, allocaBytes) -import Foreign.Marshal.Array (withArray, withArrayLen) +import Foreign.Marshal.Array (withArray, withArrayLen, peekArray) import Foreign.Storable (Storable(..)) import Foreign.Storable.Generic (GStorable(..)) import GHC.Generics (Generic(..)) @@ -363,11 +363,11 @@ foreign import ccall "hb_font_get_face" hb_font_get_face :: Font_ -> IO Face_ -- with an optional variation selector. fontGlyph :: Font -> Char -> Maybe Char -> Maybe Word32 fontGlyph font char var = - unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do + unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do success <- hb_font_get_glyph font' (c2w char) (c2w $ fromMaybe '\0' var) ret if success then return . Just =<< peek ret else return Nothing fontGlyph' font char var = - unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do + unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do throwFalse $ hb_font_get_glyph font' (c2w char) (c2w $ fromMaybe '\0' var) ret peek ret foreign import ccall "hb_font_get_glyph" hb_font_get_glyph @@ -378,7 +378,7 @@ foreign import ccall "hb_font_get_glyph" hb_font_get_glyph -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of direction . fontGlyphAdvance :: Font -> Word32 -> Maybe Direction -> (Int32, Int32) -fontGlyphAdvance font glyph dir = unsafePerformIO $ +fontGlyphAdvance font glyph dir = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do hb_font_get_glyph_advance_for_direction font' glyph (dir2int dir) x' y' x <- peek x' @@ -391,7 +391,7 @@ foreign import ccall "hb_font_get_glyph_advance_for_direction" -- | Fetches the (x,y) coordinates of a specified contour-point index -- in the specified glyph, within the specified font. fontGlyphContourPoint :: Font -> Word32 -> Int -> Maybe (Int32, Int32) -fontGlyphContourPoint font glyph index = unsafePerformIO $ +fontGlyphContourPoint font glyph index = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do success <- hb_font_get_glyph_contour_point font' glyph index x' y' if success @@ -400,7 +400,7 @@ fontGlyphContourPoint font glyph index = unsafePerformIO $ y <- peek y' return $ Just (x, y) else return Nothing -fontGlyphContourPoint' font glyph index = unsafePerformIO $ +fontGlyphContourPoint' font glyph index = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do throwFalse $ hb_font_get_glyph_contour_point font' glyph index x' y' x <- peek x' @@ -415,7 +415,7 @@ foreign import ccall "hb_font_get_glyph_contour_point" hb_font_get_glyph_contour -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of direction . fontGlyphContourPointForOrigin :: Font -> Word32 -> Int -> Maybe Direction -> Maybe (Int32, Int32) -fontGlyphContourPointForOrigin font glyph index dir = unsafePerformIO $ +fontGlyphContourPointForOrigin font glyph index dir = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do success <- hb_font_get_glyph_contour_point_for_origin font' glyph index (dir2int dir) x' y' @@ -425,7 +425,7 @@ fontGlyphContourPointForOrigin font glyph index dir = unsafePerformIO $ y <- peek y' return $ Just (x, y) else return Nothing -fontGlyphContourPointForOrigin' font glyph index dir = unsafePerformIO $ +fontGlyphContourPointForOrigin' font glyph index dir = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do throwFalse $ hb_font_get_glyph_contour_point_for_origin font' glyph index (dir2int dir) x' y' @@ -451,13 +451,13 @@ data GlyphExtents = GlyphExtents { instance GStorable GlyphExtents -- | Fetches the `GlyphExtents` data for a glyph ID in the specified `Font`. fontGlyphExtents :: Font -> Word32 -> Maybe GlyphExtents -fontGlyphExtents font glyph = unsafePerformIO $ +fontGlyphExtents font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do success <- hb_font_get_glyph_extents font' glyph ret if success then return . Just =<< peek ret else return Nothing -fontGlyphExtents' font glyph = unsafePerformIO $ +fontGlyphExtents' font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do throwFalse $ hb_font_get_glyph_extents font' glyph ret peek ret @@ -469,13 +469,13 @@ foreign import ccall "hb_font_get_glyph_extents" hb_font_get_glyph_extents -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of given `Direction`. fontGlyphExtentsForOrigin :: Font -> Word32 -> Maybe Direction -> Maybe GlyphExtents -fontGlyphExtentsForOrigin font glyph dir = unsafePerformIO $ +fontGlyphExtentsForOrigin font glyph dir = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do ok <- hb_font_get_glyph_extents_for_origin font' glyph (dir2int dir) ret if ok then return . Just =<< peek ret else return Nothing -fontGlyphExtentsForOrigin' font glyph dir = unsafePerformIO $ +fontGlyphExtentsForOrigin' font glyph dir = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do throwFalse $ hb_font_get_glyph_extents_for_origin font' glyph (dir2int dir) ret peek ret @@ -485,14 +485,14 @@ foreign import ccall "hb_font_get_glyph_extents_for_origin" -- | Fetches the glyph ID that corresponds to a name string in the specified `Font`. fontGlyphFromName :: Font -> String -> Maybe Word32 -fontGlyphFromName font name = unsafePerformIO $ +fontGlyphFromName font name = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do success <- withCStringLen name $ \(name', len) -> hb_font_get_glyph_from_name font' name' len ret if success then return . Just =<< peek ret else return Nothing -fontGlyphFromName' font name = unsafePerformIO $ +fontGlyphFromName' font name = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do throwFalse $ withCStringLen name $ \(name', len) -> hb_font_get_glyph_from_name font' name' len ret @@ -524,7 +524,7 @@ foreign import ccall "hb_font_get_glyph_h_kerning" hb_font_get_glyph_h_kerning -- | Fetches the (X,Y) coordinate of the origin for a glyph ID in the specified `Font`, -- for horizontal text segments. fontGlyphHOrigin :: Font -> Word32 -> Maybe (Int32, Int32) -fontGlyphHOrigin font glyph = unsafePerformIO $ withForeignPtr font $ \font' -> +fontGlyphHOrigin font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do success <- hb_font_get_glyph_h_origin font' glyph x' y' if success @@ -533,7 +533,7 @@ fontGlyphHOrigin font glyph = unsafePerformIO $ withForeignPtr font $ \font' -> y <- peek y' return $ Just (x, y) else return Nothing -fontGlyphHOrigin' font glyph = unsafePerformIO $ withForeignPtr font $ \font' -> +fontGlyphHOrigin' font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do throwFalse $ hb_font_get_glyph_h_origin font' glyph x' y' x <- peek x' @@ -545,7 +545,7 @@ foreign import ccall "hb_font_get_glyph_h_origin" hb_font_get_glyph_h_origin :: -- | Fetches the (X,Y) coordinates of the origin for a glyph ID in the specified `Font`, -- for vertical text segments. fontGlyphVOrigin :: Font -> Word32 -> Maybe (Int32, Int32) -fontGlyphVOrigin font glyph = unsafePerformIO $ withForeignPtr font $ \font' -> +fontGlyphVOrigin font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do success <- hb_font_get_glyph_v_origin font' glyph x' y' if success @@ -554,7 +554,7 @@ fontGlyphVOrigin font glyph = unsafePerformIO $ withForeignPtr font $ \font' -> y <- peek y' return $ Just (x, y) else return Nothing -fontGlyphVOrigin' font glyph = unsafePerformIO $ withForeignPtr font $ \font' -> +fontGlyphVOrigin' font glyph = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do throwFalse $ hb_font_get_glyph_v_origin font' glyph x' y' x <- peek x' @@ -567,7 +567,7 @@ foreign import ccall "hb_font_get_glyph_v_origin" hb_font_get_glyph_v_origin :: -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of given `Direction`. fontGlyphKerningForDir :: Font -> Word32 -> Word32 -> Maybe Direction -> (Int32, Int32) -fontGlyphKerningForDir font a b dir = unsafePerformIO $ withForeignPtr font $ \font' -> +fontGlyphKerningForDir font a b dir = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do hb_font_get_glyph_kerning_for_direction font' a b (dir2int dir) x' y' x <- peek x' @@ -584,13 +584,13 @@ fontGlyphName' a b = fontGlyphName_' a b 32 -- | Variant of `fontGlyphName` which lets you specify the maximum of the return value. -- Defaults to 32. fontGlyphName_ :: Font -> Word32 -> Int -> Maybe String -fontGlyphName_ font glyph size = unsafePerformIO $ withForeignPtr font $ \font' -> +fontGlyphName_ font glyph size = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> allocaBytes size $ \name' -> do success <- hb_font_get_glyph_name font' glyph name' (toEnum size) if success then Just <$> peekCStringLen (name', size) else return Nothing -fontGlyphName_' font glyph size = unsafePerformIO $ withForeignPtr font $ \font' -> +fontGlyphName_' font glyph size = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> allocaBytes size $ \name' -> do throwFalse $ hb_font_get_glyph_name font' glyph name' (toEnum size) peekCStringLen (name', size) @@ -601,7 +601,7 @@ foreign import ccall "hb_font_get_glyph_name" hb_font_get_glyph_name :: -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of given `Direction`. fontGlyphOriginForDir :: Font -> Word32 -> Maybe Direction -> (Int32, Int32) -fontGlyphOriginForDir font glyph dir = unsafePerformIO $ withForeignPtr font $ \font' -> +fontGlyphOriginForDir font glyph dir = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do hb_font_get_glyph_origin_for_direction font' glyph (dir2int dir) x' y' x <- peek x' @@ -619,11 +619,11 @@ foreign import ccall "hb_font_get_glyph_origin_for_direction" -- `fontVarGlyph` or use `fontGlyph`. fontNominalGlyph :: Font -> Char -> Maybe Word32 fontNominalGlyph font c = - unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do + unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do success <- hb_font_get_nominal_glyph font' (c2w c) glyph' if success then Just <$> peek glyph' else return Nothing fontNominalGlyph' font c = - unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do + unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do throwFalse $ hb_font_get_nominal_glyph font' (c2w c) glyph' peek glyph' foreign import ccall "hb_font_get_nominal_glyph" hb_font_get_nominal_glyph :: @@ -632,13 +632,13 @@ foreign import ccall "hb_font_get_nominal_glyph" hb_font_get_nominal_glyph :: -- | Fetches the parent of the given `Font`. fontParent :: Font -> Font fontParent child = - unsafePerformIO (newForeignPtr_ =<< withForeignPtr child hb_font_get_parent) + unsafeDupablePerformIO (newForeignPtr_ =<< withForeignPtr child hb_font_get_parent) foreign import ccall "hb_font_get_parent" hb_font_get_parent :: Font_ -> IO Font_ -- | Fetches the horizontal & vertical points-per-em (ppem) of a `Font`. fontPPEm :: Font -> (Word32, Word32) fontPPEm font = - unsafePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do + unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do hb_font_get_ppem font' x' y' x <- peek x' y <- peek y' @@ -653,7 +653,7 @@ foreign import ccall "hb_font_get_ptem" hb_font_get_ptem :: Font_ -> Float -- | Fetches the horizontal and vertical scale of a `Font`. fontScale :: Font -> (Int, Int) -fontScale font = unsafePerformIO $ +fontScale font = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \x' -> alloca $ \y' -> do hb_font_get_scale font' x' y' x <- peek x' :: IO Int32 @@ -671,13 +671,13 @@ foreign import ccall "hb_font_get_synthetic_slant" hb_font_get_synthetic_slant : -- | Fetches the glyph ID for a Unicode codepoint when followed by -- the specified variation-selector codepoint, in the specified `Font`. fontVarGlyph :: Font -> Word32 -> Word32 -> Maybe Word32 -fontVarGlyph font unicode varSel = unsafePerformIO $ +fontVarGlyph font unicode varSel = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do success <- hb_font_get_variation_glyph font' unicode varSel glyph' if success then return . Just =<< peek glyph' else return Nothing -fontVarGlyph' font unicode varSel = unsafePerformIO $ +fontVarGlyph' font unicode varSel = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \glyph' -> do throwFalse $ hb_font_get_variation_glyph font' unicode varSel glyph' peek glyph' @@ -689,11 +689,11 @@ foreign import ccall "hb_font_get_variation_glyph" hb_font_get_variation_glyph -- Note that this returned list may only contain values for some (or none) of the axes; -- ommitted axes effectively have their default values. fontVarCoordsDesign :: Font -> [Float] -fontVarCoordsDesign font = unsafePerformIO $ +fontVarCoordsDesign font = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \length' -> do arr <- hb_font_get_var_coords_design font' length' length <- peek length' - forM [0..fromEnum length-1] $ peekElemOff arr + peekArray (fromEnum length) arr foreign import ccall "hb_font_get_var_coords_design" hb_font_get_var_coords_design :: Font_ -> Ptr Word -> IO (Ptr Float) @@ -701,7 +701,7 @@ foreign import ccall "hb_font_get_var_coords_design" -- Note that this returned list may only contain values for some (or none) of the axes; -- ommitted axes effectively have default values. fontVarCoordsNormalized :: Font -> [Int] -fontVarCoordsNormalized font = unsafePerformIO $ +fontVarCoordsNormalized font = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \length' -> do arr <- throwNull $ hb_font_get_var_coords_normalized font' length' length <- peek length' @@ -712,14 +712,14 @@ foreign import ccall "hb_font_get_var_coords_normalized" -- | Fetches the glyph ID from given `Font` that matches the specified string. -- Strings of the format gidDDD or uniUUUU are parsed automatically. fontTxt2Glyph :: Font -> String -> Maybe Word32 -fontTxt2Glyph font str = unsafePerformIO $ +fontTxt2Glyph font str = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do ok <- withCStringLen str $ \(str', len) -> hb_font_glyph_from_string font' str' len ret if ok then return . Just =<< peek ret else return Nothing -fontTxt2Glyph' font str = unsafePerformIO $ +fontTxt2Glyph' font str = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> alloca $ \ret -> do throwFalse $ withCStringLen str $ \(str', len) -> hb_font_glyph_from_string font' str' len ret @@ -731,7 +731,7 @@ foreign import ccall "hb_font_glyph_from_string" hb_font_glyph_from_string -- If the glyph ID has no name in the `Font`, a string of the form gidDDD is generated -- with DDD being the glyph ID. fontGlyph2Str :: Font -> Word32 -> Int -> String -fontGlyph2Str font glyph length = unsafePerformIO $ +fontGlyph2Str font glyph length = unsafeDupablePerformIO $ withForeignPtr font $ \font' -> allocaBytes length $ \ret -> do hb_font_glyph_to_string font' glyph ret length peekCString ret @@ -756,7 +756,7 @@ instance GStorable FontExtents -- Calls the appropriate direction-specific variant (horizontal or vertical) -- depending on the value of direction . fontExtentsForDir :: Font -> Maybe Direction -> FontExtents -fontExtentsForDir font dir = unsafePerformIO $ alloca $ \ret -> do +fontExtentsForDir font dir = unsafeDupablePerformIO $ alloca $ \ret -> do withForeignPtr font $ \font' -> hb_font_get_extents_for_direction font' (dir2int dir) ret peek ret @@ -764,24 +764,24 @@ foreign import ccall "hb_font_get_extents_for_direction" hb_font_get_extents_for_direction :: Font_ -> Int -> Ptr FontExtents -> IO () -- | Fetches the extents for a specified font, for horizontal text segments. -fontHExtents font = unsafePerformIO $ alloca $ \ret -> do +fontHExtents font = unsafeDupablePerformIO $ alloca $ \ret -> do ok <- withForeignPtr font $ \font' -> hb_font_get_h_extents font' ret if ok then return . Just =<< peek ret else return Nothing -fontHExtents' font = unsafePerformIO $ alloca $ \ret -> do +fontHExtents' font = unsafeDupablePerformIO $ alloca $ \ret -> do throwFalse $ withForeignPtr font $ \font' -> hb_font_get_h_extents font' ret peek ret foreign import ccall "hb_font_get_h_extents" hb_font_get_h_extents :: Font_ -> Ptr FontExtents -> IO Bool -- | Fetches the extents for a specified font, for vertical text segments. -fontVExtents font = unsafePerformIO $ alloca $ \ret -> do +fontVExtents font = unsafeDupablePerformIO $ alloca $ \ret -> do ok <- withForeignPtr font $ \font' -> hb_font_get_v_extents font' ret if ok then return . Just =<< peek ret else return Nothing -fontVExtents' font = unsafePerformIO $ alloca $ \ret -> do +fontVExtents' font = unsafeDupablePerformIO $ alloca $ \ret -> do throwFalse $ withForeignPtr font $ \font' -> hb_font_get_v_extents font' ret peek ret foreign import ccall "hb_font_get_v_extents" hb_font_get_v_extents @@ -947,11 +947,11 @@ foreign import ccall "hb_blob_destroy" hb_blob_destroy' :: Blob_ -> IO () -- | Internal utility for defining trivial language bindings unwrapping `Face` foreign pointers. faceFunc :: (Face_ -> a) -> (Face -> a) -faceFunc cb fce = unsafePerformIO $ withForeignPtr fce $ return . cb +faceFunc cb fce = unsafeDupablePerformIO $ withForeignPtr fce $ return . cb -- | Internal utility for defining trivial language bindings unwrapping `Font` foreign pointers. fontFunc :: (Font_ -> a) -> (Font -> a) -fontFunc cb fnt = unsafePerformIO $ withForeignPtr fnt $ return . cb +fontFunc cb fnt = unsafeDupablePerformIO $ withForeignPtr fnt $ return . cb -- | Internal utility for exposing Harfbuzz functions that populate a bitset. -- Converts the populated bitset to a Haskell lazy linked-list. diff --git a/bench/Main.hs b/bench/Main.hs index 7b2d3f1..57ad368 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -2,8 +2,7 @@ module Main where import Criterion.Main import Data.Text.Glyphize -import FileEmbedLzma (embedLazyText, embedByteString) -import Data.FileEmbed (makeRelativeToProject) +import Data.FileEmbed import System.FilePath (()) import qualified Data.Text.Foreign as Txt import qualified Data.Text.Lazy as Txt @@ -12,19 +11,17 @@ import Control.Parallel.Strategies (parMap, rdeepseq) import Data.Word (Word8) -- Benchmarking these as well... -import Foreign.Marshal.Array (peekArray, copyArray) -import Foreign.ForeignPtr (mallocForeignPtrArray, ForeignPtr) - -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable(..)) -import System.IO.Unsafe (unsafePerformIO) +import Foreign.Marshal.Array (peekArray) +import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray) +import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO, unsafeInterleaveIO) +import Data.Text.Glyphize.Array shapeStr txt = shape font defaultBuffer { text = txt } [] where font = createFont $ createFace $( makeRelativeToProject ("assets" "Lora-Regular.ttf") >>= - embedByteString) 0 + embedFile) 0 -dracula = $(makeRelativeToProject ("bench" "dracula.txt") >>= embedLazyText) +dracula = $(makeRelativeToProject ("bench" "dracula.txt") >>= embedStringFile) main = defaultMain [ bgroup "Dracula" [ @@ -39,6 +36,25 @@ main = defaultMain [ bench "peekArray" $ whnfIO $ Txt.useAsPtr (Txt.toStrict dracula) $ \ptr l -> peekArray (fromEnum l) ptr, bench "alloc foreign ptr" $ whnfIO (mallocForeignPtrArray $ - fromEnum $ Txt.length dracula :: IO (ForeignPtr Word8)) + fromEnum $ Txt.length dracula :: IO (ForeignPtr Word8)), + bench "clone ptr" $ whnfIO $ Txt.useAsPtr (Txt.toStrict dracula) $ + \ptr l -> clonePtr ptr $ fromEnum l, + bench "peek lazy" $ whnfIO (Txt.asForeignPtr (Txt.toStrict dracula) >>= + \(ptr, l) -> return $ peekLazy ptr $ fromEnum l), + bench "iterate lazy" $ whnfIO $ Txt.useAsPtr (Txt.toStrict dracula) $ + \ptr l -> iterateLazy ptr $ fromEnum l, + bench "peek lazy (NF)" $ nfIO $ (Txt.asForeignPtr (Txt.toStrict dracula) >>= + \(ptr, l) -> return $ peekLazy ptr $ fromEnum l), + bench "iterate lazy (NF)" $ nfIO $ Txt.useAsPtr (Txt.toStrict dracula) $ + \ptr l -> iterateLazy ptr $ fromEnum l, + -- These benchmarks give unconfident results, thought they'd be interesting... + bench "unsafePerformIO" $ whnf unsafePerformIO $ return (), + bench "unsafeDupablePerformIO" $ whnf unsafeDupablePerformIO $ return (), + bench "unsafeInterleaveIO" $ whnfIO $ unsafeInterleaveIO $ return (), + bench "accursedUnutterablePerformIO" $ whnf accursedUnutterablePerformIO $ return (), + bench "peek kilo array" $ nfIO $ Txt.useAsPtr (Txt.toStrict $ Txt.take 1024 dracula) $ + \ptr l -> peekArray (fromEnum l) ptr, + bench "lazy kilo array" $ nfIO (Txt.asForeignPtr (Txt.toStrict $ Txt.take 1024 dracula) >>= + \(ptr, l) -> return $ peekLazy ptr $ fromEnum l) ] ] diff --git a/harfbuzz-pure.cabal b/harfbuzz-pure.cabal index 5414e36..a110b02 100644 --- a/harfbuzz-pure.cabal +++ b/harfbuzz-pure.cabal @@ -57,7 +57,7 @@ source-repository head library -- Modules exported by the library. - exposed-modules: Data.Text.Glyphize + exposed-modules: Data.Text.Glyphize, Data.Text.Glyphize.Array -- Modules included in this library but not exported. other-modules: Data.Text.Glyphize.Font, Data.Text.Glyphize.Buffer, Data.Text.Glyphize.Oom @@ -95,6 +95,6 @@ benchmark bench-harfbuzz type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: Main.hs - build-depends: base, harfbuzz-pure, file-embed-lzma, file-embed, criterion, filepath, text, parallel + build-depends: base, harfbuzz-pure, file-embed, criterion, filepath, text, parallel ghc-options: -threaded -- 2.30.2