diff --git a/benchmark/hashtable-benchmark.cabal b/benchmark/hashtable-benchmark.cabal --- a/benchmark/hashtable-benchmark.cabal +++ b/benchmark/hashtable-benchmark.cabal @@ -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.*, diff --git a/benchmark/src/Criterion/Collection/Internal/Types.hs b/benchmark/src/Criterion/Collection/Internal/Types.hs --- a/benchmark/src/Criterion/Collection/Internal/Types.hs +++ b/benchmark/src/Criterion/Collection/Internal/Types.hs @@ -38,7 +38,7 @@ ------------------------------------------------------------------------------ newtype WorkloadMonad a = WM (ReaderT GenIO IO a) - deriving (Monad, MonadIO) + deriving (Functor, Applicative, Monad, MonadIO) ------------------------------------------------------------------------------ diff --git a/benchmark/src/Data/Vector/Algorithms/Shuffle.hs b/benchmark/src/Data/Vector/Algorithms/Shuffle.hs --- a/benchmark/src/Data/Vector/Algorithms/Shuffle.hs +++ b/benchmark/src/Data/Vector/Algorithms/Shuffle.hs @@ -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 diff --git a/benchmark/src/Main.hs b/benchmark/src/Main.hs --- a/benchmark/src/Main.hs +++ b/benchmark/src/Main.hs @@ -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) diff --git a/cabal.project b/cabal.project new file mode 100644 --- /dev/null +++ b/cabal.project @@ -0,0 +1,8 @@ +packages: . + +tests: True + +test-show-details: direct + +allow-newer: + , *:base diff --git a/cbits/common.c b/cbits/common.c --- a/cbits/common.c +++ b/cbits/common.c @@ -3,7 +3,7 @@ #ifdef WIN32 #include #else -#include +#include #include #endif @@ -19,11 +19,7 @@ #endif if (*check) { printf("timeout expired, dying!!\n"); -#ifdef WIN32 - abort(); -#else - raise(SIGKILL); -#endif + exit(1); } } diff --git a/cbits/defs.h b/cbits/defs.h --- a/cbits/defs.h +++ b/cbits/defs.h @@ -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 */ diff --git a/cbits/sse-42-check.c b/cbits/sse-42-check.c --- a/cbits/sse-42-check.c +++ b/cbits/sse-42-check.c @@ -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)); diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/hashtables.cabal b/hashtables.cabal --- a/hashtables.cabal +++ b/hashtables.cabal @@ -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 diff --git a/src/Data/HashTable/Class.hs b/src/Data/HashTable/Class.hs --- a/src/Data/HashTable/Class.hs +++ b/src/Data/HashTable/Class.hs @@ -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 diff --git a/src/Data/HashTable/IO.hs b/src/Data/HashTable/IO.hs --- a/src/Data/HashTable/IO.hs +++ b/src/Data/HashTable/IO.hs @@ -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 #-} diff --git a/src/Data/HashTable/Internal/CacheLine.hs b/src/Data/HashTable/Internal/CacheLine.hs --- a/src/Data/HashTable/Internal/CacheLine.hs +++ b/src/Data/HashTable/Internal/CacheLine.hs @@ -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 diff --git a/src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs b/src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs --- a/src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs +++ b/src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs @@ -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 diff --git a/src/Data/HashTable/Internal/IntArray.hs b/src/Data/HashTable/Internal/IntArray.hs --- a/src/Data/HashTable/Internal/IntArray.hs +++ b/src/Data/HashTable/Internal/IntArray.hs @@ -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 diff --git a/src/Data/HashTable/Internal/Linear/Bucket.hs b/src/Data/HashTable/Internal/Linear/Bucket.hs --- a/src/Data/HashTable/Internal/Linear/Bucket.hs +++ b/src/Data/HashTable/Internal/Linear/Bucket.hs @@ -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) ------------------------------------------------------------------------------ diff --git a/src/Data/HashTable/Internal/UnsafeTricks.hs b/src/Data/HashTable/Internal/UnsafeTricks.hs --- a/src/Data/HashTable/Internal/UnsafeTricks.hs +++ b/src/Data/HashTable/Internal/UnsafeTricks.hs @@ -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) diff --git a/src/Data/HashTable/Internal/Utils.hs b/src/Data/HashTable/Internal/Utils.hs --- a/src/Data/HashTable/Internal/Utils.hs +++ b/src/Data/HashTable/Internal/Utils.hs @@ -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 diff --git a/src/Data/HashTable/ST/Basic.hs b/src/Data/HashTable/ST/Basic.hs --- a/src/Data/HashTable/ST/Basic.hs +++ b/src/Data/HashTable/ST/Basic.hs @@ -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 #-} + diff --git a/src/Data/HashTable/ST/Cuckoo.hs b/src/Data/HashTable/ST/Cuckoo.hs --- a/src/Data/HashTable/ST/Cuckoo.hs +++ b/src/Data/HashTable/ST/Cuckoo.hs @@ -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) diff --git a/src/Data/HashTable/ST/Linear.hs b/src/Data/HashTable/ST/Linear.hs --- a/src/Data/HashTable/ST/Linear.hs +++ b/src/Data/HashTable/ST/Linear.hs @@ -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 #-} diff --git a/test/compute-overhead/ComputeOverhead.hs b/test/compute-overhead/ComputeOverhead.hs --- a/test/compute-overhead/ComputeOverhead.hs +++ b/test/compute-overhead/ComputeOverhead.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} module Main where diff --git a/test/hashtables-test.cabal b/test/hashtables-test.cabal --- a/test/hashtables-test.cabal +++ b/test/hashtables-test.cabal @@ -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 diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh deleted file mode 100644 --- a/test/runTestsAndCoverage.sh +++ /dev/null @@ -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 </dev/null 2>&1 - -rm -f testsuite.tix - -cat <)) +#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 diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs --- a/test/suite/TestSuite.hs +++ b/test/suite/TestSuite.hs @@ -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