Improve performance of parsing big integers

benchmarks/haskell/Benchmarks.hs

@@ -94,6 +94,7 @@ main = do
             , env (Pure.initEnv (tf "japanese.txt")) (Pure.benchmark "japanese")
             ]
         , env (ReadNumbers.initEnv (tf "numbers.txt")) ReadNumbers.benchmark
+        , ReadNumbers.micro
         , env (Replace.initEnv (tf "russian.txt")) (Replace.benchmark "принимая" "своем")
         , env (Search.initEnv (tf "russian.txt")) (Search.benchmark "принимая")
         , env (Stream.initEnv (tf "russian.txt")) Stream.benchmark

benchmarks/haskell/Benchmarks/ReadNumbers.hs

@@ -19,6 +19,7 @@
 module Benchmarks.ReadNumbers
     ( initEnv
     , benchmark
+    , micro
     ) where
 
 import Data.Foldable (Foldable(..))
@@ -30,6 +31,7 @@ import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.IO as TL
 import qualified Data.Text.Lazy.Read as TL
 import qualified Data.Text.Read as T
+import Numeric (readHex)
 
 type Env = ([T.Text], [TL.Text])
 
@@ -63,6 +65,25 @@ benchmark ~(t, tl) =
     double :: Double -> Double
     double = id
 
+-- Microbenchmarks with no run-time dependencies
+micro :: Benchmark
+micro = bgroup "ReadBigNumber"
+  [ bgroup "Decimal"
+      [ bench "StrictText" $ whnf (wrap T.decimal :: T.Text -> Integer) tn
+      , bench "LazyText" $ whnf (wrap TL.decimal :: TL.Text -> Integer) ln
+      , bench "String" $ whnf (read :: String -> Integer) n
+      ]
+  , bgroup "Hex"
+      [ bench "StrictText" $ whnf (wrap T.hexadecimal :: T.Text -> Integer) tn
+      , bench "LazyText" $ whnf (wrap TL.hexadecimal :: TL.Text -> Integer) ln
+      , bench "String" $ whnf (readHex :: String -> [(Integer, String)]) n
+      ]
+  ] where
+    tn = T.pack n
+    ln = TL.fromChunks (T.singleton <$> n) -- Completely artificial microbench with many chunks and it still beats @read@
+    n = replicate 1000 '9'
+    wrap f x | Right (i, _) <- f x = i | otherwise = undefined
+
 text :: (Ord a, Num a) => (t -> Either String (a,t)) -> [t] -> a
 text reader = foldl' go 1000000
   where

src/Data/Text/Internal/Lazy.hs

@@ -26,6 +26,7 @@ module Data.Text.Internal.Lazy
     , empty
     , foldrChunks
     , foldlChunks
+    , splitAtWord
     -- * Data type invariant and abstraction functions
 
     -- $invariant
@@ -42,6 +43,7 @@ module Data.Text.Internal.Lazy
     ) where
 
 import Data.Bits (shiftL)
+import Data.Int (Int64)
 import Data.Text ()
 import Foreign.Storable (sizeOf)
 import qualified Data.Text.Array as A
@@ -150,3 +152,16 @@ equal (Chunk (T.Text arrA offA lenA) as) (Chunk (T.Text arrB offB lenB) bs) =
             as `equal` bs
       GT -> A.equal arrA offA arrB offB lenB &&
             Chunk (T.Text arrA (offA + lenB) (lenA - lenB)) as `equal` bs
+
+-- | /O(n)/ 'splitAtWord' @n t@ returns a pair whose first
+-- element is a prefix of @t@ whose chunks contain @n@ 'Word8'
+-- values, and whose second is the remainder of the string.
+splitAtWord :: Int64 -> Text -> (Text, Text)
+splitAtWord !_ Empty = (empty, empty)
+splitAtWord x ccs@(Chunk c@(T.Text arr off len) cs)
+    | y >= len  = let !(h, t) = splitAtWord (x-fromIntegral len) cs
+                  in (Chunk c h, t)
+    | x == 0 = (empty, ccs)
+    | otherwise = ( Chunk (T.Text arr off y) empty
+                  , Chunk (T.Text arr (off+y) (len-y)) cs)
+    where y = fromIntegral x

