Ticket #4397: rulesTest.hs

File rulesTest.hs, 1.3 KB (added by daniel.is.fischer, 5 years ago)

example for non-firing RULE for a class method

Line 
1{-# LANGUAGE BangPatterns #-}
2module Main (main) where
3
4import System.Random
5import Data.Array.Unboxed
6import Data.Array.Base (unsafeAt)
7import System.CPUTime
8import Text.Printf
9
10import GHC.Float (double2Int)
11
12test :: (Double -> Int) -> (Int,UArray Int Double) -> Int
13test fun (bd,arr) = go 0 (bd-1)
14  where
15    go :: Int -> Int -> Int
16    go !acc 0   = acc + fun (arr `unsafeAt` 0)
17    go acc i    = go (acc + fun (arr `unsafeAt` i)) (i-1)
18
19mkArr :: StdGen -> Int -> UArray Int Double
20mkArr sg bd = array (0,bd-1) $ zip [0 .. bd-1] (randomRs (miB, maB) sg)
21  where
22    miB = 0.99 * toEnum minBound
23    maB = 0.99 * toEnum maxBound
24
25
26main :: IO ()
27main = do
28    let bd = 1000000
29        sg = mkStdGen 78537
30        arr = mkArr sg bd
31        ba = (bd,arr)
32    print $ test double2Int ba
33    sequence_
34          [ bench "const 0"     (whnf (test (const 0))  ba)
35          , bench "truncate"    (whnf (test (truncate :: Double -> Int))   ba)
36          , bench "double2Int"  (whnf (test double2Int) ba)
37          ]
38
39whnf :: (a -> Int) -> a -> Int
40whnf f x = case f x of
41             0 -> 1
42             k -> k
43
44bench :: String -> Int -> IO ()
45bench name val = do
46    t0 <- getCPUTime
47    print val
48    t1 <- getCPUTime
49    printf "%-10s took %10.6fs\n" name (fromInteger (t1-t0) * (1e-12 :: Double))