@@ -90,6 +90,12 @@ import Data.Text.Internal.Unsafe.Shift (shiftR)
9090import Data.Text.Internal.Unsafe.Shift (shiftL, shiftR)
9191#endif
9292
93+#if __GLASGOW_HASKELL__ >= 706
94+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
95+#else
96+import Foreign.ForeignPtr (unsafeForeignPtrToPtr)
97+#endif
98+
9399import Data.Text ()
94100import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode)
95101import Data.Text.Internal (Text(..), safe, textP)
@@ -97,7 +103,7 @@ import Data.Text.Internal.Private (runText)
97103import Data.Text.Internal.Unsafe.Char (ord, unsafeWrite)
98104import Data.Word (Word8, Word32)
99105import Foreign.C.Types (CSize)
100−import Foreign.ForeignPtr (withForeignPtr)
106+import Foreign.ForeignPtr (ForeignPtr, touchForeignPtr, withForeignPtr)
101107import Foreign.Marshal.Utils (with)
102108import Foreign.Ptr (Ptr, minusPtr, nullPtr, plusPtr)
103109import Foreign.Storable (Storable, peek, poke)
@@ -428,45 +434,81 @@ encodeUtf8_0 (Text arr off len) = unsafeDupablePerformIO $ do
428434encodeUtf8_1 (Text arr off len)
429435 | len == 0 = B.empty
430436 | otherwise = unsafeDupablePerformIO $ do
431− let size0 = max len 4
432− mallocByteString size0 >>= start size0 off 0
437+ fp0 <- mallocByteString len
438+ withForeignPtr fp0 $ go1 off 0 fp0
433439 where
434− start size n0 m0 fp = withForeignPtr fp $ go n0 m0
435− where
436− offLen = off + len
437− poke8 p k v = poke (p `plusPtr` k) (fromIntegral v :: Word8)
438− ensure k n m p act
439− | size-m >= k = act
440− | otherwise = {-# SCC "resizeUtf8/ensure" #-} do
441− let newSize = size `shiftL` 1
442− fp' <- mallocByteString newSize
443− withForeignPtr fp' $ \ptr' ->
444− memcpy ptr' p (fromIntegral m)
445− start newSize n m fp'
446− {-# INLINE ensure #-}
447− go !n !m ptr
448− | n == offLen = return (PS fp 0 m)
449− | otherwise = do
450− case A.unsafeIndex arr n of
451− w| w <= 0x7F -> ensure 1 n m ptr $ do
452− poke8 ptr m (fromIntegral w :: Word8)
453− go (n+1) (m+1) ptr
454− | w <= 0x7FF -> ensure 2 n m ptr $ do
455− poke8 ptr m $ (w `shiftR` 6) + 0xC0
456− poke8 ptr (m+1) $ (w .&. 0x3f) + 0x80
457− go (n+1) (m+2) ptr
458− | 0xD800 <= w && w <= 0xDBFF -> ensure 4 n m ptr $ do
459− let c = ord $ U16.chr2 w (A.unsafeIndex arr (n+1))
460− poke8 ptr m $ (c `shiftR` 18) + 0xF0
461− poke8 ptr (m+1) $ ((c `shiftR` 12) .&. 0x3F) + 0x80
462− poke8 ptr (m+2) $ ((c `shiftR` 6) .&. 0x3F) + 0x80
463− poke8 ptr (m+3) $ (c .&. 0x3F) + 0x80
464− go (n+2) (m+4) ptr
465− | otherwise -> ensure 3 n m ptr $ do
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
469− go (n+1) (m+3) ptr
440+ offLen = off + len
441+ poke8 p k v = poke (p `plusPtr` k) (fromIntegral v :: Word8)
442+ resize :: Int -> Int -> ForeignPtr Word8 -> IO (ForeignPtr Word8)
443+ resize k m fp = {-# SCC "encodeUtf8_1/resize" #-} do
444+ fp' <- mallocByteString (len*k)
445+ withForeignPtr fp $ \ptr ->
446+ memcpy (unsafeForeignPtrToPtr fp') ptr (fromIntegral m)
447+ return fp'
448+ {-# NOINLINE resize #-}
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
454+ let hot !n !m
455+ | n == offLen = touchForeignPtr fp >> return (PS fp 0 m)
456+ | otherwise = do
457+ case A.unsafeIndex arr n of
458+ w| w <= 0x7F -> do1 ptr n m w hot
459+ | w <= 0x7FF -> ensure 2 n m fp go2
460+ | w < 0xD800 -> ensure 3 n m fp go3
461+ | w > 0xDBFF -> ensure 3 n m fp go3
462+ | otherwise -> ensure 4 n m fp go4
463+ hot n0 m0
464+ do2 ptr n m w k = do
465+ poke8 ptr m $ (w `shiftR` 6) + 0xC0
466+ poke8 ptr (m+1) $ (w .&. 0x3f) + 0x80
467+ k (n+1) (m+2)
468+ go2 !n0 !m0 fp ptr = do
469+ let hot !n !m
470+ | n == offLen = touchForeignPtr fp >> return (PS fp 0 m)
471+ | otherwise = do
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
476+ | w > 0xDBFF -> ensure 3 n m fp go3
477+ | otherwise -> ensure 4 n m fp go4
478+ hot n0 m0
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
483+ k (n+1) (m+3)
484+ go3 !n0 !m0 fp ptr = do
485+ let hot !n !m
486+ | n == offLen = touchForeignPtr fp >> return (PS fp 0 m)
487+ | otherwise = do
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
494+ hot n0 m0
495+ go4 !n0 !m0 fp ptr = do
496+ let hot !n !m
497+ | n == offLen = touchForeignPtr fp >> return (PS fp 0 m)
498+ | otherwise = do
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
504+ | otherwise -> do
505+ let c = ord $ U16.chr2 w (A.unsafeIndex arr (n+1))
506+ poke8 ptr m $ (c `shiftR` 18) + 0xF0
507+ poke8 ptr (m+1) $ ((c `shiftR` 12) .&. 0x3F) + 0x80
508+ poke8 ptr (m+2) $ ((c `shiftR` 6) .&. 0x3F) + 0x80
509+ poke8 ptr (m+3) $ (c .&. 0x3F) + 0x80
510+ go4 (n+2) (m+4) fp ptr
511+ hot n0 m0
470512
471513#endif
472514