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