cb8d155b83cce91f54a8d217bc716bdc8f841fb0
[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 -- | Implementation of Kahan summation algorithm that tests
7 -- performance of tight loops involving unboxed arrays and floating
8 -- point arithmetic.
9 module Main (main) where
10
11 import Control.Monad.ST
12 import Data.Array.Base
13 import Data.Array.ST
14 import Data.Bits
15 import Data.Word
16 import System.Environment
17
18 vdim :: Int
19 vdim = 100
20
21 prng :: Word -> Word
22 prng w = w'
23 where
24 w1 = w `xor` (w `shiftL` 13)
25 w2 = w1 `xor` (w1 `shiftR` 7)
26 w' = w2 `xor` (w2 `shiftL` 17)
27
28 type Vec s = STUArray s Int Double
29
30 kahan :: Int -> Vec s -> Vec s -> ST s ()
31 kahan vnum s c = do
32 let inner w j
33 | j < vdim = do
34 cj <- unsafeRead c j
35 sj <- unsafeRead s j
36 let y = fromIntegral w - cj
37 t = sj + y
38 w' = prng w
39 unsafeWrite c j ((t-sj)-y)
40 unsafeWrite s j t
41 inner w' (j+1)
42 | otherwise = return ()
43
44 outer i | i <= vnum = inner (fromIntegral i) 0 >> outer (i+1)
45 | otherwise = return ()
46 outer 1
47
48 calc :: Int -> ST s (Vec s)
49 calc vnum = do
50 s <- newArray (0,vdim-1) 0
51 c <- newArray (0,vdim-1) 0
52 kahan vnum s c
53 return s
54
55 main :: IO ()
56 main = do
57 [arg] <- getArgs
58 print . elems $ runSTUArray $ calc $ read arg