Skip to content

Commit 2aac825

Browse files
sjakobisjakobi
committed
Merge branch 'sjakobi/fine-grained-bench' into sjakobi/two-opt
2 parents 0e0b74d + 140ff89 commit 2aac825

File tree

3 files changed

+301
-1
lines changed

3 files changed

+301
-1
lines changed

‎benchmarks/FineGrained.hs‎

Lines changed: 234 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,234 @@
1+
{-# LANGUAGE DeriveAnyClass #-}
2+
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE ExplicitForAll #-}
4+
{-# LANGUAGE NumericUnderscores #-}
5+
{-# LANGUAGE TupleSections #-}
6+
{-# LANGUAGE TypeApplications #-}
7+
8+
module Main where
9+
10+
import Control.DeepSeq (NFData)
11+
import Control.Monad (replicateM)
12+
import Data.Bits (testBit)
13+
import Data.HashMap.Strict (HashMap)
14+
import qualified Data.HashMap.Strict as HM
15+
import qualified Data.HashSet
16+
import Data.Hashable
17+
import Data.List
18+
import Key.Bytes
19+
import System.Random.Stateful
20+
import Test.Tasty.Bench
21+
import Prelude hiding (Foldable (..), lookup)
22+
23+
main :: IO ()
24+
main =
25+
defaultMain
26+
[ bgroup
27+
"HashMap.Strict"
28+
[ bFromList,
29+
-- bgroup "insert" bInsert
30+
bUnion,
31+
bDifference
32+
],
33+
bgroup "HashSet" [bSetFromList]
34+
]
35+
36+
defaultSizes :: [Int]
37+
defaultSizes = [0, 1, 10, 100, 1000, 10_000, 100_000]
38+
39+
-- | Length of a 'Bytes' key in bytes.
40+
--
41+
-- For comparison: A SHA256 hash is 32 bytes long.
42+
bytesLength :: Int
43+
bytesLength = 32
44+
45+
-- | Pseudo-random generator for keys etc.
46+
--
47+
-- Change the seed to generate different random elements.
48+
defaultGen :: StdGen
49+
defaultGen = mkStdGen 42
50+
51+
env' ::
52+
(NFData a) =>
53+
Int ->
54+
(Int -> IOGenM StdGen -> IO a) ->
55+
(a -> Benchmarkable) ->
56+
Benchmark
57+
env' size setup run =
58+
env
59+
( do
60+
gen <- newIOGenM defaultGen
61+
setup size gen
62+
)
63+
(\x -> bench (show size) (run x))
64+
65+
bFromList :: Benchmark
66+
bFromList =
67+
bgroup
68+
"fromList"
69+
[ bgroup "Bytes" [env' s setupBytes run | s <- defaultSizes],
70+
bgroup "Int" [env' s genInts run | s <- defaultSizes]
71+
]
72+
where
73+
setupBytes s = genNBytes s bytesLength
74+
run :: (Hashable a) => [a] -> Benchmarkable
75+
run = whnf (HM.fromList . map (,()))
76+
77+
bUnion :: Benchmark
78+
bUnion =
79+
bgroup
80+
"union"
81+
[ bgroup "disjoint" bUnionDisjoint,
82+
bgroup "overlap" bUnionOverlap,
83+
bgroup "equal" bUnionEqual
84+
]
85+
86+
bUnionDisjoint :: [Benchmark]
87+
bUnionDisjoint =
88+
[ bgroup "Bytes" [env' s setupBytes run | s <- defaultSizes],
89+
bgroup "Int" [env' s setupInts run | s <- defaultSizes]
90+
]
91+
where
92+
run :: (Hashable a) => (HashMap a Int, HashMap a Int) -> Benchmarkable
93+
run = whnf (\(as, bs) -> HM.union as bs)
94+
setupBytes s gen = do
95+
(trues, falses) <- Key.Bytes.genDisjoint s bytesLength gen
96+
return (keysToMap trues, keysToMap falses)
97+
setupInts s gen = do
98+
ints <- genInts s gen
99+
let (trues, falses) = Data.List.partition (flip testBit (31 :: Int)) ints
100+
return (keysToMap trues, keysToMap falses)
101+
102+
-- TODO: Separate benchmarks for overlap with pointer eq?!
103+
bUnionOverlap :: [Benchmark]
104+
bUnionOverlap =
105+
[ bgroup "Bytes" [env' s setupBytes run | s <- defaultSizes],
106+
bgroup "Int" [env' s setupInts run | s <- defaultSizes]
107+
]
108+
where
109+
run :: (Hashable a) => (HashMap a Int, HashMap a Int) -> Benchmarkable
110+
run = whnf (\(as, bs) -> HM.union as bs)
111+
setupBytes s gen = do
112+
(trues, falses) <- Key.Bytes.genDisjoint s bytesLength gen
113+
let (a_sep, b_sep) = splitAt (s `div` 4) trues
114+
return
115+
( keysToMap falses `HM.union` keysToMap a_sep,
116+
keysToMap falses `HM.union` keysToMap b_sep
117+
)
118+
setupInts s gen = do
119+
let s_overlap = s `div` 2
120+
let s_a_sep = (s - s_overlap) `div` 2
121+
let s_b_sep = s - s_overlap - s_a_sep
122+
overlap <- genInts s_overlap gen
123+
a_sep <- genInts s_a_sep gen
124+
b_sep <- genInts s_b_sep gen
125+
return
126+
( keysToMap overlap `HM.union` keysToMap a_sep,
127+
keysToMap overlap `HM.union` keysToMap b_sep
128+
)
129+
130+
bUnionEqual :: [Benchmark]
131+
bUnionEqual =
132+
[ bgroup "Bytes" [env' s setupBytes run | s <- defaultSizes],
133+
bgroup "Int" [env' s setupInts run | s <- defaultSizes]
134+
]
135+
where
136+
run :: (Hashable a) => HashMap a Int -> Benchmarkable
137+
run = whnf (\m -> HM.union m m)
138+
setupBytes s gen = do
139+
ks <- Key.Bytes.genNBytes s bytesLength gen
140+
return (keysToMap ks)
141+
setupInts s gen = do
142+
ks <- genInts s gen
143+
return (keysToMap ks)
144+
145+
bDifference :: Benchmark
146+
bDifference = bgroup "difference" []
147+
{-
148+
[ bgroup "disjoint" bDifferenceDisjoint,
149+
bgroup "overlap" bDifferenceOverlap,
150+
bgroup "equal" bDifferenceEqual
151+
]
152+
-}
153+
154+
bDifferenceDisjoint :: [Benchmark]
155+
bDifferenceDisjoint = [ b "Bytes" setupBytes, b "Int" setupInts ]
156+
where
157+
b = undefined
158+
setupBytes = undefined
159+
setupInts = undefined
160+
161+
bDifferenceOverlap :: [Benchmark]
162+
bDifferenceOverlap = [ b "Bytes" setupBytes, b "Int" setupInts ]
163+
where
164+
b = undefined
165+
setupBytes = undefined
166+
setupInts = undefined
167+
168+
bDifferenceEqual :: [Benchmark]
169+
bDifferenceEqual = [ b "Bytes" setupBytes, b "Int" setupInts ]
170+
where
171+
b = undefined
172+
setupBytes = undefined
173+
setupInts = undefined
174+
175+
176+
bSetFromList :: Benchmark
177+
bSetFromList =
178+
bgroup
179+
"fromList"
180+
[ bg "Bytes" setupBytes,
181+
bg "Int" setupInts
182+
]
183+
where
184+
bg name e = bgroup name (b e)
185+
b e = [env' s e run | s <- defaultSizes]
186+
run :: (Hashable a) => [a] -> Benchmarkable
187+
run = whnf Data.HashSet.fromList
188+
setupBytes s gen = genNBytes s bytesLength gen
189+
setupInts = genInts
190+
191+
{-
192+
bg :: _
193+
bg name setup run = bgroup name (b setup run)
194+
where
195+
b e run = [env (e s) (run s) | s <- defaultSizes]
196+
-}
197+
198+
keysToMap :: (Hashable k) => [k] -> HashMap k Int
199+
keysToMap = HM.fromList . map (,1)
200+
201+
genInts ::
202+
(StatefulGen g m) =>
203+
Int ->
204+
g ->
205+
m [Int]
206+
genInts n = replicateM n . uniformM
207+
208+
{-
209+
bFromList = matrix defaultSizes e' b'
210+
where
211+
e' s = uniformListM s defaultGen
212+
b' = whnf HM.fromList
213+
-}
214+
215+
{-
216+
bInsert = [ env m $ \d -> bench (show s) $ whnf (\(k, v, m) -> HM.insert k v m) d ]
217+
where m s = do
218+
g <- newIOGenM defaultGen
219+
let hm = HM.empty
220+
forM_ [1..s] $ \v -> do
221+
b <- genBytes 32 g
222+
HMI.unsafeInsert b v hm
223+
return (m, newKeys) -- separate existing, new
224+
-}
225+
226+
{-
227+
matrix :: (NFData env) => [Int] -> (Int -> IO env) -> (env -> Benchmarkable) -> Benchmark
228+
matrix sizes e x = b -- [ b @Bytes, b @Int] -- , b @SlowInt, b @Colli ]
229+
where
230+
b = bgroup "bla" [runTemplate @Int e x s | s <- sizes]
231+
232+
runTemplate :: forall env. (NFData env) => (Int -> IO env) -> (env -> Benchmarkable) -> Int -> Benchmark
233+
runTemplate e b s = env (e s) $ \x -> bench (show s) (b x)
234+
-}

‎benchmarks/Key/Bytes.hs‎

Lines changed: 46 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,46 @@
1+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
3+
module Key.Bytes where
4+
5+
import Control.DeepSeq
6+
import Control.Monad (replicateM)
7+
import Data.ByteString.Short
8+
import Data.Hashable
9+
import Data.List
10+
import System.Random.Stateful
11+
12+
newtype Bytes = Bytes {unBytes :: ShortByteString}
13+
deriving (Eq, Hashable, Show, NFData)
14+
15+
genBytes ::
16+
(StatefulGen g m) =>
17+
Int ->
18+
g ->
19+
m Bytes
20+
genBytes len gen = Bytes <$> uniformShortByteStringM len gen
21+
22+
genNBytes ::
23+
(StatefulGen g m) =>
24+
Int ->
25+
Int ->
26+
g ->
27+
m [Bytes]
28+
genNBytes n len = replicateM n . genBytes len
29+
30+
-- | @genDisjoint n len gen@ generates @n@ 'Bytes' in total. The returned lists
31+
-- each contain roughly half of the total.
32+
genDisjoint ::
33+
(StatefulGen g m) =>
34+
Int ->
35+
-- | Must be positive
36+
Int ->
37+
g ->
38+
m ([Bytes], [Bytes])
39+
genDisjoint n len gen = Data.List.partition predicate <$> genNBytes n len gen
40+
where
41+
predicate (Bytes sbs) = even (Data.ByteString.Short.head sbs)
42+
43+
{-
44+
instance Uniform Bytes where
45+
uniformM = genBytes 32
46+
-}

‎unordered-containers.cabal‎

Lines changed: 21 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -111,7 +111,7 @@ test-suite unordered-containers-tests
111111
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
112112
cpp-options: -DASSERTS
113113

114-
benchmark benchmarks
114+
benchmark package-comparisons
115115
hs-source-dirs: benchmarks
116116
main-is: Benchmarks.hs
117117
type: exitcode-stdio-1.0
@@ -136,6 +136,26 @@ benchmark benchmarks
136136
ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A32m" -fproc-alignment=64
137137
-- cpp-options: -DBENCH_containers_Map -DBENCH_containers_IntMap -DBENCH_hashmap_Map
138138

139+
benchmark fine-grained
140+
hs-source-dirs: benchmarks
141+
main-is: FineGrained.hs
142+
type: exitcode-stdio-1.0
143+
144+
other-modules:
145+
Key.Bytes
146+
147+
build-depends:
148+
base,
149+
bytestring,
150+
deepseq,
151+
hashable,
152+
random,
153+
tasty-bench,
154+
unordered-containers
155+
156+
default-language: Haskell2010
157+
ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-A512m" -fproc-alignment=64
158+
139159
source-repository head
140160
type: git
141161
location: https://github.com/haskell-unordered-containers/unordered-containers.git

0 commit comments

Comments
 (0)