← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to libraries/containers/benchmarks/Benchmarks.hs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libraries/containers/benchmarks/Benchmarks.hs
 
1
{-# LANGUAGE BangPatterns #-}
 
2
module Main where
 
3
 
 
4
import Control.DeepSeq
 
5
import Control.Exception (evaluate)
 
6
import Control.Monad.Trans (liftIO)
 
7
import Criterion.Config
 
8
import Criterion.Main
 
9
import Data.List (foldl')
 
10
import qualified Data.Map as M
 
11
import Data.Maybe (fromMaybe)
 
12
import Prelude hiding (lookup)
 
13
 
 
14
instance (NFData k, NFData a) => NFData (M.Map k a) where
 
15
    rnf M.Tip = ()
 
16
    rnf (M.Bin _ k a l r) = rnf k `seq` rnf a `seq` rnf l `seq` rnf r
 
17
 
 
18
main = do
 
19
    let m = M.fromAscList elems :: M.Map Int Int
 
20
    defaultMainWith
 
21
        defaultConfig
 
22
        (liftIO . evaluate $ rnf [m])
 
23
        [ bench "lookup" $ nf (lookup keys) m
 
24
        , bench "insert" $ nf (ins elems) M.empty
 
25
        , bench "insertWith empty" $ nf (insWith elems) M.empty
 
26
        , bench "insertWith update" $ nf (insWith elems) m
 
27
        , bench "insertWith' empty" $ nf (insWith' elems) M.empty
 
28
        , bench "insertWith' update" $ nf (insWith' elems) m
 
29
        , bench "insertWithKey empty" $ nf (insWithKey elems) M.empty
 
30
        , bench "insertWithKey update" $ nf (insWithKey elems) m
 
31
        , bench "insertWithKey' empty" $ nf (insWithKey' elems) M.empty
 
32
        , bench "insertWithKey' update" $ nf (insWithKey' elems) m
 
33
        , bench "insertLookupWithKey empty" $
 
34
          nf (insLookupWithKey elems) M.empty
 
35
        , bench "insertLookupWithKey update" $
 
36
          nf (insLookupWithKey elems) m
 
37
        , bench "insertLookupWithKey' empty" $
 
38
          nf (insLookupWithKey' elems) M.empty
 
39
        , bench "insertLookupWithKey' update" $
 
40
          nf (insLookupWithKey' elems) m
 
41
        , bench "map" $ nf (M.map (+ 1)) m
 
42
        , bench "mapWithKey" $ nf (M.mapWithKey (+)) m
 
43
        , bench "foldlWithKey" $ nf (ins elems) m
 
44
        , bench "foldlWithKey'" $ nf (M.foldlWithKey' sum 0) m
 
45
        , bench "foldrWithKey" $ nf (M.foldrWithKey consPair []) m
 
46
        , bench "delete" $ nf (del keys) m
 
47
        , bench "update" $ nf (upd keys) m
 
48
        , bench "updateLookupWithKey" $ nf (upd' keys) m
 
49
        , bench "alter"  $ nf (alt keys) m
 
50
        , bench "mapMaybe" $ nf (M.mapMaybe maybeDel) m
 
51
        , bench "mapMaybeWithKey" $ nf (M.mapMaybeWithKey (const maybeDel)) m
 
52
        , bench "lookupIndex" $ nf (lookupIndex keys) m
 
53
        ]
 
54
  where
 
55
    elems = zip keys values
 
56
    keys = [1..2^10]
 
57
    values = [1..2^10]
 
58
    sum k v1 v2 = k + v1 + v2
 
59
    consPair k v xs = (k, v) : xs
 
60
 
 
61
add3 :: Int -> Int -> Int -> Int
 
62
add3 x y z = x + y + z
 
63
{-# INLINE add3 #-}
 
64
 
 
65
lookup :: [Int] -> M.Map Int Int -> Int
 
66
lookup xs m = foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 xs
 
67
 
 
68
lookupIndex :: [Int] -> M.Map Int Int -> Int
 
69
lookupIndex xs m = foldl' (\n k -> fromMaybe n (M.lookupIndex k m)) 0 xs
 
70
 
 
71
ins :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
 
72
ins xs m = foldl' (\m (k, v) -> M.insert k v m) m xs
 
73
 
 
74
insWith :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
 
75
insWith xs m = foldl' (\m (k, v) -> M.insertWith (+) k v m) m xs
 
76
 
 
77
insWithKey :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
 
78
insWithKey xs m = foldl' (\m (k, v) -> M.insertWithKey add3 k v m) m xs
 
79
 
 
80
insWith' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
 
81
insWith' xs m = foldl' (\m (k, v) -> M.insertWith' (+) k v m) m xs
 
82
 
 
83
insWithKey' :: [(Int, Int)] -> M.Map Int Int -> M.Map Int Int
 
84
insWithKey' xs m = foldl' (\m (k, v) -> M.insertWithKey' add3 k v m) m xs
 
85
 
 
86
data PairS a b = PS !a !b
 
87
 
 
88
insLookupWithKey :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int)
 
89
insLookupWithKey xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)
 
90
  where
 
91
    f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey add3 k v m
 
92
                        in PS (fromMaybe 0 n' + n) m'
 
93
 
 
94
insLookupWithKey' :: [(Int, Int)] -> M.Map Int Int -> (Int, M.Map Int Int)
 
95
insLookupWithKey' xs m = let !(PS a b) = foldl' f (PS 0 m) xs in (a, b)
 
96
  where
 
97
    f (PS n m) (k, v) = let !(n', m') = M.insertLookupWithKey' add3 k v m
 
98
                        in PS (fromMaybe 0 n' + n) m'
 
99
 
 
100
del :: [Int] -> M.Map Int Int -> M.Map Int Int
 
101
del xs m = foldl' (\m k -> M.delete k m) m xs
 
102
 
 
103
upd :: [Int] -> M.Map Int Int -> M.Map Int Int
 
104
upd xs m = foldl' (\m k -> M.update Just k m) m xs
 
105
 
 
106
upd' :: [Int] -> M.Map Int Int -> M.Map Int Int
 
107
upd' xs m = foldl' (\m k -> snd $ M.updateLookupWithKey (\_ a -> Just a) k m) m xs
 
108
 
 
109
alt :: [Int] -> M.Map Int Int -> M.Map Int Int
 
110
alt xs m = foldl' (\m k -> M.alter id k m) m xs
 
111
 
 
112
maybeDel :: Int -> Maybe Int
 
113
maybeDel n | n `mod` 3 == 0 = Nothing
 
114
           | otherwise      = Just n