Skip to content

Improve fine-grained benchmarks #547

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
Nov 12, 2025
Merged

Improve fine-grained benchmarks #547

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
c59897e
fine-grained: 1000 repetitions for fast ops
sjakobi Nov 10, 2025
20d2605
Add benchmarks for `update` and `alter`
sjakobi Nov 10, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
175 changes: 145 additions & 30 deletions benchmarks/FineGrained.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
-- | This file is formatted with https://hackage.haskell.org/package/ormolu

-- This file is formatted with https://hackage.haskell.org/package/ormolu
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NumericUnderscores #-}
Expand Down Expand Up @@ -30,6 +29,8 @@ main =
[ bFromList,
bLookup,
bInsert,
bUpdate,
bAlter,
bDelete,
bUnion,
bUnions,
Expand Down Expand Up @@ -66,11 +67,11 @@ bFromList =
setupBytes s gen = genNBytes s bytesLength gen
b s = bench (show s) . whnf (HM.fromList . map (,()))

-- 100 lookups each, so we get more precise timings
-- 1000 lookups each, so we get more precise timings
bLookup :: Benchmark
bLookup =
bgroup
"lookup"
"lookup (1000x)"
[ bgroup "presentKey" bLookupPresentKey,
bgroup "absentKey" bLookupAbsentKey
]
Expand All @@ -85,7 +86,7 @@ bLookupPresentKey =
b s =
bench (show s)
. whnf (\(m, ks) -> foldl' (\() k -> HM.lookup k m `seq` ()) () ks)
toKs = take 100 . Data.List.cycle . HM.keys
toKs = take 1000 . Data.List.cycle . HM.keys
setupBytes size gen = do
m <- genBytesMap size gen
return (m, toKs m)
Expand All @@ -104,20 +105,20 @@ bLookupAbsentKey =
. whnf (\(m, ks) -> foldl' (\() k -> HM.lookup k m `seq` ()) () ks)
setupBytes size gen = do
m <- genBytesMap size gen
ks0 <- genNBytes 200 bytesLength gen
let ks1 = take 100 $ Data.List.cycle $ filter (not . flip HM.member m) ks0
ks0 <- genNBytes 2000 bytesLength gen
let ks1 = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks0
return (m, ks1)
setupInts size gen = do
m <- genIntMap size gen
ks0 <- genInts 200 gen
let ks1 = take 100 $ Data.List.cycle $ filter (not . flip HM.member m) ks0
ks0 <- genInts 2000 gen
let ks1 = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks0
return (m, ks1)

-- 100 insertions each, so we get more precise timings
-- 1000 insertions each, so we get more precise timings
bInsert :: Benchmark
bInsert =
bgroup
"insert"
"insert (1000x)"
[ bgroup
"presentKey"
[ bgroup "sameValue" bInsertPresentKeySameValue,
Expand All @@ -136,7 +137,7 @@ bInsertPresentKeySameValue =
b s =
bench (show s)
. whnf (\(m, kvs) -> foldl' (\() (k, v) -> HM.insert k v m `seq` ()) () kvs)
toKVs = take 100 . Data.List.cycle . HM.toList
toKVs = take 1000 . Data.List.cycle . HM.toList
setupBytes size gen = do
m <- genBytesMap size gen
return (m, toKVs m)
Expand All @@ -154,7 +155,7 @@ bInsertPresentKeyDifferentValue =
b s =
bench (show s)
. whnf (\(m, kvs) -> foldl' (\() (k, v) -> HM.insert k v m `seq` ()) () kvs)
toKVs = take 100 . Data.List.cycle . map (second (+ 1)) . HM.toList
toKVs = take 1000 . Data.List.cycle . map (second (+ 1)) . HM.toList
setupBytes size gen = do
m <- genBytesMap size gen
return (m, toKVs m)
Expand All @@ -173,20 +174,129 @@ bInsertAbsentKey =
. whnf (\(m, kvs) -> foldl' (\() (k, v) -> HM.insert k v m `seq` ()) () kvs)
setupBytes size gen = do
m <- genBytesMap size gen
ks <- genNBytes 200 bytesLength gen
let kvs = take 100 $ Data.List.cycle $ map (,1) $ filter (not . flip HM.member m) ks
ks <- genNBytes 2000 bytesLength gen
let kvs = take 1000 $ Data.List.cycle $ map (,1) $ filter (not . flip HM.member m) ks
return (m, kvs)
setupInts size gen = do
m <- genIntMap size gen
ks <- genInts 200 gen
let kvs = take 100 $ Data.List.cycle $ map (,1) $ filter (not . flip HM.member m) ks
ks <- genInts 2000 gen
let kvs = take 1000 $ Data.List.cycle $ map (,1) $ filter (not . flip HM.member m) ks
return (m, kvs)

-- 100 deletions each, so we get more precise timings
bUpdate :: Benchmark
bUpdate =
bgroup
"update (1000x)"
[ bgroup "presentKey" bUpdatePresentKey,
bgroup "absentKey" bUpdateAbsentKey
]

updateF :: Int -> Maybe Int
updateF x
| intPredicate x = Nothing
| x `mod` 3 == 0 = Just (x + 1)
| otherwise = Just x

bUpdateAbsentKey :: [Benchmark]
bUpdateAbsentKey =
[ bgroup' "Bytes" setupBytes b,
bgroup' "Int" setupInts b
]
where
b s =
bench (show s)
. whnf (\(m, ks) -> foldl' (\() k -> HM.update updateF k m `seq` ()) () ks)
setupBytes size gen = do
m <- genBytesMap size gen
ks <- genNBytes 2000 bytesLength gen
let ks' = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks
return (m, ks')
setupInts size gen = do
m <- genIntMap size gen
ks <- genInts 2000 gen
let ks' = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks
return (m, ks')

bUpdatePresentKey :: [Benchmark]
bUpdatePresentKey =
[ bgroup'WithSizes sizes "Bytes" setupBytes b,
bgroup'WithSizes sizes "Int" setupInts b
]
where
sizes = filter (/= 0) defaultSizes
b s =
bench (show s)
. whnf (\(m, ks) -> foldl' (\() k -> HM.update updateF k m `seq` ()) () ks)
toKs = take 1000 . Data.List.cycle . HM.keys
setupBytes size gen = do
m <- genBytesMap size gen
return (m, toKs m)
setupInts size gen = do
m <- genIntMap size gen
return (m, toKs m)

bAlter :: Benchmark
bAlter =
bgroup
"alter (1000x)"
[ bgroup "presentKey" bAlterPresentKey,
bgroup "absentKey" bAlterAbsentKey
]

alterF' :: (Hashable k) => k -> Maybe Int -> Maybe Int
alterF' k Nothing
| intPredicate (hash k) = Nothing
| otherwise = Just (hash k)
alterF' k (Just v)
| odd n = Nothing
| intPredicate n = Just (n + 1)
| otherwise = Just v
where
n = hash k + v

bAlterAbsentKey :: [Benchmark]
bAlterAbsentKey =
[ bgroup' "Bytes" setupBytes b,
bgroup' "Int" setupInts b
]
where
b s =
bench (show s)
. whnf (\(m, ks) -> foldl' (\() k -> HM.alter (alterF' k) k m `seq` ()) () ks)
setupBytes size gen = do
m <- genBytesMap size gen
ks <- genNBytes 2000 bytesLength gen
let ks' = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks
return (m, ks')
setupInts size gen = do
m <- genIntMap size gen
ks <- genInts 2000 gen
let ks' = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks
return (m, ks')

bAlterPresentKey :: [Benchmark]
bAlterPresentKey =
[ bgroup'WithSizes sizes "Bytes" setupBytes b,
bgroup'WithSizes sizes "Int" setupInts b
]
where
sizes = filter (/= 0) defaultSizes
b s =
bench (show s)
. whnf (\(m, ks) -> foldl' (\() k -> HM.alter (alterF' k) k m `seq` ()) () ks)
toKs = take 1000 . Data.List.cycle . HM.keys
setupBytes size gen = do
m <- genBytesMap size gen
return (m, toKs m)
setupInts size gen = do
m <- genIntMap size gen
return (m, toKs m)

-- 1000 deletions each, so we get more precise timings
bDelete :: Benchmark
bDelete =
bgroup
"delete"
"delete (1000x)"
[ bgroup "presentKey" bDeletePresentKey,
bgroup "absentKey" bDeleteAbsentKey
]
Expand All @@ -201,7 +311,7 @@ bDeletePresentKey =
b s =
bench (show s)
. whnf (\(m, ks) -> foldl' (\() k -> HM.delete k m `seq` ()) () ks)
toKs = take 100 . Data.List.cycle . HM.keys
toKs = take 1000 . Data.List.cycle . HM.keys
setupBytes size gen = do
m <- genBytesMap size gen
return (m, toKs m)
Expand All @@ -220,13 +330,13 @@ bDeleteAbsentKey =
. whnf (\(m, ks) -> foldl' (\() k -> HM.delete k m `seq` ()) () ks)
setupBytes size gen = do
m <- genBytesMap size gen
ks0 <- genNBytes 200 bytesLength gen
let ks1 = take 100 $ Data.List.cycle $ filter (not . flip HM.member m) ks0
ks0 <- genNBytes 2000 bytesLength gen
let ks1 = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks0
return (m, ks1)
setupInts size gen = do
m <- genIntMap size gen
ks0 <- genInts 200 gen
let ks1 = take 100 $ Data.List.cycle $ filter (not . flip HM.member m) ks0
ks0 <- genInts 2000 gen
let ks1 = take 1000 $ Data.List.cycle $ filter (not . flip HM.member m) ks0
return (m, ks1)

-- TODO: For the "overlap" and "equal" cases, it would be interesting to
Expand Down Expand Up @@ -266,10 +376,12 @@ bUnionEqual =
b size = bench (show size) . whnf (\m -> HM.union m m)

bUnions :: Benchmark
bUnions = bgroup "unions"
[ bgroup'WithSizes sizes "Bytes" setupBytes b,
bgroup'WithSizes sizes "Int" setupInts b
]
bUnions =
bgroup
"unions"
[ bgroup'WithSizes sizes "Bytes" setupBytes b,
bgroup'WithSizes sizes "Int" setupInts b
]
where
sizes = filter (>= 10) defaultSizes
b size = bench (show size) . whnf (\ms -> HM.unions ms)
Expand Down Expand Up @@ -432,7 +544,7 @@ env' setup b size =
-- Generators

keysToMap :: (Hashable k) => [k] -> HashMap k Int
keysToMap = HM.fromList . map (,1)
keysToMap = HM.fromList . map (\k -> (k, hashWithSalt 123 k))

genInts ::
(StatefulGen g m) =>
Expand Down Expand Up @@ -482,7 +594,7 @@ genIntMapsDisjoint ::
Int -> g -> m (HashMap Int Int, HashMap Int Int)
genIntMapsDisjoint s gen = do
ints <- genInts s gen
let (trues, falses) = Data.List.partition (flip testBit (31 :: Int)) ints
let (trues, falses) = Data.List.partition intPredicate ints
return (keysToMap trues, keysToMap falses)

genBytesMapsDisjoint ::
Expand All @@ -491,3 +603,6 @@ genBytesMapsDisjoint ::
genBytesMapsDisjoint s gen = do
(trues, falses) <- Key.Bytes.genDisjoint s bytesLength gen
return (keysToMap trues, keysToMap falses)

intPredicate :: Int -> Bool
intPredicate n = testBit n 31