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