src/Data/Text/Lazy.hs

@@ -245,10 +245,9 @@ import qualified Data.Text.Internal as T
 import qualified Data.Text.Internal.Fusion.Common as S
 import qualified Data.Text.Unsafe as T
 import qualified Data.Text.Internal.Lazy.Fusion as S
-import Data.Text.Internal.Fusion.Types (PairS(..))
 import Data.Text.Internal.Lazy.Fusion (stream, unstream)
-import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldlChunks,
-                                foldrChunks, smallChunkSize, defaultChunkSize, equal, LazyText)
+import Data.Text.Internal.Lazy (Text(..), chunk, empty, foldlChunks, foldrChunks, splitAtWord,
+                                smallChunkSize, defaultChunkSize, equal, LazyText)
 import Data.Text.Internal (firstf, safe, text)
 import Data.Text.Internal.Reverse (reverseNonEmpty)
 import Data.Text.Internal.Transformation (mapNonEmpty, toCaseFoldNonEmpty, toLowerNonEmpty, toUpperNonEmpty, filter_)
@@ -1349,19 +1348,6 @@ splitAt = loop
          mx = intToInt64 P.maxBound
          m = T.measureOff (int64ToInt n) t
 
-
--- | /O(n)/ 'splitAtWord' @n t@ returns a strict pair whose first
--- element is a prefix of @t@ whose chunks contain @n@ 'Word8'
--- values, and whose second is the remainder of the string.
-splitAtWord :: Int64 -> Text -> PairS Text Text
-splitAtWord !_ Empty = empty :*: empty
-splitAtWord x (Chunk c@(T.Text arr off len) cs)
-    | y >= len  = let h :*: t = splitAtWord (x-intToInt64 len) cs
-                  in  Chunk c h :*: t
-    | otherwise = chunk (text arr off y) empty :*:
-                  chunk (text arr (off+y) (len-y)) cs
-    where y = int64ToInt x
-
 -- | /O(n+m)/ Find the first instance of @needle@ (which must be
 -- non-'null') in @haystack@.  The first element of the returned tuple
 -- is the prefix of @haystack@ before @needle@ is matched.  The second
@@ -1391,8 +1377,7 @@ breakOn pat src
     | null pat  = emptyError "breakOn"
     | otherwise = case indices pat src of
                     []    -> (src, empty)
-                    (x:_) -> let h :*: t = splitAtWord x src
-                             in  (h, t)
+                    (x:_) -> splitAtWord x src
 
 -- | /O(n+m)/ Similar to 'breakOn', but searches from the end of the string.
 --
@@ -1435,7 +1420,7 @@ breakOnAll pat src
     | null pat  = emptyError "breakOnAll"
     | otherwise = go 0 empty src (indices pat src)
   where
