diff --git a/Data/Text/Glyphize.hs b/Data/Text/Glyphize.hs --- a/Data/Text/Glyphize.hs +++ b/Data/Text/Glyphize.hs @@ -32,8 +32,9 @@ import Data.Text.Glyphize.Font import Data.Text.Glyphize.Buffer import Data.Text.Glyphize.Oom +import Data.Text.Glyphize.Array (noCache) -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) import Foreign.Ptr (Ptr(..)) import Foreign.ForeignPtr (withForeignPtr) import Foreign.Marshal.Alloc (alloca) @@ -49,12 +50,12 @@ -- the value of the `Feature` with the higher index takes precedance. shape :: Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)] shape _ Buffer {text = ""} _ = [] -shape font buffer features = unsafePerformIO $ withForeignPtr font $ \font' -> - withBuffer buffer $ \buffer' -> withArrayLen features $ \len features' -> do +shape font buffer features = unsafePerformIO $ withBuffer buffer $ \buffer' -> do + withForeignPtr font $ \font' -> withArrayLen features $ \len features' -> hb_shape font' buffer' features' $ toEnum len - infos <- glyphInfos buffer' - pos <- glyphsPos buffer' - return $ zip infos pos + infos <- glyphInfos buffer' + pos <- glyphsPos buffer' + return $ noCache zip infos pos foreign import ccall "hb_shape" hb_shape :: Font_ -> Buffer' -> Ptr Feature -> Word -> IO () -- | Fills in unset segment properties based on buffer unicode contents. @@ -76,7 +77,7 @@ 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 +89,4 @@ 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/Array.hs b/Data/Text/Glyphize/Array.hs new file mode 100644 --- /dev/null +++ b/Data/Text/Glyphize/Array.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +-- | Published almost entirely for benchmarks, comparing to stdlib! +-- Should have little direct interest to Harfbuzz callers, & I'm not promising a stable API. +-- This is here because, as it turns out, Harfbuzz can return a lot of output! +module Data.Text.Glyphize.Array where + +import Foreign.Storable (Storable(..)) +import Foreign.ForeignPtr (ForeignPtr, plusForeignPtr, withForeignPtr, mallocForeignPtrArray) +import Foreign.Ptr +import Foreign.Marshal.Array (copyArray) + +import GHC.IO (IO(IO)) +import GHC.Exts (realWorld#, oneShot) + +-- | Clone the given array so it can be freed without the losing access to the data. +-- Uses `memcpy` so it gets very heavily optimized by the OS. +clonePtr :: Storable a => Ptr a -> Int -> IO (ForeignPtr a) +clonePtr ptr l = do + ret <- mallocForeignPtrArray l + withForeignPtr ret $ \ptr' -> copyArray ptr' ptr l + return ret +-- | Iterate over an array in a ForeignPtr, no matter how small or large it is. +peekLazy :: Storable a => ForeignPtr a -> Int -> [a] +peekLazy fp 0 = [] +peekLazy fp n + | n <= chunkSize = withFP $ peekEager [] n + | otherwise = withFP $ peekEager (plusForeignPtr fp chunkSize `peekLazy` (-) n chunkSize) chunkSize + where withFP = accursedUnutterablePerformIO . withForeignPtr fp +-- | Variation of peekArray, taking a tail to append to the decoded list. +peekEager :: Storable a => [a] -> Int -> Ptr a -> IO [a] +peekEager acc 0 ptr = return acc +peekEager acc n ptr = let n' = pred n in do + e <- peekElemOff ptr n' + peekEager (e:acc) n' ptr +-- | How many words should be decoded by `peekLazy` & `iterateLazy`. +chunkSize :: Int +chunkSize = 1024 -- 4k, benchmarks seem to like it! +-- | Convert an array from C code into a Haskell list, +-- performant no matter how small or large it is. +iterateLazy :: Storable a => Ptr a -> Int -> IO [a] +iterateLazy ptr l + | l < 0 = putStrLn ("Invalid array length: " ++ show l) >> return [] + | l == 0 = return [] + | otherwise = do + fp <- clonePtr ptr l + return $ noCache 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 + +-- | Harfbuzz produces ~40x as much output data as its input data. +-- In many applications that input data would be a large fraction of its heap. +-- As such, unless callers are processing these results, it is usually more +-- efficient for Haskell to recompute the glyphs than to store them. +-- +-- This synonym of `oneShot` is used to instruct Haskell of this fact. +noCache :: (a -> b) -> a -> b +noCache = oneShot diff --git a/Data/Text/Glyphize/Buffer.hs b/Data/Text/Glyphize/Buffer.hs --- a/Data/Text/Glyphize/Buffer.hs +++ b/Data/Text/Glyphize/Buffer.hs @@ -7,8 +7,10 @@ import Data.Char (toUpper, toLower) import Control.Monad (forM) import Control.Exception (bracket) +import Control.DeepSeq (NFData) import Data.Text.Glyphize.Oom (throwFalse, throwNull) +import Data.Text.Glyphize.Array (iterateLazy, noCache) import qualified Data.Text.Array as A import GHC.Exts (ByteArray#, sizeofByteArray#, Int#) @@ -17,7 +19,9 @@ import Data.Bits ((.|.), (.&.), shiftR, shiftL, testBit) import System.IO.Unsafe (unsafePerformIO) + import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Array (peekArray) import Foreign.Ptr import Foreign.C.String (CString, withCString, peekCString) import Foreign.Storable (Storable(..)) @@ -389,40 +393,23 @@ -- before this cluster for elongation. -- This flag does not determine the script-specific elongation places, -- but only when it is safe to do the elongation without interrupting text shaping. -} deriving (Show, Read, Eq) -instance Storable GlyphInfo where - sizeOf _ = sizeOf (undefined :: Word32) * 5 - alignment _ = alignment (undefined :: Word32) - peek ptr = do - let ptr' :: Ptr Word32 - ptr' = castPtr ptr - -- Ignore private fields. - codepoint' <- ptr' `peekElemOff` 0 - mask <- ptr' `peekElemOff` 1 - cluster' <- ptr' `peekElemOff` 2 - return $ GlyphInfo codepoint' cluster' (mask `testBit` 1) (mask `testBit` 2) (mask `testBit` 3) - poke ptr (GlyphInfo codepoint' cluster' flag1 flag2 flag3) = do - -- Zero private fields. - let ptr' :: Ptr Word32 - ptr' = castPtr ptr - pokeElemOff ptr' 0 codepoint' - pokeElemOff ptr' 1 $ Prelude.foldl (.|.) 0 [ - if flag1 then 1 else 0, - if flag2 then 2 else 0, - if flag3 then 4 else 0 - ] - pokeElemOff ptr' 2 cluster' - pokeElemOff ptr' 3 0 - pokeElemOff ptr' 4 0 --- | Decodes `Buffer'`'s glyph information array.' +} deriving (Show, Read, Eq, Generic) +instance NFData GlyphInfo +-- | Decodes multiple `GlyphInfo`s from a dereferenced `Word32` list according to +-- Harfbuzz's ABI. +decodeInfos :: [Word32] -> [GlyphInfo] +decodeInfos (codepoint':cluster':mask:_:_:rest) = + GlyphInfo codepoint' cluster' (mask `testBit` 1) (mask `testBit` 2) + (mask `testBit` 3):decodeInfos rest +decodeInfos _ = [] +-- | Decodes `Buffer'`'s glyph information array. glyphInfos buf' = do arr <- throwNull $ hb_buffer_get_glyph_infos buf' nullPtr length <- hb_buffer_get_length buf' - if length == 0 || arr == nullPtr - then return [] - else forM [0..fromEnum length - 1] $ peekElemOff arr + words <- iterateLazy arr (fromEnum length * 5) + return $ noCache decodeInfos words foreign import ccall "hb_buffer_get_glyph_infos" hb_buffer_get_glyph_infos - :: Buffer' -> Ptr Word -> IO (Ptr GlyphInfo) + :: Buffer' -> Ptr Word -> IO (Ptr Word32) foreign import ccall "hb_buffer_get_length" hb_buffer_get_length :: Buffer' -> IO Word -- NOTE: The array returned from FFI is valid as long as the buffer is. @@ -442,33 +429,21 @@ -- ^ How much the glyph moves on the Y-axis before drawing it, this should -- not effect how much the line advances. } deriving (Show, Read, Eq, Generic) -instance Storable GlyphPos where - sizeOf _ = sizeOf (undefined :: Int32) * 5 - alignment _ = alignment (undefined :: Int32) - peek ptr = let ptr' = castPtr ptr in do - x_advance' <- ptr' `peekElemOff` 0 - y_advance' <- ptr' `peekElemOff` 1 - x_offset' <- ptr' `peekElemOff` 2 - y_offset' <- ptr' `peekElemOff` 3 - return $ GlyphPos x_advance' y_advance' x_offset' y_offset' - poke ptr (GlyphPos x_advance' y_advance' x_offset' y_offset') = do - let ptr' :: Ptr Int32 - ptr' = castPtr ptr - pokeElemOff ptr' 0 x_advance' - pokeElemOff ptr' 1 y_advance' - pokeElemOff ptr' 2 x_offset' - pokeElemOff ptr' 3 y_offset' - pokeElemOff ptr' 4 0 -- Zero private field. +instance NFData GlyphPos +-- | Decode multiple `GlyphPos`s from a dereferenced list according to +-- Harfbuzz's ABI. +decodePositions (x_advance':y_advance':x_offset':y_offset':_:rest) = + GlyphPos x_advance' y_advance' x_offset' y_offset':decodePositions rest +decodePositions _ = [] -- | Decodes `Buffer'`'s glyph position array. -- If buffer did not have positions before, they will be initialized to zeros.' glyphsPos buf' = do arr <- throwNull $ hb_buffer_get_glyph_positions buf' nullPtr length <- hb_buffer_get_length buf' - if length == 0 || arr == nullPtr - then return [] - else forM [0..fromEnum length - 1] $ peekElemOff arr + words <- iterateLazy arr (fromEnum length * 5) + return $ noCache decodePositions words foreign import ccall "hb_buffer_get_glyph_positions" hb_buffer_get_glyph_positions - :: Buffer' -> Ptr Word -> IO (Ptr GlyphPos) + :: Buffer' -> Ptr Word -> IO (Ptr Int32) -- NOTE: The array returned from FFI is valid as long as the buffer is. -- | Decodes a `Buffer'` back to corresponding pure-functional `Buffer`. diff --git a/Data/Text/Glyphize/Font.hs b/Data/Text/Glyphize/Font.hs --- a/Data/Text/Glyphize/Font.hs +++ b/Data/Text/Glyphize/Font.hs @@ -11,13 +11,14 @@ import Data.Text.Glyphize.Oom (throwNull, throwFalse) 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(..)) @@ -121,9 +122,7 @@ -- | Fetches the number of `Face`s in a `ByteString`. countFace :: ByteString -> Word -countFace bytes = unsafePerformIO $ do - blob <- bs2blob bytes - withForeignPtr blob hb_face_count +countFace bytes = unsafePerformIO $ withBlob bytes hb_face_count foreign import ccall "hb_face_count" hb_face_count :: Blob_ -> IO Word -- | A Font face. @@ -140,8 +139,7 @@ -- load named-instances in variable fonts. See `createFont` for details. createFace :: ByteString -> Word -> Face createFace bytes index = unsafePerformIO $ do - blob <- bs2blob bytes - face <- withForeignPtr blob $ throwNull . flip hb_face_create index + face <- withBlob bytes $ throwNull . flip hb_face_create index hb_face_make_immutable face newForeignPtr hb_face_destroy face foreign import ccall "hb_face_create" hb_face_create :: Blob_ -> Word -> IO Face_ @@ -260,8 +258,7 @@ -- | Variant of `createFace` which applies given options. createFaceWithOpts :: FaceOptions -> ByteString -> Word -> Face createFaceWithOpts opts bytes index = unsafePerformIO $ do - blob <- bs2blob bytes - face <- withForeignPtr blob $ throwNull . flip hb_face_create index + face <- withBlob bytes $ throwNull . flip hb_face_create index _setFaceOptions face opts hb_face_make_immutable face newForeignPtr hb_face_destroy face @@ -279,9 +276,8 @@ buildFace :: [(String, ByteString)] -> FaceOptions -> Face buildFace tables opts = unsafePerformIO $ do builder <- throwNull hb_face_builder_create - forM tables $ \(tag, bytes) -> do - blob <- bs2blob bytes - throwFalse $ withForeignPtr blob $ + forM tables $ \(tag, bytes) -> + throwFalse $ withBlob bytes $ hb_face_builder_add_table builder $ tag_from_string tag _setFaceOptions builder opts hb_face_make_immutable builder @@ -367,11 +363,11 @@ -- 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 @@ -382,7 +378,7 @@ -- 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' @@ -395,7 +391,7 @@ -- | 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 @@ -404,7 +400,7 @@ 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' @@ -419,7 +415,7 @@ -- 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' @@ -429,7 +425,7 @@ 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' @@ -455,13 +451,13 @@ 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 @@ -473,13 +469,13 @@ -- 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 @@ -489,14 +485,14 @@ -- | 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 @@ -528,7 +524,7 @@ -- | 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 @@ -537,7 +533,7 @@ 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' @@ -549,7 +545,7 @@ -- | 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 @@ -558,7 +554,7 @@ 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' @@ -571,7 +567,7 @@ -- 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' @@ -588,13 +584,13 @@ -- | 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) @@ -605,7 +601,7 @@ -- 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' @@ -623,11 +619,11 @@ -- `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 :: @@ -636,13 +632,13 @@ -- | 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' @@ -657,7 +653,7 @@ -- | 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 @@ -675,13 +671,13 @@ -- | 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' @@ -693,11 +689,11 @@ -- 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) @@ -705,7 +701,7 @@ -- 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' @@ -716,14 +712,14 @@ -- | 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 @@ -735,7 +731,7 @@ -- 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 @@ -760,7 +756,7 @@ -- 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 @@ -768,24 +764,24 @@ 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 @@ -926,9 +922,18 @@ blob <- throwNull $ withForeignPtr bytes $ \bytes' -> hb_blob_create bytes' len hb_MEMORY_MODE_DUPLICATE nullPtr nullFunPtr newForeignPtr hb_blob_destroy blob +-- | Convert from a ByteString to a temporary copy of Harfbuzz's equivalent. +-- Do not use this Blob outside the passed callback. +withBlob :: ByteString -> (Blob_ -> IO a) -> IO a +withBlob (BS bytes len) cb = withForeignPtr bytes $ \bytes' -> do + throwNull $ pure bytes' + bracket + (hb_blob_create bytes' len hb_MEMORY_MODE_READONLY nullPtr nullFunPtr) + hb_blob_destroy' cb foreign import ccall "hb_blob_create" hb_blob_create :: Ptr Word8 -> Int -> Int -> Ptr () -> FunPtr (Ptr () -> IO ()) -> IO Blob_ hb_MEMORY_MODE_DUPLICATE = 0 +hb_MEMORY_MODE_READONLY = 1 foreign import ccall "&hb_blob_destroy" hb_blob_destroy :: FunPtr (Blob_ -> IO ()) -- | Convert to a ByteString from Harfbuzz's equivalent. @@ -944,11 +949,11 @@ -- | 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/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -2,7 +2,7 @@ module Main where import "harfbuzz-pure" Data.Text.Glyphize -import Control.Parallel.Strategies (parMap, rpar) +import Control.Parallel.Strategies (parMap, rdeepseq) import Data.Text.Lazy (pack) import qualified Data.ByteString as BS @@ -21,4 +21,4 @@ let font = createFont $ createFace blob 0 case words of "!":words' -> print $ shape font (defaultBuffer { text = pack $ unwords words' }) [] - _ -> print $ parMap rpar (shapeStr font) words + _ -> print $ parMap rdeepseq (shapeStr font) words diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE TemplateHaskell, OverloadedStrings #-} +module Main where +import Criterion.Main +import Data.Text.Glyphize +import Data.FileEmbed +import System.FilePath (()) +import qualified Data.Text.Foreign as Txt +import qualified Data.Text.Lazy as Txt + +import Control.Parallel.Strategies (parMap, rdeepseq) +import Data.Word (Word8) + +-- Benchmarking these as well... +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") >>= + embedFile) 0 + +dracula = $(makeRelativeToProject ("bench" "dracula.txt") >>= embedStringFile) + +main = defaultMain [ + bgroup "Dracula" [ + bench "Week-Head" $ whnf shapeStr dracula, + bench "Normal Form" $ nf shapeStr dracula, + bench "Paragraphs" $ nf (map shapeStr) $ Txt.lines dracula, + bench "Words" $ nf (map shapeStr) $ Txt.words dracula, + bench "Parallelised" $ nf (parMap rdeepseq shapeStr) $ Txt.lines dracula, + bench "Parallelised words" $ nf (parMap rdeepseq shapeStr) $ + Txt.words dracula + ], + bench "Word" $ nf shapeStr "Dracula", + bgroup "building blocks" [ + bench "peekArray (NF)" $ nfIO $ Txt.useAsPtr (Txt.toStrict dracula) $ + \ptr l -> peekArray (fromEnum l) ptr, + 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)), + 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 --- a/harfbuzz-pure.cabal +++ b/harfbuzz-pure.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 1.0.3.2 +version: 1.0.4.0 -- A short (one-line) description of the package. synopsis: Pure-functional Harfbuzz language bindings @@ -57,16 +57,16 @@ 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.Buffer, Data.Text.Glyphize.Font, Data.Text.Glyphize.Oom + other-modules: Data.Text.Glyphize.Font, Data.Text.Glyphize.Buffer, Data.Text.Glyphize.Oom -- LANGUAGE extensions used by modules in this package. -- other-extensions: -- Other library packages from which modules are imported. - build-depends: base >=4.12 && <5, text >= 2.0 && < 3, + build-depends: base >=4.12 && <5, text >= 2.0 && < 3, deepseq >= 1, bytestring >= 0.11, freetype2 >= 0.2, derive-storable >= 0.3 && < 1 pkgconfig-depends: harfbuzz >= 3.3 @@ -88,5 +88,24 @@ -- Base language which the package is written in. default-language: Haskell2010 + + ghc-options: -threaded + +executable benchmark-harfbuzz + hs-source-dirs: bench + main-is: Main.hs + build-depends: base, harfbuzz-pure, file-embed > 0.15 && < 1, + criterion >= 1 && < 2, filepath, text, parallel + default-language: Haskell2010 + + ghc-options: -threaded + +benchmark bench-harfbuzz + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base, harfbuzz-pure, file-embed > 0.15 && < 1, + criterion >= 1 && < 2, filepath, text, parallel + default-language: Haskell2010 ghc-options: -threaded