1{-# LANGUAGE Rank2Types #-}
2
3module Blocks where
4
5import Control.Monad
6import Control.Monad.ST
7
8import Data.Vector.Unboxed.Mutable
9
10import System.CPUTime
11
12import System.Random.MWC (GenIO, Variate(..))
13
14-- Some conveniences for doing evil stuff in the ST monad.
15-- All the tests get run in IO, but uvector stuff happens
16-- in ST, so we temporarily coerce.
17clock :: IO Integer
18clock = getCPUTime
19
20-- Strategies for filling the initial arrays
21rand :: Variate e => GenIO -> Int -> IO e
22rand g _ = uniform g
23
24ascend :: Num e => Int -> IO e
25ascend = return . fromIntegral
26
27descend :: Num e => e -> Int -> IO e
28descend m n = return $ m - fromIntegral n
29
30modulo :: Integral e => e -> Int -> IO e
31modulo m n = return $ fromIntegral n `mod` m
32
33-- This is the worst case for the median-of-three quicksort
34-- used in the introsort implementation.
35medianKiller :: Integral e => e -> Int -> IO e
36medianKiller m n'
37  | n < k     = return $ if even n then n + 1 else n + k
38  | otherwise = return $ (n - k + 1) * 2
39 where
40 n = fromIntegral n'
41 k = m `div` 2
42{-# INLINE medianKiller #-}
43
44initialize :: (Unbox e) => MVector RealWorld e -> Int -> (Int -> IO e) -> IO ()
45initialize arr len fill = initial $ len - 1
46 where initial n = fill n >>= unsafeWrite arr n >> when (n > 0) (initial $ n - 1)
47{-# INLINE initialize #-}
48
49speedTest :: (Unbox e) => MVector RealWorld e
50                       -> Int
51                       -> (Int -> IO e)
52                       -> (MVector RealWorld e -> IO ())
53                       -> IO Integer
54speedTest arr n fill algo = do
55  initialize arr n fill
56  t0 <- clock
57  algo arr
58  t1 <- clock
59  return $ t1 - t0
60{-# INLINE speedTest #-}
61
62
63