-    go !n p s (x:xs) = let h :*: t = splitAtWord (x-n) s
+    go !n p s (x:xs) = let (h, t) = splitAtWord (x-n) s
                            h'      = append p h
                        in (h',t) : go x h' t xs
     go _  _ _ _      = []
@@ -1666,12 +1651,12 @@ splitOnNE pat src = case uncons pat of
   Just (c, cs) | null cs -> splitNE (== c) src
   _ -> case indices pat src of
          [] -> src :| []
-         (x:xs) -> let h :*: t = splitAtWord (x-0) src
+         (x:xs) -> let (h, t) = splitAtWord (x-0) src
                    in  h :| go (x+l) xs (dropWords l t)
   where
     go :: Int64 -> [Int64] -> Text -> [Text]
     go  _ []     cs = cs : []
-    go !i (x:xs) cs = let h :*: t = splitAtWord (x-i) cs
+    go !i (x:xs) cs = let (h, t) = splitAtWord (x-i) cs
                       in  h : go (x+l) xs (dropWords l t)
     l = foldlChunks (\a (T.Text _ _ b) -> a + intToInt64 b) 0 pat
 {-# INLINE [1] splitOnNE #-}

src/Data/Text/Lazy/Read.hs

@@ -1,4 +1,6 @@
 {-# LANGUAGE OverloadedStrings, CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE UnboxedTuples #-}
@@ -29,6 +31,8 @@ import Data.Ratio ((%))
 import Data.Text.Internal.Read
 import Data.Text.Array as A
 import Data.Text.Lazy as T
+import Data.Text.Internal.Lazy as T (splitAtWord)
+import Data.Text.Internal.Builder.Int.Digits (Base(..), base10, base16)
 import Data.Text.Internal.Lazy as T (Text(..))
 import qualified Data.Text.Internal as T (Text(..))
 import qualified Data.Text.Internal.Private as T (spanAscii_)
@@ -64,9 +68,8 @@ decimal :: Integral a => Reader a
 {-# SPECIALIZE decimal :: Reader Word64 #-}
 decimal txt
     | T.null h  = Left "input does not start with a digit"
-    | otherwise = Right (T.foldl' go 0 h, t)
+    | otherwise = Right (integer base10 (fromIntegral . digitToInt) h, t)
   where (# h, t #)  = spanAscii_ (\w -> w - ord8 '0' < 10) txt
-        go n d = (n * 10 + fromIntegral (digitToInt d))
 
 -- | Read a hexadecimal integer, consisting of an optional leading
 -- @\"0x\"@ followed by at least one hexadecimal digit. Input is
@@ -102,9 +105,47 @@ hex :: Integral a => Reader a
 {-# SPECIALIZE hexadecimal :: Reader Word64 #-}
 hex txt
     | T.null h  = Left "input does not start with a hexadecimal digit"
-    | otherwise = Right (T.foldl' go 0 h, t)
+    | otherwise = Right (integer base16 (fromIntegral . hexDigitToInt) h, t)
   where (# h, t #)  = spanAscii_ (\w -> w - ord8 '0' < 10 || w - ord8 'A' < 6 || w - ord8 'a' < 6) txt
-        go n d = (n * 16 + fromIntegral (hexDigitToInt d))
+
+-- | Internal function to read a base-@base@ number faster than the naive quadratic algorithm.
+--
+-- The input text must only contain digits. Overflows are allowed.
+{-# INLINE integer #-}
+integer :: Integral a => Base -> (Char -> Word) -> Text -> a
+integer (Base { base, maxWord, maxDigits }) digit t0
+  | n0 <= maxDigits' = fromIntegral (word base digit t0)
+  | otherwise = scanWords [word' t01] (n0 - mswSize) t02
+  where
+    n0 = lengthWord8 t0
+    -- Split the most significant word from t0 so the remainder's length is a multiple of maxDigits
+    mswSize = (n0 - 1) `mod` maxDigits' + 1
+    !(t01, t02) = T.splitAtWord mswSize t0
+
+    word' = fromIntegral . word base digit
+    maxDigits' = fromIntegral maxDigits
+
+    -- n is the length of t and it must be a positive multiple of maxDigits
+    scanWords chunks n t
+      | n <= maxDigits' = reduce (fromIntegral maxWord) (word' t : chunks)
+      | otherwise = scanWords (word' t1 : chunks) (n - maxDigits') t2
+      where !(t1, t2) = T.splitAtWord maxDigits' t
+
+    reduce !_ [c] = c
+    reduce width cs = reduce (width * width) (pairs width cs)
+
+    pairs !_ [] = []
+    pairs _ [c] = [c]
+    pairs width (c0 : c1 : cs) = c0 + width * c1 : pairs width cs
+
+lengthWord8 :: Text -> Int64
+lengthWord8 = T.foldlChunks (\n (T.Text _ _ m) -> n + fromIntegral m) 0
+
+-- | Internal function to read a base-@b@ number into a 'Word'.
+--
+-- The text must only contain digits and the result must not to overflow 'Word'.
+word :: Word -> (Char -> Word) -> Text -> Word
+word base digit = T.foldl' (\n d -> n * base + fromIntegral (digit d)) 0
 
 -- | Read an optional leading sign character (@\'-\'@ or @\'+\'@) and
 -- apply it to the result of applying the given reader.

src/Data/Text/Read.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, UnboxedTuples, CPP #-}
+{-# LANGUAGE BangPatterns, NamedFieldPuns, OverloadedStrings, UnboxedTuples, CPP #-}
 {-# LANGUAGE Trustworthy #-}
 
 -- |
@@ -29,6 +29,8 @@ import Data.Text.Internal as T (Text(..))
 import Data.Text.Array as A
 import Data.Text.Internal.Private (spanAscii_)
 import Data.Text.Internal.Read
+import Data.Text.Internal.Builder.Int.Digits (Base(..), base10, base16)
+import qualified Data.Text.Unsafe as TU
 import Data.Word (Word, Word8, Word16, Word32, Word64)
 
 -- | Read some text.  If the read succeeds, return its value and the
@@ -61,9 +63,8 @@ decimal :: Integral a => Reader a
 {-# SPECIALIZE decimal :: Reader Word64 #-}
 decimal txt
     | T.null h  = Left "input does not start with a digit"
-    | otherwise = Right (T.foldl' go 0 h, t)
+    | otherwise = Right (integer base10 (fromIntegral . digitToInt) h, t)
   where (# h,t #)  = spanAscii_ (\w -> w - ord8 '0' < 10) txt
-        go n d = (n * 10 + fromIntegral (digitToInt d))
 
 -- | Read a hexadecimal integer, consisting of an optional leading
 -- @\"0x\"@ followed by at least one hexadecimal digit. Input is
@@ -108,9 +109,38 @@ hex :: Integral a => Reader a
 {-# SPECIALIZE hex :: Reader Word64 #-}
 hex txt
     | T.null h  = Left "input does not start with a hexadecimal digit"
-    | otherwise = Right (T.foldl' go 0 h, t)
+    | otherwise = Right (integer base16 (fromIntegral . hexDigitToInt) h, t)
   where (# h,t #)  = spanAscii_ (\w -> w - ord8 '0' < 10 || w - ord8 'A' < 6 || w - ord8 'a' < 6) txt
-        go n d = (n * 16 + fromIntegral (hexDigitToInt d))
+
+-- | Internal function to read a base-@base@ number faster than the naive quadratic algorithm.
+--
+-- The input text must only contain digits. Overflows are allowed.
+integer :: Integral a => Base -> (Char -> Word) -> Text -> a
+integer (Base { base, maxWord, maxDigits }) digit t0
+  | TU.lengthWord8 t0 <= maxDigits = fromIntegral (word base digit t0)
+  | otherwise = scanWords [word' (TU.takeWord8 mswSize t0)] (TU.dropWord8 mswSize t0)
+  where
+    -- Split the most significant word from t0 so the remainder's length is a multiple of maxDigits
+    mswSize = (TU.lengthWord8 t0 - 1) `mod` maxDigits + 1
+    word' = fromIntegral . word base digit
+
+    -- The length of t is a positive multiple of maxDigits
+    scanWords chunks t
+      | TU.lengthWord8 t <= maxDigits = reduce (fromIntegral maxWord) (word' t : chunks)
+      | otherwise = scanWords (word' (TU.takeWord8 maxDigits t) : chunks) (TU.dropWord8 maxDigits t)
+
+    reduce !_ [c] = c
+    reduce width cs = reduce (width * width) (pairs width cs)
+
+    pairs !_ [] = []
+    pairs _ [c] = [c]
+    pairs width (c0 : c1 : cs) = c0 + width * c1 : pairs width cs
+
+-- | Internal function to read a base-@b@ number into a 'Word'.
+--
+-- The text must only contain digits and the result must not to overflow 'Word'.
+word :: Word -> (Char -> Word) -> Text -> Word
+word base digit = T.foldl' (\n d -> n * base + fromIntegral (digit d)) 0
 
 -- | Read an optional leading sign character (@\'-\'@ or @\'+\'@) and
 -- apply it to the result of applying the given reader.

tests/Tests/Properties/Read.hs

@@ -11,30 +11,41 @@ import Numeric (showHex)
 import Test.Tasty (TestTree, testGroup, localOption, mkTimeout)
 import Test.Tasty.QuickCheck (testProperty)
 import Test.QuickCheck
-import Tests.QuickCheckUtils ()
+import Tests.QuickCheckUtils (BigInt(Big))
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Read as TL
 import qualified Data.Text.Read as T
 
 -- Reading.
 
-t_decimal (n::Int) s =
+t_decimal n s =
     T.signed T.decimal (T.pack (show n) `T.append` t) === Right (n,t)
     where t = T.dropWhile isDigit s
-tl_decimal (n::Int) s =
+tl_decimal n s =
     TL.signed TL.decimal (TL.pack (show n) `TL.append` t) === Right (n,t)
     where t = TL.dropWhile isDigit s
-t_hexadecimal m s ox =
+
+t_decimal_int (n :: Int) = t_decimal n
+t_decimal_integer (Big n) = t_decimal n
+
+tl_decimal_int (n :: Int) = tl_decimal n
+tl_decimal_integer (Big n) = tl_decimal n
+
+t_hexadecimal n s ox =
     T.hexadecimal (T.concat [p, T.pack (showHex n ""), t]) === Right (n,t)
     where t = T.dropWhile isHexDigit s
           p = if ox then "0x" else ""
-          n = getPositive m :: Int
-tl_hexadecimal m s ox =
+tl_hexadecimal n s ox =
     TL.hexadecimal (TL.concat [p, TL.pack (showHex n ""), t]) === Right (n,t)
     where t = TL.dropWhile isHexDigit s
           p = if ox then "0x" else ""
-          n = getPositive m :: Int
+
+t_hexadecimal_int (Positive (n :: Int)) = t_hexadecimal n
+t_hexadecimal_integer (Positive (Big n)) = t_hexadecimal n
+
+tl_hexadecimal_int (Positive (n :: Int)) = tl_hexadecimal n
+tl_hexadecimal_integer (Positive (Big n)) = tl_hexadecimal n
 
 isFloaty c = c `elem` ("+-.0123456789eE" :: String)
 
@@ -75,10 +86,15 @@ tl_read_double tol n s =
 testRead :: TestTree
 testRead =
   testGroup "read" [
-    testProperty "t_decimal" t_decimal,
-    testProperty "tl_decimal" tl_decimal,
-    testProperty "t_hexadecimal" t_hexadecimal,
-    testProperty "tl_hexadecimal" tl_hexadecimal,
+    testProperty "t_decimal_int" t_decimal_int,
+    testProperty "tl_decimal_int" tl_decimal_int,
+    testProperty "t_hexadecimal_int" t_hexadecimal_int,
+    testProperty "tl_hexadecimal_int" tl_hexadecimal_int,
+
+    testProperty "t_decimal_integer" t_decimal_integer,
+    testProperty "tl_decimal_integer" tl_decimal_integer,
+    testProperty "t_hexadecimal_integer" t_hexadecimal_integer,
+    testProperty "tl_hexadecimal_integer" tl_hexadecimal_integer,
 
     testProperty "t_double" $ t_read_double 1e-13,
     testProperty "tl_double" $ tl_read_double 1e-13,

tests/Tests/QuickCheckUtils.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -109,7 +110,7 @@ instance Arbitrary TL.Text where
     shrink = map TL.pack . shrink . TL.unpack
 
 newtype BigInt = Big Integer
-               deriving (Eq, Show)
+               deriving (Eq, Ord, Show, Num)
 
 instance Arbitrary BigInt where
     arbitrary = arbitrary >>= \sign ->