@@ -0,0 +1,164 @@
1+{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+module Main (
5+ main,
6+ input17,
7+ input32,
8+ input64,
9+ input128,
10+ input256,
11+ input2048,
12+ input4096,
13+ input8192,
14+ input16384,
15+ ) where
16+
17+import Criterion.Main
18+import Prelude.Compat
19+import Data.Int (Int64)
20+import Data.Scientific (Scientific)
21+import Data.Aeson.Parser (scientific)
22+
23+import qualified Data.Attoparsec.ByteString.Lazy as AttoL
24+import qualified Data.Attoparsec.ByteString.Char8 as Atto8
25+import qualified Data.Aeson as A
26+import qualified Data.ByteString as BS
27+import qualified Data.ByteString.Lazy as LBS
28+import qualified Data.ByteString.Lazy.Char8 as LBS8
29+
30+decodeInt :: LBS.ByteString -> Maybe Int
31+decodeInt = A.decode
32+
33+decodeString :: LBS.ByteString -> Maybe String
34+decodeString = A.decode
35+
36+decodeScientific :: LBS.ByteString -> Maybe Scientific
37+decodeScientific = A.decode
38+
39+decodeViaRead :: LBS.ByteString -> Integer
40+decodeViaRead = read . LBS8.unpack
41+
42+decodeAtto :: LBS.ByteString -> Maybe Scientific
43+decodeAtto
44+ = parseOnly (scientific <* AttoL.endOfInput)
45+ where
46+ parseOnly p lbs = case AttoL.parse p lbs of
47+ AttoL.Done _ r -> Just r
48+ AttoL.Fail {} -> Nothing
49+
50+decodeAtto8 :: LBS.ByteString -> Maybe Scientific
51+decodeAtto8
52+ = parseOnly (Atto8.scientific <* AttoL.endOfInput)
53+ where
54+ parseOnly p lbs = case AttoL.parse p lbs of
55+ AttoL.Done _ r -> Just r
56+ AttoL.Fail {} -> Nothing
57+
58+generate :: Int64 -> LBS.ByteString
59+generate n = LBS8.replicate n '1'
60+
61+input17 :: LBS.ByteString
62+input17 = generate 17
63+
64+input32 :: LBS.ByteString
65+input32 = generate 32
66+
67+input64 :: LBS.ByteString
68+input64 = generate 64
69+
70+input128 :: LBS.ByteString
71+input128 = generate 128
72+
73+input256 :: LBS.ByteString
74+input256 = generate 256
75+
76+input2048 :: LBS.ByteString
77+input2048 = generate 2048
78+
79+input4096 :: LBS.ByteString
80+input4096 = generate 4096
81+
82+input8192 :: LBS.ByteString
83+input8192 = generate 8192
84+
85+input16384 :: LBS.ByteString
86+input16384 = generate 16384
87+
88+
89+main :: IO ()
90+main = defaultMain
91+ -- works on 64bit
92+ [ benchPair "17" input17
93+ -- , benchPair "32" input32
94+ -- , benchPair "64" input64
95+ -- , benchPair "128" input128
96+ -- , benchPair "256" input256
97+ , benchPair "2048" input2048
98+ , benchPair "4096" input4096
99+ , benchPair "8192" input8192
100+ , benchPair "16384" input16384
101+ ]
102+ where
103+ benchPair name input = bgroup name
104+ [ bench "Int" $ whnf decodeInt input
105+ , bench "Simple" $ whnf bsToIntegerSimple (LBS.toStrict input)
106+ , bench "Optim" $ whnf bsToInteger (LBS.toStrict input)
107+ , bench "Read" $ whnf decodeViaRead input
108+ , bench "Scientific" $ whnf decodeScientific input
109+ , bench "parserA" $ whnf decodeAtto input
110+ , bench "parserS" $ whnf decodeAtto8 input
111+ , bench "String" $ whnf decodeString $ "\"" <> input <> "\""
112+ ]
113+
114+-------------------------------------------------------------------------------
115+-- better fromInteger
116+-------------------------------------------------------------------------------
117+
118+bsToInteger :: BS.ByteString -> Integer
119+bsToInteger bs
120+ | l > 40 = valInteger 10 l [ fromIntegral (w - 48) | w <- BS.unpack bs ]
121+ | otherwise = bsToIntegerSimple bs
122+ where
123+ l = BS.length bs
124+
125+bsToIntegerSimple :: BS.ByteString -> Integer
126+bsToIntegerSimple = BS.foldl' step 0 where
127+ step a b = a * 10 + fromIntegral (b - 48) -- 48 = '0'
128+
129+-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b
130+-- digits are combined into a single radix b^2 digit. This process is
131+-- repeated until we are left with a single digit. This algorithm
132+-- performs well only on large inputs, so we use the simple algorithm
133+-- for smaller inputs.
134+valInteger :: Integer -> Int -> [Integer] -> Integer
135+valInteger = go
136+ where
137+ go :: Integer -> Int -> [Integer] -> Integer
138+ go _ _ [] = 0
139+ go _ _ [d] = d
140+ go b l ds
141+ | l > 40 = b' `seq` go b' l' (combine b ds')
142+ | otherwise = valSimple b ds
143+ where
144+ -- ensure that we have an even number of digits
145+ -- before we call combine:
146+ ds' = if even l then ds else 0 : ds
147+ b' = b * b
148+ l' = (l + 1) `quot` 2
149+
150+ combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)
151+ where
152+ d = d1 * b + d2
153+ combine _ [] = []
154+ combine _ [_] = errorWithoutStackTrace "this should not happen"
155+
156+-- The following algorithm is only linear for types whose Num operations
157+-- are in constant time.
158+valSimple :: Integer -> [Integer] -> Integer
159+valSimple base = go 0
160+ where
161+ go r [] = r
162+ go r (d : ds) = r' `seq` go r' ds
163+ where
164+ r' = r * base + fromIntegral d