diff --git a/Data/Text/Encoding.hs b/Data/Text/Encoding.hs --- a/Data/Text/Encoding.hs +++ b/Data/Text/Encoding.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, ForeignFunctionInterface, MagicHash, + UnliftedFFITypes #-} -- | -- Module : Data.Text.Encoding -- Copyright : (c) 2008, 2009 Tom Harper, @@ -47,23 +48,25 @@ ) where import Control.Exception (evaluate, try) +import Control.Monad.ST (unsafeIOToST, unsafeSTToIO) import Data.Bits ((.&.)) import Data.ByteString as B import Data.ByteString.Internal as B -import Data.ByteString.Unsafe as B import Data.Text.Encoding.Error (OnDecodeError, UnicodeException, strictDecode) import Data.Text.Internal (Text(..), textP) import Data.Text.UnsafeChar (ord, unsafeWrite) import Data.Text.UnsafeShift (shiftL, shiftR) import Data.Word (Word8) +import Foreign.C.Types (CSize) import Foreign.ForeignPtr (withForeignPtr) -import Foreign.Ptr (plusPtr) -import Foreign.Storable (poke) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (peek, poke) +import GHC.Base (MutableByteArray#) import System.IO.Unsafe (unsafePerformIO) import qualified Data.Text.Array as A import qualified Data.Text.Encoding.Fusion as E import qualified Data.Text.Encoding.Utf16 as U16 -import qualified Data.Text.Encoding.Utf8 as U8 import qualified Data.Text.Fusion as F -- $strict @@ -79,46 +82,41 @@ -- 'decodeUtf8With' allows the programmer to determine what to do on a -- decoding error. --- | Decode a 'ByteString' containing 7-bit ASCII encoded text. +-- | /Deprecated/. Decode a 'ByteString' containing 7-bit ASCII +-- encoded text. +-- +-- This function is deprecated. Use 'decodeUtf8' instead. decodeASCII :: ByteString -> Text -decodeASCII bs = F.unstream (E.streamASCII bs) -{-# INLINE decodeASCII #-} +decodeASCII = decodeUtf8 +{-# DEPRECATED decodeASCII "Use decodeUtf8 instead" #-} -- | Decode a 'ByteString' containing UTF-8 encoded text. decodeUtf8With :: OnDecodeError -> ByteString -> Text -decodeUtf8With onErr bs = textP (fst a) 0 (snd a) +decodeUtf8With onErr (PS fp off len) = textP (fst a) 0 (snd a) where - a = A.run2 (A.new len >>= outer 0 0) - len = B.length bs - outer n0 m0 arr = go n0 m0 - where - go !n !m = do - let x1 = idx m - x2 = idx (m + 1) - x3 = idx (m + 2) - x4 = idx (m + 3) - idx = B.unsafeIndex bs - case undefined of - _| m >= len -> return (arr,n) - | U8.validate1 x1 -> do - A.unsafeWrite arr n (fromIntegral x1) - go (n+1) (m+1) - | m+1 < len && U8.validate2 x1 x2 -> do - w <- unsafeWrite arr n (U8.chr2 x1 x2) - go (n+w) (m+2) - | m+2 < len && U8.validate3 x1 x2 x3 -> do - w <- unsafeWrite arr n (U8.chr3 x1 x2 x3) - go (n+w) (m+3) - | m+3 < len && U8.validate4 x1 x2 x3 x4 -> do - w <- unsafeWrite arr n (U8.chr4 x1 x2 x3 x4) - go (n+w) (m+4) - | otherwise -> case onErr desc (Just x1) of - Nothing -> go n (m+1) - Just c -> do - w <- unsafeWrite arr n c - go (n+w) (m+1) + a = A.run2 (A.new len >>= unsafeIOToST . go) desc = "Data.Text.Encoding.decodeUtf8: Invalid UTF-8 stream" -{-# INLINE[0] decodeUtf8With #-} + go dest = withForeignPtr fp $ \ptr -> + with (0::CSize) $ \destOffPtr -> do + let end = ptr `plusPtr` (off + len) + loop curPtr = do + curPtr' <- c_decode_utf8 (A.maBA dest) destOffPtr curPtr end + if curPtr' == end + then do + n <- peek destOffPtr + return (dest,fromIntegral n) + else do + x <- peek curPtr' + case onErr desc (Just x) of + Nothing -> loop $ curPtr' `plusPtr` 1 + Just c -> do + destOff <- peek destOffPtr + w <- unsafeSTToIO $ + unsafeWrite dest (fromIntegral destOff) c + poke destOffPtr (destOff + fromIntegral w) + loop $ curPtr' `plusPtr` 1 + loop (ptr `plusPtr` off) +{- INLINE[0] decodeUtf8With #-} -- | Decode a 'ByteString' containing UTF-8 encoded text that is known -- to be valid. @@ -260,3 +258,7 @@ encodeUtf32BE :: Text -> ByteString encodeUtf32BE txt = E.unstream (E.restreamUtf32BE (F.stream txt)) {-# INLINE encodeUtf32BE #-} + +foreign import ccall unsafe "_hs_text_decode_utf8" c_decode_utf8 + :: MutableByteArray# s -> Ptr CSize + -> Ptr Word8 -> Ptr Word8 -> IO (Ptr Word8) diff --git a/Data/Text/Encoding/Fusion.hs b/Data/Text/Encoding/Fusion.hs --- a/Data/Text/Encoding/Fusion.hs +++ b/Data/Text/Encoding/Fusion.hs @@ -61,6 +61,7 @@ | otherwise = Yield (unsafeChr8 x1) (i+1) where x1 = B.unsafeIndex bs i +{-# DEPRECATED streamASCII "Do not use this function" #-} {-# INLINE [0] streamASCII #-} -- | /O(n)/ Convert a 'ByteString' into a 'Stream Char', using UTF-8 diff --git a/Data/Text/Fusion/Size.hs b/Data/Text/Fusion/Size.hs --- a/Data/Text/Fusion/Size.hs +++ b/Data/Text/Fusion/Size.hs @@ -69,7 +69,7 @@ {-# INLINE f #-} add :: Int -> Int -> Int -add m n | mn > 0 = mn +add m n | mn >= 0 = mn | otherwise = overflowError where mn = m + n {-# INLINE add #-} diff --git a/Data/Text/Lazy/Encoding.hs b/Data/Text/Lazy/Encoding.hs --- a/Data/Text/Lazy/Encoding.hs +++ b/Data/Text/Lazy/Encoding.hs @@ -71,10 +71,13 @@ -- 'decodeUtf8With' allows the programmer to determine what to do on a -- decoding error. --- | Decode a 'ByteString' containing 7-bit ASCII encoded text. +-- | /Deprecated/. Decode a 'ByteString' containing 7-bit ASCII +-- encoded text. +-- +-- This function is deprecated. Use 'decodeUtf8' instead. decodeASCII :: B.ByteString -> Text -decodeASCII bs = foldr (chunk . TE.decodeASCII) empty (B.toChunks bs) -{-# INLINE decodeASCII #-} +decodeASCII = decodeUtf8 +{-# DEPRECATED decodeASCII "Use decodeUtf8 instead" #-} -- | Decode a 'ByteString' containing UTF-8 encoded text. decodeUtf8With :: OnDecodeError -> B.ByteString -> Text diff --git a/cbits/cbits.c b/cbits/cbits.c --- a/cbits/cbits.c +++ b/cbits/cbits.c @@ -1,4 +1,14 @@ +/* + * Copyright (c) 2011 Bryan O'Sullivan . + * + * Portions copyright (c) 2008-2010 Björn Höhrmann . + * + * See http://bjoern.hoehrmann.de/utf-8/decoder/dfa/ for details. + */ + #include +#include +#include void _hs_text_memcpy(void *dest, size_t doff, const void *src, size_t soff, size_t n) @@ -10,4 +20,114 @@ size_t n) { return memcmp(a + (aoff<<1), b + (boff<<1), n<<1); +} + +#define UTF8_ACCEPT 0 +#define UTF8_REJECT 12 + +static const uint8_t utf8d[] = { + /* + * The first part of the table maps bytes to character classes that + * to reduce the size of the transition table and create bitmasks. + */ + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 9,9,9,9,9,9,9,9,9,9,9,9,9,9,9,9, + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, + 8,8,2,2,2,2,2,2,2,2,2,2,2,2,2,2, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, + 10,3,3,3,3,3,3,3,3,3,3,3,3,4,3,3, 11,6,6,6,5,8,8,8,8,8,8,8,8,8,8,8, + + /* + * The second part is a transition table that maps a combination of + * a state of the automaton and a character class to a state. + */ + 0,12,24,36,60,96,84,12,12,12,48,72, 12,12,12,12,12,12,12,12,12,12,12,12, + 12, 0,12,12,12,12,12, 0,12, 0,12,12, 12,24,12,12,12,12,12,24,12,24,12,12, + 12,12,12,12,12,12,12,24,12,12,12,12, 12,24,12,12,12,12,12,12,12,24,12,12, + 12,12,12,12,12,12,12,36,12,36,12,12, 12,36,12,12,12,12,12,36,12,36,12,12, + 12,36,12,12,12,12,12,12,12,12,12,12, +}; + +static inline uint32_t +decode(uint32_t *state, uint32_t* codep, uint32_t byte) { + uint32_t type = utf8d[byte]; + + *codep = (*state != UTF8_ACCEPT) ? + (byte & 0x3fu) | (*codep << 6) : + (0xff >> type) & (byte); + + return *state = utf8d[256 + *state + type]; +} + +/* + * A best-effort decoder. Runs until it hits either end of input or + * the start of an invalid byte sequence. + * + * At exit, updates *destoff with the next offset to write to, and + * returns the next source offset to read from. + */ +uint8_t const * +_hs_text_decode_utf8(uint16_t *dest, size_t *destoff, + const uint8_t const *src, const uint8_t const *srcend) +{ + uint16_t *d = dest + *destoff; + const uint8_t const *s = src; + uint32_t state = UTF8_ACCEPT; + + while (s < srcend) { + uint32_t codepoint; + +#if defined(__i386__) || defined(__x86_64__) + /* + * This code will only work on a little-endian system that + * supports unaligned loads. + * + * It gives a substantial speed win on data that is purely or + * partly ASCII (e.g. HTML), at only a slight cost on purely + * non-ASCII text. + */ + + if (state == UTF8_ACCEPT) { + while (s < srcend - 4) { + codepoint = *((uint32_t *) s); + if ((codepoint & 0x80808080) != 0) + break; + s += 4; + + /* + * Tried 32-bit stores here, but the extra bit-twiddling + * slowed the code down. + */ + + *d++ = (uint16_t) (codepoint & 0xff); + *d++ = (uint16_t) ((codepoint >> 8) & 0xff); + *d++ = (uint16_t) ((codepoint >> 16) & 0xff); + *d++ = (uint16_t) ((codepoint >> 24) & 0xff); + } + } +#endif + + if (decode(&state, &codepoint, *s++) != UTF8_ACCEPT) { + if (state != UTF8_REJECT) + continue; + break; + } + + if (codepoint <= 0xffff) + *d++ = (uint16_t) codepoint; + else { + *d++ = (uint16_t) (0xD7C0 + (codepoint >> 10)); + *d++ = (uint16_t) (0xDC00 + (codepoint & 0x3FF)); + } + } + + /* Error recovery - if we're not in a valid finishing state, back up. */ + if (state != UTF8_ACCEPT) + s -= 1; + + *destoff = d - dest; + + return s; } diff --git a/tests/README.markdown b/tests/README.markdown --- a/tests/README.markdown +++ b/tests/README.markdown @@ -1,13 +1,19 @@ Tests ===== -This directory contains the tests for the Text library. To run these tests, you -will need the test data from: +This directory contains the tests for the Text library. To run these +tests, you will need the test data from one of the following +locations: - http://projects.haskell.org/text/text-testdata.tar.bz2 +* Mercurial master repository: + [bitbucket.org/bos/text-test-data](https://bitbucket.org/bos/text-test-data) -You should extract that archive to the same directory as this README (some tests -rely on this). +* Git mirror repository: + [github.com/bos/text-test-data](https://github.com/bos/text-test-data) + +You should clone that repository to the same directory as this `README` +file, then run `make` to uncompress the test files. Many tests will +fail if the test files are missing. There are two categories of tests: functional tests (including QuickCheck properties), and benchmarks. diff --git a/tests/benchmarks/cbits/time_iconv.c b/tests/benchmarks/cbits/time_iconv.c new file mode 100644 --- /dev/null +++ b/tests/benchmarks/cbits/time_iconv.c @@ -0,0 +1,35 @@ +#include +#include +#include +#include + +int time_iconv(char *srcbuf, size_t srcbufsize) +{ + uint16_t *destbuf = NULL; + size_t destbufsize; + static uint16_t *origdestbuf; + static size_t origdestbufsize; + iconv_t ic = (iconv_t) -1; + int ret = 0; + + if (ic == (iconv_t) -1) { + ic = iconv_open("UTF-16LE", "UTF-8"); + if (ic == (iconv_t) -1) { + ret = -1; + goto done; + } + } + + destbufsize = srcbufsize * sizeof(uint16_t); + if (destbufsize > origdestbufsize) { + free(origdestbuf); + origdestbuf = destbuf = malloc(origdestbufsize = destbufsize); + } else { + destbuf = origdestbuf; + } + + iconv(ic, &srcbuf, &srcbufsize, (char**) &destbuf, &destbufsize); + + done: + return ret; +} diff --git a/tests/benchmarks/src/Data/Text/Benchmarks.hs b/tests/benchmarks/src/Data/Text/Benchmarks.hs --- a/tests/benchmarks/src/Data/Text/Benchmarks.hs +++ b/tests/benchmarks/src/Data/Text/Benchmarks.hs @@ -39,7 +39,11 @@ -- Traditional benchmarks bs <- sequence [ Builder.benchmark - , DecodeUtf8.benchmark (tf "russian.txt") + , DecodeUtf8.benchmark "html" (tf "libya-chinese.html") + , DecodeUtf8.benchmark "xml" (tf "yiwiki.xml") + , DecodeUtf8.benchmark "ascii" (tf "ascii.txt") + , DecodeUtf8.benchmark "russian" (tf "russian.txt") + , DecodeUtf8.benchmark "japanese" (tf "japanese.txt") , EncodeUtf8.benchmark "επανάληψη 竺法蘭共譯" , Equality.benchmark (tf "japanese.txt") , FileRead.benchmark (tf "russian.txt") @@ -64,4 +68,4 @@ return $ bs ++ [ps] where -- Location of a test file - tf = ("../text/test" ) + tf = ("../text-test-data" ) diff --git a/tests/benchmarks/src/Data/Text/Benchmarks/DecodeUtf8.hs b/tests/benchmarks/src/Data/Text/Benchmarks/DecodeUtf8.hs --- a/tests/benchmarks/src/Data/Text/Benchmarks/DecodeUtf8.hs +++ b/tests/benchmarks/src/Data/Text/Benchmarks/DecodeUtf8.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + -- | Test decoding of UTF-8 -- -- Tested in this benchmark: @@ -16,7 +18,13 @@ ( benchmark ) where -import Criterion (Benchmark, bgroup, bench, nf) +import Foreign.C.Types (CInt, CSize) +import Data.ByteString.Internal (ByteString(..)) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.ForeignPtr (withForeignPtr) +import Data.Word (Word8) +import qualified Criterion as C +import Criterion (Benchmark, bgroup, nf) import qualified Codec.Binary.UTF8.Generic as U8 import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL @@ -25,12 +33,14 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL -benchmark :: FilePath -> IO Benchmark -benchmark fp = do +benchmark :: String -> FilePath -> IO Benchmark +benchmark kind fp = do bs <- B.readFile fp lbs <- BL.readFile fp + let bench name = C.bench (name ++ "+" ++ kind) return $ bgroup "DecodeUtf8" [ bench "Strict" $ nf T.decodeUtf8 bs + , bench "IConv" $ iconv bs , bench "StrictLength" $ nf (T.length . T.decodeUtf8) bs , bench "StrictInitLength" $ nf (T.length . T.init . T.decodeUtf8) bs , bench "Lazy" $ nf TL.decodeUtf8 lbs @@ -41,3 +51,9 @@ , bench "LazyStringUtf8" $ nf U8.toString lbs , bench "LazyStringUtf8Length" $ nf (length . U8.toString) lbs ] + +iconv :: ByteString -> IO CInt +iconv (PS fp off len) = withForeignPtr fp $ \ptr -> + time_iconv (ptr `plusPtr` off) (fromIntegral len) + +foreign import ccall unsafe time_iconv :: Ptr Word8 -> CSize -> IO CInt diff --git a/tests/benchmarks/text-benchmarks.cabal b/tests/benchmarks/text-benchmarks.cabal --- a/tests/benchmarks/text-benchmarks.cabal +++ b/tests/benchmarks/text-benchmarks.cabal @@ -18,6 +18,7 @@ executable text-benchmarks hs-source-dirs: src ../.. c-sources: ../../cbits/cbits.c + cbits/time_iconv.c main-is: Data/Text/Benchmarks.hs ghc-options: -Wall -O2 cpp-options: -DHAVE_DEEPSEQ diff --git a/text.cabal b/text.cabal --- a/text.cabal +++ b/text.cabal @@ -1,5 +1,5 @@ name: text -version: 0.11.1.3 +version: 0.11.1.5 homepage: https://bitbucket.org/bos/text bug-reports: https://bitbucket.org/bos/text/issues synopsis: An efficient packed Unicode text type. @@ -48,6 +48,7 @@ scripts/*.hs tests/README.markdown tests/benchmarks/Setup.hs + tests/benchmarks/cbits/*.c tests/benchmarks/python/*.py tests/benchmarks/ruby/*.rb tests/benchmarks/src/Data/Text/*.hs @@ -130,7 +131,7 @@ if impl(ghc >= 6.11) cpp-options: -DINTEGER_GMP - build-depends: integer-gmp >= 0.2 && < 0.3 + build-depends: integer-gmp >= 0.2 && < 0.4 if impl(ghc >= 6.9) && impl(ghc < 6.11) cpp-options: -DINTEGER_GMP