diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2011-2012, Google, Inc. +Copyright (c) 2011-2013, Google, Inc. All rights reserved. diff --git a/benchmark/hashtable-benchmark.cabal b/benchmark/hashtable-benchmark.cabal --- a/benchmark/hashtable-benchmark.cabal +++ b/benchmark/hashtable-benchmark.cabal @@ -15,26 +15,26 @@ Executable hashtable-benchmark main-is: Main.hs - hs-source-dirs: src ../src + hs-source-dirs: src build-depends: base >= 4 && <5, base16-bytestring == 0.1.*, bytestring >= 0.9 && <0.11, containers >= 0.4 && <0.6, - criterion >= 0.5 && <0.7, + 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.0 && <1.3, + hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3, + hashtables >= 1.2 && <1.3, mtl == 2.*, - mwc-random >= 0.8 && <0.13, + 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/Criterion/Collection/Sample.hs b/benchmark/src/Criterion/Collection/Sample.hs --- a/benchmark/src/Criterion/Collection/Sample.hs +++ b/benchmark/src/Criterion/Collection/Sample.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RankNTypes #-} module Criterion.Collection.Sample ( Benchmark(..) @@ -16,23 +16,23 @@ import Control.DeepSeq import Control.Monad import Control.Monad.Trans -import Criterion hiding (Benchmark) +import Criterion hiding (Benchmark) +import Criterion.Collection.Internal.Types import Criterion.Config import Criterion.Environment -import Criterion.IO +import Criterion.IO.Printf import Criterion.Measurement import Criterion.Monad -import Criterion.Collection.Internal.Types import Data.IORef -import Data.List (foldl') +import Data.List (foldl') import Data.Monoid -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import Statistics.Quantile (continuousBy, cadpw) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as U +import Statistics.Quantile (cadpw, continuousBy) import Statistics.Sample -import System.Mem (performGC) +import System.Mem (performGC) import System.Random.MWC -import Text.Printf (printf) +import Text.Printf (printf) ------------------------------------------------------------------------------ data MeasurementMode = PerBatch | PerOperation 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/Makefile b/cbits/Makefile new file mode 100644 --- /dev/null +++ b/cbits/Makefile @@ -0,0 +1,14 @@ +check: default.c common.c check.c sse-42.c + @echo "Testing portable version..." + @gcc -o check -O3 default.c common.c check.c + @./check + @rm check + + @echo + @echo "Testing SSE 4.2 version..." + @gcc -o check -O3 -msse4.2 sse-42.c common.c check.c sse-42-check.c + @./check + @rm check + +clean: + rm -f *.o check diff --git a/cbits/cfuncs.c b/cbits/cfuncs.c deleted file mode 100644 --- a/cbits/cfuncs.c +++ /dev/null @@ -1,517 +0,0 @@ -#include -#include -#include -#ifdef WIN32 -#include -#else -#include -#endif - -#if defined(USE_SSE_4_1) -#include -#endif - -#if defined(__GNUC__) -#define PREFETCH_READ(x) (__builtin_prefetch(x, 0, 3)) -#define PREFETCH_WRITE(x) (__builtin_prefetch(x, 1, 3)) -#else -#define PREFETCH_READ(x) -#define PREFETCH_WRITE(x) -#endif - -void prefetchCacheLine32_write(uint32_t* line, int start) -{ - PREFETCH_WRITE((void*)(&line[start])); -} - - -void prefetchCacheLine64_write(uint64_t* line, int start) -{ - PREFETCH_WRITE((void*)(&line[start])); -} - - -void prefetchCacheLine32_read(uint32_t* line, int start) -{ - PREFETCH_READ((void*)(&line[start])); -} - - -void prefetchCacheLine64_read(uint64_t* line, int start) -{ - PREFETCH_READ((void*)(&line[start])); -} - - -int forwardSearch32_2(uint32_t* array, int start, int end, - uint32_t x1, uint32_t x2) { - uint32_t* ep = array + end; - uint32_t* p = array + start; - int wrapped = 0; - while (1) { - if (p == ep) { - if (wrapped) return -1; - ep = array + start; - p = array; - wrapped = 1; - } - if (*p == x1 || *p == x2) return p - array; - ++p; - } -} - - -int forwardSearch32_3(uint32_t* array, int start, int end, - uint32_t x1, uint32_t x2, uint32_t x3) { - uint32_t* ep = array + end; - uint32_t* p = array + start; - int wrapped = 0; - while (1) { - if (p == ep) { - if (wrapped) return -1; - ep = array + start; - p = array; - wrapped = 1; - } - if (*p == x1 || *p == x2 || *p == x3) return p - array; - ++p; - } -} - - -int forwardSearch64_2(uint64_t* array, int start, int end, - uint64_t x1, uint64_t x2) { - uint64_t* ep = array + end; - uint64_t* p = array + start; - int wrapped = 0; - while (1) { - if (p == ep) { - if (wrapped) return -1; - ep = array + start; - p = array; - wrapped = 1; - } - if (*p == x1 || *p == x2) return p - array; - ++p; - } -} - - -int forwardSearch64_3(uint64_t* array, int start, int end, - uint64_t x1, uint64_t x2, uint64_t x3) { - uint64_t* ep = array + end; - uint64_t* p = array + start; - int wrapped = 0; - while (1) { - if (p == ep) { - if (wrapped) return -1; - ep = array + start; - p = array; - wrapped = 1; - } - if (*p == x1 || *p == x2 || *p == x3) return p - array; - ++p; - } -} - - -//---------------------------------------------------------------------------- -// cache line search functions -// First: 32 bit - -inline int mask(int a, int b) { return -(a == b); } - - -uint8_t deBruijnBitPositions[] = { - 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, - 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 -}; - - -int firstBitSet(int a) { - int zeroCase = mask(0, a); - uint32_t x = (uint32_t) (a & -a); - x *= 0x077CB531; - x >>= 27; - return zeroCase | deBruijnBitPositions[x]; -} - - -int32_t lineResult32(int m, int start) { - int p = firstBitSet(m); - int32_t mm = mask(p, -1); - return mm | (~mm & (start + p)); -} - - -uint32_t lineMask32(uint32_t* array, int start, uint32_t value) { - uint32_t* p = array + start; - uint32_t m = 0; - int offset = start & 0xf; - - switch (offset) { - case 0: m |= mask(*p++, value) & 0x1; - case 1: m |= mask(*p++, value) & 0x2; - case 2: m |= mask(*p++, value) & 0x4; - case 3: m |= mask(*p++, value) & 0x8; - case 4: m |= mask(*p++, value) & 0x10; - case 5: m |= mask(*p++, value) & 0x20; - case 6: m |= mask(*p++, value) & 0x40; - case 7: m |= mask(*p++, value) & 0x80; - case 8: m |= mask(*p++, value) & 0x100; - case 9: m |= mask(*p++, value) & 0x200; - case 10: m |= mask(*p++, value) & 0x400; - case 11: m |= mask(*p++, value) & 0x800; - case 12: m |= mask(*p++, value) & 0x1000; - case 13: m |= mask(*p++, value) & 0x2000; - case 14: m |= mask(*p++, value) & 0x4000; - case 15: m |= mask(*p++, value) & 0x8000; - } - - return m >> offset; -} - - -int lineSearch32(uint32_t* array, int start, uint32_t value) { - uint32_t m = lineMask32(array, start, value); - return lineResult32((int)m, start); -} - - -uint32_t lineMask32_2(uint32_t* array, int start, uint32_t x1, uint32_t x2) { - uint32_t* p = array + start; - uint32_t m = 0; - int offset = start & 0xf; - - switch (offset) { - case 0: m |= (mask(*p, x1) | mask(*p, x2)) & 0x1; ++p; - case 1: m |= (mask(*p, x1) | mask(*p, x2)) & 0x2; ++p; - case 2: m |= (mask(*p, x1) | mask(*p, x2)) & 0x4; ++p; - case 3: m |= (mask(*p, x1) | mask(*p, x2)) & 0x8; ++p; - case 4: m |= (mask(*p, x1) | mask(*p, x2)) & 0x10; ++p; - case 5: m |= (mask(*p, x1) | mask(*p, x2)) & 0x20; ++p; - case 6: m |= (mask(*p, x1) | mask(*p, x2)) & 0x40; ++p; - case 7: m |= (mask(*p, x1) | mask(*p, x2)) & 0x80; ++p; - case 8: m |= (mask(*p, x1) | mask(*p, x2)) & 0x100; ++p; - case 9: m |= (mask(*p, x1) | mask(*p, x2)) & 0x200; ++p; - case 10: m |= (mask(*p, x1) | mask(*p, x2)) & 0x400; ++p; - case 11: m |= (mask(*p, x1) | mask(*p, x2)) & 0x800; ++p; - case 12: m |= (mask(*p, x1) | mask(*p, x2)) & 0x1000; ++p; - case 13: m |= (mask(*p, x1) | mask(*p, x2)) & 0x2000; ++p; - case 14: m |= (mask(*p, x1) | mask(*p, x2)) & 0x4000; ++p; - case 15: m |= (mask(*p, x1) | mask(*p, x2)) & 0x8000; ++p; - } - - return m >> offset; -} - - -int lineSearch32_2(uint32_t* array, int start, uint32_t x1, uint32_t x2) { - uint32_t m = lineMask32_2(array, start, x1, x2); - return lineResult32((int)m, start); -} - - -uint32_t lineMask32_3(uint32_t* array, int start, - uint32_t x1, uint32_t x2, uint32_t x3) { - uint32_t* p = array + start; - uint32_t m = 0; - int offset = start & 0xf; - - switch (offset) { - case 0: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x1; ++p; - case 1: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x2; ++p; - case 2: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x4; ++p; - case 3: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x8; ++p; - case 4: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x10; ++p; - case 5: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x20; ++p; - case 6: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x40; ++p; - case 7: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x80; ++p; - case 8: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x100; ++p; - case 9: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x200; ++p; - case 10: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x400; ++p; - case 11: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x800; ++p; - case 12: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x1000; ++p; - case 13: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x2000; ++p; - case 14: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x4000; ++p; - case 15: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x8000; ++p; - } - - return m >> offset; -} - - -int lineSearch32_3(uint32_t* array, int start, - uint32_t x1, uint32_t x2, uint32_t x3) { - uint32_t m = lineMask32_3(array, start, x1, x2, x3); - return lineResult32((int)m, start); -} - - -//---------------------------------------------------------------------------- -// Now: 64-bit. If USE_SSE_4_1 is on, we will use SSE4.1 SIMD instructions to -// search the cache line super-efficiently. - -#if defined(USE_SSE_4_1) - -inline uint64_t mask_to_mask2(__m128i m) { - int mask16 = _mm_movemask_epi8(m); - // output of _mm_movemask_epi8 is a 16-bit word where bit i is 1 iff the - // most significant bit of byte i of the mask is 1 - int m1 = mask16 & 0x1; - int m2 = (mask16 & 0x100) >> 7; - return (uint64_t) (m1 | m2); -} - - -inline uint64_t cmp_and_mask(__m128i val, __m128i x0) { - __m128i mask1 = _mm_cmpeq_epi64(val, x0); - return mask_to_mask2(mask1); -} - - -inline uint64_t cmp_and_mask_2(__m128i val, __m128i x0, __m128i x1) { - __m128i mask1 = _mm_cmpeq_epi64(val, x0); - __m128i mask2 = _mm_cmpeq_epi64(val, x1); - mask1 = _mm_or_si128(mask1, mask2); - return mask_to_mask2(mask1); -} - - -inline uint64_t cmp_and_mask_3(__m128i val, __m128i x0, __m128i x1, - __m128i x2) { - __m128i mask1 = _mm_cmpeq_epi64(val, x0); - __m128i mask2 = _mm_cmpeq_epi64(val, x1); - __m128i mask3 = _mm_cmpeq_epi64(val, x2); - mask1 = _mm_or_si128(mask1, mask2); - mask1 = _mm_or_si128(mask1, mask3); - return mask_to_mask2(mask1); -} - - -uint64_t lineMask64(uint64_t* array, int start0, uint64_t v1) { - int offset = start0 & 0x7; - int start = start0 & ~0x7; - - __m128i* p = (__m128i*) (&array[start]); - __m128i x1 = _mm_cvtsi32_si128(0); - x1 = _mm_insert_epi64(x1, v1, 0); - x1 = _mm_insert_epi64(x1, v1, 1); - uint64_t dest_mask = 0; - - // x1 contains two 64-bit copies of the value to look for - - // words 0, 1 - __m128i x = _mm_load_si128(p); - dest_mask = cmp_and_mask(x, x1); - p = (__m128i*) (&array[start+2]); - - // words 2, 3 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask(x, x1) << 2); - p = (__m128i*) (&array[start+4]); - - // words 4, 5 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask(x, x1) << 4); - p = (__m128i*) (&array[start+6]); - - // words 6, 7 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask(x, x1) << 6); - - return dest_mask >> offset; -} - - -uint64_t lineMask64_2(uint64_t* array, int start0, uint64_t v1, uint64_t v2) { - int offset = start0 & 0x7; - int start = start0 & ~0x7; - - __m128i* p = (__m128i*) (&array[start]); - __m128i x1 = _mm_cvtsi32_si128(0); - x1 = _mm_insert_epi64(x1, v1, 0); - x1 = _mm_insert_epi64(x1, v1, 1); - - __m128i x2 = _mm_cvtsi32_si128(0); - x2 = _mm_insert_epi64(x2, v2, 0); - x2 = _mm_insert_epi64(x2, v2, 1); - - uint64_t dest_mask = 0; - - // words 0, 1 - __m128i x = _mm_load_si128(p); - dest_mask = cmp_and_mask_2(x, x1, x2); - p = (__m128i*) (&array[start+2]); - - // words 2, 3 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask_2(x, x1, x2) << 2); - p = (__m128i*) (&array[start+4]); - - // words 4, 5 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask_2(x, x1, x2) << 4); - p = (__m128i*) (&array[start+6]); - - // words 6, 7 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask_2(x, x1, x2) << 6); - - return dest_mask >> offset; -} - - -uint64_t lineMask64_3(uint64_t* array, int start0, - uint64_t v1, uint64_t v2, uint64_t v3) { - int offset = start0 & 0x7; - int start = start0 & ~0x7; - - __m128i* p = (__m128i*) (&array[start]); - __m128i x1 = _mm_cvtsi32_si128(0); - x1 = _mm_insert_epi64(x1, v1, 0); - x1 = _mm_insert_epi64(x1, v1, 1); - - __m128i x2 = _mm_cvtsi32_si128(0); - x2 = _mm_insert_epi64(x2, v2, 0); - x2 = _mm_insert_epi64(x2, v2, 1); - - __m128i x3 = _mm_cvtsi32_si128(0); - x3 = _mm_insert_epi64(x3, v3, 0); - x3 = _mm_insert_epi64(x3, v3, 1); - - uint64_t dest_mask = 0; - - // words 0, 1 - __m128i x = _mm_load_si128(p); - dest_mask = cmp_and_mask_3(x, x1, x2, x3); - p = (__m128i*) (&array[start+2]); - - // words 2, 3 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask_3(x, x1, x2, x3) << 2); - p = (__m128i*) (&array[start+4]); - - // words 4, 5 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask_3(x, x1, x2, x3) << 4); - p = (__m128i*) (&array[start+6]); - - // words 6, 7 - x = _mm_load_si128(p); - dest_mask |= (cmp_and_mask_3(x, x1, x2, x3) << 6); - - return dest_mask >> offset; -} - - -#else - - - -uint64_t lineMask64(uint64_t* array, int start, uint64_t value) { - uint64_t* p = array + start; - uint64_t m = 0; - int offset = start & 0x7; - - switch (offset) { - case 0: m |= mask(*p++, value) & 0x1; - case 1: m |= mask(*p++, value) & 0x2; - case 2: m |= mask(*p++, value) & 0x4; - case 3: m |= mask(*p++, value) & 0x8; - case 4: m |= mask(*p++, value) & 0x10; - case 5: m |= mask(*p++, value) & 0x20; - case 6: m |= mask(*p++, value) & 0x40; - case 7: m |= mask(*p++, value) & 0x80; - } - - return m >> offset; -} - - -uint64_t lineMask64_2(uint64_t* array, int start, uint64_t x1, uint64_t x2) { - uint64_t* p = array + start; - uint64_t m = 0; - int offset = start & 0x7; - - switch (offset) { - case 0: m |= (mask(*p, x1) | mask(*p, x2)) & 0x1; ++p; - case 1: m |= (mask(*p, x1) | mask(*p, x2)) & 0x2; ++p; - case 2: m |= (mask(*p, x1) | mask(*p, x2)) & 0x4; ++p; - case 3: m |= (mask(*p, x1) | mask(*p, x2)) & 0x8; ++p; - case 4: m |= (mask(*p, x1) | mask(*p, x2)) & 0x10; ++p; - case 5: m |= (mask(*p, x1) | mask(*p, x2)) & 0x20; ++p; - case 6: m |= (mask(*p, x1) | mask(*p, x2)) & 0x40; ++p; - case 7: m |= (mask(*p, x1) | mask(*p, x2)) & 0x80; ++p; - } - - return m >> offset; -} - - -uint64_t lineMask64_3(uint64_t* array, int start, - uint64_t x1, uint64_t x2, uint64_t x3) { - uint64_t* p = array + start; - uint64_t m = 0; - int offset = start & 0x7; - - switch (offset) { - case 0: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x1; ++p; - case 1: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x2; ++p; - case 2: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x4; ++p; - case 3: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x8; ++p; - case 4: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x10; ++p; - case 5: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x20; ++p; - case 6: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x40; ++p; - case 7: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x80; ++p; - } - - return m >> offset; -} - - -#endif // USE_SSE_4_1 - - -int64_t lineResult64(int64_t m, int64_t start) { - int p = firstBitSet((int)m); - int64_t mm = (int64_t) mask(p, -1); - return mm | (~mm & (start + p)); -} - - -int lineSearch64(uint64_t* array, int start, uint64_t value) { - uint64_t m = lineMask64(array, start, value); - return lineResult64((int)m, start); -} - - -int lineSearch64_2(uint64_t* array, int start, uint64_t x1, uint64_t x2) { - uint64_t m = lineMask64_2(array, start, x1, x2); - return lineResult64((int)m, start); -} - - -int lineSearch64_3(uint64_t* array, int start, - uint64_t x1, uint64_t x2, uint64_t x3) { - uint64_t m = lineMask64_3(array, start, x1, x2, x3); - return lineResult64((int)m, start); -} - -void suicide(volatile int* check, int t) { - int secs = (3*t + 999999) / 1000000; - if (secs < 1) secs = 1; -#ifdef WIN32 - Sleep(secs * 1000); -#else - sleep(secs); -#endif - if (*check) { - printf("timeout expired, dying!!\n"); -#ifdef WIN32 - abort(); -#else - raise(SIGKILL); -#endif - } -} diff --git a/cbits/check.c b/cbits/check.c new file mode 100644 --- /dev/null +++ b/cbits/check.c @@ -0,0 +1,185 @@ +#include +#include +#include "defs.h" + +static const int NUMH = 64 / sizeof(small_hash_t); + +static small_hash_t t_sevens[32] = + { 7,7,7,7,7,7,7,7, + 7,7,7,7,7,7,7,7, + 7,7,7,7,7,7,7,7, + 7,7,7,7,7,7,7,7 }; + +static small_hash_t t_zeroes[32] = + { 0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0, + 0,0,0,0,0,0,0,0 }; + +static small_hash_t t_mixed[32] = + { 7,1,7,7,2,7,7,7, + 7,7,3,7,7,7,7,7, + 7,7,7,7,1,7,7,7, + 7,7,7,7,3,7,7,9 }; + +static int num_tests = 0; +static int num_errors = 0; + +void CHECK(int actual, int expected, char* what) { + ++num_tests; + if (actual != expected) { + fprintf(stderr, "%s: expected %d, got %d\n", what, expected, actual); + + ++num_errors; + } +} + + +void check_forward_search_2() { + /* forward_search_2 */ + /* - offset zero */ + CHECK(forward_search_2(t_sevens, 0, NUMH, 0, 7 ), 0, "fs2-sevens-ok-1" ); + CHECK(forward_search_2(t_sevens, 0, NUMH, 7, 0 ), 0, "fs2-sevens-ok-2" ); + CHECK(forward_search_2(t_sevens, 0, NUMH, 7, 7 ), 0, "fs2-sevens-ok-3" ); + CHECK(forward_search_2(t_sevens, 0, NUMH, 3, 0 ), -1, "fs2-sevens-fail-1"); + CHECK(forward_search_2(t_zeroes, 0, NUMH, 0, 1 ), 0, "fs2-zeroes-ok-1" ); + CHECK(forward_search_2(t_zeroes, 0, NUMH, 2, 0 ), 0, "fs2-zeroes-ok-2" ); + CHECK(forward_search_2(t_zeroes, 0, NUMH, 2, 0xf0), -1, "fs2-zeroes-fail-1"); + + /* - offset 5 */ + CHECK(forward_search_2(t_sevens, 5, NUMH, 0, 7), 5, "fs2-o-sevens-ok-1" ); + CHECK(forward_search_2(t_sevens, 5, NUMH, 7, 0), 5, "fs2-o-sevens-ok-2" ); + CHECK(forward_search_2(t_sevens, 5, NUMH, 7, 7), 5, "fs2-o-sevens-ok-3" ); + CHECK(forward_search_2(t_sevens, 5, NUMH, 3, 0), -1, "fs2-o-sevens-fail-1"); + CHECK(forward_search_2(t_zeroes, 5, NUMH, 0, 1), 5, "fs2-o-zeroes-ok-1" ); + CHECK(forward_search_2(t_zeroes, 5, NUMH, 2, 0), 5, "fs2-o-zeroes-ok-2" ); + CHECK(forward_search_2(t_zeroes, 5, NUMH, 2, 0xf0), -1, "fs2-o-zeroes-fail-1"); + + /* - mixed, offset zero */ + CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 0xf0), 4, "fs2-mixed-ok-1" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 4, 0xf0), -1, "fs2-mixed-fail-1"); + CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 1), 1, "fs2-mixed-ok-2" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 7), 0, "fs2-mixed-ok-3" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 3), 4, "fs2-mixed-ok-4" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 9, 3), 10, "fs2-mixed-ok-5" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 3, 9), 10, "fs2-mixed-ok-5" ); + CHECK(forward_search_2(t_mixed, 0, NUMH, 8, 9), 31, "fs2-mixed-ok-6" ); + + /* - mixed, offset 16 */ + CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 0xf0), 4, "fs2-o-mixed-ok-1" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 4, 0xf0), -1, "fs2-o-mixed-fail-1"); + CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 1), 20, "fs2-o-mixed-ok-2" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 7), 16, "fs2-o-mixed-ok-3" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 3), 28, "fs2-o-mixed-ok-4" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 9, 3), 28, "fs2-o-mixed-ok-5" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 3, 9), 28, "fs2-o-mixed-ok-5" ); + CHECK(forward_search_2(t_mixed, 16, NUMH, 8, 9), 31, "fs2-o-mixed-ok-6" ); +} + +void check_forward_search_3() { + /* forward_search_3 */ + /* - offset zero */ + CHECK(forward_search_3(t_sevens, 0, NUMH, 0, 7, 88), 0, "fs3-sevens-ok-1" ); + CHECK(forward_search_3(t_sevens, 0, NUMH, 7, 0, 88), 0, "fs3-sevens-ok-2" ); + CHECK(forward_search_3(t_sevens, 0, NUMH, 7, 7, 88), 0, "fs3-sevens-ok-3" ); + CHECK(forward_search_3(t_sevens, 0, NUMH, 3, 0, 88), -1, "fs3-sevens-fail-1"); + CHECK(forward_search_3(t_zeroes, 0, NUMH, 0, 1, 88), 0, "fs3-zeroes-ok-1" ); + CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 0, 88), 0, "fs3-zeroes-ok-2" ); + CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 11, 0 ), 0, "fs3-zeroes-ok-3" ); + CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 32, 88), -1, "fs3-zeroes-fail-1"); + + /* - offset 5 */ + CHECK(forward_search_3(t_sevens, 5, NUMH, 0, 7, 7 ), 5, "fs3-o-sevens-ok-1" ); + CHECK(forward_search_3(t_sevens, 5, NUMH, 7, 0, 21), 5, "fs3-o-sevens-ok-2" ); + CHECK(forward_search_3(t_sevens, 5, NUMH, 7, 7, 21), 5, "fs3-o-sevens-ok-3" ); + CHECK(forward_search_3(t_sevens, 5, NUMH, 3, 0, 21), -1, "fs3-o-sevens-fail-1"); + CHECK(forward_search_3(t_zeroes, 5, NUMH, 0, 1, 21), 5, "fs3-o-zeroes-ok-1" ); + CHECK(forward_search_3(t_zeroes, 5, NUMH, 2, 0, 21), 5, "fs3-o-zeroes-ok-2" ); + CHECK(forward_search_3(t_zeroes, 5, NUMH, 2, 0xf0, 21), -1, "fs3-o-zeroes-fail-1"); + + /* - mixed, offset zero */ + CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 0xf0, -1), 4, "fs3-mixed-ok-1" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 4, 0xf0, -1), -1, "fs3-mixed-fail-1"); + CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 1, -1), 1, "fs3-mixed-ok-2" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 7, -1), 0, "fs3-mixed-ok-3" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 3, -1), 4, "fs3-mixed-ok-4" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 9, 3, -1), 10, "fs3-mixed-ok-5" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 3, 9, -1), 10, "fs3-mixed-ok-5" ); + CHECK(forward_search_3(t_mixed, 0, NUMH, 8, 9, -1), 31, "fs3-mixed-ok-6" ); + + /* - mixed, offset 16 */ + CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 96, 33), 4, "fs3-o-mixed-ok-1" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 4, 96, 33), -1, "fs3-o-mixed-fail-1"); + CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 1, 33), 20, "fs3-o-mixed-ok-2" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 7, 33), 16, "fs3-o-mixed-ok-3" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 3, 33), 28, "fs3-o-mixed-ok-4" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 9, 3, 33), 28, "fs3-o-mixed-ok-5" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 3, 9, 33), 28, "fs3-o-mixed-ok-5" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 8, 9, 33), 31, "fs3-o-mixed-ok-6" ); + CHECK(forward_search_3(t_mixed, 16, NUMH, 8, 33, 9 ), 31, "fs3-o-mixed-ok-7" ); +} + +void check_line_search() { + CHECK(line_search(t_sevens, 0, 7), 0, "ls-7s-ok-1"); + CHECK(line_search(t_sevens, 5, 7), 5, "ls-7s-ok-2"); + CHECK(line_search(t_sevens, 31, 7), 31, "ls-7s-ok-3"); + CHECK(line_search(t_sevens, 0, 1), -1, "ls-7s-fail-1"); + CHECK(line_search(t_sevens, 31, 1), -1, "ls-7s-fail-2"); + + CHECK(line_search(t_mixed, 0, 7), 0, "ls-m-ok-1"); + CHECK(line_search(t_mixed, 0, 1), 1, "ls-m-ok-2"); + CHECK(line_search(t_mixed, 1, 7), 2, "ls-m-ok-3"); + CHECK(line_search(t_mixed, 0, 9), 31, "ls-m-ok-4"); + CHECK(line_search(t_mixed, 0, 8), -1, "ls-m-fail-1"); + + CHECK(line_search(t_mixed, 16, 1), 20, "ls-m-ok-5"); +} + +void check_line_search_2() { + CHECK(line_search_2(t_sevens, 0, 7, 3), 0, "ls2-7s-ok-1"); + CHECK(line_search_2(t_sevens, 5, 7, 9), 5, "ls2-7s-ok-2"); + CHECK(line_search_2(t_sevens, 31, 0, 7), 31, "ls2-7s-ok-3"); + CHECK(line_search_2(t_sevens, 0, 1, 3), -1, "ls2-7s-fail-1"); + CHECK(line_search_2(t_sevens, 31, 6, 1), -1, "ls2-7s-fail-2"); + + CHECK(line_search_2(t_mixed, 0, 7, 9), 0, "ls2-m-ok-1"); + CHECK(line_search_2(t_mixed, 0, 9, 1), 1, "ls2-m-ok-2"); + CHECK(line_search_2(t_mixed, 1, 7, 9), 2, "ls2-m-ok-3"); + CHECK(line_search_2(t_mixed, 0, 8, 9), 31, "ls2-m-ok-4"); + CHECK(line_search_2(t_mixed, 0, 8, 4), -1, "ls2-m-fail-1"); + + CHECK(line_search_2(t_mixed, 16, 3, 1), 20, "ls2-m-ok-5"); +} + +void check_line_search_3() { + CHECK(line_search_3(t_sevens, 0, 4, 7, 3), 0, "ls2-7s-ok-1"); + CHECK(line_search_3(t_sevens, 5, 7, 4, 9), 5, "ls2-7s-ok-2"); + CHECK(line_search_3(t_sevens, 31, 0, 7, 4), 31, "ls2-7s-ok-3"); + CHECK(line_search_3(t_sevens, 0, 1, 4, 3), -1, "ls2-7s-fail-1"); + CHECK(line_search_3(t_sevens, 31, 4, 6, 1), -1, "ls2-7s-fail-2"); + + CHECK(line_search_3(t_mixed, 0, 4, 7, 9), 0, "ls2-m-ok-1"); + CHECK(line_search_3(t_mixed, 0, 9, 4, 1), 1, "ls2-m-ok-2"); + CHECK(line_search_3(t_mixed, 1, 7, 9, 4), 2, "ls2-m-ok-3"); + CHECK(line_search_3(t_mixed, 0, 8, 4, 9), 31, "ls2-m-ok-4"); + CHECK(line_search_3(t_mixed, 0, 8, 4, 6), -1, "ls2-m-fail-1"); + + CHECK(line_search_3(t_mixed, 16, 3, 1, 6), 20, "ls2-m-ok-5"); +} + + +int main() { + check_forward_search_2(); + check_forward_search_3(); + check_line_search(); + check_line_search_2(); + check_line_search_3(); + check_impl_specific(); + + if (num_errors > 0) { + printf("\n*** %d/%d tests failed.\n", num_errors, num_tests); + } else { + printf("All %d tests passed.\n", num_tests); + } + exit(num_errors < 255 ? num_errors : 255); +} diff --git a/cbits/common.c b/cbits/common.c new file mode 100644 --- /dev/null +++ b/cbits/common.c @@ -0,0 +1,79 @@ +#include "defs.h" + +#ifdef WIN32 +#include +#else +#include +#include +#endif + +#include + +void suicide(volatile int* check, int t) { + int secs = (3*t + 999999) / 1000000; + if (secs < 1) secs = 1; +#ifdef WIN32 + Sleep(secs * 1000); +#else + sleep(secs); +#endif + if (*check) { + printf("timeout expired, dying!!\n"); + exit(1); + } +} + +#if defined(__GNUC__) +#define PREFETCH_READ(x) (__builtin_prefetch(x, 0, 3)) +#define PREFETCH_WRITE(x) (__builtin_prefetch(x, 1, 3)) +#else +#define PREFETCH_READ(x) +#define PREFETCH_WRITE(x) +#endif + +void prefetch_cacheline_read(small_hash_t* line, int start) +{ + PREFETCH_READ((void*)(&line[start])); +} + +void prefetch_cacheline_write(small_hash_t* line, int start) +{ + PREFETCH_WRITE((void*)(&line[start])); +} + +int forward_search_2(small_hash_t* array, int start, int end, + small_hash_t x1, small_hash_t x2) { + small_hash_t* ep = array + end; + small_hash_t* p = array + start; + int wrapped = 0; + while (1) { + if (p >= ep) { + if (wrapped) return -1; + ep = array + start; + p = array; + wrapped = 1; + continue; + } + if (*p == x1 || *p == x2) return p - array; + ++p; + } +} + +int forward_search_3(small_hash_t* array, int start, int end, + small_hash_t x1, small_hash_t x2, small_hash_t x3) { + small_hash_t* ep = array + end; + small_hash_t* p = array + start; + int wrapped = 0; + while (1) { + if (p >= ep) { + if (wrapped) return -1; + ep = array + start; + p = array; + wrapped = 1; + continue; + } + if (*p == x1 || *p == x2 || *p == x3) return p - array; + ++p; + } +} + diff --git a/cbits/default.c b/cbits/default.c new file mode 100644 --- /dev/null +++ b/cbits/default.c @@ -0,0 +1,203 @@ +// Specialized i686 versions of the cache line search functions. + +#include "defs.h" + +static inline int32_t mask(int32_t a, int32_t b) { return -(a == b); } + +#if defined(__GNUC__) +static inline int32_t first_bit_set(int32_t a) { + return __builtin_ffs(a) - 1; +} +#else +static uint8_t de_bruijn_table[] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +static inline int32_t first_bit_set(int32_t a) { + int32_t zero_case = mask(0, a); + uint32_t x = (uint32_t) (a & -a); + x *= 0x077CB531; + x >>= 27; + return zero_case | de_bruijn_table[x]; +} +#endif + +static inline uint32_t line_mask(small_hash_t* array, int start, + small_hash_t x1) { + small_hash_t* p = array + start; + uint32_t m1 = 0; + uint32_t m2 = 0; + uint32_t m3 = 0; + int offset = start & 0x1f; + +#define M (mask(*p, x1)) + + switch (offset) { + case 0: m1 |= M & 0x1; ++p; + case 1: m2 |= M & 0x2; ++p; + case 2: m3 |= M & 0x4; ++p; + case 3: m1 |= M & 0x8; ++p; + case 4: m2 |= M & 0x10; ++p; + case 5: m3 |= M & 0x20; ++p; + case 6: m1 |= M & 0x40; ++p; + case 7: m2 |= M & 0x80; ++p; + case 8: m3 |= M & 0x100; ++p; + case 9: m1 |= M & 0x200; ++p; + case 10: m2 |= M & 0x400; ++p; + case 11: m3 |= M & 0x800; ++p; + case 12: m1 |= M & 0x1000; ++p; + case 13: m2 |= M & 0x2000; ++p; + case 14: m3 |= M & 0x4000; ++p; + case 15: m1 |= M & 0x8000; ++p; + case 16: m2 |= M & 0x10000; ++p; + case 17: m3 |= M & 0x20000; ++p; + case 18: m1 |= M & 0x40000; ++p; + case 19: m2 |= M & 0x80000; ++p; + case 20: m3 |= M & 0x100000; ++p; + case 21: m1 |= M & 0x200000; ++p; + case 22: m2 |= M & 0x400000; ++p; + case 23: m3 |= M & 0x800000; ++p; + case 24: m1 |= M & 0x1000000; ++p; + case 25: m2 |= M & 0x2000000; ++p; + case 26: m3 |= M & 0x4000000; ++p; + case 27: m1 |= M & 0x8000000; ++p; + case 28: m2 |= M & 0x10000000; ++p; + case 29: m3 |= M & 0x20000000; ++p; + case 30: m1 |= M & 0x40000000; ++p; + case 31: m2 |= M & 0x80000000; ++p; + } + +#undef M + + return (m1 | m2 | m3) >> offset; +} + +static inline uint32_t line_mask_2(small_hash_t* array, int start, + small_hash_t x1, small_hash_t x2) { + small_hash_t* p = array + start; + uint32_t m1 = 0; + uint32_t m2 = 0; + uint32_t m3 = 0; + int offset = start & 0x1f; + +#define M (mask(*p, x1) | mask(*p, x2)) + + switch (offset) { + case 0: m1 |= M & 0x1; ++p; + case 1: m2 |= M & 0x2; ++p; + case 2: m3 |= M & 0x4; ++p; + case 3: m1 |= M & 0x8; ++p; + case 4: m2 |= M & 0x10; ++p; + case 5: m3 |= M & 0x20; ++p; + case 6: m1 |= M & 0x40; ++p; + case 7: m2 |= M & 0x80; ++p; + case 8: m3 |= M & 0x100; ++p; + case 9: m1 |= M & 0x200; ++p; + case 10: m2 |= M & 0x400; ++p; + case 11: m3 |= M & 0x800; ++p; + case 12: m1 |= M & 0x1000; ++p; + case 13: m2 |= M & 0x2000; ++p; + case 14: m3 |= M & 0x4000; ++p; + case 15: m1 |= M & 0x8000; ++p; + case 16: m2 |= M & 0x10000; ++p; + case 17: m3 |= M & 0x20000; ++p; + case 18: m1 |= M & 0x40000; ++p; + case 19: m2 |= M & 0x80000; ++p; + case 20: m3 |= M & 0x100000; ++p; + case 21: m1 |= M & 0x200000; ++p; + case 22: m2 |= M & 0x400000; ++p; + case 23: m3 |= M & 0x800000; ++p; + case 24: m1 |= M & 0x1000000; ++p; + case 25: m2 |= M & 0x2000000; ++p; + case 26: m3 |= M & 0x4000000; ++p; + case 27: m1 |= M & 0x8000000; ++p; + case 28: m2 |= M & 0x10000000; ++p; + case 29: m3 |= M & 0x20000000; ++p; + case 30: m1 |= M & 0x40000000; ++p; + case 31: m2 |= M & 0x80000000; ++p; + } + +#undef M + + return (m1 | m2 | m3) >> offset; +} + +static inline uint32_t line_mask_3(small_hash_t* array, int start, + small_hash_t x1, small_hash_t x2, + small_hash_t x3) { + small_hash_t* p = array + start; + uint32_t m1 = 0; + uint32_t m2 = 0; + uint32_t m3 = 0; + int offset = start & 0x1f; + +#define M (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) + + switch (offset) { + case 0: m1 |= M & 0x1; ++p; + case 1: m2 |= M & 0x2; ++p; + case 2: m3 |= M & 0x4; ++p; + case 3: m1 |= M & 0x8; ++p; + case 4: m2 |= M & 0x10; ++p; + case 5: m3 |= M & 0x20; ++p; + case 6: m1 |= M & 0x40; ++p; + case 7: m2 |= M & 0x80; ++p; + case 8: m3 |= M & 0x100; ++p; + case 9: m1 |= M & 0x200; ++p; + case 10: m2 |= M & 0x400; ++p; + case 11: m3 |= M & 0x800; ++p; + case 12: m1 |= M & 0x1000; ++p; + case 13: m2 |= M & 0x2000; ++p; + case 14: m3 |= M & 0x4000; ++p; + case 15: m1 |= M & 0x8000; ++p; + case 16: m2 |= M & 0x10000; ++p; + case 17: m3 |= M & 0x20000; ++p; + case 18: m1 |= M & 0x40000; ++p; + case 19: m2 |= M & 0x80000; ++p; + case 20: m3 |= M & 0x100000; ++p; + case 21: m1 |= M & 0x200000; ++p; + case 22: m2 |= M & 0x400000; ++p; + case 23: m3 |= M & 0x800000; ++p; + case 24: m1 |= M & 0x1000000; ++p; + case 25: m2 |= M & 0x2000000; ++p; + case 26: m3 |= M & 0x4000000; ++p; + case 27: m1 |= M & 0x8000000; ++p; + case 28: m2 |= M & 0x10000000; ++p; + case 29: m3 |= M & 0x20000000; ++p; + case 30: m1 |= M & 0x40000000; ++p; + case 31: m2 |= M & 0x80000000; ++p; + } +#undef M + + return (m1 | m2 | m3) >> offset; +} + + +static inline int32_t line_result(uint32_t m, int start) { + int32_t p = first_bit_set((int32_t) m); + int32_t mm = mask(p, -1); + return mm | (start + p); +} + + +int line_search(small_hash_t* array, int start, small_hash_t x1) { + uint32_t m = line_mask(array, start, x1); + return line_result(m, start); +} + +int line_search_2(small_hash_t* array, int start, small_hash_t x1, + small_hash_t x2) { + uint32_t m = line_mask_2(array, start, x1, x2); + return line_result(m, start); +} + +int line_search_3(small_hash_t* array, int start, small_hash_t x1, + small_hash_t x2, small_hash_t x3) { + uint32_t m = line_mask_3(array, start, x1, x2, x3); + return line_result(m, start); +} + +void check_impl_specific(int* num_tests, int* num_errors) { + +} diff --git a/cbits/defs.h b/cbits/defs.h new file mode 100644 --- /dev/null +++ b/cbits/defs.h @@ -0,0 +1,35 @@ +#ifndef HASHTABLES_DEFS_H +#define HASHTABLES_DEFS_H + +#include +#include + +typedef uintptr_t full_hash_t; +typedef uint16_t small_hash_t; + +void prefetch_cacheline_write(small_hash_t* line, int start); +void prefetch_cacheline_read(small_hash_t* line, int start); + +int forward_search_2(small_hash_t* array, + int start, + int end, + small_hash_t x1, + small_hash_t x2); +int forward_search_3(small_hash_t* array, + int start, + int end, + small_hash_t x1, + small_hash_t x2, + small_hash_t x3); + +int line_search(small_hash_t* array, int start, small_hash_t x1); +int line_search_2(small_hash_t* array, int start, small_hash_t x1, + small_hash_t x2); +int line_search_3(small_hash_t* array, int start, small_hash_t x1, + small_hash_t x2, small_hash_t x3); +void suicide(volatile int* check, int i); + +void CHECK(int actual, int expected, char* what); +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 new file mode 100644 --- /dev/null +++ b/cbits/sse-42-check.c @@ -0,0 +1,38 @@ +#include "defs.h" + +#include +#include + +extern __m128i fill(small_hash_t v); + +static void check_fill(small_hash_t v) { + int i; + char buf[256]; + small_hash_t v2; + + __m128i x = fill(v); + +#define F(i) do { \ + v2 = _mm_extract_epi16(x, i); \ + sprintf(buf, "fill-%x-%d-of-8", (int) v, i+1); \ + CHECK(v2, v, buf); \ + } while(0); + + F(0); + F(1); + F(2); + F(3); + F(4); + F(5); + F(6); + F(7); +#undef F +} + +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)); + check_fill(7); + check_fill(0xff); +} diff --git a/cbits/sse-42.c b/cbits/sse-42.c new file mode 100644 --- /dev/null +++ b/cbits/sse-42.c @@ -0,0 +1,172 @@ +#include "defs.h" + +#include +#include + +/* Straight-line branchless SSE 4.2 code for searching an array of uint16_t + hash codes. */ + +static inline int32_t mask(int32_t a, int32_t b) { return -(a == b); } + +#if defined(__GNUC__) +static inline int32_t first_bit_set(int32_t a) { + return __builtin_ffs(a) - 1; +} +#else +static uint8_t de_bruijn_table[] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +static inline int32_t first_bit_set(int32_t a) { + int32_t zero_case = mask(0, a); + uint32_t x = (uint32_t) (a & -a); + x *= 0x077CB531; + x >>= 27; + return zero_case | de_bruijn_table[x]; +} +#endif + +static inline __m128i fill(small_hash_t v) { + int32_t v1 = (((int)v) << 16) | v; + __m128i x = _mm_cvtsi32_si128(0); + x = _mm_insert_epi32(x, v1, 0); + return _mm_shuffle_epi32(x, _MM_SHUFFLE(0,0,0,0)); +} + +#ifndef SIDD_UWORD_OPS +#define SIDD_UWORD_OPS _SIDD_UWORD_OPS +#endif + +#ifndef SIDD_CMP_EQUAL_EACH +#define SIDD_CMP_EQUAL_EACH _SIDD_CMP_EQUAL_EACH +#endif + +#ifndef SIDD_BIT_MASK +#define SIDD_BIT_MASK _SIDD_BIT_MASK +#endif + +#define _MODE (SIDD_UWORD_OPS | SIDD_CMP_EQUAL_EACH) + +static inline __m128i cmp_mask(__m128i a, __m128i b) { + const int mode = SIDD_UWORD_OPS | SIDD_CMP_EQUAL_EACH | SIDD_BIT_MASK; + return _mm_cmpistrm(a, b, mode); +} + +static inline int32_t line_result(uint32_t m, int start) { + int32_t p = first_bit_set((int32_t) m); + int32_t mm = mask(p, -1); + return mm | (start + p); +} + +#define DUMP(xval) do { \ + uint16_t xval##_x0 = _mm_extract_epi16(xval, 0); \ + uint16_t xval##_x1 = _mm_extract_epi16(xval, 1); \ + uint16_t xval##_x2 = _mm_extract_epi16(xval, 2); \ + uint16_t xval##_x3 = _mm_extract_epi16(xval, 3); \ + uint16_t xval##_x4 = _mm_extract_epi16(xval, 4); \ + uint16_t xval##_x5 = _mm_extract_epi16(xval, 5); \ + uint16_t xval##_x6 = _mm_extract_epi16(xval, 6); \ + uint16_t xval##_x7 = _mm_extract_epi16(xval, 7); \ + printf(" % 10s: %04x-%04x-%04x-%04x-%04x-%04x-%04x-%04x\n", \ + #xval, xval##_x0, xval##_x1, xval##_x2, xval##_x3, \ + xval##_x4, xval##_x5, xval##_x6, xval##_x7); \ + } while(0); + + +int line_search(small_hash_t* array, int start0, small_hash_t v1) { + int offset = start0 & 31; + int start = start0 & ~31; + __m128i* p = (__m128i*) &array[start]; + __m128i x1, val1, val2, val3, val4; + __m128i m1, m2, m3, m4, dmask; + + x1 = fill(v1); + + val1 = *p++; + m1 = cmp_mask(x1, val1); + val2 = *p++; + m2 = _mm_slli_si128(cmp_mask(x1, val2), 1); + val3 = *p++; + m3 = _mm_slli_si128(cmp_mask(x1, val3), 2); + val4 = *p; + m4 = _mm_slli_si128(cmp_mask(x1, val4), 3); + + dmask = _mm_or_si128(_mm_or_si128(m1, m2), + _mm_or_si128(m3, m4)); + uint32_t imask = _mm_extract_epi32(dmask, 0); + + const uint32_t p2 = 1 << offset; + const uint32_t dest_mask = imask & ~(p2 - 1); + + return line_result(dest_mask, start); +} + +int line_search_2(small_hash_t* array, int start0, small_hash_t v1, + small_hash_t v2) { + int offset = start0 & 31; + int start = start0 & ~31; + __m128i* p = (__m128i*) &array[start]; + __m128i x1, x2, val1, val2, val3, val4; + __m128i m1, m2, m3, m4, dmask; + + x1 = fill(v1); + x2 = fill(v2); + +#define M(v) _mm_or_si128(cmp_mask(x1,(v)), \ + cmp_mask(x2,(v))) + val1 = *p++; + m1 = M(val1); + val2 = *p++; + m2 = _mm_slli_si128(M(val2), 1); + val3 = *p++; + m3 = _mm_slli_si128(M(val3), 2); + val4 = *p; + m4 = _mm_slli_si128(M(val4), 3); +#undef M + + dmask = _mm_or_si128(_mm_or_si128(m1, m2), + _mm_or_si128(m3, m4)); + uint32_t imask = _mm_extract_epi32(dmask, 0); + + const uint32_t p2 = 1 << offset; + const uint32_t dest_mask = imask & ~(p2 - 1); + + return line_result(dest_mask, start); +} + +int line_search_3(small_hash_t* array, int start0, small_hash_t v1, + small_hash_t v2, small_hash_t v3) { + int offset = start0 & 31; + int start = start0 & ~31; + __m128i* p = (__m128i*) &array[start]; + __m128i x1, x2, x3, val1, val2, val3, val4; + __m128i m1, m2, m3, m4, dmask; + + x1 = fill(v1); + x2 = fill(v2); + x3 = fill(v3); + +#define M(v) _mm_or_si128( \ + cmp_mask(x1,(v)), \ + _mm_or_si128(cmp_mask(x2,(v)), \ + cmp_mask(x3,(v)))) + val1 = *p++; + m1 = M(val1); + val2 = *p++; + m2 = _mm_slli_si128(M(val2), 1); + val3 = *p++; + m3 = _mm_slli_si128(M(val3), 2); + val4 = *p; + m4 = _mm_slli_si128(M(val4), 3); +#undef M + + dmask = _mm_or_si128(_mm_or_si128(m1, m2), + _mm_or_si128(m3, m4)); + uint32_t imask = _mm_extract_epi32(dmask, 0); + + const uint32_t p2 = 1 << offset; + const uint32_t dest_mask = imask & ~(p2 - 1); + + return line_result(dest_mask, start); +} diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,191 @@ +# 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. + +## 1.2.1.0 + + - Fixed an FFI import typo bug + (https://github.com/gregorycollins/hashtables/pull/27), thanks to Thijs + Alkemade for the fix. + +## 1.2.0.2 + + - Fixed serious bug (https://github.com/gregorycollins/hashtables/issues/24) + in basic hash table making it impossible to reliably store more than 64k + elements (after shortening the hash code arrays to 16 bits I neglected to + realize that I was storing item counts using the same array type). + +## 1.2.0.1 + + - Fixed bug in C code re: clang interpreting "inline" strictly according to + (insane) C99 semantics: http://clang.llvm.org/compatibility.html#inline + + - Fixed a compile bug affecting versions of base older than 4.4. + + - Changed int type from Int to Word in CheapPseudoRandomBitStream to fix an + integer overflow warning. + +## 1.2.0.0 + +### Switch to smaller hash codes to go faster and save space. + +Before, in the basic and cuckoo hash tables, we were storing full +machine-word-sized hash codes in the table so that we could quickly search a +whole cache line for a key (or a combination of keys) without branching. + +It turns out that a full machine word is not really necessary for this +application; switching to a 16-bit key will very slightly increase the number +of hash collisions within buckets (meaning that we'll compare more keys), but +will pay big dividends in terms of: + + - reduced wastage of RAM + + - searching more keys at once, allowing buckets to grow bigger + + - more cache hits on the hash codes array. + +### Other + + - Dependency bumps + + - Fix definitions of forwardSearch2 and forwardSearch3 in PORTABLE mode (also + used on Windows) to match C implementations. + +## 1.1.2.1 + - Fixes for GHC 7.8 compatibility. + +## 1.1.2.0 + - Bump allowable versions of hashable, primitive, and vector, blacklisting + some bad hashable versions + + - Add specialize pragmas for fromListWithSizeHint + +## 1.1.0.2 + - Use CPP to allow compilation against base 4.2/4.3. + +## 1.1.0.1 + - Re-added SPECIALIZE pragmas that were previously removed. + +## 1.1.0.0 + - Add 'fromListWithSizeHint' + - 'fromList': don't be strict in the list argument + +## 1.0.1.8 +Bump vector and primitive dependencies. + +## 1.0.1.7 +Fix bug in C FFI code (not correctly promoting CInt to Int). + +## 1.0.1.6 +Fix for benchmark suite .cabal file. + +## 1.0.1.5 +Added benchmark suite. + +## 1.0.1.4 +Bump test-framework dependency. + +## 1.0.1.3 +Bump testsuite dependencies. + +## 1.0.1.2 +Fix testsuite on Windows. + +## 1.0.1.1 +Build fix for Windows. + +## 1.0.1.0 + +Bugfix for http://github.com/gregorycollins/hashtables/issues/1 (Basic.lookup +loops). 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.1.2.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-2013, 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 @@ -22,25 +38,25 @@ . This package currently contains three hash table implementations: . - 1. "Data.HashTable.ST.Basic" contains a basic open-addressing hash table - using linear probing as the collision strategy. On a pure speed basis it - should currently be the fastest available Haskell hash table - implementation for lookups, although it has a higher memory overhead - than the other tables and can suffer from long delays when the table is - resized because all of the elements in the table need to be rehashed. - . - 2. "Data.HashTable.ST.Cuckoo" contains an implementation of \"cuckoo + 1. "Data.HashTable.ST.Cuckoo" contains an implementation of \"cuckoo hashing\" as introduced by Pagh and Rodler in 2001 (see ). Cuckoo hashing has worst-case /O(1)/ lookups and can reach a high \"load factor\", in which - the table can perform acceptably well even when more than 90% full. + 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. . + 2. "Data.HashTable.ST.Basic" contains a basic open-addressing hash table + using linear probing as the collision strategy. On a pure speed basis it + should currently be the fastest available Haskell hash table + implementation for lookups, although it has a higher memory overhead + than the other tables and can suffer from long delays when the table is + resized because all of the elements in the table need to be rehashed. + . 3. "Data.HashTable.ST.Linear" contains a linear hash table (see ), which trades some insert and lookup performance for higher space efficiency and much shorter @@ -76,7 +92,7 @@ dangerous. Caveat emptor. In particular, these techniques are incompatible with HPC code coverage reports. . - * @sse41@, default /OFF/. If this flag is enabled, we use some SSE 4.1 + * @sse42@, default /OFF/. If this flag is enabled, we use some SSE 4.2 instructions (see , first available on Intel Core 2 processors) to speed up cache-line searches for cuckoo hashing. @@ -89,23 +105,14 @@ . * @portable@, default /OFF/. If this flag is enabled, we use only pure Haskell code and try not to use unportable GHC extensions. Turning this - flag on forces @unsafe-tricks@ and @sse41@ /OFF/. - . - This package has been tested with GHC 7.0.3, on: - . - * a MacBook Pro running Snow Leopard with an Intel Core i5 processor, - running GHC 7.0.3 in 64-bit mode. - . - * an Arch Linux desktop with an AMD Phenom II X4 940 quad-core processor. - . - * a MacBook Pro running Snow Leopard with an Intel Core 2 Duo processor, - running GHC 6.12.3 in 32-bit mode. + flag on forces @unsafe-tricks@ and @sse42@ /OFF/. . Please send bug reports to . Extra-Source-Files: README.md, + cabal.project, haddock.sh, benchmark/hashtable-benchmark.cabal, benchmark/LICENSE, @@ -118,10 +125,13 @@ benchmark/src/Data/Vector/Algorithms/Shuffle.hs, benchmark/src/Data/Benchmarks/UnorderedCollections/Distributions.hs, benchmark/src/Data/Benchmarks/UnorderedCollections/Types.hs, + cbits/Makefile, + cbits/check.c, + cbits/defs.h, + cbits/sse-42-check.c, + 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 @@ -138,9 +148,15 @@ Flag debug Description: if on, spew debugging output to stdout Default: False + Manual: True -Flag sse41 - Description: if on, use SSE 4.1 extensions to search cache lines very +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. Default: False @@ -150,10 +166,19 @@ Library + Default-Language: Haskell2010 hs-source-dirs: src + 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/cfuncs.c + C-sources: cbits/common.c Exposed-modules: Data.HashTable.Class, Data.HashTable.IO, @@ -169,17 +194,17 @@ 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.12 + vector >= 0.7 && <0.14 if flag(portable) cpp-options: -DNO_C_SEARCH -DPORTABLE if !flag(portable) && flag(unsafe-tricks) && impl(ghc) build-depends: ghc-prim - cpp-options = -DUNSAFETRICKS + cpp-options: -DUNSAFETRICKS if flag(debug) cpp-options: -DDEBUG @@ -187,15 +212,90 @@ if flag(bounds-checking) cpp-options: -DBOUNDS_CHECKING - if flag(sse41) && !flag(portable) - cc-options: -DUSE_SSE_4_1 -msse4.1 - cpp-options: -DUSE_SSE_4_1 + 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 - ghc-prof-options: -prof -auto-all + 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 +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 -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 + 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 @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExplicitForAll #-} -- | This module provides wrappers in 'IO' around the functions from -- "Data.HashTable.Class". @@ -46,31 +47,35 @@ , insert , delete , lookup + , mutate + , mutateIO , fromList , fromListWithSizeHint , toList , mapM_ , foldM , computeOverhead + , lookupIndex + , nextByIndex ) where ------------------------------------------------------------------------------ -import Control.Monad.Primitive (PrimState) -#if MIN_VERSION_base(4,4,0) -import Control.Monad.ST (stToIO) -import Control.Monad.ST.Unsafe (unsafeIOToST) -#else -import Control.Monad.ST (stToIO, unsafeIOToST) +#if !MIN_VERSION_base(4,8,0) +import Data.Word #endif -import Data.Hashable (Hashable) -import qualified Data.HashTable.Class as C -import Prelude hiding (lookup, mapM_) +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_) ------------------------------------------------------------------------------ -import qualified Data.HashTable.ST.Basic as B -import qualified Data.HashTable.ST.Cuckoo as Cu -import qualified Data.HashTable.ST.Linear as L +import Data.HashTable.Internal.Utils (unsafeIOToST) +import qualified Data.HashTable.ST.Basic as B +import qualified Data.HashTable.ST.Cuckoo as Cu +import qualified Data.HashTable.ST.Linear as L ------------------------------------------------------------------------------ @@ -93,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 #-} @@ -103,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 #-} @@ -113,93 +118,145 @@ ------------------------------------------------------------------------------ --- | See the documentation for this function in "Data.HashTable.Class#v:update". +-- | 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 @@ -217,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 @@ -233,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,850 +16,810 @@ , bl_abs# , sign# , mask# - , maskw# - ) where - -#if MIN_VERSION_base(4,4,0) -import Control.Monad.ST (ST) -import Control.Monad.ST.Unsafe -#else -import Control.Monad.ST -#endif - -import Data.HashTable.Internal.IntArray (IntArray) -import qualified Data.HashTable.Internal.IntArray as M - -#ifndef NO_C_SEARCH -import Control.Monad -import Foreign.C.Types -#else -import Data.Bits -import Data.Int -import qualified Data.Vector.Unboxed as U -import GHC.Int -#endif - -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 () -prefetchWrite :: IntArray s -> Int -> ST s () - -#ifndef NO_C_SEARCH -foreign import ccall unsafe "lineSearch32" - c_lineSearch32 :: Ptr a -> CInt -> CUInt -> IO CInt - -foreign import ccall unsafe "lineSearch64" - c_lineSearch64 :: Ptr a -> CInt -> CULong -> IO CInt - -foreign import ccall unsafe "lineSearch32_2" - c_lineSearch32_2 :: Ptr a -> CInt -> CUInt -> CUInt -> IO CInt - -foreign import ccall unsafe "lineSearch64_2" - c_lineSearch64_2 :: Ptr a -> CInt -> CULong -> CULong -> IO CInt - -foreign import ccall unsafe "lineSearch32_3" - c_lineSearch32_3 :: Ptr a -> CInt -> CUInt -> CUInt -> CUInt -> IO CInt - -foreign import ccall unsafe "lineSearch64_3" - c_lineSearch64_3 :: Ptr a -> CInt -> CULong -> CULong -> CULong -> IO CInt - -foreign import ccall unsafe "forwardSearch32_2" - c_forwardSearch32_2 :: Ptr a -> CInt -> CInt -> CUInt -> CUInt -> IO CInt - -foreign import ccall unsafe "forwardSearch32_3" - c_forwardSearch32_3 :: Ptr a -> CInt -> CInt -> CUInt -> CUInt -> CUInt - -> IO CInt - -foreign import ccall unsafe "forwardSearch64_2" - c_forwardSearch64_2 :: Ptr a -> CInt -> CInt -> CULong -> CULong -> IO CInt - -foreign import ccall unsafe "forwardSearch64_3" - c_forwardSearch64_3 :: Ptr a -> CInt -> CInt -> CULong -> CULong -> CULong - -> IO CInt - -foreign import ccall unsafe "prefetchCacheLine32_read" - prefetchCacheLine32_read :: Ptr a -> CInt -> IO () - -foreign import ccall unsafe "prefetchCacheLine64_read" - prefetchCacheLine64_read :: Ptr a -> CInt -> IO () - -foreign import ccall unsafe "prefetchCacheLine32_write" - prefetchCacheLine32_write :: Ptr a -> CInt -> IO () - -foreign import ccall unsafe "prefetchCacheLine64_write" - prefetchCacheLine64_write :: Ptr a -> CInt -> IO () - - -fI :: (Num b, Integral a) => a -> b -fI = fromIntegral - - -prefetchRead a i = unsafeIOToST c - where - v = M.toPtr a - x = fI i - c32 = prefetchCacheLine32_read v x - c64 = prefetchCacheLine64_read v x - c = if wordSize == 32 then c32 else c64 - - -prefetchWrite a i = unsafeIOToST c - where - v = M.toPtr a - x = fI i - c32 = prefetchCacheLine32_write v x - c64 = prefetchCacheLine64_write v x - c = if wordSize == 32 then c32 else c64 - - -{-# INLINE forwardSearch2 #-} -forwardSearch2 :: IntArray s -> Int -> Int -> Int -> Int -> ST s Int -forwardSearch2 !vec !start !end !x1 !x2 = - liftM fromEnum $! unsafeIOToST c - where - c32 = c_forwardSearch32_2 (M.toPtr vec) (fI start) (fI end) (fI x1) (fI x2) - c64 = c_forwardSearch64_2 (M.toPtr vec) (fI start) (fI end) (fI x1) (fI x2) - c = if wordSize == 32 then c32 else c64 - - -{-# INLINE forwardSearch3 #-} -forwardSearch3 :: IntArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int -forwardSearch3 !vec !start !end !x1 !x2 !x3 = - liftM fromEnum $! unsafeIOToST c - where - c32 = c_forwardSearch32_3 (M.toPtr vec) (fI start) (fI end) - (fI x1) (fI x2) (fI x3) - c64 = c_forwardSearch64_3 (M.toPtr vec) (fI start) (fI end) - (fI x1) (fI x2) (fI x3) - c = if wordSize == 32 then c32 else c64 - - -{-# INLINE lineSearch #-} -lineSearch :: IntArray s -> Int -> Int -> ST s Int -lineSearch !vec !start !value = - liftM fromEnum $! unsafeIOToST c - where - c32 = c_lineSearch32 (M.toPtr vec) (fI start) (fI value) - c64 = c_lineSearch64 (M.toPtr vec) (fI start) (fI value) - c = if wordSize == 32 then c32 else c64 - -{-# INLINE lineSearch2 #-} -lineSearch2 :: IntArray s -> Int -> Int -> Int -> ST s Int -lineSearch2 !vec !start !x1 !x2 = - liftM fromEnum $! unsafeIOToST c - where - c32 = c_lineSearch32_2 (M.toPtr vec) (fI start) (fI x1) (fI x2) - c64 = c_lineSearch64_2 (M.toPtr vec) (fI start) (fI x1) (fI x2) - c = if wordSize == 32 then c32 else c64 - -{-# INLINE lineSearch3 #-} -lineSearch3 :: IntArray s -> Int -> Int -> Int -> Int -> ST s Int -lineSearch3 !vec !start !x1 !x2 !x3 = - liftM fromEnum $! unsafeIOToST c - where - c32 = c_lineSearch32_3 (M.toPtr vec) (fI start) (fI x1) (fI x2) (fI x3) - c64 = c_lineSearch64_3 (M.toPtr vec) (fI start) (fI x1) (fI x2) (fI x3) - c = if wordSize == 32 then c32 else c64 -#endif - -{-# INLINE advanceByCacheLineSize #-} -advanceByCacheLineSize :: Int -> Int -> Int -advanceByCacheLineSize !(I# start0#) !(I# vecSize#) = out - where - !(I# clm#) = cacheLineIntMask - !clmm# = not# (int2Word# clm#) - !start# = word2Int# (clmm# `and#` int2Word# start0#) - !(I# nw#) = numWordsInCacheLine - !start'# = start# +# nw# - !s# = sign# (vecSize# -# start'# -# 1#) - !m# = not# (int2Word# s#) - !r# = int2Word# start'# `and#` m# - !out = I# (word2Int# r#) - - -{-# INLINE isCacheLineAligned #-} -isCacheLineAligned :: Int -> Bool -isCacheLineAligned (I# x#) = isTrue# (r# ==# 0#) - where - !(I# m#) = cacheLineIntMask - !mw# = int2Word# m# - !w# = int2Word# x# - !r# = word2Int# (mw# `and#` w#) - - -{-# INLINE sign# #-} --- | Returns 0 if x is positive, -1 otherwise -sign# :: Int# -> Int# -sign# !x# = x# `uncheckedIShiftRA#` wordSizeMinus1# - where - !(I# wordSizeMinus1#) = wordSize-1 - - -{-# INLINE bl_abs# #-} --- | Abs of an integer, branchless -bl_abs# :: Int# -> Int# -bl_abs# !x# = word2Int# r# - where - !m# = sign# x# - !r# = (int2Word# (m# +# x#)) `xor#` int2Word# m# - - -{-# INLINE mask# #-} --- | Returns 0xfff..fff (aka -1) if a# == b#, 0 otherwise. -mask# :: Int# -> Int# -> Int# -mask# !a# !b# = dest# - where - !d# = a# -# b# - !r# = bl_abs# d# -# 1# - !dest# = sign# r# - - -{- note: this code should be: - -mask# :: Int# -> Int# -> Int# -mask# !a# !b# = let !(I# z#) = fromEnum (a# ==# b#) - !q# = negateInt# z# - in q# - -but GHC doesn't properly optimize this as straight-line code at the moment. - --} - - -{-# INLINE maskw# #-} -maskw# :: Int# -> Int# -> Word# -maskw# !a# !b# = int2Word# (mask# a# b#) - - -#ifdef NO_C_SEARCH -prefetchRead _ _ = return () -prefetchWrite _ _ = return () - -{-# INLINE forwardSearch2 #-} -forwardSearch2 :: IntArray s -> Int -> Int -> Int -> Int -> ST s Int -forwardSearch2 !vec !start !end !x1 !x2 = go start end False - where - next !i !e !b = let !j = i+1 - in if j == e - then (if b then (-1,e,True) else (0,start,True)) - else (j,e,b) - - go !i !e !b = do - h <- M.readArray vec i - if h == x1 || h == x2 - then return i - else do - let (!i',!e',!b') = next i e b - if (i' < 0) then return (-1) else go i' e' b' - - -{-# INLINE forwardSearch3 #-} -forwardSearch3 :: IntArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int -forwardSearch3 !vec !start !end !x1 !x2 !x3 = go start end False - where - next !i !e !b = let !j = i+1 - in if j == e - then (if b then (-1,e,True) else (0,start,True)) - else (j,e,b) - - go !i !e !b = do - h <- M.readArray vec i - if h == x1 || h == x2 || h == x3 - then return i - else do - let (!i',!e',!b') = next i e b - if (i' < 0) then return (-1) else go i' e' b' - - -deBruijnBitPositions :: U.Vector Int8 -deBruijnBitPositions = - U.fromList [ - 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, - 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 - ] - - -{-# INLINE firstBitSet# #-} --- only works with 32-bit values -- ok for us here -firstBitSet# :: Int# -> Int# -firstBitSet# i# = word2Int# ((or# zeroCase# posw#)) - where - !zeroCase# = int2Word# (mask# 0# i#) - !w# = int2Word# i# - !iLowest# = word2Int# (and# w# (int2Word# (negateInt# i#))) - !idxW# = uncheckedShiftRL# - (narrow32Word# (timesWord# (int2Word# iLowest#) - (int2Word# 0x077CB531#))) - 27# - !idx = I# (word2Int# idxW#) - !(I8# pos8#) = U.unsafeIndex deBruijnBitPositions idx - !posw# = int2Word# pos8# - -#endif - - ------------------------------------------------------------------------------- --- | Search through a mutable vector for a given int value, cache-line aligned. --- If the start index is cache-line aligned, and there is more than a --- cache-line's room between the start index and the end of the vector, we will --- search the cache-line all at once using an efficient branchless --- bit-twiddling technique. Otherwise, we will use a typical loop. --- -cacheLineSearch :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -cacheLineSearch !vec !start !value = do -#ifdef NO_C_SEARCH - let !vlen = M.length vec - let !st1 = vlen - start - let !nvlen = numWordsInCacheLine - st1 - let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask - let st2 = adv - start - - - if nvlen > 0 || not (isCacheLineAligned start) - then naiveSearch vec start (min st1 st2) value - else lineSearch vec start value -#else - lineSearch vec start value -#endif -{-# INLINE cacheLineSearch #-} - - -#ifdef NO_C_SEARCH --- | Search through a mutable vector for a given int value. The number of --- things to search for must be at most the number of things remaining in the --- vector. -naiveSearch :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ number of things to search - -> Int -- ^ value to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -naiveSearch !vec !start !nThings !value = go start - where - !doneIdx = start + nThings - - go !i | i >= doneIdx = return (-1) - | otherwise = do - x <- M.readArray vec i - if x == value then return i else go (i+1) -{-# INLINE naiveSearch #-} - - -lineResult# :: Word# -- ^ mask - -> Int -- ^ start value - -> Int -lineResult# bitmask# (I# start#) = I# (word2Int# rv#) - where - !p# = firstBitSet# (word2Int# bitmask#) - !mm# = maskw# p# (-1#) - !nmm# = not# mm# - !rv# = mm# `or#` (nmm# `and#` (int2Word# (start# +# p#))) -{-# INLINE lineResult# #-} - - -lineSearch :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch | wordSize == 32 = lineSearch32 - | otherwise = lineSearch64 -{-# INLINE lineSearch #-} - - -lineSearch64 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch64 !vec !start !(I# v#) = do - (I# x1#) <- M.readArray vec $! start + 0 - let !p1# = maskw# x1# v# `and#` int2Word# 0x1# - - (I# x2#) <- M.readArray vec $! start + 1 - let !p2# = p1# `or#` (maskw# x2# v# `and#` int2Word# 0x2#) - - (I# x3#) <- M.readArray vec $! start + 2 - let !p3# = p2# `or#` (maskw# x3# v# `and#` int2Word# 0x4#) - - (I# x4#) <- M.readArray vec $! start + 3 - let !p4# = p3# `or#` (maskw# x4# v# `and#` int2Word# 0x8#) - - (I# x5#) <- M.readArray vec $! start + 4 - let !p5# = p4# `or#` (maskw# x5# v# `and#` int2Word# 0x10#) - - (I# x6#) <- M.readArray vec $! start + 5 - let !p6# = p5# `or#` (maskw# x6# v# `and#` int2Word# 0x20#) - - (I# x7#) <- M.readArray vec $! start + 6 - let !p7# = p6# `or#` (maskw# x7# v# `and#` int2Word# 0x40#) - - (I# x8#) <- M.readArray vec $! start + 7 - let !p8# = p7# `or#` (maskw# x8# v# `and#` int2Word# 0x80#) - - return $! lineResult# p8# start -{-# INLINE lineSearch64 #-} - - - -lineSearch32 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch32 !vec !start !(I# v#) = do - (I# x1#) <- M.readArray vec $! start + 0 - let !p1# = maskw# x1# v# `and#` int2Word# 0x1# - - (I# x2#) <- M.readArray vec $! start + 1 - let !p2# = p1# `or#` (maskw# x2# v# `and#` int2Word# 0x2#) - - (I# x3#) <- M.readArray vec $! start + 2 - let !p3# = p2# `or#` (maskw# x3# v# `and#` int2Word# 0x4#) - - (I# x4#) <- M.readArray vec $! start + 3 - let !p4# = p3# `or#` (maskw# x4# v# `and#` int2Word# 0x8#) - - (I# x5#) <- M.readArray vec $! start + 4 - let !p5# = p4# `or#` (maskw# x5# v# `and#` int2Word# 0x10#) - - (I# x6#) <- M.readArray vec $! start + 5 - let !p6# = p5# `or#` (maskw# x6# v# `and#` int2Word# 0x20#) - - (I# x7#) <- M.readArray vec $! start + 6 - let !p7# = p6# `or#` (maskw# x7# v# `and#` int2Word# 0x40#) - - (I# x8#) <- M.readArray vec $! start + 7 - let !p8# = p7# `or#` (maskw# x8# v# `and#` int2Word# 0x80#) - - (I# x9#) <- M.readArray vec $! start + 8 - let !p9# = p8# `or#` (maskw# x9# v# `and#` int2Word# 0x100#) - - (I# x10#) <- M.readArray vec $! start + 9 - let !p10# = p9# `or#` (maskw# x10# v# `and#` int2Word# 0x200#) - - (I# x11#) <- M.readArray vec $! start + 10 - let !p11# = p10# `or#` (maskw# x11# v# `and#` int2Word# 0x400#) - - (I# x12#) <- M.readArray vec $! start + 11 - let !p12# = p11# `or#` (maskw# x12# v# `and#` int2Word# 0x800#) - - (I# x13#) <- M.readArray vec $! start + 12 - let !p13# = p12# `or#` (maskw# x13# v# `and#` int2Word# 0x1000#) - - (I# x14#) <- M.readArray vec $! start + 13 - let !p14# = p13# `or#` (maskw# x14# v# `and#` int2Word# 0x2000#) - - (I# x15#) <- M.readArray vec $! start + 14 - let !p15# = p14# `or#` (maskw# x15# v# `and#` int2Word# 0x4000#) - - (I# x16#) <- M.readArray vec $! start + 15 - let !p16# = p15# `or#` (maskw# x16# v# `and#` int2Word# 0x8000#) - - return $! lineResult# p16# start -{-# INLINE lineSearch32 #-} - -#endif - ------------------------------------------------------------------------------- --- | Search through a mutable vector for one of two given int values, --- cache-line aligned. If the start index is cache-line aligned, and there is --- more than a cache-line's room between the start index and the end of the --- vector, we will search the cache-line all at once using an efficient --- branchless bit-twiddling technique. Otherwise, we will use a typical loop. --- -cacheLineSearch2 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -cacheLineSearch2 !vec !start !value !value2 = do -#ifdef NO_C_SEARCH - let !vlen = M.length vec - let !st1 = vlen - start - let !nvlen = numWordsInCacheLine - st1 - let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask - let st2 = adv - start - - if nvlen > 0 || not (isCacheLineAligned start) - then naiveSearch2 vec start (min st1 st2) value value2 - else lineSearch2 vec start value value2 -#else - lineSearch2 vec start value value2 -#endif -{-# INLINE cacheLineSearch2 #-} - - -#ifdef NO_C_SEARCH - -naiveSearch2 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ number of things to search - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -naiveSearch2 !vec !start !nThings !value1 !value2 = go start - where - !doneIdx = start + nThings - - go !i | i >= doneIdx = return (-1) - | otherwise = do - x <- M.readArray vec i - if x == value1 || x == value2 then return i else go (i+1) -{-# INLINE naiveSearch2 #-} - - -lineSearch2 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch2 | wordSize == 32 = lineSearch32_2 - | otherwise = lineSearch64_2 - - - -lineSearch64_2 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch64_2 !vec !start !(I# v#) !(I# v2#) = do - (I# x1#) <- M.readArray vec $! start + 0 - let !p1# = (maskw# x1# v# `or#` maskw# x1# v2#) `and#` int2Word# 0x1# - - (I# x2#) <- M.readArray vec $! start + 1 - let !p2# = p1# `or#` ((maskw# x2# v# `or#` maskw# x2# v2#) - `and#` int2Word# 0x2#) - - (I# x3#) <- M.readArray vec $! start + 2 - let !p3# = p2# `or#` ((maskw# x3# v# `or#` maskw# x3# v2#) - `and#` int2Word# 0x4#) - - (I# x4#) <- M.readArray vec $! start + 3 - let !p4# = p3# `or#` ((maskw# x4# v# `or#` maskw# x4# v2#) - `and#` int2Word# 0x8#) - - (I# x5#) <- M.readArray vec $! start + 4 - let !p5# = p4# `or#` ((maskw# x5# v# `or#` maskw# x5# v2#) - `and#` int2Word# 0x10#) - - (I# x6#) <- M.readArray vec $! start + 5 - let !p6# = p5# `or#` ((maskw# x6# v# `or#` maskw# x6# v2#) - `and#` int2Word# 0x20#) - - (I# x7#) <- M.readArray vec $! start + 6 - let !p7# = p6# `or#` ((maskw# x7# v# `or#` maskw# x7# v2#) - `and#` int2Word# 0x40#) - - (I# x8#) <- M.readArray vec $! start + 7 - let !p8# = p7# `or#` ((maskw# x8# v# `or#` maskw# x8# v2#) - `and#` int2Word# 0x80#) - - return $! lineResult# p8# start -{-# INLINE lineSearch64_2 #-} - - -lineSearch32_2 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch32_2 !vec !start !(I# v#) !(I# v2#) = do - (I# x1#) <- M.readArray vec $! start + 0 - let !p1# = (maskw# x1# v# `or#` maskw# x1# v2#) `and#` int2Word# 0x1# - - (I# x2#) <- M.readArray vec $! start + 1 - let !p2# = p1# `or#` ((maskw# x2# v# `or#` maskw# x2# v2#) - `and#` int2Word# 0x2#) - - (I# x3#) <- M.readArray vec $! start + 2 - let !p3# = p2# `or#` ((maskw# x3# v# `or#` maskw# x3# v2#) - `and#` int2Word# 0x4#) - - (I# x4#) <- M.readArray vec $! start + 3 - let !p4# = p3# `or#` ((maskw# x4# v# `or#` maskw# x4# v2#) - `and#` int2Word# 0x8#) - - (I# x5#) <- M.readArray vec $! start + 4 - let !p5# = p4# `or#` ((maskw# x5# v# `or#` maskw# x5# v2#) - `and#` int2Word# 0x10#) - - (I# x6#) <- M.readArray vec $! start + 5 - let !p6# = p5# `or#` ((maskw# x6# v# `or#` maskw# x6# v2#) - `and#` int2Word# 0x20#) - - (I# x7#) <- M.readArray vec $! start + 6 - let !p7# = p6# `or#` ((maskw# x7# v# `or#` maskw# x7# v2#) - `and#` int2Word# 0x40#) - - (I# x8#) <- M.readArray vec $! start + 7 - let !p8# = p7# `or#` ((maskw# x8# v# `or#` maskw# x8# v2#) - `and#` int2Word# 0x80#) - - (I# x9#) <- M.readArray vec $! start + 8 - let !p9# = p8# `or#` ((maskw# x9# v# `or#` maskw# x9# v2#) - `and#` int2Word# 0x100#) - - (I# x10#) <- M.readArray vec $! start + 9 - let !p10# = p9# `or#` ((maskw# x10# v# `or#` maskw# x10# v2#) - `and#` int2Word# 0x200#) - - (I# x11#) <- M.readArray vec $! start + 10 - let !p11# = p10# `or#` ((maskw# x11# v# `or#` maskw# x11# v2#) - `and#` int2Word# 0x400#) - - (I# x12#) <- M.readArray vec $! start + 11 - let !p12# = p11# `or#` ((maskw# x12# v# `or#` maskw# x12# v2#) - `and#` int2Word# 0x800#) - - (I# x13#) <- M.readArray vec $! start + 12 - let !p13# = p12# `or#` ((maskw# x13# v# `or#` maskw# x13# v2#) - `and#` int2Word# 0x1000#) - - (I# x14#) <- M.readArray vec $! start + 13 - let !p14# = p13# `or#` ((maskw# x14# v# `or#` maskw# x14# v2#) - `and#` int2Word# 0x2000#) - - (I# x15#) <- M.readArray vec $! start + 14 - let !p15# = p14# `or#` ((maskw# x15# v# `or#` maskw# x15# v2#) - `and#` int2Word# 0x4000#) - - (I# x16#) <- M.readArray vec $! start + 15 - let !p16# = p15# `or#` ((maskw# x16# v# `or#` maskw# x16# v2#) - `and#` int2Word# 0x8000#) - - return $! lineResult# p16# start -{-# INLINE lineSearch32_2 #-} - -#endif - - ------------------------------------------------------------------------------- --- | Search through a mutable vector for one of three given int values, --- cache-line aligned. If the start index is cache-line aligned, and there is --- more than a cache-line's room between the start index and the end of the --- vector, we will search the cache-line all at once using an efficient --- branchless bit-twiddling technique. Otherwise, we will use a typical loop. --- -cacheLineSearch3 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> Int -- ^ value 3 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -cacheLineSearch3 !vec !start !value !value2 !value3 = do -#ifdef NO_C_SEARCH - let !vlen = M.length vec - let !st1 = vlen - start - let !nvlen = numWordsInCacheLine - st1 - let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask - let st2 = adv - start - - if nvlen > 0 || not (isCacheLineAligned start) - then naiveSearch3 vec start (min st1 st2) value value2 value3 - else lineSearch3 vec start value value2 value3 -#else - lineSearch3 vec start value value2 value3 -#endif -{-# INLINE cacheLineSearch3 #-} - - -#ifdef NO_C_SEARCH - -naiveSearch3 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ number of things to search - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> Int -- ^ value 3 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -naiveSearch3 !vec !start !nThings !value1 !value2 !value3 = go start - where - !doneIdx = start + nThings - - go !i | i >= doneIdx = return (-1) - | otherwise = do - x <- M.readArray vec i - if x == value1 || x == value2 || x == value3 - then return i - else go (i+1) -{-# INLINE naiveSearch3 #-} - - -lineSearch3 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> Int -- ^ value 3 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch3 | wordSize == 32 = lineSearch32_3 - | otherwise = lineSearch64_3 - - - -lineSearch64_3 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> Int -- ^ value 3 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch64_3 !vec !start !(I# v#) !(I# v2#) !(I# v3#) = do - (I# x1#) <- M.readArray vec $! start + 0 - let !p1# = (maskw# x1# v# `or#` maskw# x1# v2# `or#` maskw# x1# v3#) - `and#` int2Word# 0x1# - - (I# x2#) <- M.readArray vec $! start + 1 - let !p2# = p1# `or#` - ((maskw# x2# v# `or#` maskw# x2# v2# `or#` maskw# x2# v3#) - `and#` int2Word# 0x2#) - - (I# x3#) <- M.readArray vec $! start + 2 - let !p3# = p2# `or#` - ((maskw# x3# v# `or#` maskw# x3# v2# `or#` maskw# x3# v3#) - `and#` int2Word# 0x4#) - - (I# x4#) <- M.readArray vec $! start + 3 - let !p4# = p3# `or#` - ((maskw# x4# v# `or#` maskw# x4# v2# `or#` maskw# x4# v3#) - `and#` int2Word# 0x8#) - - (I# x5#) <- M.readArray vec $! start + 4 - let !p5# = p4# `or#` - ((maskw# x5# v# `or#` maskw# x5# v2# `or#` maskw# x5# v3#) - `and#` int2Word# 0x10#) - - (I# x6#) <- M.readArray vec $! start + 5 - let !p6# = p5# `or#` - ((maskw# x6# v# `or#` maskw# x6# v2# `or#` maskw# x6# v3#) - `and#` int2Word# 0x20#) - - (I# x7#) <- M.readArray vec $! start + 6 - let !p7# = p6# `or#` - ((maskw# x7# v# `or#` maskw# x7# v2# `or#` maskw# x7# v3#) - `and#` int2Word# 0x40#) - - (I# x8#) <- M.readArray vec $! start + 7 - let !p8# = p7# `or#` - ((maskw# x8# v# `or#` maskw# x8# v2# `or#` maskw# x8# v3#) - `and#` int2Word# 0x80#) - - return $! lineResult# p8# start -{-# INLINE lineSearch64_3 #-} - - -lineSearch32_3 :: IntArray s -- ^ vector to search - -> Int -- ^ start index - -> Int -- ^ value to search for - -> Int -- ^ value 2 to search for - -> Int -- ^ value 3 to search for - -> ST s Int -- ^ dest index where it can be found, or - -- \"-1\" if not found -lineSearch32_3 !vec !start !(I# v#) !(I# v2#) !(I# v3#) = do - (I# x1#) <- M.readArray vec $! start + 0 - let !p1# = (maskw# x1# v# `or#` maskw# x1# v2# `or#` maskw# x1# v3#) - `and#` int2Word# 0x1# - - (I# x2#) <- M.readArray vec $! start + 1 - let !p2# = p1# `or#` - ((maskw# x2# v# `or#` maskw# x2# v2# `or#` maskw# x2# v3#) - `and#` int2Word# 0x2#) - - (I# x3#) <- M.readArray vec $! start + 2 - let !p3# = p2# `or#` - ((maskw# x3# v# `or#` maskw# x3# v2# `or#` maskw# x3# v3#) - `and#` int2Word# 0x4#) - - (I# x4#) <- M.readArray vec $! start + 3 - let !p4# = p3# `or#` - ((maskw# x4# v# `or#` maskw# x4# v2# `or#` maskw# x4# v3#) - `and#` int2Word# 0x8#) - - (I# x5#) <- M.readArray vec $! start + 4 - let !p5# = p4# `or#` - ((maskw# x5# v# `or#` maskw# x5# v2# `or#` maskw# x5# v3#) - `and#` int2Word# 0x10#) - - (I# x6#) <- M.readArray vec $! start + 5 - let !p6# = p5# `or#` - ((maskw# x6# v# `or#` maskw# x6# v2# `or#` maskw# x6# v3#) - `and#` int2Word# 0x20#) - - (I# x7#) <- M.readArray vec $! start + 6 - let !p7# = p6# `or#` - ((maskw# x7# v# `or#` maskw# x7# v2# `or#` maskw# x7# v3#) - `and#` int2Word# 0x40#) - - (I# x8#) <- M.readArray vec $! start + 7 - let !p8# = p7# `or#` - ((maskw# x8# v# `or#` maskw# x8# v2# `or#` maskw# x8# v3#) - `and#` int2Word# 0x80#) - - (I# x9#) <- M.readArray vec $! start + 8 - let !p9# = p8# `or#` - ((maskw# x9# v# `or#` maskw# x9# v2# `or#` maskw# x9# v3#) - `and#` int2Word# 0x100#) - - (I# x10#) <- M.readArray vec $! start + 9 - let !p10# = p9# `or#` - ((maskw# x10# v# `or#` maskw# x10# v2# `or#` maskw# x10# v3#) - `and#` int2Word# 0x200#) - - (I# x11#) <- M.readArray vec $! start + 10 - let !p11# = p10# `or#` - ((maskw# x11# v# `or#` maskw# x11# v2# `or#` maskw# x11# v3#) - `and#` int2Word# 0x400#) - - (I# x12#) <- M.readArray vec $! start + 11 - let !p12# = p11# `or#` - ((maskw# x12# v# `or#` maskw# x12# v2# `or#` maskw# x12# v3#) - `and#` int2Word# 0x800#) - - (I# x13#) <- M.readArray vec $! start + 12 - let !p13# = p12# `or#` - ((maskw# x13# v# `or#` maskw# x13# v2# `or#` maskw# x13# v3#) - `and#` int2Word# 0x1000#) - - (I# x14#) <- M.readArray vec $! start + 13 - let !p14# = p13# `or#` - ((maskw# x14# v# `or#` maskw# x14# v2# `or#` maskw# x14# v3#) - `and#` int2Word# 0x2000#) - - (I# x15#) <- M.readArray vec $! start + 14 - let !p15# = p14# `or#` - ((maskw# x15# v# `or#` maskw# x15# v2# `or#` maskw# x15# v3#) - `and#` int2Word# 0x4000#) - - (I# x16#) <- M.readArray vec $! start + 15 - let !p16# = p15# `or#` - ((maskw# x16# v# `or#` maskw# x16# v2# `or#` maskw# x16# v3#) - `and#` int2Word# 0x8000#) - - return $! lineResult# p16# start -{-# INLINE lineSearch32_3 #-} - -#endif + , mask + , maskw# + ) where + +import Control.Monad +import Control.Monad.ST (ST) + +import Data.HashTable.Internal.IntArray (Elem, IntArray) +import qualified Data.HashTable.Internal.IntArray as M + +#ifndef NO_C_SEARCH +import Foreign.C.Types +#else +import Data.Bits +import Data.Int +import qualified Data.Vector.Unboxed as U +import GHC.Int +#endif + +import Data.HashTable.Internal.Utils +import GHC.Exts + +{-# INLINE prefetchRead #-} +{-# INLINE prefetchWrite #-} +prefetchRead :: IntArray s -> Int -> ST s () +prefetchWrite :: IntArray s -> Int -> ST s () + +#ifndef NO_C_SEARCH +foreign import ccall unsafe "line_search" + c_lineSearch :: Ptr a -> CInt -> CUShort -> IO CInt + +foreign import ccall unsafe "line_search_2" + c_lineSearch_2 :: Ptr a -> CInt -> CUShort -> CUShort -> IO CInt + +foreign import ccall unsafe "line_search_3" + c_lineSearch_3 :: Ptr a -> CInt -> CUShort -> CUShort -> CUShort -> IO CInt + +foreign import ccall unsafe "forward_search_2" + c_forwardSearch_2 :: Ptr a -> CInt -> CInt -> CUShort -> CUShort -> IO CInt + +foreign import ccall unsafe "forward_search_3" + c_forwardSearch_3 :: Ptr a -> CInt -> CInt -> CUShort -> CUShort -> CUShort + -> IO CInt + +foreign import ccall unsafe "prefetch_cacheline_read" + prefetchCacheLine_read :: Ptr a -> CInt -> IO () + +foreign import ccall unsafe "prefetch_cacheline_write" + prefetchCacheLine_write :: Ptr a -> CInt -> IO () + + +fI :: (Num b, Integral a) => a -> b +fI = fromIntegral + +prefetchRead a i = unsafeIOToST $ prefetchCacheLine_read v x + where + v = M.toPtr a + x = fI i + +prefetchWrite a i = unsafeIOToST $ prefetchCacheLine_write v x + where + v = M.toPtr a + x = fI i + + +{-# INLINE forwardSearch2 #-} +forwardSearch2 :: IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int +forwardSearch2 !vec !start !end !x1 !x2 = + liftM fromEnum $! unsafeIOToST c + where + c = c_forwardSearch_2 (M.toPtr vec) (fI start) (fI end) (fI x1) (fI x2) + + +{-# INLINE forwardSearch3 #-} +forwardSearch3 :: IntArray s -> Int -> Int -> Elem -> Elem -> Elem -> ST s Int +forwardSearch3 !vec !start !end !x1 !x2 !x3 = + liftM fromEnum $! unsafeIOToST c + where + c = c_forwardSearch_3 (M.toPtr vec) (fI start) (fI end) + (fI x1) (fI x2) (fI x3) + + +{-# INLINE lineSearch #-} +lineSearch :: IntArray s -> Int -> Elem -> ST s Int +lineSearch !vec !start !value = + liftM fromEnum $! unsafeIOToST c + where + c = c_lineSearch (M.toPtr vec) (fI start) (fI value) + + +{-# INLINE lineSearch2 #-} +lineSearch2 :: IntArray s -> Int -> Elem -> Elem -> ST s Int +lineSearch2 !vec !start !x1 !x2 = + liftM fromEnum $! unsafeIOToST c + where + c = c_lineSearch_2 (M.toPtr vec) (fI start) (fI x1) (fI x2) + + +{-# INLINE lineSearch3 #-} +lineSearch3 :: IntArray s -> Int -> Elem -> Elem -> Elem -> ST s Int +lineSearch3 !vec !start !x1 !x2 !x3 = + liftM fromEnum $! unsafeIOToST c + where + c = c_lineSearch_3 (M.toPtr vec) (fI start) (fI x1) (fI x2) (fI x3) +#endif + +{-# INLINE advanceByCacheLineSize #-} +advanceByCacheLineSize :: Int -> Int -> Int +advanceByCacheLineSize !(I# start0#) !(I# vecSize#) = out + where + !(I# clm#) = cacheLineIntMask + !clmm# = not# (int2Word# clm#) + !start# = word2Int# (clmm# `and#` int2Word# start0#) + !(I# nw#) = numElemsInCacheLine + !start'# = start# +# nw# + !s# = sign# (vecSize# -# start'# -# 1#) + !m# = not# (int2Word# s#) + !r# = int2Word# start'# `and#` m# + !out = I# (word2Int# r#) + + +{-# INLINE isCacheLineAligned #-} +isCacheLineAligned :: Int -> Bool +isCacheLineAligned (I# x#) = isTrue# (r# ==# 0#) + where + !(I# m#) = cacheLineIntMask + !mw# = int2Word# m# + !w# = int2Word# x# + !r# = word2Int# (mw# `and#` w#) + + +{-# INLINE sign# #-} +-- | Returns 0 if x is positive, -1 otherwise +sign# :: Int# -> Int# +sign# !x# = x# `uncheckedIShiftRA#` wordSizeMinus1# + where + !(I# wordSizeMinus1#) = wordSize-1 + + +{-# INLINE bl_abs# #-} +-- | Abs of an integer, branchless +bl_abs# :: Int# -> Int# +bl_abs# !x# = word2Int# r# + where + !m# = sign# x# + !r# = (int2Word# (m# +# x#)) `xor#` int2Word# m# + + +{-# INLINE mask# #-} +-- | Returns 0xfff..fff (aka -1) if a# == b#, 0 otherwise. +mask# :: Int# -> Int# -> Int# +mask# !a# !b# = dest# + where + !d# = a# -# b# + !r# = bl_abs# d# -# 1# + !dest# = sign# r# + + +{- note: this code should be: + +mask# :: Int# -> Int# -> Int# +mask# !a# !b# = let !(I# z#) = fromEnum (a# ==# b#) + !q# = negateInt# z# + in q# + +but GHC doesn't properly optimize this as straight-line code at the moment. + +-} + + +{-# INLINE mask #-} +-- | Returns 0xfff..fff (aka -1) if a == b, 0 otherwise. +mask :: Int -> Int -> Int +mask (I# a#) (I# b#) = I# (mask# a# b#) + + +{-# INLINE maskw# #-} +maskw# :: Int# -> Int# -> Word# +maskw# !a# !b# = int2Word# (mask# a# b#) + + +#ifdef NO_C_SEARCH +prefetchRead _ _ = return () +prefetchWrite _ _ = return () + +{-# INLINE forwardSearch2 #-} +forwardSearch2 :: IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int +forwardSearch2 !vec !start !end !x1 !x2 = go start end False + where + go !i !e !b = + if i >= e then + if b then return (-1) else go 0 start True + else do + h <- M.readArray vec i + if h == x1 || h == x2 + then return i + else go (i+1) e b + + +{-# INLINE forwardSearch3 #-} +forwardSearch3 :: IntArray s -> Int -> Int -> Elem -> Elem -> Elem -> ST s Int +forwardSearch3 !vec !start !end !x1 !x2 !x3 = go start end False + where + go !i !e !b = + if i >= e then + if b then return (-1) else go 0 start True + else do + h <- M.readArray vec i + if h == x1 || h == x2 || h == x3 + then return i + else go (i+1) e b + + +deBruijnBitPositions :: U.Vector Int8 +deBruijnBitPositions = + U.fromList [ + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 + ] + + +{-# INLINE firstBitSet# #-} +-- only works with 32-bit values -- ok for us here +firstBitSet# :: Int# -> Int# +firstBitSet# i# = word2Int# ((or# zeroCase# posw#)) + where + !zeroCase# = int2Word# (mask# 0# i#) + !w# = int2Word# i# + !iLowest# = word2Int# (and# w# (int2Word# (negateInt# i#))) + !idxW# = uncheckedShiftRL# + (narrow32Word# (timesWord# (int2Word# iLowest#) + (int2Word# 0x077CB531#))) + 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 +lineResult# :: Word# -- ^ mask + -> Int -- ^ start value + -> Int +lineResult# bitmask# (I# start#) = I# (word2Int# rv#) + where + !p# = firstBitSet# (word2Int# bitmask#) + !mm# = maskw# p# (-1#) + !nmm# = not# mm# + !rv# = mm# `or#` (nmm# `and#` (int2Word# (start# +# p#))) +{-# INLINE lineResult# #-} + + +-- Required: unlike in C search, required that the start index is +-- cache-line-aligned and array has at least 32 elements after the start index +lineSearch :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +lineSearch !vec !start !elem1 = do + let !(I# v1#) = fromIntegral elem1 + + !(I# x1#) <- liftM fromIntegral $ M.readArray vec start + let !p1# = (and# (maskw# x1# v1#) (int2Word# 0x1#)) + + !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1 + let !p2# = or# p1# (and# (maskw# x2# v1#) (int2Word# 0x2#)) + + !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2 + let !p3# = or# p2# (and# (maskw# x3# v1#) (int2Word# 0x4#)) + + !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3 + let !p4# = or# p3# (and# (maskw# x4# v1#) (int2Word# 0x8#)) + + !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4 + let !p5# = or# p4# (and# (maskw# x5# v1#) (int2Word# 0x10#)) + + !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5 + let !p6# = or# p5# (and# (maskw# x6# v1#) (int2Word# 0x20#)) + + !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6 + let !p7# = or# p6# (and# (maskw# x7# v1#) (int2Word# 0x40#)) + + !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7 + let !p8# = or# p7# (and# (maskw# x8# v1#) (int2Word# 0x80#)) + + !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8 + let !p9# = or# p8# (and# (maskw# x9# v1#) (int2Word# 0x100#)) + + !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9 + let !p10# = or# p9# (and# (maskw# x10# v1#) (int2Word# 0x200#)) + + !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10 + let !p11# = or# p10# (and# (maskw# x11# v1#) (int2Word# 0x400#)) + + !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11 + let !p12# = or# p11# (and# (maskw# x12# v1#) (int2Word# 0x800#)) + + !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12 + let !p13# = or# p12# (and# (maskw# x13# v1#) (int2Word# 0x1000#)) + + !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13 + let !p14# = or# p13# (and# (maskw# x14# v1#) (int2Word# 0x2000#)) + + !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14 + let !p15# = or# p14# (and# (maskw# x15# v1#) (int2Word# 0x4000#)) + + !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15 + let !p16# = or# p15# (and# (maskw# x16# v1#) (int2Word# 0x8000#)) + + !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16 + let !p17# = or# p16# (and# (maskw# x17# v1#) (int2Word# 0x10000#)) + + !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17 + let !p18# = or# p17# (and# (maskw# x18# v1#) (int2Word# 0x20000#)) + + !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18 + let !p19# = or# p18# (and# (maskw# x19# v1#) (int2Word# 0x40000#)) + + !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19 + let !p20# = or# p19# (and# (maskw# x20# v1#) (int2Word# 0x80000#)) + + !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20 + let !p21# = or# p20# (and# (maskw# x21# v1#) (int2Word# 0x100000#)) + + !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21 + let !p22# = or# p21# (and# (maskw# x22# v1#) (int2Word# 0x200000#)) + + !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22 + let !p23# = or# p22# (and# (maskw# x23# v1#) (int2Word# 0x400000#)) + + !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23 + let !p24# = or# p23# (and# (maskw# x24# v1#) (int2Word# 0x800000#)) + + !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24 + let !p25# = or# p24# (and# (maskw# x25# v1#) (int2Word# 0x1000000#)) + + !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25 + let !p26# = or# p25# (and# (maskw# x26# v1#) (int2Word# 0x2000000#)) + + !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26 + let !p27# = or# p26# (and# (maskw# x27# v1#) (int2Word# 0x4000000#)) + + !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27 + let !p28# = or# p27# (and# (maskw# x28# v1#) (int2Word# 0x8000000#)) + + !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28 + let !p29# = or# p28# (and# (maskw# x29# v1#) (int2Word# 0x10000000#)) + + !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29 + let !p30# = or# p29# (and# (maskw# x30# v1#) (int2Word# 0x20000000#)) + + !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30 + let !p31# = or# p30# (and# (maskw# x31# v1#) (int2Word# 0x40000000#)) + + !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31 + let !p32# = or# p31# (and# (maskw# x32# v1#) (int2Word# 0x80000000#)) + + return $! lineResult# p32# start + + +-- Required: unlike in C search, required that the start index is +-- cache-line-aligned and array has at least 32 elements after the start index +lineSearch2 :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> Elem -- ^ second value to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +lineSearch2 !vec !start !elem1 !elem2 = do + let !(I# v1#) = fromIntegral elem1 + let !(I# v2#) = fromIntegral elem2 + + !(I# x1#) <- liftM fromIntegral $ M.readArray vec start + let !p1# = (and# (int2Word# 0x1#) + (or# (maskw# x1# v1#) (maskw# x1# v2#))) + !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1 + let !p2# = or# p1# (and# (int2Word# 0x2#) + (or# (maskw# x2# v1#) (maskw# x2# v2#))) + !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2 + let !p3# = or# p2# (and# (int2Word# 0x4#) + (or# (maskw# x3# v1#) (maskw# x3# v2#))) + !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3 + let !p4# = or# p3# (and# (int2Word# 0x8#) + (or# (maskw# x4# v1#) (maskw# x4# v2#))) + !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4 + let !p5# = or# p4# (and# (int2Word# 0x10#) + (or# (maskw# x5# v1#) (maskw# x5# v2#))) + !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5 + let !p6# = or# p5# (and# (int2Word# 0x20#) + (or# (maskw# x6# v1#) (maskw# x6# v2#))) + !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6 + let !p7# = or# p6# (and# (int2Word# 0x40#) + (or# (maskw# x7# v1#) (maskw# x7# v2#))) + !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7 + let !p8# = or# p7# (and# (int2Word# 0x80#) + (or# (maskw# x8# v1#) (maskw# x8# v2#))) + !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8 + let !p9# = or# p8# (and# (int2Word# 0x100#) + (or# (maskw# x9# v1#) (maskw# x9# v2#))) + !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9 + let !p10# = or# p9# (and# (int2Word# 0x200#) + (or# (maskw# x10# v1#) (maskw# x10# v2#))) + !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10 + let !p11# = or# p10# (and# (int2Word# 0x400#) + (or# (maskw# x11# v1#) (maskw# x11# v2#))) + !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11 + let !p12# = or# p11# (and# (int2Word# 0x800#) + (or# (maskw# x12# v1#) (maskw# x12# v2#))) + !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12 + let !p13# = or# p12# (and# (int2Word# 0x1000#) + (or# (maskw# x13# v1#) (maskw# x13# v2#))) + !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13 + let !p14# = or# p13# (and# (int2Word# 0x2000#) + (or# (maskw# x14# v1#) (maskw# x14# v2#))) + !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14 + let !p15# = or# p14# (and# (int2Word# 0x4000#) + (or# (maskw# x15# v1#) (maskw# x15# v2#))) + !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15 + let !p16# = or# p15# (and# (int2Word# 0x8000#) + (or# (maskw# x16# v1#) (maskw# x16# v2#))) + !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16 + let !p17# = or# p16# (and# (int2Word# 0x10000#) + (or# (maskw# x17# v1#) (maskw# x17# v2#))) + !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17 + let !p18# = or# p17# (and# (int2Word# 0x20000#) + (or# (maskw# x18# v1#) (maskw# x18# v2#))) + !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18 + let !p19# = or# p18# (and# (int2Word# 0x40000#) + (or# (maskw# x19# v1#) (maskw# x19# v2#))) + !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19 + let !p20# = or# p19# (and# (int2Word# 0x80000#) + (or# (maskw# x20# v1#) (maskw# x20# v2#))) + !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20 + let !p21# = or# p20# (and# (int2Word# 0x100000#) + (or# (maskw# x21# v1#) (maskw# x21# v2#))) + !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21 + let !p22# = or# p21# (and# (int2Word# 0x200000#) + (or# (maskw# x22# v1#) (maskw# x22# v2#))) + !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22 + let !p23# = or# p22# (and# (int2Word# 0x400000#) + (or# (maskw# x23# v1#) (maskw# x23# v2#))) + !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23 + let !p24# = or# p23# (and# (int2Word# 0x800000#) + (or# (maskw# x24# v1#) (maskw# x24# v2#))) + !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24 + let !p25# = or# p24# (and# (int2Word# 0x1000000#) + (or# (maskw# x25# v1#) (maskw# x25# v2#))) + !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25 + let !p26# = or# p25# (and# (int2Word# 0x2000000#) + (or# (maskw# x26# v1#) (maskw# x26# v2#))) + !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26 + let !p27# = or# p26# (and# (int2Word# 0x4000000#) + (or# (maskw# x27# v1#) (maskw# x27# v2#))) + !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27 + let !p28# = or# p27# (and# (int2Word# 0x8000000#) + (or# (maskw# x28# v1#) (maskw# x28# v2#))) + !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28 + let !p29# = or# p28# (and# (int2Word# 0x10000000#) + (or# (maskw# x29# v1#) (maskw# x29# v2#))) + !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29 + let !p30# = or# p29# (and# (int2Word# 0x20000000#) + (or# (maskw# x30# v1#) (maskw# x30# v2#))) + !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30 + let !p31# = or# p30# (and# (int2Word# 0x40000000#) + (or# (maskw# x31# v1#) (maskw# x31# v2#))) + !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31 + let !p32# = or# p31# (and# (int2Word# 0x80000000#) + (or# (maskw# x32# v1#) (maskw# x32# v2#))) + + return $! lineResult# p32# start + + +-- Required: unlike in C search, required that the start index is +-- cache-line-aligned and array has at least 32 elements after the start index +lineSearch3 :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> Elem -- ^ second value to search for + -> Elem -- ^ third value to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +lineSearch3 !vec !start !elem1 !elem2 !elem3 = do + let !(I# v1#) = fromIntegral elem1 + let !(I# v2#) = fromIntegral elem2 + let !(I# v3#) = fromIntegral elem3 + + !(I# x1#) <- liftM fromIntegral $ M.readArray vec start + let !p1# = (and# (int2Word# 0x1#) + (or# (maskw# x1# v1#) + (or# (maskw# x1# v2#) (maskw# x1# v3#)))) + + !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1 + let !p2# = or# p1# (and# (int2Word# 0x2#) + (or# (maskw# x2# v1#) + (or# (maskw# x2# v2#) (maskw# x2# v3#)))) + + !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2 + let !p3# = or# p2# (and# (int2Word# 0x4#) + (or# (maskw# x3# v1#) + (or# (maskw# x3# v2#) (maskw# x3# v3#)))) + + !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3 + let !p4# = or# p3# (and# (int2Word# 0x8#) + (or# (maskw# x4# v1#) + (or# (maskw# x4# v2#) (maskw# x4# v3#)))) + + !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4 + let !p5# = or# p4# (and# (int2Word# 0x10#) + (or# (maskw# x5# v1#) + (or# (maskw# x5# v2#) (maskw# x5# v3#)))) + + !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5 + let !p6# = or# p5# (and# (int2Word# 0x20#) + (or# (maskw# x6# v1#) + (or# (maskw# x6# v2#) (maskw# x6# v3#)))) + + !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6 + let !p7# = or# p6# (and# (int2Word# 0x40#) + (or# (maskw# x7# v1#) + (or# (maskw# x7# v2#) (maskw# x7# v3#)))) + + !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7 + let !p8# = or# p7# (and# (int2Word# 0x80#) + (or# (maskw# x8# v1#) + (or# (maskw# x8# v2#) (maskw# x8# v3#)))) + + !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8 + let !p9# = or# p8# (and# (int2Word# 0x100#) + (or# (maskw# x9# v1#) + (or# (maskw# x9# v2#) (maskw# x9# v3#)))) + + !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9 + let !p10# = or# p9# (and# (int2Word# 0x200#) + (or# (maskw# x10# v1#) + (or# (maskw# x10# v2#) (maskw# x10# v3#)))) + + !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10 + let !p11# = or# p10# (and# (int2Word# 0x400#) + (or# (maskw# x11# v1#) + (or# (maskw# x11# v2#) (maskw# x11# v3#)))) + + !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11 + let !p12# = or# p11# (and# (int2Word# 0x800#) + (or# (maskw# x12# v1#) + (or# (maskw# x12# v2#) (maskw# x12# v3#)))) + + !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12 + let !p13# = or# p12# (and# (int2Word# 0x1000#) + (or# (maskw# x13# v1#) + (or# (maskw# x13# v2#) (maskw# x13# v3#)))) + + !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13 + let !p14# = or# p13# (and# (int2Word# 0x2000#) + (or# (maskw# x14# v1#) + (or# (maskw# x14# v2#) (maskw# x14# v3#)))) + + !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14 + let !p15# = or# p14# (and# (int2Word# 0x4000#) + (or# (maskw# x15# v1#) + (or# (maskw# x15# v2#) (maskw# x15# v3#)))) + + !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15 + let !p16# = or# p15# (and# (int2Word# 0x8000#) + (or# (maskw# x16# v1#) + (or# (maskw# x16# v2#) (maskw# x16# v3#)))) + + !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16 + let !p17# = or# p16# (and# (int2Word# 0x10000#) + (or# (maskw# x17# v1#) + (or# (maskw# x17# v2#) (maskw# x17# v3#)))) + + !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17 + let !p18# = or# p17# (and# (int2Word# 0x20000#) + (or# (maskw# x18# v1#) + (or# (maskw# x18# v2#) (maskw# x18# v3#)))) + + !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18 + let !p19# = or# p18# (and# (int2Word# 0x40000#) + (or# (maskw# x19# v1#) + (or# (maskw# x19# v2#) (maskw# x19# v3#)))) + + !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19 + let !p20# = or# p19# (and# (int2Word# 0x80000#) + (or# (maskw# x20# v1#) + (or# (maskw# x20# v2#) (maskw# x20# v3#)))) + + !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20 + let !p21# = or# p20# (and# (int2Word# 0x100000#) + (or# (maskw# x21# v1#) + (or# (maskw# x21# v2#) (maskw# x21# v3#)))) + + !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21 + let !p22# = or# p21# (and# (int2Word# 0x200000#) + (or# (maskw# x22# v1#) + (or# (maskw# x22# v2#) (maskw# x22# v3#)))) + + !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22 + let !p23# = or# p22# (and# (int2Word# 0x400000#) + (or# (maskw# x23# v1#) + (or# (maskw# x23# v2#) (maskw# x23# v3#)))) + + !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23 + let !p24# = or# p23# (and# (int2Word# 0x800000#) + (or# (maskw# x24# v1#) + (or# (maskw# x24# v2#) (maskw# x24# v3#)))) + + !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24 + let !p25# = or# p24# (and# (int2Word# 0x1000000#) + (or# (maskw# x25# v1#) + (or# (maskw# x25# v2#) (maskw# x25# v3#)))) + + !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25 + let !p26# = or# p25# (and# (int2Word# 0x2000000#) + (or# (maskw# x26# v1#) + (or# (maskw# x26# v2#) (maskw# x26# v3#)))) + + !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26 + let !p27# = or# p26# (and# (int2Word# 0x4000000#) + (or# (maskw# x27# v1#) + (or# (maskw# x27# v2#) (maskw# x27# v3#)))) + + !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27 + let !p28# = or# p27# (and# (int2Word# 0x8000000#) + (or# (maskw# x28# v1#) + (or# (maskw# x28# v2#) (maskw# x28# v3#)))) + + !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28 + let !p29# = or# p28# (and# (int2Word# 0x10000000#) + (or# (maskw# x29# v1#) + (or# (maskw# x29# v2#) (maskw# x29# v3#)))) + + !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29 + let !p30# = or# p29# (and# (int2Word# 0x20000000#) + (or# (maskw# x30# v1#) + (or# (maskw# x30# v2#) (maskw# x30# v3#)))) + + !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30 + let !p31# = or# p30# (and# (int2Word# 0x40000000#) + (or# (maskw# x31# v1#) + (or# (maskw# x31# v2#) (maskw# x31# v3#)))) + + !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31 + let !p32# = or# p31# (and# (int2Word# 0x80000000#) + (or# (maskw# x32# v1#) + (or# (maskw# x32# v2#) (maskw# x32# v3#)))) + + return $! lineResult# p32# start + + +------------------------------------------------------------------------------ +-- | Search through a mutable vector for a given int value. The number of +-- things to search for must be at most the number of things remaining in the +-- vector. +naiveSearch :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Int -- ^ number of things to search + -> Elem -- ^ value to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +naiveSearch !vec !start !nThings !value = go start + where + !doneIdx = start + nThings + + go !i | i >= doneIdx = return (-1) + | otherwise = do + x <- M.readArray vec i + if x == value then return i else go (i+1) +{-# INLINE naiveSearch #-} + + +------------------------------------------------------------------------------ +naiveSearch2 :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Int -- ^ number of things to search + -> Elem -- ^ value to search for + -> Elem -- ^ value 2 to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +naiveSearch2 !vec !start !nThings !value1 !value2 = go start + where + !doneIdx = start + nThings + + go !i | i >= doneIdx = return (-1) + | otherwise = do + x <- M.readArray vec i + if x == value1 || x == value2 then return i else go (i+1) +{-# INLINE naiveSearch2 #-} + + +------------------------------------------------------------------------------ +naiveSearch3 :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Int -- ^ number of things to search + -> Elem -- ^ value to search for + -> Elem -- ^ value 2 to search for + -> Elem -- ^ value 3 to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +naiveSearch3 !vec !start !nThings !value1 !value2 !value3 = go start + where + !doneIdx = start + nThings + + go !i | i >= doneIdx = return (-1) + | otherwise = do + x <- M.readArray vec i + if x == value1 || x == value2 || x == value3 + then return i + else go (i+1) +{-# INLINE naiveSearch3 #-} + +-- end #if NO_C_SEARCH +#endif + +------------------------------------------------------------------------------ +-- | Search through a mutable vector for a given int value, cache-line aligned. +-- If the start index is cache-line aligned, and there is more than a +-- cache-line's room between the start index and the end of the vector, we will +-- search the cache-line all at once using an efficient branchless +-- bit-twiddling technique. Otherwise, we will use a typical loop. +-- +cacheLineSearch :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +cacheLineSearch !vec !start !value = do +#ifdef NO_C_SEARCH + vlen <- M.length vec + let !st1 = vlen - start + let !nvlen = numElemsInCacheLine - st1 + let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask + let st2 = adv - start + + + if nvlen > 0 || not (isCacheLineAligned start) + then naiveSearch vec start (min st1 st2) value + else lineSearch vec start value +#else + lineSearch vec start value +#endif +{-# INLINE cacheLineSearch #-} + + +------------------------------------------------------------------------------ +-- | Search through a mutable vector for one of two given int values, +-- cache-line aligned. If the start index is cache-line aligned, and there is +-- more than a cache-line's room between the start index and the end of the +-- vector, we will search the cache-line all at once using an efficient +-- branchless bit-twiddling technique. Otherwise, we will use a typical loop. +-- +cacheLineSearch2 :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> Elem -- ^ value 2 to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +cacheLineSearch2 !vec !start !value !value2 = do +#ifdef NO_C_SEARCH + !vlen <- M.length vec + let !st1 = vlen - start + let !nvlen = numElemsInCacheLine - st1 + let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask + let st2 = adv - start + + if nvlen > 0 || not (isCacheLineAligned start) + then naiveSearch2 vec start (min st1 st2) value value2 + else lineSearch2 vec start value value2 +#else + lineSearch2 vec start value value2 +#endif +{-# INLINE cacheLineSearch2 #-} + + +------------------------------------------------------------------------------ +-- | Search through a mutable vector for one of three given int values, +-- cache-line aligned. If the start index is cache-line aligned, and there is +-- more than a cache-line's room between the start index and the end of the +-- vector, we will search the cache-line all at once using an efficient +-- branchless bit-twiddling technique. Otherwise, we will use a typical loop. +-- +cacheLineSearch3 :: IntArray s -- ^ vector to search + -> Int -- ^ start index + -> Elem -- ^ value to search for + -> Elem -- ^ value 2 to search for + -> Elem -- ^ value 3 to search for + -> ST s Int -- ^ dest index where it can be found, or + -- \"-1\" if not found +cacheLineSearch3 !vec !start !value !value2 !value3 = do +#ifdef NO_C_SEARCH + !vlen <- M.length vec + let !st1 = vlen - start + let !nvlen = numElemsInCacheLine - st1 + let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask + let st2 = adv - start + + if nvlen > 0 || not (isCacheLineAligned start) + then naiveSearch3 vec start (min st1 st2) value value2 value3 + else lineSearch3 vec start value value2 value3 +#else + lineSearch3 vec start value value2 value3 +#endif +{-# INLINE cacheLineSearch3 #-} 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 @@ -9,19 +10,23 @@ import Control.Applicative import Control.Monad.ST -import Data.Bits -import Data.Int +import Data.Bits ((.&.)) import Data.STRef -import qualified Data.Vector.Unboxed as V -import Data.Vector.Unboxed (Vector) +import Data.Vector.Unboxed (Vector) +import qualified Data.Vector.Unboxed as V +import Data.Word (Word32, Word64) +#if !MIN_VERSION_base(4,8,0) +import Data.Word (Word) +#endif + import Data.HashTable.Internal.Utils ------------------------------------------------------------------------------ -- Chosen by fair dice roll. Guaranteed random. More importantly, there are an -- equal number of 0 and 1 bits in both of these vectors. -random32s :: Vector Int32 +random32s :: Vector Word32 random32s = V.fromList [ 0xe293c315 , 0x82e2ff62 , 0xcb1ef9ae @@ -42,7 +47,7 @@ ------------------------------------------------------------------------------ -random64s :: Vector Int64 +random64s :: Vector Word64 random64s = V.fromList [ 0x62ef447e007e8732 , 0x149d6acb499feef8 , 0xca7725f9b404fbf8 @@ -68,16 +73,16 @@ ------------------------------------------------------------------------------ -randoms :: Vector Int -randoms | wordSize == 32 = V.map fromEnum random32s - | otherwise = V.map fromEnum random64s +randoms :: Vector Word +randoms | wordSize == 32 = V.map fromIntegral random32s + | otherwise = V.map fromIntegral random64s ------------------------------------------------------------------------------ data BitStream s = BitStream { - _curRandom :: !(STRef s Int) - , _bitsLeft :: !(STRef s Int) - , _randomPos :: !(STRef s Int) + _curRandom :: !(STRef s Word) + , _bitsLeft :: !(STRef s Int ) + , _randomPos :: !(STRef s Int ) } @@ -91,12 +96,12 @@ ------------------------------------------------------------------------------ -getNextBit :: BitStream s -> ST s Int +getNextBit :: BitStream s -> ST s Word getNextBit = getNBits 1 ------------------------------------------------------------------------------ -getNBits :: Int -> BitStream s -> ST s Int +getNBits :: Int -> BitStream s -> ST s Word getNBits nbits (BitStream crRef blRef rpRef) = do !bl <- readSTRef blRef if bl < nbits @@ -112,8 +117,8 @@ extractBits r extractBits r = do - let !b = r .&. ((1 `iShiftL` nbits) - 1) - writeSTRef crRef $! (r `iShiftRL` nbits) + let !b = r .&. ((1 `shiftL` nbits) - 1) + writeSTRef crRef $! (r `shiftRL` nbits) return b nextBits bl = do 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 @@ -4,6 +4,11 @@ module Data.HashTable.Internal.IntArray ( IntArray + , Elem + , elemMask + , primWordToElem + , elemToInt + , elemToInt# , newArray , readArray , writeArray @@ -11,64 +16,120 @@ , toPtr ) where +------------------------------------------------------------------------------ import Control.Monad.ST import Data.Bits import qualified Data.Primitive.ByteArray as A -import Data.Primitive.Types (Addr(..)) +#if !MIN_VERSION_primitive(0,7,0) +import Data.Primitive.Types (Addr (..)) +#endif import GHC.Exts -import Prelude hiding (length) +import GHC.Word +import Prelude hiding (length) +------------------------------------------------------------------------------ + #ifdef BOUNDS_CHECKING -#define BOUNDS_MSG(sz,i) concat [ "[", __FILE__, ":", \ - show (__LINE__ :: Int), \ - "] bounds check exceeded: ",\ +#define BOUNDS_MSG(sz,i) concat [ "[", __FILE__, ":", \ + show (__LINE__ :: Int), \ + "] bounds check exceeded: ", \ "size was ", show (sz), " i was ", show (i) ] -#define BOUNDS_CHECK(arr,i) let sz = (A.sizeofMutableByteArray (arr) \ - `div` wordSizeInBytes) in \ - if (i) < 0 || (i) >= sz \ - then error (BOUNDS_MSG(sz,(i))) \ + +#define BOUNDS_CHECK(arr,i) let sz = (A.sizeofMutableByteArray (arr) \ + `div` wordSizeInBytes) in \ + if (i) < 0 || (i) >= sz \ + then error (BOUNDS_MSG(sz,(i))) \ else return () #else #define BOUNDS_CHECK(arr,i) #endif + +------------------------------------------------------------------------------ newtype IntArray s = IA (A.MutableByteArray s) +type Elem = Word16 +------------------------------------------------------------------------------ +primWordToElem :: Word# -> Elem +primWordToElem w# = W16# (wordToWord16Compat# w#) + + +------------------------------------------------------------------------------ +elemToInt :: Elem -> Int +elemToInt e = let !i# = elemToInt# e + in (I# i#) + + +------------------------------------------------------------------------------ +elemToInt# :: Elem -> Int# +elemToInt# (W16# w#) = word2Int# (word16ToWordCompat# w#) + + +------------------------------------------------------------------------------ +elemMask :: Int +elemMask = 0xffff + + +------------------------------------------------------------------------------ wordSizeInBytes :: Int -wordSizeInBytes = bitSize (0::Int) `div` 8 +wordSizeInBytes = finiteBitSize (0::Elem) `div` 8 +------------------------------------------------------------------------------ -- | Cache line size, in bytes cacheLineSize :: Int cacheLineSize = 64 +------------------------------------------------------------------------------ newArray :: Int -> ST s (IntArray s) newArray n = do let !sz = n * wordSizeInBytes - !arr <- A.newAlignedPinnedByteArray sz cacheLineSize + !arr <- A.newAlignedPinnedByteArray sz cacheLineSize A.fillByteArray arr 0 sz 0 return $! IA arr -readArray :: IntArray s -> Int -> ST s Int +------------------------------------------------------------------------------ +readArray :: IntArray s -> Int -> ST s Elem readArray (IA a) idx = do BOUNDS_CHECK(a,idx) A.readByteArray a idx -writeArray :: IntArray s -> Int -> Int -> ST s () +------------------------------------------------------------------------------ +writeArray :: IntArray s -> Int -> Elem -> ST s () writeArray (IA a) idx val = do BOUNDS_CHECK(a,idx) A.writeByteArray a idx val -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 @@ -1,5 +1,5 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} module Data.HashTable.Internal.Linear.Bucket ( Bucket, @@ -10,7 +10,11 @@ snoc, size, lookup, + lookupIndex, + elemAt, delete, + mutate, + mutateST, toList, fromList, mapM_, @@ -23,13 +27,19 @@ ------------------------------------------------------------------------------ +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad hiding (foldM, mapM_) import qualified Control.Monad -import Control.Monad hiding (mapM_, foldM) -import Control.Monad.ST -import Data.Maybe (fromMaybe) +import Control.Monad.ST (ST) +#ifdef DEBUG +import Data.HashTable.Internal.Utils (unsafeIOToST) +#endif import Data.HashTable.Internal.Array +import Data.Maybe (fromMaybe) import Data.STRef -import Prelude hiding (lookup, mapM_) +import Prelude hiding (lookup, mapM_) ------------------------------------------------------------------------------ import Data.HashTable.Internal.UnsafeTricks @@ -189,7 +199,7 @@ debug "Bucket.snoc: spill finished, snoccing element" let (Bucket _ hwRef' keys' values') = fromKey bk - + let !hw' = hw+1 writeArray keys' hw k writeArray values' hw v @@ -226,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 +325,64 @@ ------------------------------------------------------------------------------ +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) + + +------------------------------------------------------------------------------ {-# INLINE mapM_ #-} mapM_ :: ((k,v) -> ST s a) -> Bucket s k v -> ST s () mapM_ f bucketKey @@ -293,7 +392,7 @@ | otherwise = doMap $ fromKey bucketKey where doMap (Bucket sz hwRef keys values) = do - hw <- readSTRef hwRef + hw <- readSTRef hwRef debug $ "Bucket.mapM_: hw was " ++ show hw ++ ", sz was " ++ show sz go hw 0 where @@ -313,7 +412,7 @@ | otherwise = doMap $ fromKey bucketKey where doMap (Bucket _ hwRef keys values) = do - hw <- readSTRef hwRef + hw <- readSTRef hwRef go hw seed0 0 where go !hw !seed !i | i >= hw = return seed 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 @@ -30,7 +30,7 @@ type Key a = Any #else -data Key a = Key !a +data Key a = Key !a | EmptyElement | DeletedElement deriving (Show) @@ -61,12 +61,12 @@ deletedRecord = unsafeCoerce DeletedElement {-# INLINE keyIsEmpty #-} -keyIsEmpty a = x# ==# 1# +keyIsEmpty a = isTrue# (x# ==# 1#) where !x# = reallyUnsafePtrEquality# a emptyRecord {-# INLINE keyIsDeleted #-} -keyIsDeleted a = x# ==# 1# +keyIsDeleted a = isTrue# (x# ==# 1#) where !x# = reallyUnsafePtrEquality# a deletedRecord 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 @@ -2,7 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -module Data.HashTable.Internal.Utils +module Data.HashTable.Internal.Utils ( whichBucket , nextBestPrime , bumpSize @@ -15,15 +15,17 @@ , highestBitMask , wordSize , cacheLineSize - , numWordsInCacheLine + , numElemsInCacheLine , cacheLineIntMask , cacheLineIntBits , forceSameType + , unsafeIOToST ) where -import Data.Bits hiding (shiftL) -import Data.Vector (Vector) -import qualified Data.Vector as V +import Data.Bits hiding (shiftL) +import Data.HashTable.Internal.IntArray (Elem) +import Data.Vector (Vector) +import qualified Data.Vector as V #if __GLASGOW_HASKELL__ >= 503 import GHC.Exts #else @@ -31,20 +33,25 @@ import Data.Word #endif +#if MIN_VERSION_base(4,4,0) +import Control.Monad.ST.Unsafe (unsafeIOToST) +#else +import Control.Monad.ST (unsafeIOToST) +#endif ------------------------------------------------------------------------------ wordSize :: Int -wordSize = bitSize (0::Int) +wordSize = finiteBitSize (0::Int) cacheLineSize :: Int cacheLineSize = 64 -numWordsInCacheLine :: Int -numWordsInCacheLine = z +numElemsInCacheLine :: Int +numElemsInCacheLine = z where - !z = cacheLineSize `div` (wordSize `div` 8) + !z = cacheLineSize `div` (finiteBitSize (0::Elem) `div` 8) -- | What you have to mask an integer index by to tell if it's @@ -52,11 +59,11 @@ cacheLineIntMask :: Int cacheLineIntMask = z where - !z = numWordsInCacheLine - 1 + !z = numElemsInCacheLine - 1 cacheLineIntBits :: Int -cacheLineIntBits = log2 $ toEnum numWordsInCacheLine +cacheLineIntBits = log2 $ toEnum numElemsInCacheLine ------------------------------------------------------------------------------ @@ -237,12 +244,8 @@ ------------------------------------------------------------------------------ -bumpSize :: Int -> Int -bumpSize !s = nextBestPrime s' - where - -- double at small sizes, then 3/2 thereafter - s' = if s < 24593 then 2*s else (s `div` 2) * 3 - +bumpSize :: Double -> Int -> Int +bumpSize !maxLoad !s = nextBestPrime $! ceiling (fromIntegral s / maxLoad) ------------------------------------------------------------------------------ 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 @@ -18,49 +18,51 @@ with deleted markers and force the table to be completely rehashed fairly often. -/Details:/ - -Of the hash tables in this collection, this hash table has the best insert and -lookup performance, with the following caveats. +Of the hash tables in this collection, this hash table has the best lookup +performance, while maintaining competitive insert performance. /Space overhead/ This table is not especially memory-efficient; firstly, the table has a maximum load factor of 0.83 and will be resized if load exceeds this value. Secondly, -to improve insert and lookup performance, we store the hash code for each key -in the table. +to improve insert and lookup performance, we store a 16-bit hash code for each +key in the table. -Each hash table entry requires three words, two for the pointers to the key and -value and one for the hash code. We don't count key and value pointers as -overhead, because they have to be there -- so the overhead for a full slot is -one word -- but empty slots in the hash table count for a full three words of -overhead. Define @m@ as the number of slots in the table and @n@ as the number -of key value mappings. If the load factor is @k=n\/m@, the amount of space -wasted is: +Each hash table entry requires at least 2.25 words (on a 64-bit machine), two +for the pointers to the key and value and one quarter word for the hash code. +We don't count key and value pointers as overhead, because they have to be +there -- so the overhead for a full slot is at least one quarter word -- but +empty slots in the hash table count for a full 2.25 words of overhead. Define +@m@ as the number of slots in the table, @n@ as the number of key value +mappings, and @ws@ as the machine word size in /bytes/. If the load factor is +@k=n\/m@, the amount of space /wasted/ per mapping in words is: @ -w(n) = 1*n + 3(m-n) +w(n) = (m*(2*ws + 2) - n*(2*ws)) / ws @ Since @m=n\/k@, @ -w(n) = n + 3(n\/k - n) -= n (3\/k-2) +w(n) = n\/k * (2*ws + 2) - n*(2*ws) + = (n * (2 + 2*ws*(1-k)) / k) / ws @ -Solving for @k=0.83@, the maximum load factor, gives a /minimum/ overhead of 2 -words per mapping. If @k=0.5@, under normal usage the /maximum/ overhead -situation, then the overhead would be 4 words per mapping. +Solving for @k=0.83@, the maximum load factor, gives a /minimum/ overhead of +0.71 words per mapping on a 64-bit machine, or 1.01 words per mapping on a +32-bit machine. If @k=0.5@, which should be under normal usage the /maximum/ +overhead situation, then the overhead would be 2.5 words per mapping on a +64-bit machine, or 3.0 words per mapping on a 32-bit machine. /Space overhead: experimental results/ -In randomized testing (see @test\/compute-overhead\/ComputeOverhead.hs@ in the -source distribution), mean overhead (that is, the number of words needed to -store the key-value mapping over and above the two words necessary for the key -and the value pointers) is approximately 2.29 machine words per key-value -mapping with a standard deviation of about 0.44 words, and 3.14 words per -mapping at the 95th percentile. +In randomized testing on a 64-bit machine (see +@test\/compute-overhead\/ComputeOverhead.hs@ in the source distribution), mean +overhead (that is, the number of words needed to store the key-value mapping +over and above the two words necessary for the key and the value pointers) is +approximately 1.24 machine words per key-value mapping with a standard +deviation of about 0.30 words, and 1.70 words per mapping at the 95th +percentile. /Expensive resizes/ @@ -78,14 +80,16 @@ Searching. Addison-Wesley Publishing Company, 1973. -} - module Data.HashTable.ST.Basic ( HashTable , new , newSized + , size , delete , lookup , insert + , mutate + , mutateST , mapM_ , foldM , computeOverhead @@ -93,37 +97,69 @@ ------------------------------------------------------------------------------ -import Control.Exception (assert) -import Control.Monad hiding (mapM_, foldM) -import Control.Monad.ST -import Data.Hashable (Hashable) -import qualified Data.Hashable as H +#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) +import Data.Bits +import Data.Hashable (Hashable) +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 -import Prelude hiding (lookup, read, mapM_) +import Prelude hiding (lookup, mapM_, read) ------------------------------------------------------------------------------ +import qualified Data.HashTable.Class as C import Data.HashTable.Internal.Array -import qualified Data.HashTable.Internal.IntArray as U import Data.HashTable.Internal.CacheLine +import Data.HashTable.Internal.IntArray (Elem) +import qualified Data.HashTable.Internal.IntArray as U import Data.HashTable.Internal.Utils -import qualified Data.HashTable.Class as C ------------------------------------------------------------------------------ -- | An open addressing hash table using linear probing. newtype HashTable s k v = HT (STRef s (HashTable_ s k v)) +type SizeRefs s = A.MutableByteArray s + +intSz :: Int +intSz = (finiteBitSize (0::Int) `div` 8) + +readLoad :: SizeRefs s -> ST s Int +readLoad = flip A.readByteArray 0 + +writeLoad :: SizeRefs s -> Int -> ST s () +writeLoad = flip A.writeByteArray 0 + +readDelLoad :: SizeRefs s -> ST s Int +readDelLoad = flip A.readByteArray 1 + +writeDelLoad :: SizeRefs s -> Int -> ST s () +writeDelLoad = flip A.writeByteArray 1 + +newSizeRefs :: ST s (SizeRefs s) +newSizeRefs = do + let asz = 2 * intSz + a <- A.newAlignedPinnedByteArray asz intSz + A.fillByteArray a 0 asz 0 + return a + + data HashTable_ s k v = HashTable - { _size :: {-# UNPACK #-} !Int - , _load :: !(U.IntArray s) -- ^ How many entries in the table? Prefer - -- unboxed vector here to STRef because I - -- know it will be appropriately strict - , _delLoad :: !(U.IntArray s) -- ^ How many deleted entries in the table? - , _hashes :: !(U.IntArray s) - , _keys :: {-# UNPACK #-} !(MutableArray s k) - , _values :: {-# UNPACK #-} !(MutableArray s v) + { _size :: {-# UNPACK #-} !Int + , _load :: !(SizeRefs s) -- ^ 2-element array, stores how many entries + -- and deleted entries are in the table. + , _hashes :: !(U.IntArray s) + , _keys :: {-# UNPACK #-} !(MutableArray s k) + , _values :: {-# UNPACK #-} !(MutableArray s v) } @@ -136,7 +172,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_ + lookupIndex = lookupIndex + nextByIndex = nextByIndex computeOverhead = computeOverhead + mutate = mutate + mutateST = mutateST ------------------------------------------------------------------------------ @@ -146,49 +186,56 @@ ------------------------------------------------------------------------------ -- | 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 30 +new = newSized 1 {-# INLINE new #-} ------------------------------------------------------------------------------ -- | 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 let m = nextBestPrime $ ceiling (fromIntegral n / maxLoad) ht <- newSizedReal m newRef ht {-# INLINE newSized #-} - ------------------------------------------------------------------------------ newSizedReal :: Int -> ST s (HashTable_ s k v) newSizedReal m = do -- make sure the hash array is a multiple of cache-line sized so we can -- always search a whole cache line at once - let m' = ((m + numWordsInCacheLine - 1) `div` numWordsInCacheLine) - * numWordsInCacheLine + let m' = ((m + numElemsInCacheLine - 1) `div` numElemsInCacheLine) + * numElemsInCacheLine h <- U.newArray m' k <- newArray m undefined v <- newArray m undefined - ld <- U.newArray 1 - dl <- U.newArray 1 - return $! HashTable m ld dl h k v + 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 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 #-} @@ -196,22 +243,30 @@ ------------------------------------------------------------------------------ -- | 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 lookup' ht where - lookup' (HashTable sz _ _ hashes keys values) = do + lookup' (HashTable sz _ hashes keys values) = do let !b = whichBucket h sz - debug $ "lookup sz=" ++ show sz ++ " h=" ++ show h ++ " b=" ++ show b + debug $ "lookup h=" ++ show h ++ " sz=" ++ show sz ++ " b=" ++ show b go b 0 sz where - !h = hash k + !h = hash k + !he = hashToElem h go !b !start !end = {-# SCC "lookup/go" #-} do - idx <- forwardSearch2 hashes b end h emptyMarker + debug $ concat [ "lookup'/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 @@ -220,7 +275,9 @@ debug $ "h0 was " ++ show h0 if recordIsEmpty h0 - then return Nothing + then do + debug $ "record empty, returning Nothing" + return Nothing else do k' <- readArray keys idx if k == k' @@ -228,15 +285,17 @@ debug $ "value found at " ++ show idx v <- readArray values idx return $! Just v - else if idx < b - then go (idx + 1) (idx + 1) b - else go (idx + 1) start end + else do + debug $ "value not found, recursing" + if idx < b + then go (idx + 1) (idx + 1) b + else go (idx + 1) start end {-# INLINE lookup #-} ------------------------------------------------------------------------------ -- | 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 @@ -244,36 +303,78 @@ -> 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 $ "insert': writing h=" ++ show h ++ " b=" ++ show b - U.writeArray hashes b h - 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 - 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 - work (HashTable sz _ _ hashes keys values) = go 0 seed0 + work (HashTable sz _ hashes keys values) = go 0 seed0 where go !i !seed | i >= sz = return seed | otherwise = do @@ -289,11 +390,11 @@ ------------------------------------------------------------------------------ -- | 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 - work (HashTable sz _ _ hashes keys values) = go 0 + work (HashTable sz _ hashes keys values) = go 0 where go !i | i >= sz = return () | otherwise = do @@ -309,19 +410,19 @@ ------------------------------------------------------------------------------ -- | 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 - work (HashTable sz' loadRef _ _ _ _) = do - !ld <- U.readArray loadRef 0 + work (HashTable sz' loadRef _ _ _) = do + !ld <- readLoad loadRef let k = fromIntegral ld / sz - return $ constOverhead / sz + overhead k + return $ constOverhead/sz + (2 + 2*ws*(1-k)) / (k * ws) where + ws = fromIntegral $! finiteBitSize (0::Int) `div` 8 sz = fromIntegral sz' -- Change these if you change the representation constOverhead = 14 - overhead k = 3 / k - 2 ------------------------------ @@ -345,11 +446,13 @@ probe b where + he = hashToElem h + probe !i = {-# SCC "insertRecord/probe" #-} do !idx <- forwardSearch2 hashes i sz emptyMarker deletedMarker debug $ "forwardSearch2 returned " ++ show idx assert (idx >= 0) $ do - U.writeArray hashes idx h + U.writeArray hashes idx he writeArray keys idx key writeArray values idx value @@ -358,11 +461,9 @@ checkOverflow :: (Eq k, Hashable k) => (HashTable_ s k v) -> ST s (HashTable_ s k v) -checkOverflow ht@(HashTable sz ldRef delRef _ _ _) = do - !ld <- U.readArray ldRef 0 - let !ld' = ld + 1 - U.writeArray ldRef 0 ld' - !dl <- U.readArray delRef 0 +checkOverflow ht@(HashTable sz ldRef _ _ _) = do + !ld <- readLoad ldRef + !dl <- readDelLoad ldRef debug $ concat [ "checkOverflow: sz=" , show sz @@ -380,11 +481,11 @@ ------------------------------------------------------------------------------ rehashAll :: Hashable k => HashTable_ s k v -> Int -> ST s (HashTable_ s k v) -rehashAll (HashTable sz loadRef _ hashes keys values) sz' = do +rehashAll (HashTable sz loadRef hashes keys values) sz' = do debug $ "rehashing: old size " ++ show sz ++ ", new size " ++ show sz' ht' <- newSizedReal sz' - let (HashTable _ loadRef' _ newHashes newKeys newValues) = ht' - U.readArray loadRef 0 >>= U.writeArray loadRef' 0 + let (HashTable _ loadRef' newHashes newKeys newValues) = ht' + readLoad loadRef >>= writeLoad loadRef' rehash newHashes newKeys newValues return ht' @@ -404,57 +505,70 @@ ------------------------------------------------------------------------------ growTable :: Hashable k => HashTable_ s k v -> ST s (HashTable_ s k v) -growTable ht@(HashTable sz _ _ _ _ _) = do - let !sz' = bumpSize sz +growTable ht@(HashTable sz _ _ _ _) = do + let !sz' = bumpSize maxLoad sz rehashAll ht sz' ------------------------------------------------------------------------------ --- 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 delRef hashes keys values) clearOut k h = do - debug $ "delete': sz=" ++ show sz ++ " h=" ++ show h - ++ " b0=" ++ show b0 - (found, slot) <- go mempty b0 False +-- 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) $ bump delRef (-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 - bump ref i = do - !ld <- U.readArray ref 0 - U.writeArray ref 0 $! 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 @@ -466,10 +580,22 @@ -- * wrap True if we've wrapped around, False otherwise go !fp !b !wrap = do - debug $ "go: fp=" ++ show fp ++ " b=" ++ show b - ++ ", wrap=" ++ show wrap - !idx <- forwardSearch3 hashes b sz h emptyMarker deletedMarker + debug $ concat [ "go: fp=" + , show fp + , " b=" + , show b + , ", wrap=" + , show wrap + , ", he=" + , show he + , ", emptyMarker=" + , show emptyMarker + , ", deletedMarker=" + , show deletedMarker ] + + !idx <- forwardSearch3 hashes b sz he emptyMarker deletedMarker 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; @@ -478,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 @@ -490,80 +617,146 @@ 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 - if h == h0 + if he == h0 then do + debug $ "found he == h0 == " ++ show h0 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 - bump delRef 1 - U.writeArray hashes idx 1 - 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 ------------------------------------------------------------------------------ -emptyMarker :: Int +emptyMarker :: Elem emptyMarker = 0 + ------------------------------------------------------------------------------ -deletedMarker :: Int +deletedMarker :: Elem deletedMarker = 1 ------------------------------------------------------------------------------ +{-# INLINE trueInt #-} +trueInt :: Int -> Bool +trueInt (I# i#) = tagToEnum# i# + + +------------------------------------------------------------------------------ {-# INLINE recordIsEmpty #-} -recordIsEmpty :: Int -> Bool +recordIsEmpty :: Elem -> Bool recordIsEmpty = (== emptyMarker) ------------------------------------------------------------------------------ {-# INLINE recordIsDeleted #-} -recordIsDeleted :: Int -> Bool +recordIsDeleted :: Elem -> Bool recordIsDeleted = (== deletedMarker) ------------------------------------------------------------------------------ +{-# 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 k = out +hash = H.hash + + +------------------------------------------------------------------------------ +{-# INLINE hashToElem #-} +hashToElem :: Int -> Elem +hashToElem !h = out where - !(I# h#) = H.hash k + !(I# lo#) = h .&. U.elemMask - !m# = maskw# h# 0# `or#` maskw# h# 1# + !m# = maskw# lo# 0# `or#` maskw# lo# 1# !nm# = not# m# - !r# = ((int2Word# 2#) `and#` m#) `or#` (int2Word# h# `and#` nm#) - !out = I# (word2Int# r#) + !r# = ((int2Word# 2#) `and#` m#) `or#` (int2Word# lo# `and#` nm#) + !out = U.primWordToElem r# ------------------------------------------------------------------------------ @@ -588,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 @@ -10,7 +10,7 @@ * want the fastest possible inserts, and very fast lookups. * are conscious of memory usage; this table has less space overhead than - "Data.HashTable.ST.Basic", but more than "Data.HashTable.ST.Linear". + "Data.HashTable.ST.Basic" or "Data.HashTable.ST.Linear". * don't care that a table resize might pause for a long time to rehash all of the key-value mappings. @@ -51,9 +51,8 @@ the basic open-addressing hash table using linear probing, and on average is more space-efficient: in randomized testing on my 64-bit machine (see @test\/compute-overhead\/ComputeOverhead.hs@ in the source distribution), mean -overhead is 1.71 machine words per key-value mapping, with a standard deviation -of 0.30 words, and 2.46 words per mapping at the 95th percentile. - +overhead is 0.77 machine words per key-value mapping, with a standard deviation +of 0.29 words, and 1.23 words per mapping at the 95th percentile. /References:/ @@ -69,27 +68,42 @@ , delete , lookup , insert + , mutate + , mutateST , mapM_ , foldM + , lookupIndex + , nextByIndex ) where ------------------------------------------------------------------------------ -import Control.Monad hiding (foldM, mapM_) -import Control.Monad.ST -import Data.Hashable hiding (hash) -import qualified Data.Hashable as H +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif +import Control.Monad hiding + (foldM, + mapM_) +import Control.Monad.ST (ST) +import Data.Bits +import Data.Hashable hiding + (hash) +import qualified Data.Hashable as H import Data.Int import Data.Maybe import Data.Primitive.Array import Data.STRef import GHC.Exts -import Prelude hiding ( lookup, read, mapM_ ) +import Prelude hiding + (lookup, + mapM_, + read) ------------------------------------------------------------------------------ -import qualified Data.HashTable.Class as C -import Data.HashTable.Internal.CheapPseudoRandomBitStream +import qualified Data.HashTable.Class as C import Data.HashTable.Internal.CacheLine -import qualified Data.HashTable.Internal.IntArray as U +import Data.HashTable.Internal.CheapPseudoRandomBitStream +import Data.HashTable.Internal.IntArray (Elem) +import qualified Data.HashTable.Internal.IntArray as U import Data.HashTable.Internal.Utils #ifdef DEBUG @@ -102,12 +116,12 @@ newtype HashTable s k v = HT (STRef s (HashTable_ s k v)) data HashTable_ s k v = HashTable - { _size :: {-# UNPACK #-} !Int -- ^ in buckets, total size is - -- numWordsInCacheLine * _size - , _rng :: {-# UNPACK #-} !(BitStream s) - , _hashes :: {-# UNPACK #-} !(U.IntArray s) - , _keys :: {-# UNPACK #-} !(MutableArray s k) - , _values :: {-# UNPACK #-} !(MutableArray s v) + { _size :: {-# UNPACK #-} !Int -- ^ in buckets, total size is + -- numElemsInCacheLine * _size + , _rng :: {-# UNPACK #-} !(BitStream s) + , _hashes :: {-# UNPACK #-} !(U.IntArray s) + , _keys :: {-# UNPACK #-} !(MutableArray s k) + , _values :: {-# UNPACK #-} !(MutableArray s v) , _maxAttempts :: {-# UNPACK #-} !Int } @@ -121,7 +135,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_ + lookupIndex = lookupIndex + nextByIndex = nextByIndex computeOverhead = computeOverhead + mutate = mutate + mutateST = mutateST ------------------------------------------------------------------------------ @@ -131,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 #-} @@ -139,10 +157,10 @@ ------------------------------------------------------------------------------ -- | 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 + numWordsInCacheLine - 1) `div` numWordsInCacheLine + let n' = (n + numElemsInCacheLine - 1) `div` numElemsInCacheLine let k = nextBestPrime $ ceiling $ fromIntegral n' / maxLoad newSizedReal k >>= newRef {-# INLINE newSized #-} @@ -150,35 +168,61 @@ ------------------------------------------------------------------------------ -- | 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 work (HashTable sz _ _ _ _ _) = do nFilled <- foldM f 0 htRef - let oh = totSz -- one word per element in hashes - + 2 * (totSz - nFilled) -- two words per non-filled entry - + 12 -- fixed overhead + let oh = (totSz `div` hashCodesPerWord) -- one half or quarter word + -- per element in hashes + + 2 * (totSz - nFilled) -- two words per non-filled entry + + 12 -- fixed overhead return $! fromIntegral (oh::Int) / fromIntegral nFilled where - totSz = numWordsInCacheLine * sz + hashCodesPerWord = (finiteBitSize (0 :: Int)) `div` 16 + totSz = numElemsInCacheLine * sz f !a _ = return $! a+1 ------------------------------------------------------------------------------ -- | 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 @@ -199,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 @@ -218,14 +262,14 @@ lookup' (HashTable sz _ hashes keys values _) !k = do -- Unlike the write case, prefetch doesn't seem to help here for lookup. -- prefetchRead hashes b2 - idx1 <- searchOne keys hashes k b1 h1 + idx1 <- searchOne keys hashes k b1 he1 if idx1 >= 0 then do v <- readArray values idx1 return $! Just v else do - idx2 <- searchOne keys hashes k b2 h2 + idx2 <- searchOne keys hashes k b2 he2 if idx2 >= 0 then do v <- readArray values idx2 @@ -237,6 +281,9 @@ h1 = hash1 k h2 = hash2 k + he1 = hashToElem h1 + he2 = hashToElem h2 + b1 = whichLine h1 sz b2 = whichLine h2 sz {-# INLINE lookup' #-} @@ -248,12 +295,12 @@ -> U.IntArray s -> k -> Int - -> Int + -> Elem -> ST s Int -searchOne !keys !hashes !k = go +searchOne !keys !hashes !k !b0 !h = go b0 where - go !b !h = do - debug $ "searchOne: go " ++ show b ++ " " ++ show h + go !b = do + debug $ "searchOne: go/" ++ show b ++ "/" ++ show h idx <- cacheLineSearch hashes b h debug $ "searchOne: cacheLineSearch returned " ++ show idx @@ -267,14 +314,14 @@ let !idx' = idx + 1 if isCacheLineAligned idx' then return (-1) - else go idx' h + else go idx' {-# INLINE searchOne #-} ------------------------------------------------------------------------------ -- | 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 @@ -290,7 +337,7 @@ -> ST s a foldMWork f seed0 (HashTable sz _ hashes keys values _) = go 0 seed0 where - totSz = numWordsInCacheLine * sz + totSz = numElemsInCacheLine * sz go !i !seed | i >= totSz = return seed | otherwise = do @@ -309,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 () @@ -323,7 +370,7 @@ -> ST s () mapMWork f (HashTable sz _ hashes keys values _) = go 0 where - totSz = numWordsInCacheLine * sz + totSz = numElemsInCacheLine * sz go !i | i >= totSz = return () | otherwise = do @@ -347,7 +394,7 @@ ------------------------------------------------------------------------------ newSizedReal :: Int -> ST s (HashTable_ s k v) newSizedReal nbuckets = do - let !ntotal = nbuckets * numWordsInCacheLine + let !ntotal = nbuckets * numElemsInCacheLine let !maxAttempts = 12 + (log2 $ toEnum nbuckets) debug $ "creating cuckoo hash table with " ++ @@ -379,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 @@ -421,7 +564,7 @@ ------------------------------------------------------------------------------ --- Returns either (-1,-1) (not found, and both buckets full ==> trigger +-- Returns either (-1, 0) (not found, and both buckets full ==> trigger -- cuckoo), or the slot in the array where it would be safe to write the given -- key, and the hashcode to use there delete' :: (Hashable k, Eq k) => @@ -432,17 +575,19 @@ -> Int -- ^ cache line start address 2 -> Int -- ^ hash1 -> Int -- ^ hash2 - -> ST s (Int, Int) + -> ST s (Int, Elem) delete' (HashTable _ _ hashes keys values _) !updating !k b1 b2 h1 h2 = do debug $ "delete' b1=" ++ show b1 ++ " b2=" ++ show b2 ++ " h1=" ++ show h1 ++ " h2=" ++ show h2 prefetchWrite hashes b2 - idx1 <- searchOne keys hashes k b1 h1 + let !he1 = hashToElem h1 + let !he2 = hashToElem h2 + idx1 <- searchOne keys hashes k b1 he1 if idx1 < 0 then do - idx2 <- searchOne keys hashes k b2 h2 + idx2 <- searchOne keys hashes k b2 he2 if idx2 < 0 then if updating then do @@ -451,16 +596,16 @@ idxE1 <- cacheLineSearch hashes b1 emptyMarker debug $ "delete': idxE1 was " ++ show idxE1 if idxE1 >= 0 - then return (idxE1, h1) + then return (idxE1, he1) else do idxE2 <- cacheLineSearch hashes b2 emptyMarker debug $ "delete': idxE2 was " ++ show idxE1 if idxE2 >= 0 - then return (idxE2, h2) - else return (-1, -1) - else return (-1,-1) - else deleteIt idx2 h2 - else deleteIt idx1 h1 + then return (idxE2, he2) + else return (-1, 0) + else return (-1, 0) + else deleteIt idx2 he2 + else deleteIt idx1 he1 where deleteIt !idx !h = do @@ -517,21 +662,23 @@ where randomIdx !b = do !z <- getNBits cacheLineIntBits rng - return $! b + z + return $! b + fromIntegral z bumpIdx !idx !h !k !v = do + let !he = hashToElem h debug $ "bumpIdx idx=" ++ show idx ++ " h=" ++ show h - !h' <- U.readArray hashes idx - debug $ "bumpIdx: h' was " ++ show h' + ++ " he=" ++ show he + !he' <- U.readArray hashes idx + debug $ "bumpIdx: he' was " ++ show he' !k' <- readArray keys idx v' <- readArray values idx - U.writeArray hashes idx h + U.writeArray hashes idx he writeArray keys idx k writeArray values idx v - debug $ "bumped key with h'=" ++ show h' - return $! (h', k', v') + debug $ "bumped key with he'=" ++ show he' + return $! (he', k', v') - otherHash h k = if h2 == h then h1 else h2 + otherHash he k = if hashToElem h1 == he then h2 else h1 where h1 = hash1 k h2 = hash2 k @@ -543,7 +690,7 @@ if idx >= 0 then do - U.writeArray hashes idx h + U.writeArray hashes idx $! hashToElem h writeArray keys idx k writeArray values idx v return Nothing @@ -552,8 +699,8 @@ go !b !h !k v !maxAttempts | maxAttempts == 0 = return $! Just (k,v) | otherwise = do idx <- randomIdx b - (!h0', !k', v') <- bumpIdx idx h k v - let !h' = otherHash h0' k' + (!he0', !k', v') <- bumpIdx idx h k v + let !h' = otherHash he0' k' let !b' = whichLine h' sz tryWrite b' h' k' v' maxAttempts @@ -566,11 +713,11 @@ -> v -> ST s (HashTable_ s k v) grow (HashTable sz _ hashes keys values _) k0 v0 = do - newHt <- grow' $! bumpSize sz + newHt <- grow' $! bumpSize bumpFactor sz mbR <- updateOrFail newHt k0 v0 maybe (return newHt) - (\_ -> grow' $ bumpSize $ _size newHt) + (\_ -> grow' $ bumpSize bumpFactor $ _size newHt) mbR where @@ -583,7 +730,7 @@ rehash !newSz !newHt = go 0 where - totSz = numWordsInCacheLine * sz + totSz = numElemsInCacheLine * sz go !i | i >= totSz = return newHt | otherwise = do @@ -595,7 +742,7 @@ mbR <- updateOrFail newHt k v maybe (go $ i + 1) - (\_ -> grow' $ bumpSize newSz) + (\_ -> grow' $ bumpSize bumpFactor newSz) mbR else go $ i + 1 @@ -610,30 +757,31 @@ ------------------------------------------------------------------------------ hash1 :: Hashable k => k -> Int -hash1 = hashF H.hash +hash1 = H.hash {-# INLINE hash1 #-} hash2 :: Hashable k => k -> Int -hash2 = hashF (H.hashWithSalt hashPrime) +hash2 = H.hashWithSalt hashPrime {-# INLINE hash2 #-} -hashF :: (k -> Int) -> k -> Int -hashF f k = out +------------------------------------------------------------------------------ +hashToElem :: Int -> Elem +hashToElem !h = out where - !(I# h#) = f k + !(I# lo#) = h .&. U.elemMask - !m# = maskw# h# 0# + !m# = maskw# lo# 0# !nm# = not# m# - !r# = ((int2Word# 1#) `and#` m#) `or#` (int2Word# h# `and#` nm#) - !out = I# (word2Int# r#) -{-# INLINE hashF #-} + !r# = ((int2Word# 1#) `and#` m#) `or#` (int2Word# lo# `and#` nm#) + !out = U.primWordToElem r# +{-# INLINE hashToElem #-} ------------------------------------------------------------------------------ -emptyMarker :: Int +emptyMarker :: Elem emptyMarker = 0 @@ -643,6 +791,11 @@ ------------------------------------------------------------------------------ +bumpFactor :: Double +bumpFactor = 0.73 + + +------------------------------------------------------------------------------ debug :: String -> ST s () #ifdef DEBUG debug s = unsafeIOToST (putStrLn s >> hFlush stdout) @@ -671,3 +824,43 @@ 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 @@ -6,9 +6,6 @@ {-| An implementation of linear hash tables. (See ). Use this hash table if you... - * care a lot about fitting your data set into memory; of the hash tables - included in this collection, this one has the lowest space overhead - * don't care that inserts and lookups are slower than the other hash table implementations in this collection (this one is slightly faster than @Data.HashTable@ from the base library in most cases) @@ -86,23 +83,29 @@ , delete , lookup , insert + , mutate + , mutateST , mapM_ , foldM , computeOverhead ) where ------------------------------------------------------------------------------ -import Control.Monad hiding (mapM_, foldM) +#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 import Data.Hashable import Data.STRef -import Prelude hiding (mapM_, lookup) +import Prelude hiding (lookup, mapM_) ------------------------------------------------------------------------------ -import qualified Data.HashTable.Class as C +import qualified Data.HashTable.Class as C import Data.HashTable.Internal.Array -import qualified Data.HashTable.Internal.Linear.Bucket as Bucket import Data.HashTable.Internal.Linear.Bucket (Bucket) +import qualified Data.HashTable.Internal.Linear.Bucket as Bucket import Data.HashTable.Internal.Utils #ifdef DEBUG @@ -130,7 +133,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_ + lookupIndex = lookupIndex + nextByIndex = nextByIndex computeOverhead = computeOverhead + mutate = mutate + mutateST = mutateST ------------------------------------------------------------------------------ @@ -221,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 () @@ -462,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 @@ -2,10 +2,10 @@ Version: 0.2 Author: Gregory Collins Maintainer: greg@gregorycollins.net -Copyright: (c) 2011-2012, Google, Inc. +Copyright: (c) 2011-2013, Google, Inc. Category: Data Build-type: Simple -Cabal-version: >= 1.8 +Cabal-version: >= 1.10 ------------------------------------------------------------------------------ Flag debug @@ -22,75 +22,31 @@ Description: if on, use bounds-checking array accesses Default: False - -Flag sse41 - Description: if on, use SSE 4.1 extensions to search cache lines very - efficiently +Flag sse42 + Description: if on, use SSE 4.2 extensions to search cache lines very + efficiently. The portable flag forces this off. Default: False - Flag portable Description: if on, use only pure Haskell code and no GHC extensions. Default: False -Executable testsuite - hs-source-dirs: ../src suite - main-is: TestSuite.hs - - if !flag(portable) - C-sources: ../cbits/cfuncs.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 - - if !flag(portable) && flag(sse41) - cc-options: -DUSE_SSE_4_1 -msse4.1 - cpp-options: -DUSE_SSE_4_1 - - 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 - C-sources: ../cbits/cfuncs.c + 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) @@ -106,19 +62,15 @@ if flag(bounds-checking) cpp-options: -DBOUNDS_CHECKING - if !flag(portable) && flag(sse41) - cc-options: -DUSE_SSE_4_1 -msse4.1 - cpp-options: -DUSE_SSE_4_1 - 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.7, - test-framework-quickcheck2 >= 0.2.6 && <0.3, + 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) @@ -27,14 +26,15 @@ 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 -import Test.QuickCheck.Monadic +import Test.Tasty +import Test.Tasty.HUnit hiding (assert) +import Test.Tasty.QuickCheck +import Test.QuickCheck.Monadic (PropertyM, assert, + forAllM, monadicIO, pre, + run) ------------------------------------------------------------------------------ import qualified Data.HashTable.Class as C +import Data.HashTable.Internal.Utils (unsafeIOToST) import Data.HashTable.IO #ifndef PORTABLE @@ -45,11 +45,32 @@ ------------------------------------------------------------------------------ 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 ------------------------------------------------------------------------------ +announce :: Show a => String -> a -> IO () +#ifdef DEBUG +announce nm x = do + putStrLn "\n=============================" + putStrLn $ concat [ "starting " + , nm + , " with " + , show x + ] + putStrLn "=============================" +#else +announce _ _ = return () +#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 = @@ -70,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 @@ -83,6 +104,8 @@ , SomeTest testDelete , SomeTest testNastyFullLookup , SomeTest testForwardSearch3 + , SomeTest testMutate + , SomeTest testMutateGrow ] @@ -97,7 +120,8 @@ where prop :: GenIO -> [(Int, Int)] -> PropertyM IO () prop rng origL = do - let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL + 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') @@ -114,8 +138,9 @@ where prop :: GenIO -> ([(Int, Int)], (Int,Int)) -> PropertyM IO () - prop rng (origL, (k,v)) = do - let l = V.toList $ shuffle rng $ V.fromList $ remove k $ dedupe origL + prop rng o@(origL, (k,v)) = do + 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 @@ -139,8 +164,9 @@ where prop :: GenIO -> ([(Int, Int)], (Int,Int,Int)) -> PropertyM IO () - prop rng (origL, (k,v,v2)) = do - let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL + prop rng o@(origL, (k,v,v2)) = do + announceQ "insert2" o + let l = V.toList $ shuffleVector rng $ V.fromList $ dedupe origL ht <- run $ fromList l run $ insert ht k v @@ -162,7 +188,8 @@ where prop :: (Int,Int,Int) -> PropertyM IO () - prop (k,v,v2) = do + prop o@(k,v,v2) = do + announceQ "newAndInsert" o ht <- run new nothing <- run $ lookup ht k @@ -209,8 +236,9 @@ prop :: Int -> PropertyM IO () prop n = do + 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 @@ -254,9 +282,11 @@ prop :: Int -> PropertyM IO () prop n = do + 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 @@ -269,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 @@ -276,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 @@ -426,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:)) [] @@ -458,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 @@ -475,4 +546,3 @@ idx <- pickOne k swap k idx f (k-1) - 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