1module Main where
2
3import Criterion.Main
4import Data.Int
5import Data.Word
6import Data.Scientific
7
8main :: IO ()
9main = defaultMain
10       [ bgroup "realToFrac"
11         [ bgroup "Scientific->Double"
12           [ sToD "dangerouslyBig"   dangerouslyBig
13           , sToD "dangerouslySmall" dangerouslySmall
14           , sToD "pos"              pos
15           , sToD "neg"              neg
16           , sToD "int"              int
17           , sToD "negInt"           negInt
18           ]
19         , bgroup "Double->Scientific"
20           [ dToS "pos"    pos
21           , dToS "neg"    neg
22           , dToS "int"    int
23           , dToS "negInt" negInt
24           ]
25         ]
26       , bgroup "floor"
27         [ bench "floor"        (nf (floor :: Scientific -> Integer) $! pos)
28         , bench "floorDefault" (nf floorDefault                     $! pos)
29         ]
30       , bgroup "ceiling"
31         [ bench "ceiling"        (nf (ceiling :: Scientific -> Integer) $! pos)
32         , bench "ceilingDefault" (nf ceilingDefault                     $! pos)
33         ]
34       , bgroup "truncate"
35         [ bench "truncate"        (nf (truncate :: Scientific -> Integer) $! pos)
36         , bench "truncateDefault" (nf truncateDefault                     $! pos)
37         ]
38
39       , bgroup "round"
40         [ bench "round"        (nf (round :: Scientific -> Integer) $! pos)
41         , bench "roundDefault" (nf roundDefault                     $! pos)
42         ]
43
44       , bgroup "toDecimalDigits"
45         [ bench "big" (nf toDecimalDigits $! big)
46         ]
47
48       , bgroup "fromFloatDigits"
49         [ bench "pos"    $ nf (fromFloatDigits :: Double -> Scientific) pos
50         , bench "neg"    $ nf (fromFloatDigits :: Double -> Scientific) neg
51         , bench "int"    $ nf (fromFloatDigits :: Double -> Scientific) int
52         , bench "negInt" $ nf (fromFloatDigits :: Double -> Scientific) negInt
53         ]
54
55       , bgroup "toBoundedInteger"
56         [ bgroup "0"              $ benchToBoundedInteger 0
57         , bgroup "dangerouslyBig" $ benchToBoundedInteger dangerouslyBig
58         , bgroup "64"             $ benchToBoundedInteger 64
59         ]
60       ]
61    where
62      pos :: Fractional a => a
63      pos = 12345.12345
64
65      neg :: Fractional a => a
66      neg = -pos
67
68      int :: Fractional a => a
69      int = 12345
70
71      negInt :: Fractional a => a
72      negInt = -int
73
74      big :: Scientific
75      big = read $ "0." ++ concat (replicate 20 "0123456789")
76
77      dangerouslyBig :: Scientific
78      dangerouslyBig = read "1e500"
79
80      dangerouslySmall :: Scientific
81      dangerouslySmall = read "1e-500"
82
83realToFracStoD :: Scientific -> Double
84realToFracStoD = fromRational . toRational
85{-# INLINE realToFracStoD #-}
86
87realToFracDtoS :: Double -> Scientific
88realToFracDtoS = fromRational . toRational
89{-# INLINE realToFracDtoS #-}
90
91sToD :: String -> Scientific -> Benchmark
92sToD name f = bgroup name
93              [ bench "toRealFloat"  . nf (realToFrac     :: Scientific -> Double) $! f
94              , bench "via Rational" . nf (realToFracStoD :: Scientific -> Double) $! f
95              ]
96
97dToS :: String -> Double -> Benchmark
98dToS name f = bgroup name
99              [ bench "fromRealFloat"  . nf (realToFrac     :: Double -> Scientific) $! f
100              , bench "via Rational"   . nf (realToFracDtoS :: Double -> Scientific) $! f
101              ]
102
103floorDefault :: Scientific -> Integer
104floorDefault x = if r < 0 then n - 1 else n
105                 where (n,r) = properFraction x
106{-# INLINE floorDefault #-}
107
108ceilingDefault :: Scientific -> Integer
109ceilingDefault x = if r > 0 then n + 1 else n
110                   where (n,r) = properFraction x
111{-# INLINE ceilingDefault #-}
112
113truncateDefault :: Scientific -> Integer
114truncateDefault x =  m where (m,_) = properFraction x
115{-# INLINE truncateDefault #-}
116
117roundDefault :: Scientific -> Integer
118roundDefault x = let (n,r) = properFraction x
119                     m     = if r < 0 then n - 1 else n + 1
120                 in case signum (abs r - 0.5) of
121                      -1 -> n
122                      0  -> if even n then n else m
123                      1  -> m
124                      _  -> error "round default defn: Bad value"
125{-# INLINE roundDefault #-}
126
127benchToBoundedInteger :: Scientific -> [Benchmark]
128benchToBoundedInteger s =
129    [ bench "Int"    $ nf (toBoundedInteger :: Scientific -> Maybe Int)    s
130    , bench "Int8"   $ nf (toBoundedInteger :: Scientific -> Maybe Int8)   s
131    , bench "Int16"  $ nf (toBoundedInteger :: Scientific -> Maybe Int16)  s
132    , bench "Int32"  $ nf (toBoundedInteger :: Scientific -> Maybe Int32)  s
133    , bench "Int64"  $ nf (toBoundedInteger :: Scientific -> Maybe Int64)  s
134    , bench "Word"   $ nf (toBoundedInteger :: Scientific -> Maybe Word)   s
135    , bench "Word8"  $ nf (toBoundedInteger :: Scientific -> Maybe Word8)  s
136    , bench "Word16" $ nf (toBoundedInteger :: Scientific -> Maybe Word16) s
137    , bench "Word32" $ nf (toBoundedInteger :: Scientific -> Maybe Word32) s
138    , bench "Word64" $ nf (toBoundedInteger :: Scientific -> Maybe Word64) s
139    ]
140