hashtables 1.2.1.1 → 1.4.2
raw patch · 27 files changed
Files
- benchmark/hashtable-benchmark.cabal +5/−5
- benchmark/src/Criterion/Collection/Internal/Types.hs +1/−1
- benchmark/src/Data/Vector/Algorithms/Shuffle.hs +1/−1
- benchmark/src/Main.hs +0/−19
- cabal.project +8/−0
- cbits/common.c +2/−6
- cbits/defs.h +1/−1
- cbits/sse-42-check.c +1/−1
- changelog.md +90/−0
- hashtables.cabal +116/−14
- src/Data/HashTable/Class.hs +34/−2
- src/Data/HashTable/IO.hs +89/−29
- src/Data/HashTable/Internal/CacheLine.hs +14/−11
- src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs +6/−1
- src/Data/HashTable/Internal/IntArray.hs +25/−5
- src/Data/HashTable/Internal/Linear/Bucket.hs +96/−0
- src/Data/HashTable/Internal/UnsafeTricks.hs +1/−9
- src/Data/HashTable/Internal/Utils.hs +2/−2
- src/Data/HashTable/ST/Basic.hs +284/−98
- src/Data/HashTable/ST/Cuckoo.hs +181/−9
- src/Data/HashTable/ST/Linear.hs +98/−0
- test/compute-overhead/ComputeOverhead.hs +1/−0
- test/hashtables-test.cabal +4/−60
- test/runTestsAndCoverage.sh +0/−46
- test/runTestsNoCoverage.sh +0/−20
- test/suite/Data/HashTable/Test/Common.hs +78/−26
- test/suite/TestSuite.hs +2/−2
benchmark/hashtable-benchmark.cabal view
@@ -21,20 +21,20 @@ base16-bytestring == 0.1.*, bytestring >= 0.9 && <0.11, containers >= 0.4 && <0.6,- criterion >= 0.8 && <0.9,+ criterion >= 1.2 && <1.3, csv == 0.1.*,- deepseq >= 1.1 && <1.4,+ deepseq >= 1.1 && <1.5, filepath == 1.*, hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3, hashtables >= 1.2 && <1.3, mtl == 2.*, mwc-random >= 0.8 && <0.14, primitive,- statistics >= 0.8 && <0.11,+ statistics >= 0.14 && <0.15, threads >= 0.4 && <0.6, unordered-containers >= 0.2 && <0.3,- vector >= 0.7 && <0.12,- vector-algorithms >= 0.5 && <0.6+ vector >= 0.7 && <0.13,+ vector-algorithms >= 0.5 && <0.8 if flag(chart) Build-depends: Chart == 0.14.*,
benchmark/src/Criterion/Collection/Internal/Types.hs view
@@ -38,7 +38,7 @@ ------------------------------------------------------------------------------ newtype WorkloadMonad a = WM (ReaderT GenIO IO a)- deriving (Monad, MonadIO)+ deriving (Functor, Applicative, Monad, MonadIO) ------------------------------------------------------------------------------
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)
+ cabal.project view
@@ -0,0 +1,8 @@+packages: .++tests: True++test-show-details: direct++allow-newer:+ , *:base
cbits/common.c view
@@ -3,7 +3,7 @@ #ifdef WIN32 #include <windows.h> #else-#include <signal.h>+#include <stdlib.h> #include <unistd.h> #endif @@ -19,11 +19,7 @@ #endif if (*check) { printf("timeout expired, dying!!\n");-#ifdef WIN32- abort();-#else- raise(SIGKILL);-#endif+ exit(1); } }
cbits/defs.h view
@@ -30,6 +30,6 @@ void suicide(volatile int* check, int i); void CHECK(int actual, int expected, char* what);-void check_impl_specific();+void check_impl_specific(int* num_tests, int* num_errors); #endif /* HASHTABLES_DEFS_H */
cbits/sse-42-check.c view
@@ -29,7 +29,7 @@ #undef F } -void check_impl_specific() {+void check_impl_specific(int* num_tests, int* num_errors) { check_fill(0); check_fill((small_hash_t) (-1)); check_fill((small_hash_t) (-5));
changelog.md view
@@ -1,5 +1,95 @@ # Hashtables changelog +## 1.4.2++ - Fix C compile errors in cbits.+ - Bump lower bound for QuickCheck.++## 1.4.1++ - Fix broken compile when compiling with `-fportable` flag.+ - Make it build with GHC WASM (Bodigrim).++## 1.4.0++ - Replace deprecated Mutable Array function, which modifies the signature of the `length`+ function and hence the API.+ - Support more recent compilers.++## 1.3.1++ - Fix Noncanonical mappend definition warning.+ - Support more recent compilers.+++## 1.3++ - Support Hashable 1.4. This new version of Hashable drops the Eq constraint, so the Eq constraint+ needs to be dropped in the SPECIALIZE statements in Hashtables.++## 1.2.4.2++ - Cabal file: add missing other-modules+ - Silence import warnings. Know that we require ghc >= 7.8.+ - Fix build with GHC 9.2++## 1.2.4.1++ - Update some test suite dep upper bounds.++## 1.2.4.0++ - Fix a [correctness bug](https://github.com/gregorycollins/hashtables/issues/55)+with cuckoo hash tables and the new `mutate` function introduced in 1.2.3.0.++ - Bring test suite into main .cabal file++## 1.2.3.4++Fix build with GHC 8.8.++## 1.2.3.3++Fix build with certain versions of `primitive` (thx again Carter)++## 1.2.3.2++ - CPP fix for breakage caused by primitive 0.7 (thx Carter)++ - Fix some haddock syntax errors (thx Frederik Hanghøj Iversen)++ - Fix typo in module reference (thx Don Allen)++## 1.2.3.1++ - Fix building with GHC <7.10 (thx Vanessa McHale)++## 1.2.3.0++ - update for Semigroup/monoid breakage with GHC 8.4 (thx Fumiaki Kinoshita)++ - Implement mutateST and mutateIO (thx Andy Morris)++ - Fix build breakage w/ "pre" function (thx Andy Morris)++## 1.2.2.1++ - Adjusted base lower bound (it was incorrect), bumped some testsuite ++ benchmark bounds.++## 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,16 +1,32 @@+Cabal-Version: 2.2 Name: hashtables-Version: 1.2.1.1+Version: 1.4.2 Synopsis: Mutable hash tables in the ST monad Homepage: http://github.com/gregorycollins/hashtables-License: BSD3+License: BSD-3-Clause License-file: LICENSE Author: Gregory Collins-Maintainer: greg@gregorycollins.net-Copyright: (c) 2011-2014, Google, Inc.+Maintainer: greg@gregorycollins.net, mgoremeier@gmail.com, erikd@mega-nerd.com+Copyright: (c) 2011-2014, Google, Inc., 2016-present contributors Category: Data Build-type: Simple-Cabal-version: >= 1.8 ++tested-with:+ GHC == 9.12.1+ GHC == 9.10.1+ GHC == 9.8.2+ GHC == 9.6.6+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2+ Description: This package provides a couple of different implementations of mutable hash tables in the ST monad, as well as a typeclass abstracting their common@@ -29,7 +45,7 @@ the table can perform acceptably well even when approaching 90% full. Randomized testing shows this implementation of cuckoo hashing to be slightly faster on insert and slightly slower on lookup than- "Data.Hashtable.ST.Basic", while being more space efficient by about a+ "Data.HashTable.ST.Basic", while being more space efficient by about a half-word per key-value mapping. Cuckoo hashing, like the basic hash table implementation using linear probing, can suffer from long delays when the table is resized.@@ -96,6 +112,7 @@ Extra-Source-Files: README.md,+ cabal.project, haddock.sh, benchmark/hashtable-benchmark.cabal, benchmark/LICENSE,@@ -115,8 +132,6 @@ changelog.md, test/compute-overhead/ComputeOverhead.hs, test/hashtables-test.cabal,- test/runTestsAndCoverage.sh,- test/runTestsNoCoverage.sh, test/suite/Data/HashTable/Test/Common.hs, test/suite/TestSuite.hs @@ -133,7 +148,13 @@ Flag debug Description: if on, spew debugging output to stdout Default: False+ Manual: True +Flag detailed-profiling+ Description: add detailed profiling information to profiled build-depends+ Default: False+ Manual: True+ Flag sse42 Description: if on, use SSE 4.2 extensions to search cache lines very efficiently. The portable flag forces this off.@@ -145,6 +166,7 @@ Library+ Default-Language: Haskell2010 hs-source-dirs: src if flag(sse42) && !flag(portable)@@ -172,10 +194,10 @@ Data.HashTable.Internal.Utils, Data.HashTable.Internal.Linear.Bucket - Build-depends: base >= 4 && <5,- hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,+ Build-depends: base >= 4.7 && <5,+ hashable >= 1.4 && < 1.6, primitive,- vector >= 0.7 && <0.13+ vector >= 0.7 && <0.14 if flag(portable) cpp-options: -DNO_C_SEARCH -DPORTABLE@@ -190,10 +212,90 @@ if flag(bounds-checking) cpp-options: -DBOUNDS_CHECKING - ghc-prof-options: -auto-all+ if flag(detailed-profiling)+ if impl(ghc >= 7.4.1)+ ghc-prof-options: -fprof-auto+ if impl(ghc < 7.4.1)+ ghc-prof-options: -auto-all if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields++test-suite testsuite+ Default-Language: Haskell2010+ hs-source-dirs: src test/suite+ main-is: TestSuite.hs+ type: exitcode-stdio-1.0++ other-modules:+ Data.HashTable.Class+ Data.HashTable.IO+ Data.HashTable.Internal.Array+ Data.HashTable.Internal.CacheLine+ Data.HashTable.Internal.CheapPseudoRandomBitStream+ Data.HashTable.Internal.IntArray+ Data.HashTable.Internal.Linear.Bucket+ Data.HashTable.Internal.UnsafeTricks+ Data.HashTable.Internal.Utils+ Data.HashTable.ST.Basic+ Data.HashTable.ST.Cuckoo+ Data.HashTable.ST.Linear+ Data.HashTable.Test.Common++ if flag(sse42) && !flag(portable)+ cc-options: -DUSE_SSE_4_2 -msse4.2+ cpp-options: -DUSE_SSE_4_2+ C-sources: cbits/sse-42.c++ if !flag(portable) && !flag(sse42)+ C-sources: cbits/default.c++ if !flag(portable)+ C-sources: cbits/common.c++ if flag(detailed-profiling)+ ghc-prof-options: -auto-all++ if flag(portable)+ cpp-options: -DNO_C_SEARCH -DPORTABLE++ if !flag(portable) && flag(unsafe-tricks) && impl(ghc)+ cpp-options: -DUNSAFETRICKS+ build-depends: ghc-prim++ if flag(debug)+ cpp-options: -DDEBUG++ if flag(bounds-checking)+ cpp-options: -DBOUNDS_CHECKING++ Build-depends: base >= 4 && <5,+ hashable >= 1.4 && < 1.6,+ mwc-random >= 0.8 && <0.16,+ primitive,+ QuickCheck >= 2.9,+ tasty >= 1.4 && <= 1.6,+ tasty-quickcheck >= 0.10 && <0.12,+ tasty-hunit >= 0.10 && <0.11,+ vector >= 0.7++ cpp-options: -DTESTSUITE++ if impl(ghc >= 7)+ ghc-options: -rtsopts++ if impl(ghc >= 6.12.0)+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ -fno-warn-unused-do-bind+ else+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields++ if !arch(wasm32)+ ghc-options: -threaded++source-repository head+ type: git+ location: https://github.com/gregorycollins/hashtables.git
src/Data/HashTable/Class.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} -- | This module contains a 'HashTable' typeclass for the hash table -- implementations in this package. This allows you to provide functions which@@ -45,10 +46,13 @@ , toList ) where -+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+import Data.Word (Word)+#endif import Control.Monad.ST import Data.Hashable-import Prelude hiding (mapM_)+import Prelude hiding (mapM_) -- | A typeclass for hash tables in the 'ST' monad. The operations on these -- hash tables are typically both key- and value-strict.@@ -59,6 +63,25 @@ -- | 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+ mutate tbl k f = mutateST tbl k (pure . f)++ -- | As 'mutate', except that the action can perform additional side+ -- effects.+ mutateST :: (Eq k, Hashable k) =>+ h s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a+ -- | Inserts a key/value mapping into a hash table, replacing any existing -- mapping for that key. --@@ -80,6 +103,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,20 +47,28 @@ , insert , delete , lookup+ , mutate+ , mutateIO , fromList , fromListWithSizeHint , toList , mapM_ , foldM , computeOverhead+ , lookupIndex+ , nextByIndex ) where ------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+import Data.Word+#endif import Control.Monad.Primitive (PrimState) import Control.Monad.ST (stToIO) import Data.Hashable (Hashable) import qualified Data.HashTable.Class as C+import GHC.IO (ioToST) import Prelude hiding (lookup, mapM_) ------------------------------------------------------------------------------@@ -90,7 +98,7 @@ --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:new".+-- | See the documentation for this function in 'Data.HashTable.Class.new'. new :: C.HashTable h => IO (IOHashTable h k v) new = stToIO C.new {-# INLINE new #-}@@ -100,7 +108,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:newSized".+-- 'Data.HashTable.Class.newSized'. newSized :: C.HashTable h => Int -> IO (IOHashTable h k v) newSized = stToIO . C.newSized {-# INLINE newSized #-}@@ -110,93 +118,145 @@ --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:insert".+-- | See the documentation for this function in 'Data.HashTable.Class.insert'. insert :: (C.HashTable h, Eq k, Hashable k) => IOHashTable h k v -> k -> v -> IO () insert h k v = stToIO $ C.insert h k v {-# INLINE insert #-}-{-# SPECIALIZE INLINE insert :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE insert :: Hashable k => BasicHashTable k v -> k -> v -> IO () #-}-{-# SPECIALIZE INLINE insert :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE insert :: Hashable k => LinearHashTable k v -> k -> v -> IO () #-}-{-# SPECIALIZE INLINE insert :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE insert :: Hashable k => CuckooHashTable k v -> k -> v -> IO () #-} --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:delete".+-- | See the documentation for this function in 'Data.HashTable.Class.delete'. delete :: (C.HashTable h, Eq k, Hashable k) => IOHashTable h k v -> k -> IO () delete h k = stToIO $ C.delete h k {-# INLINE delete #-}-{-# SPECIALIZE INLINE delete :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE delete :: Hashable k => BasicHashTable k v -> k -> IO () #-}-{-# SPECIALIZE INLINE delete :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE delete :: Hashable k => LinearHashTable k v -> k -> IO () #-}-{-# SPECIALIZE INLINE delete :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE delete :: Hashable k => CuckooHashTable k v -> k -> IO () #-} --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:lookup".+-- | See the documentation for this function in 'Data.HashTable.Class.lookup'. lookup :: (C.HashTable h, Eq k, Hashable k) => IOHashTable h k v -> k -> IO (Maybe v) lookup h k = stToIO $ C.lookup h k {-# INLINE lookup #-}-{-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE lookup :: Hashable k => BasicHashTable k v -> k -> IO (Maybe v) #-}-{-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE lookup :: Hashable k => LinearHashTable k v -> k -> IO (Maybe v) #-}-{-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE lookup :: Hashable k => CuckooHashTable k v -> k -> IO (Maybe v) #-} +------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.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 :: Hashable k =>+ BasicHashTable k v -> k -> IO (Maybe Word) #-}+{-# SPECIALIZE INLINE lookupIndex :: Hashable k =>+ LinearHashTable k v -> k -> IO (Maybe Word) #-}+{-# SPECIALIZE INLINE lookupIndex :: Hashable k =>+ CuckooHashTable k v -> k -> IO (Maybe Word) #-} ------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.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 :: Hashable k =>+ BasicHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}+{-# SPECIALIZE INLINE nextByIndex :: Hashable k =>+ LinearHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}+{-# SPECIALIZE INLINE nextByIndex :: Hashable k =>+ CuckooHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}++------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.mutateST'.+mutateIO :: (C.HashTable h, Eq k, Hashable k) =>+ IOHashTable h k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a+mutateIO h k f = stToIO $ C.mutateST h k (ioToST . f)+{-# INLINE mutateIO #-}+{-# SPECIALIZE INLINE mutateIO :: Hashable k =>+ BasicHashTable k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutateIO :: Hashable k =>+ LinearHashTable k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutateIO :: Hashable k =>+ CuckooHashTable k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a #-}++------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.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 :: Hashable k =>+ BasicHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutate :: Hashable k =>+ LinearHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutate :: Hashable k =>+ CuckooHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-}+++------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:fromList".+-- 'Data.HashTable.Class.fromList'. fromList :: (C.HashTable h, Eq k, Hashable k) => [(k,v)] -> IO (IOHashTable h k v) fromList = stToIO . C.fromList {-# INLINE fromList #-}-{-# SPECIALIZE INLINE fromList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromList :: Hashable k => [(k,v)] -> IO (BasicHashTable k v) #-}-{-# SPECIALIZE INLINE fromList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromList :: Hashable k => [(k,v)] -> IO (LinearHashTable k v) #-}-{-# SPECIALIZE INLINE fromList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromList :: Hashable k => [(k,v)] -> IO (CuckooHashTable k v) #-} ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:fromListWithSizeHint".+-- 'Data.HashTable.Class.fromListWithSizeHint'. fromListWithSizeHint :: (C.HashTable h, Eq k, Hashable k) => Int -> [(k,v)] -> IO (IOHashTable h k v) fromListWithSizeHint n = stToIO . C.fromListWithSizeHint n {-# INLINE fromListWithSizeHint #-}-{-# SPECIALIZE INLINE fromListWithSizeHint :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromListWithSizeHint :: Hashable k => Int -> [(k,v)] -> IO (BasicHashTable k v) #-}-{-# SPECIALIZE INLINE fromListWithSizeHint :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromListWithSizeHint :: Hashable k => Int -> [(k,v)] -> IO (LinearHashTable k v) #-}-{-# SPECIALIZE INLINE fromListWithSizeHint :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromListWithSizeHint :: Hashable k => Int -> [(k,v)] -> IO (CuckooHashTable k v) #-} --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:toList".+-- | See the documentation for this function in 'Data.HashTable.Class.toList'. toList :: (C.HashTable h, Eq k, Hashable k) => IOHashTable h k v -> IO [(k,v)] toList = stToIO . C.toList {-# INLINE toList #-}-{-# SPECIALIZE INLINE toList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE toList :: Hashable k => BasicHashTable k v -> IO [(k,v)] #-}-{-# SPECIALIZE INLINE toList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE toList :: Hashable k => LinearHashTable k v -> IO [(k,v)] #-}-{-# SPECIALIZE INLINE toList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE toList :: Hashable k => CuckooHashTable k v -> IO [(k,v)] #-} --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:foldM".+-- | See the documentation for this function in 'Data.HashTable.Class.foldM'. foldM :: (C.HashTable h) => (a -> (k,v) -> IO a) -> a@@ -214,7 +274,7 @@ --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:mapM_".+-- | See the documentation for this function in 'Data.HashTable.Class.mapM_'. mapM_ :: (C.HashTable h) => ((k,v) -> IO a) -> IOHashTable h k v -> IO () mapM_ f ht = stToIO $ C.mapM_ f' ht where@@ -230,7 +290,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:computeOverhead".+-- 'Data.HashTable.Class.computeOverhead'. computeOverhead :: (C.HashTable h) => IOHashTable h k v -> IO Double computeOverhead = stToIO . C.computeOverhead {-# INLINE computeOverhead #-}
src/Data/HashTable/Internal/CacheLine.hs view
@@ -16,6 +16,7 @@ , bl_abs# , sign# , mask#+ , mask , maskw# ) where @@ -37,13 +38,6 @@ import Data.HashTable.Internal.Utils import GHC.Exts -#if __GLASGOW_HASKELL__ >= 707-import GHC.Exts (isTrue#)-#else-isTrue# :: Bool -> Bool-isTrue# = id-#endif- {-# INLINE prefetchRead #-} {-# INLINE prefetchWrite #-} prefetchRead :: IntArray s -> Int -> ST s ()@@ -192,6 +186,12 @@ -} +{-# 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# #-} maskw# :: Int# -> Int# -> Word# maskw# !a# !b# = int2Word# (mask# a# b#)@@ -251,9 +251,12 @@ 27# !idx = I# (word2Int# idxW#) !(I8# pos8#) = U.unsafeIndex deBruijnBitPositions idx+#if __GLASGOW_HASKELL__ >= 900+ !posw# = int2Word# (int8ToInt# pos8#)+#else !posw# = int2Word# pos8#- #endif+#endif #ifdef NO_C_SEARCH@@ -745,7 +748,7 @@ -- \"-1\" if not found cacheLineSearch !vec !start !value = do #ifdef NO_C_SEARCH- let !vlen = M.length vec+ vlen <- M.length vec let !st1 = vlen - start let !nvlen = numElemsInCacheLine - st1 let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask@@ -776,7 +779,7 @@ -- \"-1\" if not found cacheLineSearch2 !vec !start !value !value2 = do #ifdef NO_C_SEARCH- let !vlen = M.length vec+ !vlen <- M.length vec let !st1 = vlen - start let !nvlen = numElemsInCacheLine - st1 let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask@@ -807,7 +810,7 @@ -- \"-1\" if not found cacheLineSearch3 !vec !start !value !value2 !value3 = do #ifdef NO_C_SEARCH- let !vlen = M.length vec+ !vlen <- M.length vec let !st1 = vlen - start let !nvlen = numElemsInCacheLine - st1 let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask
src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} module Data.HashTable.Internal.CheapPseudoRandomBitStream ( BitStream@@ -13,7 +14,11 @@ import Data.STRef import Data.Vector.Unboxed (Vector) import qualified Data.Vector.Unboxed as V-import Data.Word (Word, Word32, Word64)++import Data.Word (Word32, Word64)+#if !MIN_VERSION_base(4,8,0)+import Data.Word (Word)+#endif import Data.HashTable.Internal.Utils
src/Data/HashTable/Internal/IntArray.hs view
@@ -20,7 +20,9 @@ import Control.Monad.ST import Data.Bits import qualified Data.Primitive.ByteArray as A+#if !MIN_VERSION_primitive(0,7,0) import Data.Primitive.Types (Addr (..))+#endif import GHC.Exts import GHC.Word import Prelude hiding (length)@@ -50,7 +52,7 @@ ------------------------------------------------------------------------------ primWordToElem :: Word# -> Elem-primWordToElem = W16#+primWordToElem w# = W16# (wordToWord16Compat# w#) ------------------------------------------------------------------------------@@ -61,7 +63,7 @@ ------------------------------------------------------------------------------ elemToInt# :: Elem -> Int#-elemToInt# (W16# w#) = word2Int# w#+elemToInt# (W16# w#) = word2Int# (word16ToWordCompat# w#) ------------------------------------------------------------------------------@@ -71,7 +73,7 @@ ------------------------------------------------------------------------------ wordSizeInBytes :: Int-wordSizeInBytes = bitSize (0::Elem) `div` 8+wordSizeInBytes = finiteBitSize (0::Elem) `div` 8 ------------------------------------------------------------------------------@@ -104,12 +106,30 @@ -------------------------------------------------------------------------------length :: IntArray s -> Int-length (IA a) = A.sizeofMutableByteArray a `div` wordSizeInBytes+length :: IntArray s -> ST s Int+length (IA a) = (`div` wordSizeInBytes) <$> A.getSizeofMutableByteArray a ------------------------------------------------------------------------------ toPtr :: IntArray s -> Ptr a toPtr (IA a) = Ptr a# where+#if MIN_VERSION_primitive(0,7,0)+ !(Ptr !a#) = A.mutableByteArrayContents a+#else !(Addr !a#) = A.mutableByteArrayContents a+#endif++#if MIN_VERSION_base(4,16,0)+word16ToWordCompat# :: Word16# -> Word#+word16ToWordCompat# = word16ToWord#++wordToWord16Compat# :: Word# -> Word16#+wordToWord16Compat# = wordToWord16#+#else+word16ToWordCompat# :: Word# -> Word#+word16ToWordCompat# x = x++wordToWord16Compat# :: Word# -> Word#+wordToWord16Compat# x = x+#endif
src/Data/HashTable/Internal/Linear/Bucket.hs view
@@ -10,7 +10,11 @@ snoc, size, lookup,+ lookupIndex,+ elemAt, delete,+ mutate,+ mutateST, toList, fromList, mapM_,@@ -23,6 +27,9 @@ ------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif import Control.Monad hiding (foldM, mapM_) import qualified Control.Monad import Control.Monad.ST (ST)@@ -229,7 +236,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 +322,64 @@ 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 = mutateST bucketKey k (pure . f)+{-# INLINE mutate #-}+++------------------------------------------------------------------------------+mutateST :: (Eq k) =>+ Bucket s k v+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s (Int, Maybe (Bucket s k v), a)+mutateST bucketKey !k !f+ | keyIsEmpty bucketKey = do+ fRes <- f Nothing+ case fRes 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+ fRes <- f mv+ case (mv, fRes) 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/UnsafeTricks.hs view
@@ -22,23 +22,15 @@ #ifdef UNSAFETRICKS import GHC.Exts import Unsafe.Coerce--#if __GLASGOW_HASKELL__ >= 707-import GHC.Exts (isTrue#)-#else-isTrue# :: Bool -> Bool-isTrue# = id #endif -#endif - ------------------------------------------------------------------------------ #ifdef UNSAFETRICKS type Key a = Any #else-data Key a = Key !a +data Key a = Key !a | EmptyElement | DeletedElement deriving (Show)
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
@@ -84,9 +84,12 @@ ( HashTable , new , newSized+ , size , delete , lookup , insert+ , mutate+ , mutateST , mapM_ , foldM , computeOverhead@@ -94,6 +97,9 @@ ------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif import Control.Exception (assert) import Control.Monad hiding (foldM, mapM_) import Control.Monad.ST (ST)@@ -102,6 +108,9 @@ import qualified Data.Hashable as H import Data.Maybe import Data.Monoid+#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif import qualified Data.Primitive.ByteArray as A import Data.STRef import GHC.Exts@@ -122,7 +131,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 +172,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate+ mutateST = mutateST ------------------------------------------------------------------------------@@ -173,7 +186,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:new".+-- 'Data.HashTable.Class.new'. new :: ST s (HashTable s k v) new = newSized 1 {-# INLINE new #-}@@ -181,7 +194,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:newSized".+-- 'Data.HashTable.Class.newSized'. newSized :: Int -> ST s (HashTable s k v) newSized n = do debug $ "entering: newSized " ++ show n@@ -190,7 +203,6 @@ newRef ht {-# INLINE newSized #-} - ------------------------------------------------------------------------------ newSizedReal :: Int -> ST s (HashTable_ s k v) newSizedReal m = do@@ -204,19 +216,26 @@ ld <- newSizeRefs return $! HashTable m ld h k v +------------------------------------------------------------------------------+-- | Returns the number of mappings currently stored in this table. /O(1)/+size :: HashTable s k v -> ST s Int+size htRef = do+ HashTable _ sizeRefs _ _ _ <- readRef htRef+ readLoad sizeRefs+{-# INLINE size #-} + ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:delete".+-- 'Data.HashTable.Class.delete'. delete :: (Hashable k, Eq k) => (HashTable s k v) -> 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 #-}@@ -224,7 +243,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:lookup".+-- 'Data.HashTable.Class.lookup'. lookup :: (Eq k, Hashable k) => (HashTable s k v) -> k -> ST s (Maybe v) lookup htRef !k = do ht <- readRef htRef@@ -276,7 +295,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:insert".+-- 'Data.HashTable.Class.insert'. insert :: (Eq k, Hashable k) => (HashTable s k v) -> k@@ -284,39 +303,74 @@ -> 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+------------------------------------------------------------------------------+-- | See the documentation for this function in+-- 'Data.HashTable.Class.mutate'.+mutate :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef !k !f = mutateST htRef k (pure . f)+{-# INLINE mutate #-} - 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.mutateST'.+mutateST :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s a+mutateST 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+ (!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 mutateST #-} + ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:foldM".+-- 'Data.HashTable.Class.foldM'. foldM :: (a -> (k,v) -> ST s a) -> a -> HashTable s k v -> ST s a foldM f seed0 htRef = readRef htRef >>= work where@@ -336,7 +390,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:mapM_".+-- 'Data.HashTable.Class.mapM_'. mapM_ :: ((k,v) -> ST s b) -> HashTable s k v -> ST s () mapM_ f htRef = readRef htRef >>= work where@@ -356,7 +410,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:computeOverhead".+-- 'Data.HashTable.Class.computeOverhead'. computeOverhead :: HashTable s k v -> ST s Double computeOverhead htRef = readRef htRef >>= work where@@ -365,7 +419,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 +463,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 +511,64 @@ --------------------------------------------------------------------------------- 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) ------------------------------------------------------------------------------++#if MIN_VERSION_base(4,9,0)+instance Semigroup Slot where+ (<>) = slotMappend+#endif+ 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+#if ! MIN_VERSION_base(4,11,0)+ mappend = slotMappend+#endif +slotMappend :: Slot -> Slot -> Slot+slotMappend (Slot x1) (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 +594,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 +604,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 +617,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 +634,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 +699,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 +724,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 +781,68 @@ #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,12 +68,19 @@ , delete , lookup , insert+ , mutate+ , mutateST , mapM_ , foldM+ , lookupIndex+ , nextByIndex ) where ------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif import Control.Monad hiding (foldM, mapM_)@@ -128,7 +135,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate+ mutateST = mutateST ------------------------------------------------------------------------------@@ -138,7 +149,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:new".+-- 'Data.HashTable.Class.new'. new :: ST s (HashTable s k v) new = newSizedReal 2 >>= newRef {-# INLINE new #-}@@ -146,7 +157,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:newSized".+-- 'Data.HashTable.Class.newSized'. newSized :: Int -> ST s (HashTable s k v) newSized n = do let n' = (n + numElemsInCacheLine - 1) `div` numElemsInCacheLine@@ -157,14 +168,38 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:insert".+-- 'Data.HashTable.Class.insert'. insert :: (Eq k, Hashable k) => HashTable s k v -> k -> v -> ST s () insert ht !k !v = readRef ht >>= \h -> insert' h k v >>= writeRef ht ------------------------------------------------------------------------------+mutate :: (Eq k, Hashable k) =>+ HashTable s k v+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef !k !f = mutateST htRef k (pure . f)+{-# INLINE mutate #-}+++------------------------------------------------------------------------------+mutateST :: (Eq k, Hashable k) =>+ HashTable s k v+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s a+mutateST htRef !k !f = do+ ht <- readRef htRef+ (newHt, a) <- mutate' ht k f+ writeRef htRef newHt+ return a+{-# INLINE mutateST #-}+++------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:computeOverhead".+-- 'Data.HashTable.Class.computeOverhead'. computeOverhead :: HashTable s k v -> ST s Double computeOverhead htRef = readRef htRef >>= work where@@ -179,7 +214,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@@ -187,7 +222,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:delete".+-- 'Data.HashTable.Class.delete'. delete :: (Hashable k, Eq k) => HashTable s k v -> k@@ -208,7 +243,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:lookup".+-- 'Data.HashTable.Class.lookup'. lookup :: (Eq k, Hashable k) => HashTable s k v -> k@@ -286,7 +321,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:foldM".+-- 'Data.HashTable.Class.foldM'. foldM :: (a -> (k,v) -> ST s a) -> a -> HashTable s k v@@ -321,7 +356,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:mapM_".+-- 'Data.HashTable.Class.mapM_'. mapM_ :: ((k,v) -> ST s a) -> HashTable s k v -> ST s ()@@ -391,6 +426,102 @@ ------------------------------------------------------------------------------+mutate' :: (Eq k, Hashable k) =>+ HashTable_ s k v+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s (HashTable_ s k v, a)+mutate' ht@(HashTable sz _ hashes keys values _) !k !f = do+ !(maybeVal, idx, _hashCode) <- lookupSlot+ !fRes <- f maybeVal+ case (maybeVal, fRes) 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 +823,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,12 +83,18 @@ , delete , lookup , insert+ , mutate+ , mutateST , mapM_ , foldM , computeOverhead ) where ------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+import Data.Word+#endif import Control.Monad hiding (foldM, mapM_) import Control.Monad.ST import Data.Bits@@ -127,7 +133,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate+ mutateST = mutateST ------------------------------------------------------------------------------@@ -218,8 +228,42 @@ {-# INLINE insert #-} +------------------------------------------------------------------------------+mutate :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef k f = mutateST htRef k (pure . f)+{-# INLINE mutate #-} + ------------------------------------------------------------------------------+mutateST :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s a+mutateST 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.mutateST 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_". mapM_ :: ((k,v) -> ST s b) -> HashTable s k v -> ST s ()@@ -459,3 +503,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
@@ -5,7 +5,7 @@ Copyright: (c) 2011-2013, Google, Inc. Category: Data Build-type: Simple-Cabal-version: >= 1.8+Cabal-version: >= 1.10 ------------------------------------------------------------------------------ Flag debug@@ -32,62 +32,6 @@ Default: False -Executable testsuite- hs-source-dirs: ../src suite- main-is: TestSuite.hs-- if flag(sse42) && !flag(portable)- cc-options: -DUSE_SSE_4_2 -msse4.2- cpp-options: -DUSE_SSE_4_2- C-sources: ../cbits/sse-42.c-- if !flag(portable) && !flag(sse42)- C-sources: ../cbits/default.c-- if !flag(portable)- C-sources: ../cbits/common.c-- ghc-prof-options: -prof -auto-all-- if flag(portable) || !flag(unsafe-tricks)- ghc-options: -fhpc-- if flag(portable)- cpp-options: -DNO_C_SEARCH -DPORTABLE-- if !flag(portable) && flag(unsafe-tricks) && impl(ghc)- cpp-options: -DUNSAFETRICKS- build-depends: ghc-prim-- if flag(debug)- cpp-options: -DDEBUG-- if flag(bounds-checking)- cpp-options: -DBOUNDS_CHECKING-- Build-depends: base >= 4 && <5,- hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,- mwc-random >= 0.8 && <0.13,- primitive,- QuickCheck >= 2.3.0.2,- 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,- vector >= 0.7-- cpp-options: -DTESTSUITE-- if impl(ghc >= 7)- ghc-options: -rtsopts-- if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2- -fno-warn-unused-do-bind -threaded- else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -threaded-- Executable compute-overhead hs-source-dirs: ../src suite compute-overhead main-is: ComputeOverhead.hs@@ -120,13 +64,13 @@ Build-depends: base >= 4 && <5, hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,- mwc-random >= 0.8 && <0.13,- QuickCheck >= 2.3.0.2 && <3,+ mwc-random >= 0.8 && <0.14,+ QuickCheck >= 2.9 && <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.14 && <0.15, primitive, vector >= 0.7
− test/runTestsAndCoverage.sh
@@ -1,46 +0,0 @@-#!/bin/sh--set -e--SUITE=./dist/build/testsuite/testsuite--export LC_ALL=C-export LANG=C--rm -f testsuite.tix--if [ ! -f $SUITE ]; then- cat <<EOF-Testsuite executable not found, please run:- cabal configure -ftest-then- cabal build-EOF- exit;-fi--./dist/build/testsuite/testsuite -a1000 $*--DIR=dist/hpc--rm -Rf $DIR-mkdir -p $DIR--EXCLUDES='Main-Data.HashTable.Test.Common-'--EXCL=""--for m in $EXCLUDES; do- EXCL="$EXCL --exclude=$m"-done--hpc markup $EXCL --destdir=$DIR testsuite >/dev/null 2>&1--rm -f testsuite.tix--cat <<EOF--Test coverage report written to $DIR.-EOF
− test/runTestsNoCoverage.sh
@@ -1,20 +0,0 @@-#!/bin/sh--set -e--SUITE=./dist/build/testsuite/testsuite--export LC_ALL=C-export LANG=C--if [ ! -f $SUITE ]; then- cat <<EOF-Testsuite executable not found, please run:- cabal configure -ftest-then- cabal build-EOF- exit;-fi--./dist/build/testsuite/testsuite -j4 -a1000 $*
test/suite/Data/HashTable/Test/Common.hs view
@@ -11,7 +11,12 @@ ) where -------------------------------------------------------------------------------import Control.Monad (foldM_, liftM, when)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (pure, (<$>))+#endif+import Control.Applicative ((<|>))+import Control.Monad (foldM_, when)+import qualified Control.Monad as Monad import Data.IORef import Data.List hiding (delete, insert, lookup)@@ -21,14 +26,12 @@ import Prelude hiding (lookup, mapM_) import System.Random.MWC import System.Timeout-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit (assertFailure)-import Test.QuickCheck (arbitrary, choose,- sample')+import Test.Tasty+import Test.Tasty.HUnit hiding (assert)+import Test.Tasty.QuickCheck import Test.QuickCheck.Monadic (PropertyM, assert,- forAllM, monadicIO, run)+ forAllM, monadicIO, pre,+ run) ------------------------------------------------------------------------------ import qualified Data.HashTable.Class as C import Data.HashTable.Internal.Utils (unsafeIOToST)@@ -42,7 +45,7 @@ ------------------------------------------------------------------------------ type FixedTableType h = forall k v . IOHashTable h k v-type HashTest = forall h . C.HashTable h => String -> FixedTableType h -> Test+type HashTest = forall h . C.HashTable h => String -> FixedTableType h -> TestTree data SomeTest = SomeTest HashTest @@ -62,6 +65,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 =@@ -82,7 +91,7 @@ -------------------------------------------------------------------------------tests :: C.HashTable h => String -> FixedTableType h -> Test+tests :: C.HashTable h => String -> FixedTableType h -> TestTree tests prefix dummyArg = testGroup prefix $ map f ts where f (SomeTest ht) = ht prefix dummyArg@@ -95,6 +104,8 @@ , SomeTest testDelete , SomeTest testNastyFullLookup , SomeTest testForwardSearch3+ , SomeTest testMutate+ , SomeTest testMutateGrow ] @@ -109,8 +120,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 +139,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 +165,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 +189,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,9 +236,9 @@ 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)+ i <- run $ generate $ choose (0,n-1) v <- run $ lookup ht i assertEq ("lookup " ++ show i) (Just i) v@@ -271,11 +282,11 @@ prop :: Int -> PropertyM IO () prop n = do- run $ announce "delete" n+ announceQ "delete" n ht <- run $ go n - i <- liftM head $ run $ sample' $ choose (4,n-1)+ i <- run $ generate $ choose (4,n-1) v <- run $ lookup ht i assertEq ("lookup " ++ show i) (Just i) v @@ -288,6 +299,47 @@ ------------------------------------------------------------------------------+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++testMutateGrow :: HashTest+testMutateGrow prefix dummyArg = testCase (prefix ++ "/mutateGrow") go+ where+ go = do+ tbl <- new+ forceType tbl dummyArg+ timeout_ 3000000 $ do+ let inputs = [0..128 :: Int]+ Monad.mapM_ (mutIns tbl) inputs+ l <- sort <$> toList tbl+ let expected = map (\i -> (i, i)) inputs+ assertEqual "mutate-grow" expected l+ mutIns tbl i = mutate tbl i (const (Just i, ()))++------------------------------------------------------------------------------ data Action = Lookup Int | Insert Int | Delete Int@@ -295,7 +347,7 @@ timeout_ :: Int -> IO a -> IO ()-#ifdef PORTABLE+#if defined(PORTABLE) || defined(wasm32_HOST_ARCH) timeout_ t m = timeout t m >>= maybe (assertFailure "timeout") (const $ return ()) #else@@ -445,14 +497,14 @@ ------------------------------------------------------------------------------ initializeRNG :: PropertyM IO GenIO-initializeRNG = run $ withSystemRandom (return :: GenIO -> IO GenIO)+initializeRNG = run createSystemRandom ------------------------------------------------------------------------------ dedupe :: (Ord k, Ord v, Eq k) => [(k,v)] -> [(k,v)] dedupe l = go0 $ sort l where- go0 [] = []+ go0 [] = [] go0 (x:xs) = go id x xs go !dl !lastOne [] = (dl . (lastOne:)) []@@ -477,8 +529,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
test/suite/TestSuite.hs view
@@ -2,7 +2,7 @@ module Main where -import Test.Framework (defaultMain)+import Test.Tasty (defaultMain, testGroup) ------------------------------------------------------------------------------ import qualified Data.HashTable.Test.Common as Common import qualified Data.HashTable.ST.Basic as B@@ -13,7 +13,7 @@ ------------------------------------------------------------------------------ main :: IO ()-main = defaultMain tests+main = defaultMain $ testGroup "All" tests where dummyBasicTable = Common.dummyTable :: forall k v . IO.IOHashTable (B.HashTable) k v