unordered-containers 0.2.17.0 → 0.2.18.0
raw patch · 9 files changed
+347/−157 lines, 9 filesdep +nothunksPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: nothunks
API changes (from Hackage documentation)
- Data.HashMap.Internal: updateOrConcatWith :: Eq k => (v -> v -> v) -> Array (Leaf k v) -> Array (Leaf k v) -> Array (Leaf k v)
- Data.HashMap.Internal: updateOrConcatWithKey :: Eq k => (k -> v -> v -> v) -> Array (Leaf k v) -> Array (Leaf k v) -> Array (Leaf k v)
+ Data.HashMap.Internal: updateOrConcatWithKey :: Eq k => (k -> v -> v -> (# v #)) -> Array (Leaf k v) -> Array (Leaf k v) -> Array (Leaf k v)
Files
- CHANGES.md +21/−0
- Data/HashMap/Internal.hs +63/−63
- Data/HashMap/Internal/Array.hs +12/−8
- Data/HashMap/Internal/Strict.hs +92/−80
- Data/HashSet/Internal.hs +2/−3
- benchmarks/Benchmarks.hs +4/−1
- tests/Regressions.hs +142/−0
- tests/Strictness.hs +1/−1
- unordered-containers.cabal +10/−1
CHANGES.md view
@@ -1,3 +1,24 @@+## [0.2.18.0]++* [Fix strictness properties of `Strict.mapMaybe[WithKey]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/385)++* [Fix strictness properties of `Strict.alterFEager`](https://github.com/haskell-unordered-containers/unordered-containers/pull/384)++* [Fix space leaks in `union[With[Key]]`](https://github.com/haskell-unordered-containers/unordered-containers/pull/380)++* [Fix space leak in `Lazy.fromListWith`](https://github.com/haskell-unordered-containers/unordered-containers/pull/386)++* [Speed up `difference*` and `intersection*` with `unsafeInsert`](https://github.com/haskell-unordered-containers/unordered-containers/pull/372)++* [`unionArrayBy`: Find next 1-bits with `countTrailingZeros`](https://github.com/haskell-unordered-containers/unordered-containers/pull/395)+ - This speeds up `union*` for sparsely filled nodes, while penalizing `union` operations on densely filled nodes.++* [Reduce reboxing in internal array operations](https://github.com/haskell-unordered-containers/unordered-containers/pull/377)++* [Reduce code size of array operations in `union*`](https://github.com/haskell-unordered-containers/unordered-containers/pull/376)++[0.2.18.0]: https://github.com/haskell-unordered-containers/unordered-containers/compare/v0.2.17.0...v0.2.18.0+ ## [0.2.17.0] * [Define `dataCast1` for `HashMap`](https://github.com/haskell-unordered-containers/unordered-containers/pull/345)
Data/HashMap/Internal.hs view
@@ -122,7 +122,6 @@ , update32 , update32M , update32With'- , updateOrConcatWith , updateOrConcatWithKey , filterMapAux , equalKeys@@ -145,7 +144,7 @@ import Control.Monad.ST (ST, runST) import Data.Bifoldable (Bifoldable (..)) import Data.Bits (complement, popCount, unsafeShiftL,- unsafeShiftR, (.&.), (.|.))+ unsafeShiftR, (.&.), (.|.), countTrailingZeros) import Data.Coerce (coerce) import Data.Data (Constr, Data (..), DataType) import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..),@@ -194,7 +193,7 @@ -- | @since 0.2.14.0 instance NFData k => NFData1 (Leaf k) where- liftRnf rnf2 = liftRnf2 rnf rnf2+ liftRnf = liftRnf2 rnf -- | @since 0.2.14.0 instance NFData2 Leaf where@@ -226,7 +225,7 @@ -- | @since 0.2.14.0 instance NFData k => NFData1 (HashMap k) where- liftRnf rnf2 = liftRnf2 rnf rnf2+ liftRnf = liftRnf2 rnf -- | @since 0.2.14.0 instance NFData2 HashMap where@@ -334,8 +333,7 @@ instance (Eq k, Hashable k, Read k, Read e) => Read (HashMap k e) where readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP- xs <- readPrec- return (fromList xs)+ fromList <$> readPrec readListPrec = readListPrecDefault @@ -395,7 +393,7 @@ equal2 :: (k -> k' -> Bool) -> (v -> v' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool-equal2 eqk eqv t1 t2 = go (toList' t1 []) (toList' t2 [])+equal2 eqk eqv t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 []) where -- If the two trees are the same, then their lists of 'Leaf's and -- 'Collision's read from left to right should be the same (modulo the@@ -429,7 +427,7 @@ cmp :: (k -> k' -> Ordering) -> (v -> v' -> Ordering) -> HashMap k v -> HashMap k' v' -> Ordering-cmp cmpk cmpv t1 t2 = go (toList' t1 []) (toList' t2 [])+cmp cmpk cmpv t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 []) where go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) = compare k1 k2 `mappend`@@ -445,13 +443,13 @@ go [] [] = EQ go [] _ = LT go _ [] = GT- go _ _ = error "cmp: Should never happen, toList' includes non Leaf / Collision"+ go _ _ = error "cmp: Should never happen, leavesAndCollisions includes non Leaf / Collision" leafCompare (L k v) (L k' v') = cmpk k k' `mappend` cmpv v v' -- Same as 'equal2' but doesn't compare the values. equalKeys1 :: (k -> k' -> Bool) -> HashMap k v -> HashMap k' v' -> Bool-equalKeys1 eq t1 t2 = go (toList' t1 []) (toList' t2 [])+equalKeys1 eq t1 t2 = go (leavesAndCollisions t1 []) (leavesAndCollisions t2 []) where go (Leaf k1 l1 : tl1) (Leaf k2 l2 : tl2) | k1 == k2 && leafEq l1 l2@@ -482,7 +480,7 @@ leafEq (L k1 _) (L k2 _) = k1 == k2 instance Hashable2 HashMap where- liftHashWithSalt2 hk hv salt hm = go salt (toList' hm [])+ liftHashWithSalt2 hk hv salt hm = go salt (leavesAndCollisions hm []) where -- go :: Int -> [HashMap k v] -> Int go s [] = s@@ -531,15 +529,15 @@ arrayHashesSorted :: Int -> A.Array (Leaf k v) -> [Int] arrayHashesSorted s = List.sort . List.map (hashLeafWithSalt s) . A.toList - -- Helper to get 'Leaf's and 'Collision's as a list.-toList' :: HashMap k v -> [HashMap k v] -> [HashMap k v]-toList' (BitmapIndexed _ ary) a = A.foldr toList' a ary-toList' (Full ary) a = A.foldr toList' a ary-toList' l@(Leaf _ _) a = l : a-toList' c@(Collision _ _) a = c : a-toList' Empty a = a+-- | Helper to get 'Leaf's and 'Collision's as a list.+leavesAndCollisions :: HashMap k v -> [HashMap k v] -> [HashMap k v]+leavesAndCollisions (BitmapIndexed _ ary) a = A.foldr leavesAndCollisions a ary+leavesAndCollisions (Full ary) a = A.foldr leavesAndCollisions a ary+leavesAndCollisions l@(Leaf _ _) a = l : a+leavesAndCollisions c@(Collision _ _) a = c : a+leavesAndCollisions Empty a = a --- Helper function to detect 'Leaf's and 'Collision's.+-- | Helper function to detect 'Leaf's and 'Collision's. isLeafOrCollision :: HashMap k v -> Bool isLeafOrCollision (Leaf _ _) = True isLeafOrCollision (Collision _ _) = True@@ -717,7 +715,7 @@ lookupDefault :: (Eq k, Hashable k) => v -- ^ Default value to return. -> k -> HashMap k v -> v-lookupDefault def k t = findWithDefault def k t+lookupDefault = findWithDefault {-# INLINE lookupDefault #-} -- | /O(log n)/ Return the value to which the specified key is mapped.@@ -741,7 +739,10 @@ -- | Create a 'BitmapIndexed' or 'Full' node. bitmapIndexedOrFull :: Bitmap -> A.Array (HashMap k v) -> HashMap k v-bitmapIndexedOrFull b ary+-- The strictness in @ary@ helps achieve a nice code size reduction in+-- @unionWith[Key]@ with GHC 9.2.2. See the Core diffs in+-- https://github.com/haskell-unordered-containers/unordered-containers/pull/376.+bitmapIndexedOrFull b !ary | b == fullNodeMask = Full ary | otherwise = BitmapIndexed b ary {-# INLINE bitmapIndexedOrFull #-}@@ -968,7 +969,7 @@ | hy == h = if ky == k then case f y of (# v' #) | ptrEq y v' -> t- | otherwise -> Leaf h (L k (v'))+ | otherwise -> Leaf h (L k v') else collision h l (L k x) | otherwise = runST (two s h k x hy t) go h k s t@(BitmapIndexed b ary)@@ -1025,11 +1026,11 @@ unsafeInsertWith :: forall k v. (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v-unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (const f) k0 v0 m0+unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (\_ a b -> (# f a b #)) k0 v0 m0 {-# INLINABLE unsafeInsertWith #-} unsafeInsertWithKey :: forall k v. (Eq k, Hashable k)- => (k -> v -> v -> v) -> k -> v -> HashMap k v+ => (k -> v -> v -> (# v #)) -> k -> v -> HashMap k v -> HashMap k v unsafeInsertWithKey f k0 v0 m0 = runST (go h0 k0 v0 0 m0) where@@ -1038,7 +1039,8 @@ go !h !k x !_ Empty = return $! Leaf h (L k x) go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k- then return $! Leaf h (L k (f k x y))+ then case f k x y of+ (# v #) -> return $! Leaf h (L k v) else return $! collision h l (L k x) | otherwise = two s h k x hy t go h k x s t@(BitmapIndexed b ary)@@ -1059,7 +1061,7 @@ return t where i = index h s go h k x s t@(Collision hy v)- | h == hy = return $! Collision h (updateOrSnocWithKey (\key a b -> (# f key a b #) ) k x v)+ | h == hy = return $! Collision h (updateOrSnocWithKey f k x v) | otherwise = go h k x s $ BitmapIndexed (mask hy s) (A.singleton t) {-# INLINABLE unsafeInsertWithKey #-} @@ -1264,10 +1266,9 @@ let !h = hash k mv = lookup' h k m- in (<$> f mv) $ \fres ->- case fres of- Nothing -> maybe m (const (delete' h k m)) mv- Just v' -> insert' h k v' m+ in (<$> f mv) $ \case+ Nothing -> maybe m (const (delete' h k m)) mv+ Just v' -> insert' h k v' m -- We unconditionally rewrite alterF in RULES, but we expose an -- unfolding just in case it's used in some way that prevents the@@ -1356,8 +1357,7 @@ -- eagerly, whether or not the given function requires that information. alterFEager :: (Functor f, Eq k, Hashable k) => (Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)-alterFEager f !k m = (<$> f mv) $ \fres ->- case fres of+alterFEager f !k m = (<$> f mv) $ \case ------------------------------ -- Delete the key from the map.@@ -1407,7 +1407,7 @@ -- -- @since 0.2.12 isSubmapOf :: (Eq k, Hashable k, Eq v) => HashMap k v -> HashMap k v -> Bool-isSubmapOf = (Exts.inline isSubmapOfBy) (==)+isSubmapOf = Exts.inline isSubmapOfBy (==) {-# INLINABLE isSubmapOf #-} -- | /O(n*log m)/ Inclusion of maps with value comparison. A map is included in@@ -1551,7 +1551,7 @@ | h1 == h2 = Collision h1 (updateOrSnocWithKey (\k a b -> (# f k b a #)) k2 v2 ls1) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Collision h2 ls2)- | h1 == h2 = Collision h1 (updateOrConcatWithKey f ls1 ls2)+ | h1 == h2 = Collision h1 (updateOrConcatWithKey (\k a b -> (# f k a b #)) ls1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) =@@ -1618,27 +1618,31 @@ -- | Strict in the result of @f@. unionArrayBy :: (a -> a -> a) -> Bitmap -> Bitmap -> A.Array a -> A.Array a -> A.Array a-unionArrayBy f b1 b2 ary1 ary2 = A.run $ do- let b' = b1 .|. b2- mary <- A.new_ (popCount b')+-- The manual forcing of @b1@, @b2@, @ary1@ and @ary2@ results in handsome+-- Core size reductions with GHC 9.2.2. See the Core diffs in+-- https://github.com/haskell-unordered-containers/unordered-containers/pull/376.+unionArrayBy f !b1 !b2 !ary1 !ary2 = A.run $ do+ let bCombined = b1 .|. b2+ mary <- A.new_ (popCount bCombined) -- iterate over nonzero bits of b1 .|. b2- -- it would be nice if we could shift m by more than 1 each time- let ba = b1 .&. b2- go !i !i1 !i2 !m- | m > b' = return ()- | b' .&. m == 0 = go i i1 i2 (m `unsafeShiftL` 1)- | ba .&. m /= 0 = do+ let go !i !i1 !i2 !b+ | b == 0 = return ()+ | testBit (b1 .&. b2) = do x1 <- A.indexM ary1 i1 x2 <- A.indexM ary2 i2 A.write mary i $! f x1 x2- go (i+1) (i1+1) (i2+1) (m `unsafeShiftL` 1)- | b1 .&. m /= 0 = do+ go (i+1) (i1+1) (i2+1) b'+ | testBit b1 = do A.write mary i =<< A.indexM ary1 i1- go (i+1) (i1+1) (i2 ) (m `unsafeShiftL` 1)- | otherwise = do+ go (i+1) (i1+1) i2 b'+ | otherwise = do A.write mary i =<< A.indexM ary2 i2- go (i+1) (i1 ) (i2+1) (m `unsafeShiftL` 1)- go 0 0 0 (b' .&. negate b') -- XXX: b' must be non-zero+ go (i+1) i1 (i2+1) b'+ where+ m = 1 `unsafeShiftL` (countTrailingZeros b)+ testBit x = x .&. m /= 0+ b' = b .&. complement m+ go 0 0 0 bCombined return mary -- TODO: For the case where b1 .&. b2 == b1, i.e. when one is a -- subset of the other, we could use a slightly simpler algorithm,@@ -1748,7 +1752,7 @@ difference a b = foldlWithKey' go empty a where go m k v = case lookup k b of- Nothing -> insert k v m+ Nothing -> unsafeInsert k v m _ -> m {-# INLINABLE difference #-} @@ -1760,8 +1764,8 @@ differenceWith f a b = foldlWithKey' go empty a where go m k v = case lookup k b of- Nothing -> insert k v m- Just w -> maybe m (\y -> insert k y m) (f v w)+ Nothing -> unsafeInsert k v m+ Just w -> maybe m (\y -> unsafeInsert k y m) (f v w) {-# INLINABLE differenceWith #-} -- | /O(n*log m)/ Intersection of two maps. Return elements of the first@@ -1770,7 +1774,7 @@ intersection a b = foldlWithKey' go empty a where go m k v = case lookup k b of- Just _ -> insert k v m+ Just _ -> unsafeInsert k v m _ -> m {-# INLINABLE intersection #-} @@ -1782,7 +1786,7 @@ intersectionWith f a b = foldlWithKey' go empty a where go m k v = case lookup k b of- Just w -> insert k (f v w) m+ Just w -> unsafeInsert k (f v w) m _ -> m {-# INLINABLE intersectionWith #-} @@ -1794,7 +1798,7 @@ intersectionWithKey f a b = foldlWithKey' go empty a where go m k v = case lookup k b of- Just w -> insert k (f k v w) m+ Just w -> unsafeInsert k (f k v w) m _ -> m {-# INLINABLE intersectionWithKey #-} @@ -2102,7 +2106,7 @@ -- -- @since 0.2.11 fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v-fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty+fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey (\k' a b -> (# f k' a b #)) k v m) empty {-# INLINE fromListWithKey #-} ------------------------------------------------------------------------@@ -2174,11 +2178,7 @@ = go k v ary (i+1) n {-# INLINABLE updateOrSnocWithKey #-} -updateOrConcatWith :: Eq k => (v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v)-updateOrConcatWith f = updateOrConcatWithKey (const f)-{-# INLINABLE updateOrConcatWith #-}--updateOrConcatWithKey :: Eq k => (k -> v -> v -> v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v)+updateOrConcatWithKey :: Eq k => (k -> v -> v -> (# v #)) -> A.Array (Leaf k v) -> A.Array (Leaf k v) -> A.Array (Leaf k v) updateOrConcatWithKey f ary1 ary2 = A.run $ do -- TODO: instead of mapping and then folding, should we traverse? -- We'll have to be careful to avoid allocating pairs or similar.@@ -2200,7 +2200,7 @@ Just i1 -> do -- key occurs in both arrays, store combination in position i1 L k v1 <- A.indexM ary1 i1 L _ v2 <- A.indexM ary2 i2- A.write mary i1 (L k (f k v1 v2))+ case f k v1 v2 of (# v3 #) -> A.write mary i1 (L k v3) go iEnd (i2+1) Nothing -> do -- key is only in ary2, append to end A.write mary iEnd =<< A.indexM ary2 i2@@ -2268,7 +2268,7 @@ -- | Mask out the 'bitsPerSubkey' bits used for indexing at this level -- of the tree. index :: Hash -> Shift -> Int-index w s = fromIntegral $ (unsafeShiftR w s) .&. subkeyMask+index w s = fromIntegral $ unsafeShiftR w s .&. subkeyMask {-# INLINE index #-} -- | A bitmask with the 'bitsPerSubkey' least significant bits set.
Data/HashMap/Internal/Array.hs view
@@ -442,9 +442,10 @@ in run $ do mary <- new_ n go ary mary 0 n+ return mary where go ary mary i n- | i >= n = return mary+ | i >= n = return () | otherwise = do x <- indexM ary i write mary i $ f x@@ -458,9 +459,10 @@ in run $ do mary <- new_ n go ary mary 0 n+ return mary where go ary mary i n- | i >= n = return mary+ | i >= n = return () | otherwise = do x <- indexM ary i write mary i $! f x@@ -473,10 +475,11 @@ run $ do mary <- new_ n go xs0 mary 0+ return mary where- go [] !mary !_ = return mary- go (x:xs) mary i = do write mary i x- go xs mary (i+1)+ go [] !_ !_ = return ()+ go (x:xs) mary i = do write mary i x+ go xs mary (i+1) fromList' :: Int -> [a] -> Array a fromList' n xs0 =@@ -484,10 +487,11 @@ run $ do mary <- new_ n go xs0 mary 0+ return mary where- go [] !mary !_ = return mary- go (!x:xs) mary i = do write mary i x- go xs mary (i+1)+ go [] !_ !_ = return ()+ go (!x:xs) mary i = do write mary i x+ go xs mary (i+1) -- | @since 0.2.17.0 instance TH.Lift a => TH.Lift (Array a) where
Data/HashMap/Internal/Strict.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Trustworthy #-}@@ -48,74 +49,74 @@ HashMap -- * Construction- , empty+ , HM.empty , singleton -- * Basic interface , HM.null- , size+ , HM.size , HM.member , HM.lookup , (HM.!?) , HM.findWithDefault- , lookupDefault- , (!)+ , HM.lookupDefault+ , (HM.!) , insert , insertWith- , delete+ , HM.delete , adjust , update , alter , alterF- , isSubmapOf- , isSubmapOfBy+ , HM.isSubmapOf+ , HM.isSubmapOfBy -- * Combine -- ** Union- , union+ , HM.union , unionWith , unionWithKey- , unions+ , HM.unions -- ** Compose- , compose+ , HM.compose -- * Transformations , map , mapWithKey , traverseWithKey- , mapKeys+ , HM.mapKeys -- * Difference and intersection- , difference+ , HM.difference , differenceWith- , intersection+ , HM.intersection , intersectionWith , intersectionWithKey -- * Folds- , foldMapWithKey- , foldr'- , foldl'- , foldrWithKey'- , foldlWithKey'+ , HM.foldMapWithKey+ , HM.foldr'+ , HM.foldl'+ , HM.foldrWithKey'+ , HM.foldlWithKey' , HM.foldr , HM.foldl- , foldrWithKey- , foldlWithKey+ , HM.foldrWithKey+ , HM.foldlWithKey -- * Filter , HM.filter- , filterWithKey+ , HM.filterWithKey , mapMaybe , mapMaybeWithKey -- * Conversions- , keys- , elems+ , HM.keys+ , HM.elems -- ** Lists- , toList+ , HM.toList , fromList , fromListWith , fromListWithKey@@ -126,19 +127,31 @@ import Data.Bits ((.&.), (.|.)) import Data.Coerce (coerce) import Data.Functor.Identity (Identity (..))-import Data.HashMap.Internal hiding (adjust, alter, alterF, differenceWith,- fromList, fromListWith, fromListWithKey, insert,- insertWith, intersectionWith, intersectionWithKey,- map, mapMaybe, mapMaybeWithKey, mapWithKey,- singleton, traverseWithKey, unionWith,- unionWithKey, update)+-- See Note [Imports from Data.HashMap.Internal]+import Data.HashMap.Internal (Hash, HashMap (..), Leaf (..), LookupRes (..),+ bitsPerSubkey, fullNodeMask, hash, index, mask,+ ptrEq, sparseIndex) import Data.Hashable (Hashable) import Prelude hiding (lookup, map) +-- See Note [Imports from Data.HashMap.Internal] import qualified Data.HashMap.Internal as HM import qualified Data.HashMap.Internal.Array as A import qualified Data.List as List +{-+Note [Imports from Data.HashMap.Internal]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is very important for code in this module not to make mistakes about+the strictness properties of any utilities. Mistakes can easily lead to space+leaks, see e.g. #383.++Therefore nearly all functions imported from Data.HashMap.Internal should be+imported qualified. Only functions that do not manipulate HashMaps or their+values are exempted.+-}+ -- $strictness -- -- This module satisfies the following strictness properties:@@ -181,12 +194,12 @@ go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k then leaf h k (f x y)- else x `seq` (collision h l (L k x))- | otherwise = x `seq` runST (two s h k x hy t)+ else x `seq` HM.collision h l (L k x)+ | otherwise = x `seq` runST (HM.two s h k x hy t) go h k x s (BitmapIndexed b ary) | b .&. m == 0 = let ary' = A.insert ary i $! leaf h k x- in bitmapIndexedOrFull (b .|. m) ary'+ in HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st@@ -197,7 +210,7 @@ go h k x s (Full ary) = let st = A.index ary i st' = go h k x (s+bitsPerSubkey) st- ary' = update32 ary i $! st'+ ary' = HM.update32 ary i $! st' in Full ary' where i = index h s go h k x s t@(Collision hy v)@@ -221,13 +234,13 @@ | hy == h = if ky == k then return $! leaf h k (f k x y) else do- let l' = x `seq` (L k x)- return $! collision h l l'- | otherwise = x `seq` two s h k x hy t+ let l' = x `seq` L k x+ return $! HM.collision h l l'+ | otherwise = x `seq` HM.two s h k x hy t go h k x s t@(BitmapIndexed b ary) | b .&. m == 0 = do ary' <- A.insertM ary i $! leaf h k x- return $! bitmapIndexedOrFull (b .|. m) ary'+ return $! HM.bitmapIndexedOrFull (b .|. m) ary' | otherwise = do st <- A.indexM ary i st' <- go h k x (s+bitsPerSubkey) st@@ -268,7 +281,7 @@ let i = index h s st = A.index ary i st' = go h k (s+bitsPerSubkey) st- ary' = update32 ary i $! st'+ ary' = HM.update32 ary i $! st' in Full ary' go h k _ t@(Collision hy v) | h == hy = Collision h (updateWith f k v)@@ -293,7 +306,7 @@ alter :: (Eq k, Hashable k) => (Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v alter f k m = case f (HM.lookup k m) of- Nothing -> delete k m+ Nothing -> HM.delete k m Just v -> insert k v m {-# INLINABLE alter #-} @@ -315,11 +328,10 @@ -- @f@ and a functor that is similar to Const but not actually Const. alterF f = \ !k !m -> let !h = hash k- mv = lookup' h k m- in (<$> f mv) $ \fres ->- case fres of- Nothing -> maybe m (const (delete' h k m)) mv- Just !v' -> insert' h k v' m+ mv = HM.lookup' h k m+ in (<$> f mv) $ \case+ Nothing -> maybe m (const (HM.delete' h k m)) mv+ Just !v' -> HM.insert' h k v' m -- We rewrite this function unconditionally in RULES, but we expose -- an unfolding just in case it's used in a context where the rules@@ -345,13 +357,13 @@ "alterFconstant" forall (f :: Maybe a -> Identity (Maybe a)) x. alterFWeird x x f = \ !k !m ->- Identity (case runIdentity x of {Nothing -> delete k m; Just a -> insert k a m})+ Identity (case runIdentity x of {Nothing -> HM.delete k m; Just a -> insert k a m}) "alterFinsertWith" [1] forall (f :: Maybe a -> Identity (Maybe a)) x y. alterFWeird (coerce (Just x)) (coerce (Just y)) f =- coerce (insertModifying x (\mold -> case runIdentity (f (Just mold)) of- Nothing -> bogus# (# #)- Just !new -> (# new #)))+ coerce (HM.insertModifying x (\mold -> case runIdentity (f (Just mold)) of+ Nothing -> bogus# (# #)+ Just !new -> (# new #))) -- This rule is written a bit differently than the one for lazy -- maps because the adjust here is strict. We could write it the@@ -363,7 +375,7 @@ Nothing -> impossibleAdjust)) "alterFlookup" forall _ign1 _ign2 (f :: Maybe a -> Const r (Maybe a)) .- alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (lookup k m)))+ alterFWeird _ign1 _ign2 f = \ !k !m -> Const (getConst (f (HM.lookup k m))) #-} -- This is a very unsafe version of alterF used for RULES. When calling@@ -397,25 +409,25 @@ Absent -> m -- Key did exist, no collision- Present _ collPos -> deleteKeyExists collPos h k m+ Present _ collPos -> HM.deleteKeyExists collPos h k m ------------------------------ -- Update value- Just v' -> case lookupRes of+ Just !v' -> case lookupRes of -- Key did not exist before, insert v' under a new key- Absent -> insertNewKey h k v' m+ Absent -> HM.insertNewKey h k v' m -- Key existed before, no hash collision- Present v collPos -> v' `seq`+ Present v collPos -> if v `ptrEq` v' -- If the value is identical, no-op then m -- If the value changed, update the value.- else insertKeyExists collPos h k v' m+ else HM.insertKeyExists collPos h k v' m where !h = hash k- !lookupRes = lookupRecordCollision h k m+ !lookupRes = HM.lookupRecordCollision h k m !mv = case lookupRes of Absent -> Nothing Present v _ -> Just v@@ -444,7 +456,7 @@ go s t1@(Leaf h1 l1@(L k1 v1)) t2@(Leaf h2 l2@(L k2 v2)) | h1 == h2 = if k1 == k2 then leaf h1 k1 (f k1 v1 v2)- else collision h1 l1 l2+ else HM.collision h1 l1 l2 | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Leaf h1 (L k1 v1)) t2@(Collision h2 ls2) | h1 == h2 = Collision h1 (updateOrSnocWithKey f k1 v1 ls2)@@ -453,28 +465,28 @@ | h1 == h2 = Collision h1 (updateOrSnocWithKey (flip . f) k2 v2 ls1) | otherwise = goDifferentHash s h1 h2 t1 t2 go s t1@(Collision h1 ls1) t2@(Collision h2 ls2)- | h1 == h2 = Collision h1 (updateOrConcatWithKey f ls1 ls2)+ | h1 == h2 = Collision h1 (HM.updateOrConcatWithKey (\k a b -> let !v = f k a b in (# v #)) ls1 ls2) | otherwise = goDifferentHash s h1 h2 t1 t2 -- branch vs. branch go s (BitmapIndexed b1 ary1) (BitmapIndexed b2 ary2) = let b' = b1 .|. b2- ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2- in bitmapIndexedOrFull b' ary'+ ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) b1 b2 ary1 ary2+ in HM.bitmapIndexedOrFull b' ary' go s (BitmapIndexed b1 ary1) (Full ary2) =- let ary' = unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2+ let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) b1 fullNodeMask ary1 ary2 in Full ary' go s (Full ary1) (BitmapIndexed b2 ary2) =- let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2+ let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask b2 ary1 ary2 in Full ary' go s (Full ary1) (Full ary2) =- let ary' = unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask+ let ary' = HM.unionArrayBy (go (s+bitsPerSubkey)) fullNodeMask fullNodeMask ary1 ary2 in Full ary' -- leaf vs. branch go s (BitmapIndexed b1 ary1) t2 | b1 .&. m2 == 0 = let ary' = A.insert ary1 i t2 b' = b1 .|. m2- in bitmapIndexedOrFull b' ary'+ in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in BitmapIndexed b1 ary'@@ -485,7 +497,7 @@ go s t1 (BitmapIndexed b2 ary2) | b2 .&. m1 == 0 = let ary' = A.insert ary2 i $! t1 b' = b2 .|. m1- in bitmapIndexedOrFull b' ary'+ in HM.bitmapIndexedOrFull b' ary' | otherwise = let ary' = A.updateWith' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in BitmapIndexed b2 ary'@@ -496,12 +508,12 @@ go s (Full ary1) t2 = let h2 = leafHashCode t2 i = index h2 s- ary' = update32With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2+ ary' = HM.update32With' ary1 i $ \st1 -> go (s+bitsPerSubkey) st1 t2 in Full ary' go s t1 (Full ary2) = let h1 = leafHashCode t1 i = index h1 s- ary' = update32With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2+ ary' = HM.update32With' ary2 i $ \st2 -> go (s+bitsPerSubkey) t1 st2 in Full ary' leafHashCode (Leaf h _) = h@@ -544,11 +556,11 @@ -- | /O(n)/ Transform this map by applying a function to every value -- and retaining only some of them. mapMaybeWithKey :: (k -> v1 -> Maybe v2) -> HashMap k v1 -> HashMap k v2-mapMaybeWithKey f = filterMapAux onLeaf onColl+mapMaybeWithKey f = HM.filterMapAux onLeaf onColl where onLeaf (Leaf h (L k v)) | Just v' <- f k v = Just (leaf h k v') onLeaf _ = Nothing - onColl (L k v) | Just v' <- f k v = Just (L k v')+ onColl (L k v) | Just !v' <- f k v = Just (L k v') | otherwise = Nothing {-# INLINE mapMaybeWithKey #-} @@ -592,11 +604,11 @@ -- If it returns 'Nothing', the element is discarded (proper set difference). If -- it returns (@'Just' y@), the element is updated with a new value @y@. differenceWith :: (Eq k, Hashable k) => (v -> w -> Maybe v) -> HashMap k v -> HashMap k w -> HashMap k v-differenceWith f a b = foldlWithKey' go empty a+differenceWith f a b = HM.foldlWithKey' go HM.empty a where go m k v = case HM.lookup k b of- Nothing -> insert k v m- Just w -> maybe m (\y -> insert k y m) (f v w)+ Nothing -> v `seq` HM.unsafeInsert k v m+ Just w -> maybe m (\ !y -> HM.unsafeInsert k y m) (f v w) {-# INLINABLE differenceWith #-} -- | /O(n+m)/ Intersection of two maps. If a key occurs in both maps@@ -604,10 +616,10 @@ -- maps. intersectionWith :: (Eq k, Hashable k) => (v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3-intersectionWith f a b = foldlWithKey' go empty a+intersectionWith f a b = HM.foldlWithKey' go HM.empty a where go m k v = case HM.lookup k b of- Just w -> insert k (f v w) m+ Just w -> let !x = f v w in HM.unsafeInsert k x m _ -> m {-# INLINABLE intersectionWith #-} @@ -616,10 +628,10 @@ -- maps. intersectionWithKey :: (Eq k, Hashable k) => (k -> v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3-intersectionWithKey f a b = foldlWithKey' go empty a+intersectionWithKey f a b = HM.foldlWithKey' go HM.empty a where go m k v = case HM.lookup k b of- Just w -> insert k (f k v w) m+ Just w -> let !x = f k v w in HM.unsafeInsert k x m _ -> m {-# INLINABLE intersectionWithKey #-} @@ -630,7 +642,7 @@ -- list contains duplicate mappings, the later mappings take -- precedence. fromList :: (Eq k, Hashable k) => [(k, v)] -> HashMap k v-fromList = List.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) empty+fromList = List.foldl' (\ m (k, !v) -> HM.unsafeInsert k v m) HM.empty {-# INLINABLE fromList #-} -- | /O(n*log n)/ Construct a map from a list of elements. Uses@@ -664,7 +676,7 @@ -- > fromListWith f [(k, a), (k, b), (k, c), (k, d)] -- > = fromList [(k, f d (f c (f b a)))] fromListWith :: (Eq k, Hashable k) => (v -> v -> v) -> [(k, v)] -> HashMap k v-fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) empty+fromListWith f = List.foldl' (\ m (k, v) -> unsafeInsertWith f k v m) HM.empty {-# INLINE fromListWith #-} -- | /O(n*log n)/ Construct a map from a list of elements. Uses@@ -694,7 +706,7 @@ -- -- @since 0.2.11 fromListWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> [(k, v)] -> HashMap k v-fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) empty+fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey f k v m) HM.empty {-# INLINE fromListWithKey #-} ------------------------------------------------------------------------@@ -734,7 +746,7 @@ -- Not found, append to the end. mary <- A.new_ (n + 1) A.copy ary 0 mary 0 n- let !l = v `seq` (L k v)+ let !l = v `seq` L k v A.write mary n l return mary | otherwise = case A.index ary i of
Data/HashSet/Internal.hs view
@@ -214,8 +214,7 @@ instance (Eq a, Hashable a, Read a) => Read (HashSet a) where readPrec = parens $ prec 10 $ do Ident "fromList" <- lexP- xs <- readPrec- return (fromList xs)+ fromList <$> readPrec readListPrec = readListPrecDefault @@ -442,7 +441,7 @@ -- | /O(n)/ Return a list of this set's elements. The list is -- produced lazily. toList :: HashSet a -> [a]-toList t = Exts.build (\ c z -> foldrWithKey ((const .) c) z (asMap t))+toList t = Exts.build (\ c z -> foldrWithKey (const . c) z (asMap t)) {-# INLINE toList #-} -- | /O(n*min(W, n))/ Construct a set from a list of elements.
benchmarks/Benchmarks.hs view
@@ -314,7 +314,10 @@ ] -- Combine- , bench "union" $ whnf (HM.union hmi) hmi2+ , bgroup "union" + [ bench "Int" $ whnf (HM.union hmi) hmi2+ , bench "ByteString" $ whnf (HM.union hmbs) hmbsSubset+ ] -- Transformations , bench "map" $ whnf (HM.map (\ v -> v + 1)) hmi
tests/Regressions.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} module Regressions (tests) where @@ -10,6 +12,7 @@ import Data.Maybe (isJust, isNothing) import GHC.Exts (touch#) import GHC.IO (IO (..))+import Numeric.Natural (Natural) import System.Mem (performGC) import System.Mem.Weak (deRefWeak, mkWeakPtr) import System.Random (randomIO)@@ -22,6 +25,13 @@ import qualified Data.HashMap.Lazy as HML import qualified Data.HashMap.Strict as HMS +#if MIN_VERSION_base(4,12,0)+-- nothunks requires base >= 4.12+#define HAVE_NOTHUNKS+import qualified Data.Foldable as Foldable+import NoThunks.Class (noThunksInValues)+#endif+ issue32 :: Assertion issue32 = assert $ isJust $ HMS.lookup 7 m' where@@ -125,6 +135,120 @@ assert $ isNothing res ------------------------------------------------------------------------+-- Issue #379++#ifdef HAVE_NOTHUNKS++issue379Union :: Assertion+issue379Union = do+ let m0 = HMS.fromList [(KC 1, ()), (KC 2, ())]+ let m1 = HMS.fromList [(KC 2, ()), (KC 3, ())]+ let u = m0 `HMS.union` m1+ mThunkInfo <- noThunksInValues mempty (Foldable.toList u)+ assert $ isNothing mThunkInfo++issue379StrictUnionWith :: Assertion+issue379StrictUnionWith = do+ let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)]+ let m1 = HMS.fromList [(KC 2, 20), (KC 3, 30)]+ let u = HMS.unionWith (+) m0 m1+ mThunkInfo <- noThunksInValues mempty (Foldable.toList u)+ assert $ isNothing mThunkInfo++issue379StrictUnionWithKey :: Assertion+issue379StrictUnionWithKey = do+ let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)]+ let m1 = HMS.fromList [(KC 2, 20), (KC 3, 30)]+ let u = HMS.unionWithKey (\(KC i) v0 v1 -> i + v0 + v1) m0 m1+ mThunkInfo <- noThunksInValues mempty (Foldable.toList u)+ assert $ isNothing mThunkInfo++#endif++-- Another key type that always collides.+--+-- Note (sjakobi): The KC newtype of Int somehow can't be used to demonstrate+-- the space leak in issue379LazyUnionWith. This type does the trick.+newtype SC = SC String+ deriving (Eq, Ord, Show)+instance Hashable SC where+ hashWithSalt salt _ = salt++issue379LazyUnionWith :: Assertion+issue379LazyUnionWith = do+ i :: Int <- randomIO+ let k = SC (show i)+ weakK <- mkWeakPtr k Nothing -- add the ability to test whether k is alive+ let f :: Int -> Int+ f x = error ("Should not be evaluated " ++ show x)+ let m = HML.fromList [(SC "1", f 1), (SC "2", f 2), (k, f 3)]+ let u = HML.unionWith (+) m m+ Just v <- evaluate $ HML.lookup k u+ performGC+ res <- deRefWeak weakK -- gives Just if k is still alive+ touch v -- makes sure that we didn't GC away the combined value+ assert $ isNothing res++------------------------------------------------------------------------+-- Issue #381++#ifdef HAVE_NOTHUNKS++issue381mapMaybe :: Assertion+issue381mapMaybe = do+ let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)]+ let m1 = HMS.mapMaybe (Just . (+ 1)) m0+ mThunkInfo <- noThunksInValues mempty (Foldable.toList m1)+ assert $ isNothing mThunkInfo++issue381mapMaybeWithKey :: Assertion+issue381mapMaybeWithKey = do+ let m0 = HMS.fromList [(KC 1, 10), (KC 2, 20 :: Int)]+ let m1 = HMS.mapMaybeWithKey (\(KC k) v -> Just (k + v)) m0+ mThunkInfo <- noThunksInValues mempty (Foldable.toList m1)+ assert $ isNothing mThunkInfo++#endif++------------------------------------------------------------------------+-- Issue #382++issue382 :: Assertion+issue382 = do+ i :: Int <- randomIO+ let k = SC (show i)+ weakK <- mkWeakPtr k Nothing -- add the ability to test whether k is alive+ let f :: Int -> Int -> Int+ f x = error ("Should not be evaluated " ++ show x)+ let m = HML.fromListWith f [(k, 1), (k, 2)]+ Just v <- evaluate $ HML.lookup k m+ performGC+ res <- deRefWeak weakK -- gives Just if k is still alive+ touch v -- makes sure that we didn't GC away the combined value+ assert $ isNothing res++------------------------------------------------------------------------+-- Issue #383++#ifdef HAVE_NOTHUNKS++-- Custom Functor to prevent interference from alterF rules+newtype MyIdentity a = MyIdentity a+instance Functor MyIdentity where+ fmap f (MyIdentity x) = MyIdentity (f x)++issue383 :: Assertion+issue383 = do+ i :: Int <- randomIO+ let f Nothing = MyIdentity (Just (fromIntegral @Int @Natural (abs i)))+ f Just{} = MyIdentity (error "Impossible")+ let (MyIdentity m) = HMS.alterF f () mempty+ mThunkInfo <- noThunksInValues mempty (Foldable.toList m)+ assert $ isNothing mThunkInfo++#endif++------------------------------------------------------------------------ -- * Test list tests :: TestTree@@ -135,4 +259,22 @@ , testProperty "issue39b" propEqAfterDelete , testCase "issue254 lazy" issue254Lazy , testCase "issue254 strict" issue254Strict+ , testGroup "issue379"+ [ testCase "Lazy.unionWith" issue379LazyUnionWith+#ifdef HAVE_NOTHUNKS+ , testCase "union" issue379Union+ , testCase "Strict.unionWith" issue379StrictUnionWith+ , testCase "Strict.unionWithKey" issue379StrictUnionWithKey+#endif+ ]+#ifdef HAVE_NOTHUNKS+ , testGroup "issue381"+ [ testCase "mapMaybe" issue381mapMaybe+ , testCase "mapMaybeWithKey" issue381mapMaybeWithKey+ ]+#endif+ , testCase "issue382" issue382+#ifdef HAVE_NOTHUNKS+ , testCase "issue383" issue383+#endif ]
tests/Strictness.hs view
@@ -48,7 +48,7 @@ pSingletonKeyStrict v = isBottom $ HM.singleton (bottom :: Key) v pSingletonValueStrict :: Key -> Bool-pSingletonValueStrict k = isBottom $ (HM.singleton k (bottom :: Int))+pSingletonValueStrict k = isBottom $ HM.singleton k (bottom :: Int) pLookupDefaultKeyStrict :: Int -> HashMap Key Int -> Bool pLookupDefaultKeyStrict def m = isBottom $ HM.lookupDefault def bottom m
unordered-containers.cabal view
@@ -1,5 +1,5 @@ name: unordered-containers-version: 0.2.17.0+version: 0.2.18.0 synopsis: Efficient hashing-based container types description: Efficient hashing-based container types. The containers have been@@ -69,6 +69,11 @@ ghc-options: -Wall -O2 -fwarn-tabs -ferror-spans + -- For dumping the generated code:+ -- ghc-options: -ddump-simpl -ddump-stg-final -ddump-cmm -ddump-asm -ddump-to-file+ -- ghc-options: -dsuppress-coercions -dsuppress-unfoldings -dsuppress-module-prefixes+ -- ghc-options: -dsuppress-uniques -dsuppress-timestamps+ if flag(debug) cpp-options: -DASSERTS @@ -97,6 +102,10 @@ tasty-hunit >= 0.10.0.3, tasty-quickcheck >= 0.10.1.2, unordered-containers++ if impl(ghc >= 8.6)+ build-depends:+ nothunks >= 0.1.3 default-language: Haskell2010 ghc-options: -Wall