hashtables 1.2.1.1 → 1.2.2.0
raw patch · 16 files changed
+698/−130 lines, 16 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.HashTable.Class: lookupIndex :: (HashTable h, Eq k, Hashable k) => h s k v -> k -> ST s (Maybe Word)
+ Data.HashTable.Class: mutate :: (HashTable h, Eq k, Hashable k) => h s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
+ Data.HashTable.Class: nextByIndex :: HashTable h => h s k v -> Word -> ST s (Maybe (Word, k, v))
+ Data.HashTable.IO: lookupIndex :: (HashTable h, Eq k, Hashable k) => IOHashTable h k v -> k -> IO (Maybe Word)
+ Data.HashTable.IO: mutate :: (HashTable h, Eq k, Hashable k) => IOHashTable h k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a
+ Data.HashTable.IO: nextByIndex :: (HashTable h, Eq k, Hashable k) => IOHashTable h k v -> Word -> IO (Maybe (Word, k, v))
+ Data.HashTable.ST.Basic: instance GHC.Show.Show Data.HashTable.ST.Basic.SlotFindResponse
+ Data.HashTable.ST.Basic: mutate :: (Eq k, Hashable k) => (HashTable s k v) -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
+ Data.HashTable.ST.Cuckoo: lookupIndex :: (Hashable k, Eq k) => HashTable s k v -> k -> ST s (Maybe Word)
+ Data.HashTable.ST.Cuckoo: mutate :: (Eq k, Hashable k) => HashTable s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
+ Data.HashTable.ST.Cuckoo: nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word, k, v))
+ Data.HashTable.ST.Linear: mutate :: (Eq k, Hashable k) => (HashTable s k v) -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
Files
- benchmark/src/Data/Vector/Algorithms/Shuffle.hs +1/−1
- benchmark/src/Main.hs +0/−19
- changelog.md +13/−0
- hashtables.cabal +2/−2
- src/Data/HashTable/Class.hs +22/−0
- src/Data/HashTable/IO.hs +42/−0
- src/Data/HashTable/Internal/CacheLine.hs +7/−0
- src/Data/HashTable/Internal/IntArray.hs +1/−1
- src/Data/HashTable/Internal/Linear/Bucket.hs +80/−0
- src/Data/HashTable/Internal/Utils.hs +2/−2
- src/Data/HashTable/ST/Basic.hs +237/−90
- src/Data/HashTable/ST/Cuckoo.hs +157/−1
- src/Data/HashTable/ST/Linear.hs +82/−0
- test/compute-overhead/ComputeOverhead.hs +1/−0
- test/hashtables-test.cabal +3/−3
- test/suite/Data/HashTable/Test/Common.hs +48/−11
benchmark/src/Data/Vector/Algorithms/Shuffle.hs view
@@ -2,7 +2,7 @@ module Data.Vector.Algorithms.Shuffle ( shuffle ) where -import Control.Monad.ST (unsafeIOToST)+import Control.Monad.ST.Unsafe (unsafeIOToST) import Data.Vector (Vector) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV
benchmark/src/Main.hs view
@@ -16,7 +16,6 @@ import qualified Data.ByteString.Base16 as B16 import Data.Hashable import qualified Data.HashMap.Strict as UC-import qualified Data.HashTable as H import qualified Data.HashTable.IO as IOH import Data.IORef import qualified Data.Map as Map@@ -57,21 +56,6 @@ -------------------------------------------------------------------------------hashTable :: (Hashable k, Eq k) => DataStructure (Operation k)-hashTable = setupDataIO (const (H.new (==) (toEnum . (.&. 0x7fffffff) . hash))) f- where- f !m !op = case op of- (Insert k v) -> H.update m k v >> return m- (Lookup k) -> do- !_ <- H.lookup m k- return m- (Delete k) -> do- !_ <- H.delete m k- return m-{-# INLINE hashTable #-}--------------------------------------------------------------------------------- basicHashTable :: (Hashable k, Eq k) => DataStructure (Operation k) basicHashTable = setupDataIO (IOH.newSized :: Int -> IO (IOH.BasicHashTable k v)) f@@ -159,7 +143,6 @@ ------------------------------------------------------------------------------ testStructures = [ ("Data.Map" , dataMap )- , ("Data.Hashtable" , hashTable ) , ("Data.HashMap" , hashMap ) , ("Data.BasicHashTable" , basicHashTable ) , ("Data.LinearHashTable" , linearHashTable)@@ -167,14 +150,12 @@ ] intStructures = [ ("Data.Map" , dataMap )- , ("Data.Hashtable" , hashTable ) , ("Data.HashMap" , hashMap ) , ("Data.BasicHashTable" , basicHashTable ) , ("Data.CuckooHashTable", cuckooHashTable) ] intStructures' = [ ("Data.Map" , dataMap )- , ("Data.Hashtable" , hashTable ) , ("Data.HashMap" , hashMap ) , ("Data.BasicHashTable" , basicHashTable ) , ("Data.CuckooHashTable", cuckooHashTable)
changelog.md view
@@ -1,5 +1,18 @@ # Hashtables changelog +## 1.2.2.0+ - Bumped vector bounds.++ - Added `lookupIndex` and `nextByIndex` functions.+ - Add `mutate` function.++Thanks to contributors:++ - Vykintas Baltrušaitis.+ - Franklin Chen+ - Iavor Diatchki+ - Eric Mertins+ ## 1.2.1.1 - Bumped vector bounds.
hashtables.cabal view
@@ -1,12 +1,12 @@ Name: hashtables-Version: 1.2.1.1+Version: 1.2.2.0 Synopsis: Mutable hash tables in the ST monad Homepage: http://github.com/gregorycollins/hashtables License: BSD3 License-file: LICENSE Author: Gregory Collins Maintainer: greg@gregorycollins.net-Copyright: (c) 2011-2014, Google, Inc.+Copyright: (c) 2011-2014, Google, Inc., 2016-present contributors Category: Data Build-type: Simple Cabal-version: >= 1.8
src/Data/HashTable/Class.hs view
@@ -59,6 +59,19 @@ -- | Creates a new hash table sized to hold @n@ elements. /O(n)/. newSized :: Int -> ST s (h s k v) + -- | Generalized update. Given a key /k/, and a user function /f/, calls:+ --+ -- - `f Nothing` if the key did not exist in the hash table+ -- - `f (Just v)` otherwise+ --+ -- If the user function returns @(Nothing, _)@, then the value is deleted+ -- from the hash table. Otherwise the mapping for /k/ is inserted or+ -- replaced with the provided value.+ --+ -- Returns the second part of the tuple returned by /f/.+ mutate :: (Eq k, Hashable k) =>+ h s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a+ -- | Inserts a key/value mapping into a hash table, replacing any existing -- mapping for that key. --@@ -80,6 +93,15 @@ -- | A side-effecting map over the key-value records of a hash -- table. /O(n)/. mapM_ :: ((k,v) -> ST s b) -> h s k v -> ST s ()++ -- | Looks up the index of a key-value mapping in a hash table suitable+ -- for passing to 'nextByIndex'.+ lookupIndex :: (Eq k, Hashable k) => h s k v -> k -> ST s (Maybe Word)++ -- | Returns the next key-value mapping stored at the given index or at+ -- a greater index. The index, key, and value of the next record are+ -- returned.+ nextByIndex :: h s k v -> Word -> ST s (Maybe (Word,k,v)) -- | Computes the overhead (in words) per key-value mapping. Used for -- debugging, etc; time complexity depends on the underlying hash table
src/Data/HashTable/IO.hs view
@@ -47,12 +47,15 @@ , insert , delete , lookup+ , mutate , fromList , fromListWithSizeHint , toList , mapM_ , foldM , computeOverhead+ , lookupIndex+ , nextByIndex ) where @@ -149,6 +152,45 @@ LinearHashTable k v -> k -> IO (Maybe v) #-} {-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) => CuckooHashTable k v -> k -> IO (Maybe v) #-}++------------------------------------------------------------------------------+-- | See the documentation for this function in "Data.HashTable.Class#v:lookupIndex".+lookupIndex :: (C.HashTable h, Eq k, Hashable k) =>+ IOHashTable h k v -> k -> IO (Maybe Word)+lookupIndex h k = stToIO $ C.lookupIndex h k+{-# INLINE lookupIndex #-}+{-# SPECIALIZE INLINE lookupIndex :: (Eq k, Hashable k) =>+ BasicHashTable k v -> k -> IO (Maybe Word) #-}+{-# SPECIALIZE INLINE lookupIndex :: (Eq k, Hashable k) =>+ LinearHashTable k v -> k -> IO (Maybe Word) #-}+{-# SPECIALIZE INLINE lookupIndex :: (Eq k, Hashable k) =>+ CuckooHashTable k v -> k -> IO (Maybe Word) #-}++------------------------------------------------------------------------------+-- | See the documentation for this function in "Data.HashTable.Class#v:nextByIndex".+nextByIndex :: (C.HashTable h, Eq k, Hashable k) =>+ IOHashTable h k v -> Word -> IO (Maybe (Word,k,v))+nextByIndex h k = stToIO $ C.nextByIndex h k+{-# INLINE nextByIndex #-}+{-# SPECIALIZE INLINE nextByIndex :: (Eq k, Hashable k) =>+ BasicHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}+{-# SPECIALIZE INLINE nextByIndex :: (Eq k, Hashable k) =>+ LinearHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}+{-# SPECIALIZE INLINE nextByIndex :: (Eq k, Hashable k) =>+ CuckooHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}++------------------------------------------------------------------------------+-- | See the documentation for this function in "Data.HashTable.Class#v:mutate".+mutate :: (C.HashTable h, Eq k, Hashable k) =>+ IOHashTable h k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a+mutate h k f = stToIO $ C.mutate h k f+{-# INLINE mutate #-}+{-# SPECIALIZE INLINE mutate :: (Eq k, Hashable k) =>+ BasicHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutate :: (Eq k, Hashable k) =>+ LinearHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutate :: (Eq k, Hashable k) =>+ CuckooHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-} ------------------------------------------------------------------------------
src/Data/HashTable/Internal/CacheLine.hs view
@@ -16,6 +16,7 @@ , bl_abs# , sign# , mask#+ , mask , maskw# ) where @@ -190,6 +191,12 @@ but GHC doesn't properly optimize this as straight-line code at the moment. -}+++{-# INLINE mask #-}+-- | Returns 0xfff..fff (aka -1) if a == b, 0 otherwise.+mask :: Int -> Int -> Int+mask (I# a#) (I# b#) = I# (mask# a# b#) {-# INLINE maskw# #-}
src/Data/HashTable/Internal/IntArray.hs view
@@ -71,7 +71,7 @@ ------------------------------------------------------------------------------ wordSizeInBytes :: Int-wordSizeInBytes = bitSize (0::Elem) `div` 8+wordSizeInBytes = finiteBitSize (0::Elem) `div` 8 ------------------------------------------------------------------------------
src/Data/HashTable/Internal/Linear/Bucket.hs view
@@ -10,7 +10,10 @@ snoc, size, lookup,+ lookupIndex,+ elemAt, delete,+ mutate, toList, fromList, mapM_,@@ -229,7 +232,38 @@ return $! Just v else go (i-1) +------------------------------------------------------------------------------+-- note: search in reverse order! We prefer recently snoc'd keys.+lookupIndex :: (Eq k) => Bucket s k v -> k -> ST s (Maybe Int)+lookupIndex bucketKey !k+ | keyIsEmpty bucketKey = return Nothing+ | otherwise = lookup' $ fromKey bucketKey+ where+ lookup' (Bucket _ hwRef keys _values) = do+ hw <- readSTRef hwRef+ go (hw-1)+ where+ go !i+ | i < 0 = return Nothing+ | otherwise = do+ k' <- readArray keys i+ if k == k'+ then return (Just i)+ else go (i-1) +elemAt :: Bucket s k v -> Int -> ST s (Maybe (k,v))+elemAt bucketKey ix+ | keyIsEmpty bucketKey = return Nothing+ | otherwise = lookup' $ fromKey bucketKey+ where+ lookup' (Bucket _ hwRef keys values) = do+ hw <- readSTRef hwRef+ if 0 <= ix && ix < hw+ then do k <- readArray keys ix+ v <- readArray values ix+ return (Just (k,v))+ else return Nothing+ ------------------------------------------------------------------------------ {-# INLINE toList #-} toList :: Bucket s k v -> ST s [(k,v)]@@ -284,6 +318,52 @@ writeSTRef hwRef hw' return True else go hw (i-1)+++------------------------------------------------------------------------------+mutate :: (Eq k) =>+ Bucket s k v+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s (Int, Maybe (Bucket s k v), a)+mutate bucketKey !k !f+ | keyIsEmpty bucketKey =+ case f Nothing of+ (Nothing, a) -> return (0, Nothing, a)+ (Just v', a) -> do+ (!hw', mbk) <- snoc bucketKey k v'+ return (hw', mbk, a)+ | otherwise = mutate' $ fromKey bucketKey+ where+ mutate' (Bucket sz hwRef keys values) = do+ hw <- readSTRef hwRef+ pos <- findPosition hw (hw-1)+ mv <- do+ if pos < 0+ then return Nothing+ else readArray values pos >>= return . Just+ case (mv, f mv) of+ (Nothing, (Nothing, a)) -> return (hw, Nothing, a)+ (Nothing, (Just v', a)) -> do+ (!hw', mbk) <- snoc bucketKey k v'+ return (hw', mbk, a)+ (Just v, (Just v', a)) -> do+ writeArray values pos v'+ return (hw, Nothing, a)+ (Just v, (Nothing, a)) -> do+ move (hw-1) pos keys+ move (hw-1) pos values+ let !hw' = hw-1+ writeSTRef hwRef hw'+ return (hw', Nothing, a)+ where+ findPosition !hw !i+ | i < 0 = return (-1)+ | otherwise = do+ k' <- readArray keys i+ if k == k'+ then return i+ else findPosition hw (i-1) ------------------------------------------------------------------------------
src/Data/HashTable/Internal/Utils.hs view
@@ -41,7 +41,7 @@ ------------------------------------------------------------------------------ wordSize :: Int-wordSize = bitSize (0::Int)+wordSize = finiteBitSize (0::Int) cacheLineSize :: Int@@ -51,7 +51,7 @@ numElemsInCacheLine :: Int numElemsInCacheLine = z where- !z = cacheLineSize `div` (bitSize (0::Elem) `div` 8)+ !z = cacheLineSize `div` (finiteBitSize (0::Elem) `div` 8) -- | What you have to mask an integer index by to tell if it's
src/Data/HashTable/ST/Basic.hs view
@@ -87,6 +87,7 @@ , delete , lookup , insert+ , mutate , mapM_ , foldM , computeOverhead@@ -122,7 +123,7 @@ type SizeRefs s = A.MutableByteArray s intSz :: Int-intSz = (bitSize (0::Int) `div` 8)+intSz = (finiteBitSize (0::Int) `div` 8) readLoad :: SizeRefs s -> ST s Int readLoad = flip A.readByteArray 0@@ -163,7 +164,10 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate ------------------------------------------------------------------------------@@ -213,10 +217,9 @@ -> k -> ST s () delete htRef k = do- debug $ "entered: delete: hash=" ++ show h ht <- readRef htRef- _ <- delete' ht True k h- return ()+ slots <- findSafeSlots ht k h+ when (trueInt (_slotFound slots)) $ deleteFromSlot ht (_slotB1 slots) where !h = hash k {-# INLINE delete #-}@@ -284,34 +287,57 @@ -> ST s () insert htRef !k !v = do ht <- readRef htRef- !ht' <- insert' ht+ debug $ "insert: h=" ++ show h+ slots@(SlotFindResponse foundInt b0 b1) <- findSafeSlots ht k h+ let found = trueInt foundInt+ debug $ "insert: findSafeSlots returned " ++ show slots+ when (found && (b0 /= b1)) $ deleteFromSlot ht b1+ insertIntoSlot ht b0 he k v+ ht' <- checkOverflow ht writeRef htRef ht' where- insert' ht = do- debug "insert': calling delete'"- b <- delete' ht False k h+ !h = hash k+ !he = hashToElem h+{-# INLINE insert #-} - debug $ concat [ "insert': writing h="- , show h- , " he="- , show he- , " b="- , show b- ]- U.writeArray hashes b he- writeArray keys b k- writeArray values b v - checkOverflow ht-- where- !h = hash k- !he = hashToElem h- hashes = _hashes ht- keys = _keys ht- values = _values ht-{-# INLINE insert #-}+------------------------------------------------------------------------------+-- | See the documentation for this function in+-- "Data.HashTable.Class#v:alter".+mutate :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef !k !f = do+ ht <- readRef htRef+ let values = _values ht+ debug $ "mutate h=" ++ show h+ slots@(SlotFindResponse foundInt b0 b1) <- findSafeSlots ht k h+ let found = trueInt foundInt+ debug $ "findSafeSlots returned " ++ show slots+ !mv <- if found+ then fmap Just $ readArray values b1+ else return Nothing+ let (!mv', !result) = f mv+ case (mv, mv') of+ (Nothing, Nothing) -> return ()+ (Just _, Nothing) -> do+ deleteFromSlot ht b1+ (Nothing, Just v') -> do+ insertIntoSlot ht b0 he k v'+ ht' <- checkOverflow ht+ writeRef htRef ht'+ (Just _, Just v') -> do+ when (b0 /= b1) $+ deleteFromSlot ht b1+ insertIntoSlot ht b0 he k v'+ return result+ where+ !h = hash k+ !he = hashToElem h+{-# INLINE mutate #-} ------------------------------------------------------------------------------@@ -365,7 +391,7 @@ let k = fromIntegral ld / sz return $ constOverhead/sz + (2 + 2*ws*(1-k)) / (k * ws) where- ws = fromIntegral $! bitSize (0::Int) `div` 8+ ws = fromIntegral $! finiteBitSize (0::Int) `div` 8 sz = fromIntegral sz' -- Change these if you change the representation constOverhead = 14@@ -409,8 +435,6 @@ -> ST s (HashTable_ s k v) checkOverflow ht@(HashTable sz ldRef _ _ _) = do !ld <- readLoad ldRef- let !ld' = ld + 1- writeLoad ldRef ld' !dl <- readDelLoad ldRef debug $ concat [ "checkOverflow: sz="@@ -459,56 +483,54 @@ --------------------------------------------------------------------------------- Helper data structure for delete'-data Slot = Slot {- _slot :: {-# UNPACK #-} !Int- , _wasDeleted :: {-# UNPACK #-} !Int -- we use Int because Bool won't- -- unpack- }- deriving (Show)+-- Helper data structure for findSafeSlots+newtype Slot = Slot { _slot :: Int } deriving (Show) ------------------------------------------------------------------------------ instance Monoid Slot where- mempty = Slot maxBound 0- (Slot x1 b1) `mappend` (Slot x2 b2) =- if x1 == maxBound then Slot x2 b2 else Slot x1 b1+ mempty = Slot maxBound+ (Slot x1) `mappend` (Slot x2) =+ let !m = mask x1 maxBound+ in Slot $! (complement m .&. x1) .|. (m .&. x2) --------------------------------------------------------------------------------- Returns the slot in the array where it would be safe to write the given key.-delete' :: (Hashable k, Eq k) =>- (HashTable_ s k v)- -> Bool- -> k- -> Int- -> ST s Int-delete' (HashTable sz loadRef hashes keys values) clearOut k h = do- debug $ "delete': h=" ++ show h ++ " he=" ++ show he- ++ " sz=" ++ show sz ++ " b0=" ++ show b0- pair@(found, slot) <- go mempty b0 False- debug $ "go returned " ++ show pair+-- findSafeSlots return type+data SlotFindResponse = SlotFindResponse {+ _slotFound :: {-# UNPACK #-} !Int -- we use Int because Bool won't unpack+ , _slotB0 :: {-# UNPACK #-} !Int+ , _slotB1 :: {-# UNPACK #-} !Int+} deriving (Show) - let !b' = _slot slot - when found $ bump loadRef (-1)-- -- bump the delRef lower if we're writing over a deleted marker- when (not clearOut && _wasDeleted slot == 1) $ bumpDel loadRef (-1)- return b'+------------------------------------------------------------------------------+-- Returns ST s (SlotFoundResponse found b0 b1),+-- where+-- * found :: Int - 1 if key-value mapping is already in the table,+-- 0 otherwise.+-- * b0 :: Int - The index of a slot where it would be safe to write+-- the given key (if the key is already in the mapping,+-- you have to delete it before using this slot).+-- * b1 :: Int - The index of a slot where the key currently resides.+-- Or, if the key is not in the table, b1 is a slot+-- where it is safe to write the key (b1 == b0).+findSafeSlots :: (Hashable k, Eq k) =>+ (HashTable_ s k v)+ -> k+ -> Int+ -> ST s SlotFindResponse+findSafeSlots (HashTable !sz _ hashes keys _) k h = do+ debug $ "findSafeSlots: h=" ++ show h ++ " he=" ++ show he+ ++ " sz=" ++ show sz ++ " b0=" ++ show b0+ response <- go mempty b0 False+ debug $ "go returned " ++ show response+ return response where- he = hashToElem h- bump ref i = do- !ld <- readLoad ref- writeLoad ref $! ld + i- bumpDel ref i = do- !ld <- readDelLoad ref- writeDelLoad ref $! ld + i-+ !he = hashToElem h !b0 = whichBucket h sz-- haveWrapped !(Slot fp _) !b = if fp == maxBound+ haveWrapped !(Slot fp) !b = if fp == maxBound then False else b <= fp @@ -534,7 +556,8 @@ , show deletedMarker ] !idx <- forwardSearch3 hashes b sz he emptyMarker deletedMarker- debug $ "forwardSearch3 returned " ++ show idx ++ " with sz=" ++ show sz ++ ", b=" ++ show b+ debug $ "forwardSearch3 returned " ++ show idx+ ++ " with sz=" ++ show sz ++ ", b=" ++ show b if wrap && idx >= b0 -- we wrapped around in the search and didn't find our hash code;@@ -543,8 +566,9 @@ -- -- TODO: if we get in this situation we should probably just rehash -- the table, because every insert is going to be O(n).- then return $!- (False, fp `mappend` (Slot (error "impossible") 0))+ then do+ let !sl = fp `mappend` (Slot (error "impossible"))+ return $! SlotFindResponse 0 (_slot sl) (_slot sl) else do -- because the table isn't full, we know that there must be either -- an empty or a deleted marker somewhere in the table. Assert this@@ -555,14 +579,14 @@ if recordIsEmpty h0 then do- let pl = fp `mappend` (Slot idx 0)+ let pl = fp `mappend` (Slot idx) debug $ "empty, returning " ++ show pl- return (False, pl)+ return $! SlotFindResponse 0 (_slot pl) (_slot pl) else do let !wrap' = haveWrapped fp idx if recordIsDeleted h0 then do- let pl = fp `mappend` (Slot idx 1)+ let !pl = fp `mappend` (Slot idx) debug $ "deleted, cont with pl=" ++ show pl go pl (idx + 1) wrap' else@@ -572,27 +596,63 @@ k' <- readArray keys idx if k == k' then do- let samePlace = _slot fp == idx debug $ "found at " ++ show idx- debug $ "clearout=" ++ show clearOut- debug $ "sp? " ++ show samePlace- -- "clearOut" is set if we intend to write a new- -- element into the slot. If we're doing an update- -- and we found the old key, instead of writing- -- "deleted" and then re-writing the new element- -- there, we can just write the new element. This- -- only works if we were planning on writing the- -- new element here.- when (clearOut || not samePlace) $ do- bumpDel loadRef 1- U.writeArray hashes idx deletedMarker- writeArray keys idx undefined- writeArray values idx undefined- return (True, fp `mappend` (Slot idx 0))+ let !sl = fp `mappend` (Slot idx)+ return $! SlotFindResponse 1 (_slot sl) idx else go fp (idx + 1) wrap' else go fp (idx + 1) wrap' + ------------------------------------------------------------------------------+{-# INLINE deleteFromSlot #-}+deleteFromSlot :: (HashTable_ s k v) -> Int -> ST s ()+deleteFromSlot (HashTable _ loadRef hashes keys values) idx = do+ !he <- U.readArray hashes idx+ when (recordIsFilled he) $ do+ bumpDelLoad loadRef 1+ bumpLoad loadRef (-1)+ U.writeArray hashes idx deletedMarker+ writeArray keys idx undefined+ writeArray values idx undefined+++------------------------------------------------------------------------------+{-# INLINE insertIntoSlot #-}+insertIntoSlot :: (HashTable_ s k v) -> Int -> Elem -> k -> v -> ST s ()+insertIntoSlot (HashTable _ loadRef hashes keys values) idx he k v = do+ !heOld <- U.readArray hashes idx+ let !heInt = fromIntegral heOld :: Int+ !delInt = fromIntegral deletedMarker :: Int+ !emptyInt = fromIntegral emptyMarker :: Int+ !delBump = mask heInt delInt -- -1 if heInt == delInt,+ -- 0 otherwise+ !mLoad = mask heInt delInt .|. mask heInt emptyInt+ !loadBump = mLoad .&. 1 -- 1 if heInt == delInt || heInt == emptyInt,+ -- 0 otherwise+ bumpDelLoad loadRef delBump+ bumpLoad loadRef loadBump+ U.writeArray hashes idx he+ writeArray keys idx k+ writeArray values idx v+++-------------------------------------------------------------------------------+{-# INLINE bumpLoad #-}+bumpLoad :: (SizeRefs s) -> Int -> ST s ()+bumpLoad ref i = do+ !ld <- readLoad ref+ writeLoad ref $! ld + i+++------------------------------------------------------------------------------+{-# INLINE bumpDelLoad #-}+bumpDelLoad :: (SizeRefs s) -> Int -> ST s ()+bumpDelLoad ref i = do+ !ld <- readDelLoad ref+ writeDelLoad ref $! ld + i+++----------------------------------------------------------------------------- maxLoad :: Double maxLoad = 0.82 @@ -601,12 +661,19 @@ emptyMarker :: Elem emptyMarker = 0 + ------------------------------------------------------------------------------ deletedMarker :: Elem deletedMarker = 1 ------------------------------------------------------------------------------+{-# INLINE trueInt #-}+trueInt :: Int -> Bool+trueInt (I# i#) = tagToEnum# i#+++------------------------------------------------------------------------------ {-# INLINE recordIsEmpty #-} recordIsEmpty :: Elem -> Bool recordIsEmpty = (== emptyMarker)@@ -619,6 +686,22 @@ ------------------------------------------------------------------------------+{-# INLINE recordIsFilled #-}+recordIsFilled :: Elem -> Bool+recordIsFilled !el = tagToEnum# isFilled#+ where+ !el# = U.elemToInt# el+ !deletedMarker# = U.elemToInt# deletedMarker+ !emptyMarker# = U.elemToInt# emptyMarker+#if __GLASGOW_HASKELL__ >= 708+ !isFilled# = (el# /=# deletedMarker#) `andI#` (el# /=# emptyMarker#)+#else+ !delOrEmpty# = mask# el# deletedMarker# `orI#` mask# el# emptyMarker#+ !isFilled# = 1# `andI#` notI# delOrEmpty#+#endif+++------------------------------------------------------------------------------ {-# INLINE hash #-} hash :: (Hashable k) => k -> Int hash = H.hash@@ -660,3 +743,67 @@ #else debug _ = return () #endif++lookupIndex :: (Eq k, Hashable k) => HashTable s k v -> k -> ST s (Maybe Word)+lookupIndex htRef !k = do+ ht <- readRef htRef+ lookup' ht+ where+ lookup' (HashTable sz _ hashes keys _values) = do+ let !b = whichBucket h sz+ debug $ "lookup h=" ++ show h ++ " sz=" ++ show sz ++ " b=" ++ show b+ go b 0 sz++ where+ !h = hash k+ !he = hashToElem h++ go !b !start !end = {-# SCC "lookupIndex/go" #-} do+ debug $ concat [ "lookupIndex/go: "+ , show b+ , "/"+ , show start+ , "/"+ , show end+ ]+ idx <- forwardSearch2 hashes b end he emptyMarker+ debug $ "forwardSearch2 returned " ++ show idx+ if (idx < 0 || idx < start || idx >= end)+ then return Nothing+ else do+ h0 <- U.readArray hashes idx+ debug $ "h0 was " ++ show h0++ if recordIsEmpty h0+ then do+ debug $ "record empty, returning Nothing"+ return Nothing+ else do+ k' <- readArray keys idx+ if k == k'+ then do+ debug $ "value found at " ++ show idx+ return $! (Just $! fromIntegral idx)+ else do+ debug $ "value not found, recursing"+ if idx < b+ then go (idx + 1) (idx + 1) b+ else go (idx + 1) start end+{-# INLINE lookupIndex #-}++nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word, k, v))+nextByIndex htRef i0 = readRef htRef >>= work+ where+ work (HashTable sz _ hashes keys values) = go (fromIntegral i0)+ where+ go i | i >= sz = return Nothing+ | otherwise = do+ h <- U.readArray hashes i+ if recordIsEmpty h || recordIsDeleted h+ then go (i+1)+ else do+ k <- readArray keys i+ v <- readArray values i+ let !i' = fromIntegral i+ return (Just (i', k, v))+{-# INLINE nextByIndex #-}
src/Data/HashTable/ST/Cuckoo.hs view
@@ -68,8 +68,11 @@ , delete , lookup , insert+ , mutate , mapM_ , foldM+ , lookupIndex+ , nextByIndex ) where @@ -128,7 +131,10 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate ------------------------------------------------------------------------------@@ -163,6 +169,20 @@ ------------------------------------------------------------------------------+mutate :: (Eq k, Hashable k) =>+ HashTable s k v+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef !k !f = do+ ht <- readRef htRef+ (newHt, a) <- mutate' ht k f+ writeRef htRef newHt+ return a+{-# INLINE mutate #-}+++------------------------------------------------------------------------------ -- | See the documentation for this function in -- "Data.HashTable.Class#v:computeOverhead". computeOverhead :: HashTable s k v -> ST s Double@@ -179,7 +199,7 @@ return $! fromIntegral (oh::Int) / fromIntegral nFilled where- hashCodesPerWord = (bitSize (0 :: Int)) `div` 16+ hashCodesPerWord = (finiteBitSize (0 :: Int)) `div` 16 totSz = numElemsInCacheLine * sz f !a _ = return $! a+1@@ -391,6 +411,101 @@ ------------------------------------------------------------------------------+mutate' :: (Eq k, Hashable k) =>+ HashTable_ s k v+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s (HashTable_ s k v, a)+mutate' ht@(HashTable sz _ hashes keys values _) !k !f = do+ !(maybeVal, idx, hashCode) <- lookupSlot+ case (maybeVal, f maybeVal) of+ (Nothing, (Nothing, a)) -> return (ht, a)+ (Just v, (Just v', a)) -> do+ writeArray values idx v'+ return (ht, a)+ (Just v, (Nothing, a)) -> do+ deleteFromSlot ht idx+ return (ht, a)+ (Nothing, (Just v', a)) -> do+ newHt <- insertNew v'+ return (newHt, a)++ where+ h1 = hash1 k+ h2 = hash2 k++ b1 = whichLine h1 sz+ b2 = whichLine h2 sz+ + he1 = hashToElem h1+ he2 = hashToElem h2++ lookupSlot = do+ idx1 <- searchOne keys hashes k b1 he1+ if idx1 >= 0+ then do+ v <- readArray values idx1+ return (Just v, idx1, h1)+ else do+ idx2 <- searchOne keys hashes k b2 he2+ if idx2 >= 0+ then do+ v <- readArray values idx2+ return (Just v, idx2, h2)+ else do+ return (Nothing, -1, -1)++ insertNew v = do+ idxE1 <- cacheLineSearch hashes b1 emptyMarker+ if idxE1 >= 0+ then do+ insertIntoSlot ht idxE1 he1 k v+ return ht+ else do+ idxE2 <- cacheLineSearch hashes b2 emptyMarker+ if idxE2 >= 0+ then do+ insertIntoSlot ht idxE2 he2 k v+ return ht+ else do+ result <- cuckooOrFail ht h1 h2 b1 b2 k v+ maybe (return ht)+ (\(k', v') -> do+ newHt <- grow ht k v+ return newHt)+ result+{-# INLINE mutate' #-}+++------------------------------------------------------------------------------+deleteFromSlot :: (Eq k, Hashable k) =>+ HashTable_ s k v+ -> Int+ -> ST s ()+deleteFromSlot ht@(HashTable _ _ hashes keys values _) idx = do+ U.writeArray hashes idx emptyMarker+ writeArray keys idx undefined+ writeArray values idx undefined+{-# INLINE deleteFromSlot #-}+++------------------------------------------------------------------------------+insertIntoSlot :: (Eq k, Hashable k) =>+ HashTable_ s k v+ -> Int+ -> Elem+ -> k+ -> v+ -> ST s ()+insertIntoSlot ht@(HashTable _ _ hashes keys values _) idx he k v = do+ U.writeArray hashes idx he+ writeArray keys idx k+ writeArray values idx v+{-# INLINE insertIntoSlot #-}++++------------------------------------------------------------------------------ updateOrFail :: (Eq k, Hashable k) => HashTable_ s k v -> k@@ -692,3 +807,44 @@ readRef :: HashTable s k v -> ST s (HashTable_ s k v) readRef (HT ref) = readSTRef ref {-# INLINE readRef #-}+++------------------------------------------------------------------------------++-- | Find index of given key in the hashtable.+lookupIndex :: (Hashable k, Eq k) => HashTable s k v -> k -> ST s (Maybe Word)+lookupIndex htRef k =+ do HashTable sz _ hashes keys _ _ <- readRef htRef++ let !h1 = hash1 k+ !h2 = hash2 k+ !he1 = hashToElem h1+ !he2 = hashToElem h2+ !b1 = whichLine h1 sz+ !b2 = whichLine h2 sz++ idx1 <- searchOne keys hashes k b1 he1+ if idx1 >= 0+ then return $! (Just $! fromIntegral idx1)+ else do idx2 <- searchOne keys hashes k b2 he2+ if idx2 >= 0+ then return $! (Just $! fromIntegral idx2)+ else return Nothing++-- | Find the next entry in the hashtable starting at the given index.+nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word,k,v))+nextByIndex htRef i0 =+ do HashTable sz _ hashes keys values _ <- readRef htRef+ let totSz = numElemsInCacheLine * sz+ go i+ | i >= totSz = return Nothing+ | otherwise =+ do h <- U.readArray hashes i+ if h == emptyMarker+ then go (i+1)+ else do k <- readArray keys i+ v <- readArray values i+ let !i' = fromIntegral i+ return (Just (i',k,v))++ go (fromIntegral i0)
src/Data/HashTable/ST/Linear.hs view
@@ -83,6 +83,7 @@ , delete , lookup , insert+ , mutate , mapM_ , foldM , computeOverhead@@ -127,7 +128,10 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate ------------------------------------------------------------------------------@@ -218,7 +222,31 @@ {-# INLINE insert #-} +------------------------------------------------------------------------------+mutate :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef k f = do+ (ht, a) <- readRef htRef >>= work+ writeRef htRef ht+ return a+ where+ work ht@(HashTable lvl splitptr buckets) = do+ let !h0 = hashKey lvl splitptr k+ bucket <- readArray buckets h0+ (!bsz, mbk, a) <- Bucket.mutate bucket k f+ maybe (return ())+ (writeArray buckets h0)+ mbk+ if checkOverflow bsz+ then do+ ht' <- split ht+ return (ht', a)+ else return (ht, a) + ------------------------------------------------------------------------------ -- | See the documentation for this function in -- "Data.HashTable.Class#v:mapM_".@@ -459,3 +487,57 @@ #endif #endif ++------------------------------------------------------------------------------+-- | See the documentation for this function in+-- "Data.HashTable.Class#v:lookupIndex".+lookupIndex :: (Eq k, Hashable k) => HashTable s k v -> k -> ST s (Maybe Word)+lookupIndex htRef !k = readRef htRef >>= work+ where+ work (HashTable lvl splitptr buckets) = do+ let h0 = hashKey lvl splitptr k+ bucket <- readArray buckets h0+ mbIx <- Bucket.lookupIndex bucket k+ return $! do ix <- mbIx+ Just $! encodeIndex lvl h0 ix+{-# INLINE lookupIndex #-}++encodeIndex :: Int -> Int -> Int -> Word+encodeIndex lvl bucketIx elemIx =+ fromIntegral bucketIx `Data.Bits.shiftL` indexOffset lvl .|.+ fromIntegral elemIx+{-# INLINE encodeIndex #-}++decodeIndex :: Int -> Word -> (Int, Int)+decodeIndex lvl ix =+ ( fromIntegral (ix `Data.Bits.shiftR` offset)+ , fromIntegral ( (bit offset - 1) .&. ix )+ )+ where offset = indexOffset lvl+{-# INLINE decodeIndex #-}++indexOffset :: Int -> Int+indexOffset lvl = finiteBitSize (0 :: Word) - lvl+{-# INLINE indexOffset #-}++nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word,k,v))+nextByIndex htRef !k = readRef htRef >>= work+ where+ work (HashTable lvl _ buckets) = do+ let (h0,ix) = decodeIndex lvl k+ go h0 ix++ where+ bucketN = power2 lvl+ go h ix+ | h < 0 || bucketN <= h = return Nothing+ | otherwise = do+ bucket <- readArray buckets h+ mb <- Bucket.elemAt bucket ix+ case mb of+ Just (k',v) ->+ let !ix' = encodeIndex lvl h ix+ in return (Just (ix', k', v))+ Nothing -> go (h+1) 0++{-# INLINE nextByIndex #-}
test/compute-overhead/ComputeOverhead.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} module Main where
test/hashtables-test.cabal view
@@ -67,7 +67,7 @@ Build-depends: base >= 4 && <5, hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,- mwc-random >= 0.8 && <0.13,+ mwc-random >= 0.8 && <0.14, primitive, QuickCheck >= 2.3.0.2, HUnit >= 1.2 && <2,@@ -120,13 +120,13 @@ Build-depends: base >= 4 && <5, hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,- mwc-random >= 0.8 && <0.13,+ mwc-random >= 0.8 && <0.14, QuickCheck >= 2.3.0.2 && <3, HUnit >= 1.2 && <2, test-framework >= 0.3.1 && <0.9, test-framework-quickcheck2 >= 0.2.6 && <0.4, test-framework-hunit >= 0.2.6 && <3,- statistics >= 0.8 && <0.11,+ statistics >= 0.8 && <0.14, primitive, vector >= 0.7
test/suite/Data/HashTable/Test/Common.hs view
@@ -11,7 +11,9 @@ ) where ------------------------------------------------------------------------------+import Control.Applicative (pure, (<|>)) import Control.Monad (foldM_, liftM, when)+import qualified Control.Monad as Monad import Data.IORef import Data.List hiding (delete, insert, lookup)@@ -62,6 +64,12 @@ #endif +------------------------------------------------------------------------------+announceQ :: Show a => String -> a -> PropertyM IO ()+announceQ nm x = run $ announce nm x+++------------------------------------------------------------------------------ assertEq :: (Eq a, Show a) => String -> a -> a -> PropertyM IO () assertEq s expected got =@@ -95,6 +103,7 @@ , SomeTest testDelete , SomeTest testNastyFullLookup , SomeTest testForwardSearch3+ , SomeTest testMutate ] @@ -109,8 +118,8 @@ where prop :: GenIO -> [(Int, Int)] -> PropertyM IO () prop rng origL = do- let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL- run $ announce "fromListToList" l+ let l = V.toList $ shuffleVector rng $ V.fromList $ dedupe origL+ announceQ "fromListToList" l ht <- run $ fromList l l' <- run $ toList ht assertEq "fromList . toList == id" (sort l) (sort l')@@ -128,8 +137,8 @@ where prop :: GenIO -> ([(Int, Int)], (Int,Int)) -> PropertyM IO () prop rng o@(origL, (k,v)) = do- run $ announce "insert" o- let l = V.toList $ shuffle rng $ V.fromList $ remove k $ dedupe origL+ announceQ "insert" o+ let l = V.toList $ shuffleVector rng $ V.fromList $ remove k $ dedupe origL assert $ all (\t -> fst t /= k) l ht <- run $ fromList l@@ -154,8 +163,8 @@ where prop :: GenIO -> ([(Int, Int)], (Int,Int,Int)) -> PropertyM IO () prop rng o@(origL, (k,v,v2)) = do- run $ announce "insert2" o- let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL+ announceQ "insert2" o+ let l = V.toList $ shuffleVector rng $ V.fromList $ dedupe origL ht <- run $ fromList l run $ insert ht k v@@ -178,7 +187,7 @@ where prop :: (Int,Int,Int) -> PropertyM IO () prop o@(k,v,v2) = do- run $ announce "newAndInsert" o+ announceQ "newAndInsert" o ht <- run new nothing <- run $ lookup ht k@@ -225,7 +234,7 @@ prop :: Int -> PropertyM IO () prop n = do- run $ announce "growTable" n+ announceQ "growTable" n ht <- run $ go n i <- liftM head $ run $ sample' $ choose (0,n-1) @@ -271,7 +280,7 @@ prop :: Int -> PropertyM IO () prop n = do- run $ announce "delete" n+ announceQ "delete" n ht <- run $ go n @@ -288,6 +297,34 @@ ------------------------------------------------------------------------------+testMutate :: HashTest+testMutate prefix dummyArg = testProperty (prefix ++ "/mutate") $+ monadicIO $ forAllM arbitrary prop+ where+ prop :: ([(Int, Int)], [(Int, [Int])]) -> PropertyM IO ()+ prop o@(seedList, testList) = do+ announceQ "mutate" o+ ht <- run $ fromList seedList+ Monad.mapM_ (testOne ht) testList+++ upd n v = (fmap (+ n) v <|> pure n, ())++ testOne ht (k, values) = do+ pre . not . null $ values+ run $ mutate ht k (const (Nothing, ()))+ out1 <- run $ lookup ht k+ assertEq ("mutate deletes " ++ show k) Nothing out1+ out2 <- run $ do+ Monad.mapM_ (mutate ht k . upd) values+ (Just v) <- lookup ht k+ return $! v+ let s = sum values+ assertEq "mutate inserts correctly folded list value" s out2+ forceType dummyArg ht+++------------------------------------------------------------------------------ data Action = Lookup Int | Insert Int | Delete Int@@ -477,8 +514,8 @@ -------------------------------------------------------------------------------shuffle :: GenIO -> Vector k -> Vector k-shuffle rng v = if V.null v then v else V.modify go v+shuffleVector :: GenIO -> Vector k -> Vector k+shuffleVector rng v = if V.null v then v else V.modify go v where !n = V.length v