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