Stabilise benchmarks wrt. GC
[nofib.git] / imaginary / kahan / Main.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 -- Inferred type for 'inner' has a constraint (MArray (STUArray s) Double m)
3 -- An alternative fix (better, but less faithful to backward perf comparison)
4 -- would be MonoLocalBinds
5 --
6 -- SG: I tried adding MonoLocalBinds here and it didn't change anything in
7 -- -ddump-simpl. `inner` is probably properly specialised now. I think this
8 -- comment can go?!
9
10 -- | Implementation of Kahan summation algorithm that tests
11 -- performance of tight loops involving unboxed arrays and floating
12 -- point arithmetic.
13 module Main (main) where
14
15 import Control.Monad.ST
16 import Data.Array.Base
17 import Data.Array.ST
18 import Data.Bits
19 import Data.Word
20 import System.Environment
21
22 vdim :: Int
23 vdim = 100
24
25 prng :: Word -> Word
26 prng w = w'
27 where
28 w1 = w `xor` (w `shiftL` 13)
29 w2 = w1 `xor` (w1 `shiftR` 7)
30 w' = w2 `xor` (w2 `shiftL` 17)
31
32 type Vec s = STUArray s Int Double
33
34 kahan :: Int -> Vec s -> Vec s -> ST s ()
35 kahan vnum s c = do
36 let inner w j
37 | j < vdim = do
38 cj <- unsafeRead c j
39 sj <- unsafeRead s j
40 let y = fromIntegral w - cj
41 t = sj + y
42 w' = prng w
43 unsafeWrite c j ((t-sj)-y)
44 unsafeWrite s j t
45 inner w' (j+1)
46 | otherwise = return ()
47
48 outer i | i <= vnum = inner (fromIntegral i) 0 >> outer (i+1)
49 | otherwise = return ()
50 outer 1
51
52 calc :: Int -> ST s (Vec s)
53 calc vnum = do
54 s <- newArray (0,vdim-1) 0
55 c <- newArray (0,vdim-1) 0
56 kahan vnum s c
57 return s
58
59 main :: IO ()
60 main = do
61 [arg] <- getArgs
62 -- Floating point benchmarks have unstable output across platforms, so
63 -- we output the actual result.
64 -- print . elems $ runSTUArray $ calc $ read arg
65 runSTUArray (calc (read arg)) `seq` return ()