@@ -90,6 +90,12 @@ import Data.Text.Internal.Unsafe.Shift (shiftR)
90import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
90import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
93+#if __GLASGOW_HASKELL__ >= 706
94+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
96+import Foreign.ForeignPtr (unsafeForeignPtrToPtr)
93import Data.Text ()
99import Data.Text ()
94import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
100import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
95import Data.Text.Internal (Text(..), safe, textP)
101import Data.Text.Internal (Text(..), safe, textP)
@@ -97,7 +103,7 @@ import Data.Text.Internal.Private (runText)
97import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
103import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
98import Data.Word (Word8, Word32)
104import Data.Word (Word8, Word32)
99import Foreign.C.Types (CSize)
105import Foreign.C.Types (CSize)
100−import Foreign.ForeignPtr (withForeignPtr)
106+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr, withForeignPtr)
101import Foreign.Marshal.Utils (with)
107import Foreign.Marshal.Utils (with)
102import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)
108import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)
103import Foreign.Storable (Storable, peek, poke)
109import Foreign.Storable (Storable, peek, poke)
@@ -428,45 +434,81 @@ encodeUtf8_0 (Text arr off len) = unsafeDupablePerformIO $ do
428encodeUtf8_1 (Text arr off len)
434encodeUtf8_1 (Text arr off len)
429 | len == 0 = B.empty
435 | len == 0 = B.empty
430 | otherwise = unsafeDupablePerformIO $ do
436 | otherwise = unsafeDupablePerformIO $ do
431− let size0 = max len 4
437+ fp0 <- mallocByteString len
432− mallocByteString size0 >>= start size0 off 0
438+ withForeignPtr fp0 $ go1 off 0 fp0
434− start size n0 m0 fp = withForeignPtr fp $ go n0 m0
436− offLen = off + len
440+ offLen = off + len
437− poke8 p k v = poke (p `plusPtr` k) (fromIntegral v :: Word8)
441+ poke8 p k v = poke (p `plusPtr` k) (fromIntegral v :: Word8)
438− ensure k n m p act
442+ resize :: Int -> Int -> ForeignPtr Word8 -> IO (ForeignPtr Word8)
439− | size-m >= k = act
443+ resize k m fp = {-# SCC "encodeUtf8_1/resize" #-} do
440− | otherwise = {-# SCC "resizeUtf8/ensure" #-} do
441− let newSize = size `shiftL` 1
442− fp' <- mallocByteString newSize
444+ fp' <- mallocByteString (len*k)
443− withForeignPtr fp' $ \ptr' ->
445+ withForeignPtr fp $ \ptr ->
444− memcpy ptr' p (fromIntegral m)
446+ memcpy (unsafeForeignPtrToPtr fp') ptr (fromIntegral m)
445− start newSize n m fp'
447+ return fp'
446− {-# INLINE ensure #-}
448+ {-# NOINLINE resize #-}
447− go !n !m ptr
449+ ensure k n m fp go = {-# SCC "encodeUtf8_1/ensure" #-} do
450+ fp' <- resize k m fp
451+ go n m fp' (unsafeForeignPtrToPtr fp')
452+ do1 ptr n m w k = poke8 ptr m w >> k (n+1) (m+1)
453+ go1 !n0 !m0 fp ptr = do
448− | n == offLen = return (PS fp 0 m)
455+ | n == offLen = touchForeignPtr fp >> return (PS fp 0 m)
449− | otherwise = do
456+ | otherwise = do
450− case A.unsafeIndex arr n of
457+ case A.unsafeIndex arr n of
451− w| w <= 0x7F -> ensure 1 n m ptr $ do
458+ w| w <= 0x7F -> do1 ptr n m w hot
452− poke8 ptr m (fromIntegral w :: Word8)
459+ | w <= 0x7FF -> ensure 2 n m fp go2
453− go (n+1) (m+1) ptr
460+ | w < 0xD800 -> ensure 3 n m fp go3
454− | w <= 0x7FF -> ensure 2 n m ptr $ do
461+ | w > 0xDBFF -> ensure 3 n m fp go3
462+ | otherwise -> ensure 4 n m fp go4
464+ do2 ptr n m w k = do
455− poke8 ptr m $ (w `shiftR` 6) + 0xC0
465+ poke8 ptr m $ (w `shiftR` 6) + 0xC0
456− poke8 ptr (m+1) $ (w .&. 0x3f) + 0x80
466+ poke8 ptr (m+1) $ (w .&. 0x3f) + 0x80
457− go (n+1) (m+2) ptr
467+ k (n+1) (m+2)
468+ go2 !n0 !m0 fp ptr = do
470+ | n == offLen = touchForeignPtr fp >> return (PS fp 0 m)
472+ case A.unsafeIndex arr n of
473+ w| w <= 0x7F -> do1 ptr n m w hot
474+ | w <= 0x7FF -> do2 ptr n m w hot
475+ | w < 0xD800 -> ensure 3 n m fp go3
458− | 0xD800 <= w && w <= 0xDBFF -> ensure 4 n m ptr $ do
476+ | w > 0xDBFF -> ensure 3 n m fp go3
477+ | otherwise -> ensure 4 n m fp go4
479+ do3 ptr !n m w k = do
480+ poke8 ptr m $ (w `shiftR` 12) + 0xE0
481+ poke8 ptr (m+1) $ ((w `shiftR` 6) .&. 0x3F) + 0x80
482+ poke8 ptr (m+2) $ (w .&. 0x3F) + 0x80
484+ go3 !n0 !m0 fp ptr = do
486+ | n == offLen = touchForeignPtr fp >> return (PS fp 0 m)
488+ case A.unsafeIndex arr n of
489+ w| w <= 0x7F -> do1 ptr n m w hot
490+ | w <= 0x7FF -> do2 ptr n m w hot
491+ | w < 0xD800 -> do3 ptr n m w hot
492+ | w > 0xDBFF -> do3 ptr n m w hot
493+ | otherwise -> ensure 4 n m fp go4
495+ go4 !n0 !m0 fp ptr = do
497+ | n == offLen = touchForeignPtr fp >> return (PS fp 0 m)
499+ case A.unsafeIndex arr n of
500+ w| w <= 0x7F -> do1 ptr n m w hot
501+ | w <= 0x7FF -> do2 ptr n m w hot
502+ | w < 0xD800 -> do3 ptr n m w hot
503+ | w > 0xDBFF -> do3 ptr n m w hot
459− let c = ord $ U16.chr2 w (A.unsafeIndex arr (n+1))
505+ let c = ord $ U16.chr2 w (A.unsafeIndex arr (n+1))
460− poke8 ptr m $ (c `shiftR` 18) + 0xF0
506+ poke8 ptr m $ (c `shiftR` 18) + 0xF0
461− poke8 ptr (m+1) $ ((c `shiftR` 12) .&. 0x3F) + 0x80
507+ poke8 ptr (m+1) $ ((c `shiftR` 12) .&. 0x3F) + 0x80
462− poke8 ptr (m+2) $ ((c `shiftR` 6) .&. 0x3F) + 0x80
508+ poke8 ptr (m+2) $ ((c `shiftR` 6) .&. 0x3F) + 0x80
463− poke8 ptr (m+3) $ (c .&. 0x3F) + 0x80
509+ poke8 ptr (m+3) $ (c .&. 0x3F) + 0x80
464− go (n+2) (m+4) ptr
510+ go4 (n+2) (m+4) fp ptr
465− | otherwise -> ensure 3 n m ptr $ do
511+ hot n0 m0
466− poke8 ptr m $ (w `shiftR` 12) + 0xE0
467− poke8 ptr (m+1) $ ((w `shiftR` 6) .&. 0x3F) + 0x80
468− poke8 ptr (m+2) $ (w .&. 0x3F) + 0x80