From c07029d605bf0a9f146c72f30d86259e8adc80a7 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Thu, 13 Nov 2025 15:38:09 +0100 Subject: [PATCH 1/2] Introduce 'hashOfLeafOrCollision' Core size reduction with GHC 9.12.2: * Lazy.unionWithKey: 2256 terms -> 1286 * Strict.unionWithKey: 2101 terms -> 1167 * union @Int in fine-grained: 1245 terms -> 1134 --- Data/HashMap/Internal.hs | 26 ++++++++++++++++++-------- Data/HashMap/Internal/Strict.hs | 12 ++++-------- 2 files changed, 22 insertions(+), 16 deletions(-) diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs index 13d3d0f5..cbbf0ba9 100644 --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -146,6 +146,7 @@ module Data.HashMap.Internal , deleteKeyExists , insertModifying , ptrEq + , hashOfLeafOrCollision , adjust# ) where @@ -1625,7 +1626,7 @@ unionWithKey f = go 0 go (nextShift s) st1 t2 in BitmapIndexed b1 ary' where - h2 = leafHashCode t2 + h2 = hashOfLeafOrCollision t2 m2 = mask h2 s i = sparseIndex b1 m2 go s t1 (BitmapIndexed b2 ary2) @@ -1636,24 +1637,20 @@ unionWithKey f = go 0 go (nextShift s) t1 st2 in BitmapIndexed b2 ary' where - h1 = leafHashCode t1 + h1 = hashOfLeafOrCollision t1 m1 = mask h1 s i = sparseIndex b2 m1 go s (Full ary1) t2 = - let h2 = leafHashCode t2 + let h2 = hashOfLeafOrCollision t2 i = index h2 s ary' = updateFullArrayWith' ary1 i $ \st1 -> go (nextShift s) st1 t2 in Full ary' go s t1 (Full ary2) = - let h1 = leafHashCode t1 + let h1 = hashOfLeafOrCollision t1 i = index h1 s ary' = updateFullArrayWith' ary2 i $ \st2 -> go (nextShift s) t1 st2 in Full ary' - leafHashCode (Leaf h _) = h - leafHashCode (Collision h _) = h - leafHashCode _ = error "leafHashCode" - goDifferentHash s h1 h2 t1 t2 | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (nextShift s) h1 h2 t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) @@ -2841,6 +2838,19 @@ otherOfOneOrZero :: Int -> Int otherOfOneOrZero i = 1 - i {-# INLINE otherOfOneOrZero #-} +------------------------------------------------------------------------ +-- Tools for reducing duplication in code handling 'Leaf' and 'Collision' nodes + +-- | The 'Hash' of a 'Leaf' or 'Collision' node. +-- +-- This function is marked @NOINLINE@ to prevent GHC from generating separate +-- alternatives for 'Leaf' and 'Collision' nodes. +hashOfLeafOrCollision :: HashMap k v -> Hash +hashOfLeafOrCollision (Leaf h _) = h +hashOfLeafOrCollision (Collision h _) = h +hashOfLeafOrCollision _ = error "hashOfLeafOrCollision" +{-# NOINLINE hashOfLeafOrCollision #-} + ------------------------------------------------------------------------ -- IsList instance instance (Eq k, Hashable k) => Exts.IsList (HashMap k v) where diff --git a/Data/HashMap/Internal/Strict.hs b/Data/HashMap/Internal/Strict.hs index 42caac16..f0c0d928 100644 --- a/Data/HashMap/Internal/Strict.hs +++ b/Data/HashMap/Internal/Strict.hs @@ -505,7 +505,7 @@ unionWithKey f = go 0 go (nextShift s) st1 t2 in BitmapIndexed b1 ary' where - h2 = leafHashCode t2 + h2 = HM.hashOfLeafOrCollision t2 m2 = mask h2 s i = sparseIndex b1 m2 go s t1 (BitmapIndexed b2 ary2) @@ -516,24 +516,20 @@ unionWithKey f = go 0 go (nextShift s) t1 st2 in BitmapIndexed b2 ary' where - h1 = leafHashCode t1 + h1 = HM.hashOfLeafOrCollision t1 m1 = mask h1 s i = sparseIndex b2 m1 go s (Full ary1) t2 = - let h2 = leafHashCode t2 + let h2 = HM.hashOfLeafOrCollision t2 i = index h2 s ary' = HM.updateFullArrayWith' ary1 i $ \st1 -> go (nextShift s) st1 t2 in Full ary' go s t1 (Full ary2) = - let h1 = leafHashCode t1 + let h1 = HM.hashOfLeafOrCollision t1 i = index h1 s ary' = HM.updateFullArrayWith' ary2 i $ \st2 -> go (nextShift s) t1 st2 in Full ary' - leafHashCode (Leaf h _) = h - leafHashCode (Collision h _) = h - leafHashCode _ = error "leafHashCode" - goDifferentHash s h1 h2 t1 t2 | m1 == m2 = BitmapIndexed m1 (A.singleton $! goDifferentHash (nextShift s) h1 h2 t1 t2) | m1 < m2 = BitmapIndexed (m1 .|. m2) (A.pair t1 t2) From fb7c3d09e2a10fcfdd0f85fd63c9dbc3c6419adb Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Thu, 13 Nov 2025 16:52:48 +0100 Subject: [PATCH 2/2] differenceWithKey: Use hashOfLeafOrCollision --- Data/HashMap/Internal.hs | 74 ++++++++++++++-------------------------- 1 file changed, 25 insertions(+), 49 deletions(-) diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs index cbbf0ba9..7d7d6b5f 100644 --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -1939,7 +1939,26 @@ differenceWithKey f = go_differenceWithKey 0 go_differenceWithKey _s a@(Collision hA aryA) (Leaf hB (L kB vB)) | hA == hB = updateCollision (\vA -> f kB vA vB) hA kB aryA a | otherwise = a - go_differenceWithKey s a@(BitmapIndexed bA aryA) b@(Leaf hB _) + go_differenceWithKey s a@(Collision hA _) (BitmapIndexed bB aryB) + | bB .&. m == 0 = a + | otherwise = + case A.index# aryB (sparseIndex bB m) of + (# stB #) -> go_differenceWithKey (nextShift s) a stB + where m = mask hA s + go_differenceWithKey s a@(Collision hA _) (Full aryB) + = case A.index# aryB (index hA s) of + (# stB #) -> go_differenceWithKey (nextShift s) a stB + go_differenceWithKey s a@(BitmapIndexed bA aryA) (BitmapIndexed bB aryB) + = differenceWithKey_Arrays s bA aryA a bB aryB + go_differenceWithKey s a@(Full aryA) (BitmapIndexed bB aryB) + = differenceWithKey_Arrays s fullBitmap aryA a bB aryB + go_differenceWithKey s a@(BitmapIndexed bA aryA) (Full aryB) + = differenceWithKey_Arrays s bA aryA a fullBitmap aryB + go_differenceWithKey s a@(Full aryA) (Full aryB) + = differenceWithKey_Arrays s fullBitmap aryA a fullBitmap aryB + go_differenceWithKey _s a@(Collision hA aryA) (Collision hB aryB) + = differenceWithKey_Collisions f hA aryA a hB aryB + go_differenceWithKey s a@(BitmapIndexed bA aryA) b | bA .&. m == 0 = a | otherwise = case A.index# aryA i of (# !stA #) -> case go_differenceWithKey (nextShift s) stA b of @@ -1953,36 +1972,10 @@ differenceWithKey f = go_differenceWithKey 0 | stA `ptrEq` stA' -> a | otherwise -> BitmapIndexed bA (A.update aryA i stA') where + hB = hashOfLeafOrCollision b m = mask hB s i = sparseIndex bA m - go_differenceWithKey s a@(BitmapIndexed bA aryA) b@(Collision hB _) - | bA .&. m == 0 = a - | otherwise = - case A.index# aryA i of - (# !st #) -> case go_differenceWithKey (nextShift s) st b of - Empty | A.length aryA == 2 - , (# l #) <- A.index# aryA (otherOfOneOrZero i) - , isLeafOrCollision l - -> l - | otherwise - -> BitmapIndexed (bA .&. complement m) (A.delete aryA i) - st' | isLeafOrCollision st' && A.length aryA == 1 -> st' - | st `ptrEq` st' -> a - | otherwise -> BitmapIndexed bA (A.update aryA i st') - where - m = mask hB s - i = sparseIndex bA m - go_differenceWithKey s a@(Full aryA) b@(Leaf hB _) - = case A.index# aryA i of - (# !stA #) -> case go_differenceWithKey (nextShift s) stA b of - Empty -> - let aryA' = A.delete aryA i - bm = fullBitmap .&. complement (1 `unsafeShiftL` i) - in BitmapIndexed bm aryA' - stA' | stA `ptrEq` stA' -> a - | otherwise -> Full (updateFullArray aryA i stA') - where i = index hB s - go_differenceWithKey s a@(Full aryA) b@(Collision hB _) + go_differenceWithKey s a@(Full aryA) b = case A.index# aryA i of (# !stA #) -> case go_differenceWithKey (nextShift s) stA b of Empty -> @@ -1991,26 +1984,9 @@ differenceWithKey f = go_differenceWithKey 0 in BitmapIndexed bm aryA' stA' | stA `ptrEq` stA' -> a | otherwise -> Full (updateFullArray aryA i stA') - where i = index hB s - go_differenceWithKey s a@(Collision hA _) (BitmapIndexed bB aryB) - | bB .&. m == 0 = a - | otherwise = - case A.index# aryB (sparseIndex bB m) of - (# stB #) -> go_differenceWithKey (nextShift s) a stB - where m = mask hA s - go_differenceWithKey s a@(Collision hA _) (Full aryB) - = case A.index# aryB (index hA s) of - (# stB #) -> go_differenceWithKey (nextShift s) a stB - go_differenceWithKey s a@(BitmapIndexed bA aryA) (BitmapIndexed bB aryB) - = differenceWithKey_Arrays s bA aryA a bB aryB - go_differenceWithKey s a@(Full aryA) (BitmapIndexed bB aryB) - = differenceWithKey_Arrays s fullBitmap aryA a bB aryB - go_differenceWithKey s a@(BitmapIndexed bA aryA) (Full aryB) - = differenceWithKey_Arrays s bA aryA a fullBitmap aryB - go_differenceWithKey s a@(Full aryA) (Full aryB) - = differenceWithKey_Arrays s fullBitmap aryA a fullBitmap aryB - go_differenceWithKey _s a@(Collision hA aryA) (Collision hB aryB) - = differenceWithKey_Collisions f hA aryA a hB aryB + where + hB = hashOfLeafOrCollision b + i = index hB s differenceWithKey_Arrays !s !bA !aryA tA !bB !aryB | bA .&. bB == 0 = tA