Ticket #4397: rulesTest.hs

{-# LANGUAGE BangPatterns #-}
module Main (main) where

import System.Random
import Data.Array.Unboxed
import Data.Array.Base (unsafeAt)
import System.CPUTime
import Text.Printf

import GHC.Float (double2Int)

test :: (Double -> Int) -> (Int,UArray Int Double) -> Int
test fun (bd,arr) = go 0 (bd-1)
  where
    go :: Int -> Int -> Int
    go !acc 0   = acc + fun (arr `unsafeAt` 0)
    go acc i    = go (acc + fun (arr `unsafeAt` i)) (i-1)

mkArr :: StdGen -> Int -> UArray Int Double
mkArr sg bd = array (0,bd-1) $ zip [0 .. bd-1] (randomRs (miB, maB) sg)
  where
    miB = 0.99 * toEnum minBound
    maB = 0.99 * toEnum maxBound


main :: IO ()
main = do
    let bd = 1000000
        sg = mkStdGen 78537
        arr = mkArr sg bd
        ba = (bd,arr)
    print $ test double2Int ba
    sequence_
          [ bench "const 0"     (whnf (test (const 0))  ba)
          , bench "truncate"    (whnf (test (truncate :: Double -> Int))   ba)
          , bench "double2Int"  (whnf (test double2Int) ba)
          ]

whnf :: (a -> Int) -> a -> Int
whnf f x = case f x of
             0 -> 1
             k -> k

bench :: String -> Int -> IO ()
bench name val = do
    t0 <- getCPUTime
    print val
    t1 <- getCPUTime
    printf "%-10s took %10.6fs\n" name (fromInteger (t1-t0) * (1e-12 :: Double))