From 2f95084b538189de257f7498cc64ff1ba79d59ba Mon Sep 17 00:00:00 2001 From: meooow25 Date: Sun, 5 Jan 2025 00:52:07 +0530 Subject: [PATCH 1/8] Benchmarks for compare --- containers-tests/benchmarks/IntMap.hs | 1 + containers-tests/benchmarks/IntSet.hs | 2 ++ 2 files changed, 3 insertions(+) diff --git a/containers-tests/benchmarks/IntMap.hs b/containers-tests/benchmarks/IntMap.hs index b41bd6e75..2ac463acd 100644 --- a/containers-tests/benchmarks/IntMap.hs +++ b/containers-tests/benchmarks/IntMap.hs @@ -53,6 +53,7 @@ main = do , bench "split" $ whnf (M.split key_mid) m , bench "splitLookup" $ whnf (M.splitLookup key_mid) m , bench "eq" $ whnf (\m' -> m' == m') m -- worst case, compares everything + , bench "compare" $ whnf (\m' -> compare m' m') m -- worst case, compares everything , bgroup "folds" $ foldBenchmarks M.foldr M.foldl M.foldr' M.foldl' foldMap m , bgroup "folds with key" $ foldWithKeyBenchmarks M.foldrWithKey M.foldlWithKey M.foldrWithKey' M.foldlWithKey' M.foldMapWithKey m diff --git a/containers-tests/benchmarks/IntSet.hs b/containers-tests/benchmarks/IntSet.hs index 0e9a95d9c..d47680c01 100644 --- a/containers-tests/benchmarks/IntSet.hs +++ b/containers-tests/benchmarks/IntSet.hs @@ -58,6 +58,8 @@ main = do , bench "splitMember:dense" $ whnf (IS.splitMember elem_mid) s , bench "splitMember:sparse" $ whnf (IS.splitMember elem_sparse_mid) s_sparse , bench "eq" $ whnf (\s' -> s' == s') s -- worst case, compares everything + , bench "compare:dense" $ whnf (\s' -> compare s' s') s -- worst case, compares everything + , bench "compare:sparse" $ whnf (\s' -> compare s' s') s_sparse -- worst case, compares everything , bgroup "folds:dense" $ foldBenchmarks IS.foldr IS.foldl IS.foldr' IS.foldl' IS.foldMap s , bgroup "folds:sparse" $ foldBenchmarks IS.foldr IS.foldl IS.foldr' IS.foldl' IS.foldMap s_sparse ] From 7d90d018cbdd31139f091ad2e72251ab3096491e Mon Sep 17 00:00:00 2001 From: meooow25 Date: Sun, 5 Jan 2025 00:52:18 +0530 Subject: [PATCH 2/8] Improve compare for IntSet and IntMap Compare the trees directly instead of converting to lists. The implementation follows broadly the same approach as the previous attempt in commit 7aff529. --- containers-tests/tests/intmap-properties.hs | 6 +- containers/src/Data/IntMap/Internal.hs | 92 ++++++++++++++- containers/src/Data/IntSet/Internal.hs | 109 +++++++++++++++++- .../Data/IntSet/Internal/IntTreeCommons.hs | 9 ++ 4 files changed, 210 insertions(+), 6 deletions(-) diff --git a/containers-tests/tests/intmap-properties.hs b/containers-tests/tests/intmap-properties.hs index 9c3463e15..adb8795aa 100644 --- a/containers-tests/tests/intmap-properties.hs +++ b/containers-tests/tests/intmap-properties.hs @@ -34,7 +34,7 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Test.QuickCheck.Function (apply) -import Test.QuickCheck.Poly (A, B, C) +import Test.QuickCheck.Poly (A, B, C, OrdA) default (Int) @@ -247,6 +247,7 @@ main = defaultMain $ testGroup "intmap-properties" , testProperty "mapAccumRWithKey" prop_mapAccumRWithKey , testProperty "mapKeysWith" prop_mapKeysWith , testProperty "mapKeysMonotonic" prop_mapKeysMonotonic + , testProperty "compare" prop_compare ] {-------------------------------------------------------------------- @@ -1980,3 +1981,6 @@ prop_mapKeysMonotonic (Positive a) b m = fromIntegral (minBound :: Int) <= y && y <= fromIntegral (maxBound :: Int) where y = fromIntegral a * fromIntegral x + fromIntegral b :: Integer + +prop_compare :: IntMap OrdA -> IntMap OrdA -> Property +prop_compare m1 m2 = compare m1 m2 === compare (toList m1) (toList m2) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 9cd613bf5..44b344461 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -308,6 +308,7 @@ import Data.IntSet.Internal.IntTreeCommons , TreeTreeBranch(..) , treeTreeBranch , i2w + , Order(..) ) import Utils.Containers.Internal.BitUtil (shiftLL, shiftRL, iShiftRL) import Utils.Containers.Internal.StrictPair @@ -3487,12 +3488,97 @@ instance Eq1 IntMap where --------------------------------------------------------------------} instance Ord a => Ord (IntMap a) where - compare m1 m2 = compare (toList m1) (toList m2) + compare m1 m2 = liftCmp compare m1 m2 + {-# INLINABLE compare #-} -- | @since 0.5.9 instance Ord1 IntMap where - liftCompare cmp m n = - liftCompare (liftCompare cmp) (toList m) (toList n) + liftCompare = liftCmp + +liftCmp :: (a -> b -> Ordering) -> IntMap a -> IntMap b -> Ordering +liftCmp cmp = go0 + where + go0 t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of + ABL | signBranch p1 -> LT + | otherwise -> case go l1 t2 of + Less -> LT + _ -> GT + ABR | signBranch p1 -> case go r1 t2 of + Less -> LT + _ -> GT + | otherwise -> LT + BAL | signBranch p2 -> GT + | otherwise -> case go t1 l2 of + Greater -> GT + _ -> LT + BAR | signBranch p2 -> case go t1 r2 of + Greater -> GT + _ -> LT + | otherwise -> GT + EQL -> + let !(l1', r1', l2', r2') = if signBranch p1 + then (r1, l1, r2, l2) + else (l1, r1, l2, r2) + in case go l1' l2' of + Less -> LT + Prefix' -> GT + Equals -> case go r1' r2' of + Less -> LT + Prefix' -> LT + Equals -> EQ + FlipPrefix -> GT + Greater -> GT + FlipPrefix -> LT + Greater -> GT + NOM -> compare (unPrefix p1) (unPrefix p2) + go0 (Bin p1 l1 r1) (Tip k2 x2) = + case lookupMinSure (if signBranch p1 then r1 else l1) of + KeyValue k1 x1 -> case compare k1 k2 <> cmp x1 x2 of + EQ -> GT + o -> o + go0 (Tip k1 x1) (Bin p2 l2 r2) = + case lookupMinSure (if signBranch p2 then r2 else l2) of + KeyValue k2 x2 -> case compare k1 k2 <> cmp x1 x2 of + EQ -> LT + o -> o + go0 (Tip k1 x1) (Tip k2 x2) = compare k1 k2 <> cmp x1 x2 + go0 Nil Nil = EQ + go0 Nil _ = LT + go0 _ Nil = GT + + go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of + ABL -> case go l1 t2 of + Prefix' -> Greater + Equals -> FlipPrefix + o -> o + ABR -> Less + BAL -> case go t1 l2 of + Equals -> Prefix' + FlipPrefix -> Less + o -> o + BAR -> Greater + EQL -> case go l1 l2 of + Prefix' -> Greater + Equals -> go r1 r2 + FlipPrefix -> Less + o -> o + NOM -> if unPrefix p1 < unPrefix p2 then Less else Greater + go (Bin _ l1 _) (Tip k2 x2) = case lookupMinSure l1 of + KeyValue k1 x1 -> case compare k1 k2 <> cmp x1 x2 of + LT -> Less + EQ -> FlipPrefix + GT -> Greater + go (Tip k1 x1) (Bin _ l2 _) = case lookupMinSure l2 of + KeyValue k2 x2 -> case compare k1 k2 <> cmp x1 x2 of + LT -> Less + EQ -> Prefix' + GT -> Greater + go (Tip k1 x1) (Tip k2 x2) = case compare k1 k2 <> cmp x1 x2 of + LT -> Less + EQ -> Equals + GT -> Greater + go _ _ = error "liftCmp.go: Nil" +{-# INLINE liftCmp #-} {-------------------------------------------------------------------- Functor diff --git a/containers/src/Data/IntSet/Internal.hs b/containers/src/Data/IntSet/Internal.hs index 21a2897b5..9eb600d84 100644 --- a/containers/src/Data/IntSet/Internal.hs +++ b/containers/src/Data/IntSet/Internal.hs @@ -212,6 +212,7 @@ import Data.IntSet.Internal.IntTreeCommons , TreeTreeBranch(..) , treeTreeBranch , i2w + , Order(..) ) #if __GLASGOW_HASKELL__ @@ -1486,8 +1487,112 @@ equal _ _ = False --------------------------------------------------------------------} instance Ord IntSet where - compare s1 s2 = compare (toAscList s1) (toAscList s2) - -- tentative implementation. See if more efficient exists. + compare = compareIntSets + +compareIntSets :: IntSet -> IntSet -> Ordering +compareIntSets = go0 + where + go0 t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of + ABL | signBranch p1 -> LT + | otherwise -> case go l1 t2 of + Less -> LT + _ -> GT + ABR | signBranch p1 -> case go r1 t2 of + Less -> LT + _ -> GT + | otherwise -> LT + BAL | signBranch p2 -> GT + | otherwise -> case go t1 l2 of + Greater -> GT + _ -> LT + BAR | signBranch p2 -> case go t1 r2 of + Greater -> GT + _ -> LT + | otherwise -> GT + EQL -> + let !(l1', r1', l2', r2') = if signBranch p1 + then (r1, l1, r2, l2) + else (l1, r1, l2, r2) + in case go l1' l2' of + Less -> LT + Prefix' -> GT + Equals -> case go r1' r2' of + Less -> LT + Prefix' -> LT + Equals -> EQ + FlipPrefix -> GT + Greater -> GT + FlipPrefix -> LT + Greater -> GT + NOM -> compare (unPrefix p1) (unPrefix p2) + go0 (Bin p1 l1 r1) (Tip k2 bm2) = + case leftmostTipSure (if signBranch p1 then r1 else l1) of + k1 :*: bm1 -> case orderTips k1 bm1 k2 bm2 of + Less -> LT + _ -> GT + go0 (Tip k1 bm1) (Bin p2 l2 r2) = + case leftmostTipSure (if signBranch p2 then r2 else l2) of + k2 :*: bm2 -> case orderTips k1 bm1 k2 bm2 of + Greater -> GT + _ -> LT + go0 (Tip k1 bm1) (Tip k2 bm2) = case orderTips k1 bm1 k2 bm2 of + Less -> LT + Prefix' -> LT + Equals -> EQ + FlipPrefix -> GT + Greater -> GT + go0 Nil Nil = EQ + go0 Nil _ = LT + go0 _ Nil = GT + + go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of + ABL -> case go l1 t2 of + Prefix' -> Greater + Equals -> FlipPrefix + o -> o + ABR -> Less + BAL -> case go t1 l2 of + Equals -> Prefix' + FlipPrefix -> Less + o -> o + BAR -> Greater + EQL -> case go l1 l2 of + Prefix' -> Greater + Equals -> go r1 r2 + FlipPrefix -> Less + o -> o + NOM -> if unPrefix p1 < unPrefix p2 then Less else Greater + go (Bin _ l1 _) (Tip k2 bm2) = case leftmostTipSure l1 of + k1 :*: bm1 -> case orderTips k1 bm1 k2 bm2 of + Prefix' -> Greater + Equals -> FlipPrefix + o -> o + go (Tip k1 bm1) (Bin _ l2 _) = case leftmostTipSure l2 of + k2 :*: bm2 -> case orderTips k1 bm1 k2 bm2 of + Equals -> Prefix' + FlipPrefix -> Less + o -> o + go (Tip k1 bm1) (Tip k2 bm2) = orderTips k1 bm1 k2 bm2 + go _ _ = error "compareIntSets.go: Nil" + +leftmostTipSure :: IntSet -> StrictPair Int BitMap +leftmostTipSure (Bin _ l _) = leftmostTipSure l +leftmostTipSure (Tip k bm) = k :*: bm +leftmostTipSure Nil = error "leftmostTipSure: Nil" + +orderTips :: Int -> BitMap -> Int -> BitMap -> Order +orderTips k1 bm1 k2 bm2 = case compare k1 k2 of + LT -> Less + EQ | bm1 == bm2 -> Equals + | otherwise -> + let diff = bm1 `xor` bm2 + lowestDiff = diff .&. negate diff + highMask = negate lowestDiff + in if bm1 .&. lowestDiff == 0 + then (if bm1 .&. highMask == 0 then Prefix' else Greater) + else (if bm2 .&. highMask == 0 then FlipPrefix else Less) + GT -> Greater +{-# INLINE orderTips #-} {-------------------------------------------------------------------- Show diff --git a/containers/src/Data/IntSet/Internal/IntTreeCommons.hs b/containers/src/Data/IntSet/Internal/IntTreeCommons.hs index ba3cbb166..d7cbf8c60 100644 --- a/containers/src/Data/IntSet/Internal/IntTreeCommons.hs +++ b/containers/src/Data/IntSet/Internal/IntTreeCommons.hs @@ -36,6 +36,7 @@ module Data.IntSet.Internal.IntTreeCommons , mask , branchMask , i2w + , Order(..) ) where import Data.Bits (Bits(..), countLeadingZeros) @@ -161,6 +162,14 @@ i2w :: Int -> Word i2w = fromIntegral {-# INLINE i2w #-} +-- Used to compare IntSets and IntMaps +data Order + = Less -- holds for [0,3,4] [0,3,5,1] + | Prefix' -- holds for [0,3,4] [0,3,4,5] + | Equals -- holds for [0,3,4] [0,3,4] + | FlipPrefix -- holds for [0,3,4] [0,3] + | Greater -- holds for [0,3,4] [0,2,5] + {-------------------------------------------------------------------- Notes --------------------------------------------------------------------} From 13a1bd33f7e601f500fe59fa04d9ef7e43a713f6 Mon Sep 17 00:00:00 2001 From: meooow25 Date: Thu, 9 Jan 2025 01:23:19 +0530 Subject: [PATCH 3/8] Adopt splitSign Greatly simplifies the top-level code. --- containers/src/Data/IntMap/Internal.hs | 77 +++++++++----------------- containers/src/Data/IntSet/Internal.hs | 74 ++++++++----------------- 2 files changed, 50 insertions(+), 101 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index 44b344461..d5390f3cd 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -3496,56 +3496,19 @@ instance Ord1 IntMap where liftCompare = liftCmp liftCmp :: (a -> b -> Ordering) -> IntMap a -> IntMap b -> Ordering -liftCmp cmp = go0 +liftCmp cmp m1 m2 = case (splitSign m1, splitSign m2) of + ((l1, r1), (l2, r2)) -> case go l1 l2 of + Less -> LT + Prefix' -> if null r1 then LT else GT + Equals -> case go r1 r2 of + Less -> LT + Prefix' -> LT + Equals -> EQ + FlipPrefix -> GT + Greater -> GT + FlipPrefix -> if null r2 then GT else LT + Greater -> GT where - go0 t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of - ABL | signBranch p1 -> LT - | otherwise -> case go l1 t2 of - Less -> LT - _ -> GT - ABR | signBranch p1 -> case go r1 t2 of - Less -> LT - _ -> GT - | otherwise -> LT - BAL | signBranch p2 -> GT - | otherwise -> case go t1 l2 of - Greater -> GT - _ -> LT - BAR | signBranch p2 -> case go t1 r2 of - Greater -> GT - _ -> LT - | otherwise -> GT - EQL -> - let !(l1', r1', l2', r2') = if signBranch p1 - then (r1, l1, r2, l2) - else (l1, r1, l2, r2) - in case go l1' l2' of - Less -> LT - Prefix' -> GT - Equals -> case go r1' r2' of - Less -> LT - Prefix' -> LT - Equals -> EQ - FlipPrefix -> GT - Greater -> GT - FlipPrefix -> LT - Greater -> GT - NOM -> compare (unPrefix p1) (unPrefix p2) - go0 (Bin p1 l1 r1) (Tip k2 x2) = - case lookupMinSure (if signBranch p1 then r1 else l1) of - KeyValue k1 x1 -> case compare k1 k2 <> cmp x1 x2 of - EQ -> GT - o -> o - go0 (Tip k1 x1) (Bin p2 l2 r2) = - case lookupMinSure (if signBranch p2 then r2 else l2) of - KeyValue k2 x2 -> case compare k1 k2 <> cmp x1 x2 of - EQ -> LT - o -> o - go0 (Tip k1 x1) (Tip k2 x2) = compare k1 k2 <> cmp x1 x2 - go0 Nil Nil = EQ - go0 Nil _ = LT - go0 _ Nil = GT - go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of ABL -> case go l1 t2 of Prefix' -> Greater @@ -3577,9 +3540,23 @@ liftCmp cmp = go0 LT -> Less EQ -> Equals GT -> Greater - go _ _ = error "liftCmp.go: Nil" + go Nil Nil = Equals + go Nil _ = Prefix' + go _ Nil = FlipPrefix {-# INLINE liftCmp #-} +-- Split into negative and non-negative +splitSign :: IntMap a -> (IntMap a, IntMap a) +splitSign t@(Bin p l r) + | signBranch p = (r, l) + | unPrefix p < 0 = (t, Nil) + | otherwise = (Nil, t) +splitSign t@(Tip k _) + | k < 0 = (t, Nil) + | otherwise = (Nil, t) +splitSign Nil = (Nil, Nil) +{-# INLINE splitSign #-} + {-------------------------------------------------------------------- Functor --------------------------------------------------------------------} diff --git a/containers/src/Data/IntSet/Internal.hs b/containers/src/Data/IntSet/Internal.hs index 9eb600d84..ce836f27e 100644 --- a/containers/src/Data/IntSet/Internal.hs +++ b/containers/src/Data/IntSet/Internal.hs @@ -1490,61 +1490,19 @@ instance Ord IntSet where compare = compareIntSets compareIntSets :: IntSet -> IntSet -> Ordering -compareIntSets = go0 - where - go0 t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of - ABL | signBranch p1 -> LT - | otherwise -> case go l1 t2 of - Less -> LT - _ -> GT - ABR | signBranch p1 -> case go r1 t2 of - Less -> LT - _ -> GT - | otherwise -> LT - BAL | signBranch p2 -> GT - | otherwise -> case go t1 l2 of - Greater -> GT - _ -> LT - BAR | signBranch p2 -> case go t1 r2 of - Greater -> GT - _ -> LT - | otherwise -> GT - EQL -> - let !(l1', r1', l2', r2') = if signBranch p1 - then (r1, l1, r2, l2) - else (l1, r1, l2, r2) - in case go l1' l2' of - Less -> LT - Prefix' -> GT - Equals -> case go r1' r2' of - Less -> LT - Prefix' -> LT - Equals -> EQ - FlipPrefix -> GT - Greater -> GT - FlipPrefix -> LT - Greater -> GT - NOM -> compare (unPrefix p1) (unPrefix p2) - go0 (Bin p1 l1 r1) (Tip k2 bm2) = - case leftmostTipSure (if signBranch p1 then r1 else l1) of - k1 :*: bm1 -> case orderTips k1 bm1 k2 bm2 of - Less -> LT - _ -> GT - go0 (Tip k1 bm1) (Bin p2 l2 r2) = - case leftmostTipSure (if signBranch p2 then r2 else l2) of - k2 :*: bm2 -> case orderTips k1 bm1 k2 bm2 of - Greater -> GT - _ -> LT - go0 (Tip k1 bm1) (Tip k2 bm2) = case orderTips k1 bm1 k2 bm2 of +compareIntSets s1 s2 = case (splitSign s1, splitSign s2) of + ((l1, r1), (l2, r2)) -> case go l1 l2 of + Less -> LT + Prefix' -> if null r1 then LT else GT + Equals -> case go r1 r2 of Less -> LT Prefix' -> LT Equals -> EQ FlipPrefix -> GT Greater -> GT - go0 Nil Nil = EQ - go0 Nil _ = LT - go0 _ Nil = GT - + FlipPrefix -> if null r2 then GT else LT + Greater -> GT + where go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of ABL -> case go l1 t2 of Prefix' -> Greater @@ -1573,7 +1531,9 @@ compareIntSets = go0 FlipPrefix -> Less o -> o go (Tip k1 bm1) (Tip k2 bm2) = orderTips k1 bm1 k2 bm2 - go _ _ = error "compareIntSets.go: Nil" + go Nil Nil = Equals + go Nil _ = Prefix' + go _ Nil = FlipPrefix leftmostTipSure :: IntSet -> StrictPair Int BitMap leftmostTipSure (Bin _ l _) = leftmostTipSure l @@ -1594,6 +1554,18 @@ orderTips k1 bm1 k2 bm2 = case compare k1 k2 of GT -> Greater {-# INLINE orderTips #-} +-- Split into negative and non-negative +splitSign :: IntSet -> (IntSet, IntSet) +splitSign t@(Bin p l r) + | signBranch p = (r, l) + | unPrefix p < 0 = (t, Nil) + | otherwise = (Nil, t) +splitSign t@(Tip k _) + | k < 0 = (t, Nil) + | otherwise = (Nil, t) +splitSign Nil = (Nil, Nil) +{-# INLINE splitSign #-} + {-------------------------------------------------------------------- Show --------------------------------------------------------------------} From 5b6ee3ada8a23dab748a89b5bde63d63fe9c3e8f Mon Sep 17 00:00:00 2001 From: meooow25 Date: Sat, 18 Jan 2025 11:24:48 +0530 Subject: [PATCH 4/8] Make sure leftmostTipSure returns unboxed values --- containers/src/Data/IntSet/Internal.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/containers/src/Data/IntSet/Internal.hs b/containers/src/Data/IntSet/Internal.hs index ce836f27e..76d41667d 100644 --- a/containers/src/Data/IntSet/Internal.hs +++ b/containers/src/Data/IntSet/Internal.hs @@ -1521,12 +1521,12 @@ compareIntSets s1 s2 = case (splitSign s1, splitSign s2) of o -> o NOM -> if unPrefix p1 < unPrefix p2 then Less else Greater go (Bin _ l1 _) (Tip k2 bm2) = case leftmostTipSure l1 of - k1 :*: bm1 -> case orderTips k1 bm1 k2 bm2 of + Tip' k1 bm1 -> case orderTips k1 bm1 k2 bm2 of Prefix' -> Greater Equals -> FlipPrefix o -> o go (Tip k1 bm1) (Bin _ l2 _) = case leftmostTipSure l2 of - k2 :*: bm2 -> case orderTips k1 bm1 k2 bm2 of + Tip' k2 bm2 -> case orderTips k1 bm1 k2 bm2 of Equals -> Prefix' FlipPrefix -> Less o -> o @@ -1535,9 +1535,15 @@ compareIntSets s1 s2 = case (splitSign s1, splitSign s2) of go Nil _ = Prefix' go _ Nil = FlipPrefix -leftmostTipSure :: IntSet -> StrictPair Int BitMap +-- This type allows GHC to return unboxed ints from leftmostTipSure, as +-- $wleftmostTipSure :: IntSet -> (# Int#, Word# #) +-- On a modern enough GHC (>=9.4) this is unnecessary, we could use StrictPair +-- instead and get the same Core. +data Tip' = Tip' {-# UNPACK #-} !Int {-# UNPACK #-} !BitMap + +leftmostTipSure :: IntSet -> Tip' leftmostTipSure (Bin _ l _) = leftmostTipSure l -leftmostTipSure (Tip k bm) = k :*: bm +leftmostTipSure (Tip k bm) = Tip' k bm leftmostTipSure Nil = error "leftmostTipSure: Nil" orderTips :: Int -> BitMap -> Int -> BitMap -> Order From 6633dd712f1c5f5463b37a36258690f53b26f7d1 Mon Sep 17 00:00:00 2001 From: meooow25 Date: Sat, 18 Jan 2025 11:42:53 +0530 Subject: [PATCH 5/8] Update changelog --- containers/changelog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/containers/changelog.md b/containers/changelog.md index 917bd757d..7aab72cf5 100644 --- a/containers/changelog.md +++ b/containers/changelog.md @@ -70,6 +70,8 @@ including `insert` and `delete`, by inlining part of the balancing routine. (Soumik Sarkar) +* Improved performance for `IntSet` and `IntMap`'s `Ord` instances. + ## Unreleased with `@since` annotation for 0.7.1: ### Additions From a85b6fb6c14fb781544b73637b8aaf590d3c1253 Mon Sep 17 00:00:00 2001 From: meooow25 Date: Thu, 23 Jan 2025 21:04:02 +0530 Subject: [PATCH 6/8] Rename Order constructors --- containers/src/Data/IntMap/Internal.hs | 64 +++++++++---------- containers/src/Data/IntSet/Internal.hs | 64 +++++++++---------- .../Data/IntSet/Internal/IntTreeCommons.hs | 10 +-- 3 files changed, 69 insertions(+), 69 deletions(-) diff --git a/containers/src/Data/IntMap/Internal.hs b/containers/src/Data/IntMap/Internal.hs index d5390f3cd..4c626ff77 100644 --- a/containers/src/Data/IntMap/Internal.hs +++ b/containers/src/Data/IntMap/Internal.hs @@ -3498,51 +3498,51 @@ instance Ord1 IntMap where liftCmp :: (a -> b -> Ordering) -> IntMap a -> IntMap b -> Ordering liftCmp cmp m1 m2 = case (splitSign m1, splitSign m2) of ((l1, r1), (l2, r2)) -> case go l1 l2 of - Less -> LT - Prefix' -> if null r1 then LT else GT - Equals -> case go r1 r2 of - Less -> LT - Prefix' -> LT - Equals -> EQ - FlipPrefix -> GT - Greater -> GT - FlipPrefix -> if null r2 then GT else LT - Greater -> GT + A_LT_B -> LT + A_Prefix_B -> if null r1 then LT else GT + A_EQ_B -> case go r1 r2 of + A_LT_B -> LT + A_Prefix_B -> LT + A_EQ_B -> EQ + B_Prefix_A -> GT + A_GT_B -> GT + B_Prefix_A -> if null r2 then GT else LT + A_GT_B -> GT where go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of ABL -> case go l1 t2 of - Prefix' -> Greater - Equals -> FlipPrefix + A_Prefix_B -> A_GT_B + A_EQ_B -> B_Prefix_A o -> o - ABR -> Less + ABR -> A_LT_B BAL -> case go t1 l2 of - Equals -> Prefix' - FlipPrefix -> Less + A_EQ_B -> A_Prefix_B + B_Prefix_A -> A_LT_B o -> o - BAR -> Greater + BAR -> A_GT_B EQL -> case go l1 l2 of - Prefix' -> Greater - Equals -> go r1 r2 - FlipPrefix -> Less + A_Prefix_B -> A_GT_B + A_EQ_B -> go r1 r2 + B_Prefix_A -> A_LT_B o -> o - NOM -> if unPrefix p1 < unPrefix p2 then Less else Greater + NOM -> if unPrefix p1 < unPrefix p2 then A_LT_B else A_GT_B go (Bin _ l1 _) (Tip k2 x2) = case lookupMinSure l1 of KeyValue k1 x1 -> case compare k1 k2 <> cmp x1 x2 of - LT -> Less - EQ -> FlipPrefix - GT -> Greater + LT -> A_LT_B + EQ -> B_Prefix_A + GT -> A_GT_B go (Tip k1 x1) (Bin _ l2 _) = case lookupMinSure l2 of KeyValue k2 x2 -> case compare k1 k2 <> cmp x1 x2 of - LT -> Less - EQ -> Prefix' - GT -> Greater + LT -> A_LT_B + EQ -> A_Prefix_B + GT -> A_GT_B go (Tip k1 x1) (Tip k2 x2) = case compare k1 k2 <> cmp x1 x2 of - LT -> Less - EQ -> Equals - GT -> Greater - go Nil Nil = Equals - go Nil _ = Prefix' - go _ Nil = FlipPrefix + LT -> A_LT_B + EQ -> A_EQ_B + GT -> A_GT_B + go Nil Nil = A_EQ_B + go Nil _ = A_Prefix_B + go _ Nil = B_Prefix_A {-# INLINE liftCmp #-} -- Split into negative and non-negative diff --git a/containers/src/Data/IntSet/Internal.hs b/containers/src/Data/IntSet/Internal.hs index 76d41667d..14d35b1ae 100644 --- a/containers/src/Data/IntSet/Internal.hs +++ b/containers/src/Data/IntSet/Internal.hs @@ -1492,48 +1492,48 @@ instance Ord IntSet where compareIntSets :: IntSet -> IntSet -> Ordering compareIntSets s1 s2 = case (splitSign s1, splitSign s2) of ((l1, r1), (l2, r2)) -> case go l1 l2 of - Less -> LT - Prefix' -> if null r1 then LT else GT - Equals -> case go r1 r2 of - Less -> LT - Prefix' -> LT - Equals -> EQ - FlipPrefix -> GT - Greater -> GT - FlipPrefix -> if null r2 then GT else LT - Greater -> GT + A_LT_B -> LT + A_Prefix_B -> if null r1 then LT else GT + A_EQ_B -> case go r1 r2 of + A_LT_B -> LT + A_Prefix_B -> LT + A_EQ_B -> EQ + B_Prefix_A -> GT + A_GT_B -> GT + B_Prefix_A -> if null r2 then GT else LT + A_GT_B -> GT where go t1@(Bin p1 l1 r1) t2@(Bin p2 l2 r2) = case treeTreeBranch p1 p2 of ABL -> case go l1 t2 of - Prefix' -> Greater - Equals -> FlipPrefix + A_Prefix_B -> A_GT_B + A_EQ_B -> B_Prefix_A o -> o - ABR -> Less + ABR -> A_LT_B BAL -> case go t1 l2 of - Equals -> Prefix' - FlipPrefix -> Less + A_EQ_B -> A_Prefix_B + B_Prefix_A -> A_LT_B o -> o - BAR -> Greater + BAR -> A_GT_B EQL -> case go l1 l2 of - Prefix' -> Greater - Equals -> go r1 r2 - FlipPrefix -> Less + A_Prefix_B -> A_GT_B + A_EQ_B -> go r1 r2 + B_Prefix_A -> A_LT_B o -> o - NOM -> if unPrefix p1 < unPrefix p2 then Less else Greater + NOM -> if unPrefix p1 < unPrefix p2 then A_LT_B else A_GT_B go (Bin _ l1 _) (Tip k2 bm2) = case leftmostTipSure l1 of Tip' k1 bm1 -> case orderTips k1 bm1 k2 bm2 of - Prefix' -> Greater - Equals -> FlipPrefix + A_Prefix_B -> A_GT_B + A_EQ_B -> B_Prefix_A o -> o go (Tip k1 bm1) (Bin _ l2 _) = case leftmostTipSure l2 of Tip' k2 bm2 -> case orderTips k1 bm1 k2 bm2 of - Equals -> Prefix' - FlipPrefix -> Less + A_EQ_B -> A_Prefix_B + B_Prefix_A -> A_LT_B o -> o go (Tip k1 bm1) (Tip k2 bm2) = orderTips k1 bm1 k2 bm2 - go Nil Nil = Equals - go Nil _ = Prefix' - go _ Nil = FlipPrefix + go Nil Nil = A_EQ_B + go Nil _ = A_Prefix_B + go _ Nil = B_Prefix_A -- This type allows GHC to return unboxed ints from leftmostTipSure, as -- $wleftmostTipSure :: IntSet -> (# Int#, Word# #) @@ -1548,16 +1548,16 @@ leftmostTipSure Nil = error "leftmostTipSure: Nil" orderTips :: Int -> BitMap -> Int -> BitMap -> Order orderTips k1 bm1 k2 bm2 = case compare k1 k2 of - LT -> Less - EQ | bm1 == bm2 -> Equals + LT -> A_LT_B + EQ | bm1 == bm2 -> A_EQ_B | otherwise -> let diff = bm1 `xor` bm2 lowestDiff = diff .&. negate diff highMask = negate lowestDiff in if bm1 .&. lowestDiff == 0 - then (if bm1 .&. highMask == 0 then Prefix' else Greater) - else (if bm2 .&. highMask == 0 then FlipPrefix else Less) - GT -> Greater + then (if bm1 .&. highMask == 0 then A_Prefix_B else A_GT_B) + else (if bm2 .&. highMask == 0 then B_Prefix_A else A_LT_B) + GT -> A_GT_B {-# INLINE orderTips #-} -- Split into negative and non-negative diff --git a/containers/src/Data/IntSet/Internal/IntTreeCommons.hs b/containers/src/Data/IntSet/Internal/IntTreeCommons.hs index d7cbf8c60..d361ac4c5 100644 --- a/containers/src/Data/IntSet/Internal/IntTreeCommons.hs +++ b/containers/src/Data/IntSet/Internal/IntTreeCommons.hs @@ -164,11 +164,11 @@ i2w = fromIntegral -- Used to compare IntSets and IntMaps data Order - = Less -- holds for [0,3,4] [0,3,5,1] - | Prefix' -- holds for [0,3,4] [0,3,4,5] - | Equals -- holds for [0,3,4] [0,3,4] - | FlipPrefix -- holds for [0,3,4] [0,3] - | Greater -- holds for [0,3,4] [0,2,5] + = A_LT_B -- holds for [0,3,4] [0,3,5,1] + | A_Prefix_B -- holds for [0,3,4] [0,3,4,5] + | A_EQ_B -- holds for [0,3,4] [0,3,4] + | B_Prefix_A -- holds for [0,3,4] [0,3] + | A_GT_B -- holds for [0,3,4] [0,2,5] {-------------------------------------------------------------------- Notes From 030fb5ee8b73c6c37f67047fd53bfcf9b430017f Mon Sep 17 00:00:00 2001 From: meooow25 Date: Thu, 23 Jan 2025 21:18:28 +0530 Subject: [PATCH 7/8] Comment on orderTip internals --- containers/src/Data/IntSet/Internal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/containers/src/Data/IntSet/Internal.hs b/containers/src/Data/IntSet/Internal.hs index 14d35b1ae..d31a28162 100644 --- a/containers/src/Data/IntSet/Internal.hs +++ b/containers/src/Data/IntSet/Internal.hs @@ -1551,6 +1551,10 @@ orderTips k1 bm1 k2 bm2 = case compare k1 k2 of LT -> A_LT_B EQ | bm1 == bm2 -> A_EQ_B | otherwise -> + -- To lexicographically compare the elements of two BitMaps, + -- * Find the lowest bit where they differ. + -- * For the BitMap with this bit 0, check if all higher bits are also + -- 0. If yes it is a prefix, otherwise it is greater. let diff = bm1 `xor` bm2 lowestDiff = diff .&. negate diff highMask = negate lowestDiff From c9eb5b7613e579f7fe8f0195679b9d3f65a23f55 Mon Sep 17 00:00:00 2001 From: meooow25 Date: Thu, 23 Jan 2025 21:48:38 +0530 Subject: [PATCH 8/8] Work around pre-9.0 Haddock misbehaving --- containers/src/Data/IntSet/Internal.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/containers/src/Data/IntSet/Internal.hs b/containers/src/Data/IntSet/Internal.hs index d31a28162..6741ef138 100644 --- a/containers/src/Data/IntSet/Internal.hs +++ b/containers/src/Data/IntSet/Internal.hs @@ -1552,8 +1552,8 @@ orderTips k1 bm1 k2 bm2 = case compare k1 k2 of EQ | bm1 == bm2 -> A_EQ_B | otherwise -> -- To lexicographically compare the elements of two BitMaps, - -- * Find the lowest bit where they differ. - -- * For the BitMap with this bit 0, check if all higher bits are also + -- - Find the lowest bit where they differ. + -- - For the BitMap with this bit 0, check if all higher bits are also -- 0. If yes it is a prefix, otherwise it is greater. let diff = bm1 `xor` bm2 lowestDiff = diff .&. negate diff