Ticket #8793: bench.hs

File bench.hs, 1.4 KB (added by cdk, 14 months ago)

benchmark code

Line 
1{-# LANGUAGE BangPatterns #-}
2
3import qualified Data.Vector.Unboxed as U
4import IntTable    as IT
5import GHCIntTable as GT
6import System.Random.MWC
7
8import Criterion.Main
9
10main = do
11    let n = 4096 :: Int
12    it <- IT.new 32
13    gt <- GT.new 32
14    v  <- create >>= U.replicateM n . uniformR (0, n)
15    defaultMain
16        [ bcompare
17            [ bench "ghc-insert" $ loopV_ v (\x -> GT.insertWith (++) x [x] gt)
18            , bench "cdk-insert" $ loopV_ v (\x -> IT.insertWith (++) x [x] it)
19            ]
20        , bcompare
21            [ bench "ghc-lookup" $ loopN_ n (\x -> GT.lookup x gt)
22            , bench "cdk-lookup" $ loopN_ n (\x -> IT.lookup x it)
23            ]
24        , bcompare
25            [ bench "ghc-update" $ loopN_ n (\x -> GT.updateWith (dropReg x) x gt)
26            , bench "cdk-update" $ loopN_ n (\x -> IT.updateWith (dropReg x) x it)
27            ]
28        , bcompare
29            [ bench "ghc-delete" $ loopN_ n (\x -> GT.delete x gt)
30            , bench "cdk-delete" $ loopN_ n (\x -> IT.delete x it)
31            ]
32        ]
33
34dropReg :: Eq a => a -> [a] -> Maybe [a]
35dropReg a = nullToMaybe . filter (/= a)
36
37nullToMaybe :: [a] -> Maybe [a]
38nullToMaybe [] = Nothing
39nullToMaybe xs = Just xs
40
41loopV_ :: U.Vector Int -> (Int -> IO a) -> IO ()
42loopV_ v f = U.mapM_ f v
43
44loopN_ :: Int -> (Int -> IO a) -> IO ()
45loopN_ n f = go 0
46    where go !i | i == n    = return ()
47                | otherwise = f i >> go (i + 1)