diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2011, Google, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + + * Neither the name of Google, Inc. nor the names of other contributors may + be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON +ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,79 @@ +This package provides a couple of different implementations of mutable hash +tables in the ST monad, as well as a typeclass abstracting their common +operations, and a set of wrappers to use the hash tables in the IO monad. + +**Quick start**: documentation for the hash table operations is provided in the +`Data.HashTable.Class` module, and the IO wrappers are located in the +`Data.HashTable.IO` module. + +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 hashing" + as introduced by Pagh and Rodler in 2001 (see + [http://en.wikipedia.org/wiki/Cuckoo\_hashing](http://en.wikipedia.org/wiki/Cuckoo_hashing)). + 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. 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 + 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. + + 3. `Data.HashTable.ST.Linear` contains a linear hash table (see + [http://en.wikipedia.org/wiki/Linear\_hashing](http://en.wikipedia.org/wiki/Linear_hashing)), + which trades some insert and lookup performance for higher space + efficiency and much shorter delays when expanding the table. In most + cases, benchmarks show this table to be currently slightly faster than + `Data.HashTable` from the Haskell base library. + +It is recommended to create a concrete type alias in your code when using this +package, i.e.: + + import qualified Data.HashTable.IO as H + + type HashTable k v = H.BasicHashTable k v + + foo :: IO (HashTable Int Int) + foo = do + ht <- H.new + H.insert ht 1 1 + return ht + +Firstly, this makes it easy to switch to a different hash table implementation, +and secondly, using a concrete type rather than leaving your functions abstract +in the HashTable class should allow GHC to optimize away the typeclass +dictionaries. + +This package accepts a couple of different cabal flags: + + * `unsafe-tricks`, default **on**. If this flag is enabled, we use some + unsafe GHC-specific tricks to save indirections (namely `unsafeCoerce#` and + `reallyUnsafePtrEquality#`. These techniques rely on assumptions about the + behaviour of the GHC runtime system and, although they've been tested and + should be safe under normal conditions, are slightly 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 + instructions (see + [http://en.wikipedia.org/wiki/SSE4](http://en.wikipedia.org/wiki/SSE4), + first available on Intel Core 2 processors) to speed up cache-line searches + for cuckoo hashing. + + * `bounds-checking`, default /off/. If this flag is enabled, array accesses + are bounds-checked. + + * `debug`, default /off/. If turned on, we'll rudely spew debug output to + stdout. + + * `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*. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/cfuncs.c b/cbits/cfuncs.c new file mode 100644 --- /dev/null +++ b/cbits/cfuncs.c @@ -0,0 +1,471 @@ +#include + + +#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; + while (1) { + if (p == ep) p = array; + 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; + while (1) { + if (p == ep) p = array; + 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; + while (1) { + if (p == ep) p = array; + 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; + while (1) { + if (p == ep) p = array; + 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); +} + diff --git a/haddock.sh b/haddock.sh new file mode 100644 --- /dev/null +++ b/haddock.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +set -x + +rm -Rf dist/doc + +HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + +cabal haddock $HADDOCK_OPTS --hyperlink-source $@ diff --git a/hashtables.cabal b/hashtables.cabal new file mode 100644 --- /dev/null +++ b/hashtables.cabal @@ -0,0 +1,191 @@ +Name: hashtables +Version: 1.0.0.0 +Synopsis: Mutable hash tables in the ST monad +Homepage: http://github.com/gregorycollins/hashtables +License: BSD3 +License-file: LICENSE +Author: Gregory Collins +Maintainer: greg@gregorycollins.net +Copyright: (c) 2011, Google, Inc. +Category: Data +Build-type: Simple +Cabal-version: >= 1.8 + +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 + operations, and a set of wrappers to use the hash tables in the IO monad. + . + /QUICK START/: documentation for the hash table operations is provided in the + "Data.HashTable.Class" module, and the IO wrappers (which most users will + probably prefer) are located in the "Data.HashTable.IO" module. + . + 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 + 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. + 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 + 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. + . + 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 + delays when expanding the table. In most cases, benchmarks show this + table to be currently slightly faster than @Data.HashTable@ from the + Haskell base library. + . + It is recommended to create a concrete type alias in your code when using this + package, i.e.: + . + > import qualified Data.HashTable.IO as H + > + > type HashTable k v = H.BasicHashTable k v + > + > foo :: IO (HashTable Int Int) + > foo = do + > ht <- H.new + > H.insert ht 1 1 + > return ht + . + Firstly, this makes it easy to switch to a different hash table implementation, + and secondly, using a concrete type rather than leaving your functions abstract + in the HashTable class should allow GHC to optimize away the typeclass + dictionaries. + . + This package accepts a couple of different cabal flags: + . + * @unsafe-tricks@, default /ON/. If this flag is enabled, we use some + unsafe GHC-specific tricks to save indirections (namely @unsafeCoerce#@ + and @reallyUnsafePtrEquality#@. These techniques rely on assumptions + about the behaviour of the GHC runtime system and, although they've been + tested and should be safe under normal conditions, are slightly + 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 + instructions (see , first available on + Intel Core 2 processors) to speed up cache-line searches for cuckoo + hashing. + . + * @bounds-checking@, default /OFF/. If this flag is enabled, array accesses + are bounds-checked. + . + * @debug@, default /OFF/. If turned on, we'll rudely spew debug output to + stdout. + . + * @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. + . + Please send bug reports to + . + +Extra-Source-Files: + README.md, + haddock.sh, + 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 + + +------------------------------------------------------------------------------ +Flag unsafe-tricks + Description: turn on unsafe GHC tricks + Default: True + +Flag bounds-checking + Description: if on, use bounds-checking array accesses + Default: False + +Flag debug + Description: if on, spew debugging output to stdout + Default: False + +Flag sse41 + Description: if on, use SSE 4.1 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 + + +Library + hs-source-dirs: src + + if !flag(portable) + C-sources: cbits/cfuncs.c + + Exposed-modules: Data.HashTable.Class, + Data.HashTable.IO, + Data.HashTable.ST.Basic, + Data.HashTable.ST.Cuckoo, + Data.HashTable.ST.Linear + + Other-modules: Data.HashTable.Internal.Array, + Data.HashTable.Internal.IntArray, + Data.HashTable.Internal.CacheLine, + Data.HashTable.Internal.CheapPseudoRandomBitStream, + Data.HashTable.Internal.UnsafeTricks, + Data.HashTable.Internal.Utils, + Data.HashTable.Internal.Linear.Bucket + + Build-depends: base >= 4 && <5, + hashable >= 1.1 && <2, + primitive, + vector >= 0.7 + + + if flag(portable) + cpp-options: -DNO_C_SEARCH + + if !flag(portable) && flag(unsafe-tricks) && impl(ghc) + build-depends: ghc-prim + cpp-options = -DUNSAFETRICKS + + if flag(debug) + cpp-options: -DDEBUG + + 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 + + ghc-prof-options: -prof -auto-all + + if impl(ghc >= 6.12.0) + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-unused-do-bind + else + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + diff --git a/src/Data/HashTable/Class.hs b/src/Data/HashTable/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/Class.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns #-} + +-- | This module contains a 'HashTable' typeclass for the hash table +-- implementations in this package. This allows you to provide functions which +-- will work for any hash table implementation in this collection. +-- +-- It is recommended to create a concrete type alias in your code when using this +-- package, i.e.: +-- +-- > import qualified Data.HashTable.IO as H +-- > +-- > type HashTable k v = H.BasicHashTable k v +-- > +-- > foo :: IO (HashTable Int Int) +-- > foo = do +-- > ht <- H.new +-- > H.insert ht 1 1 +-- > return ht +-- +-- or +-- +-- > import qualified Data.HashTable.ST.Cuckoo as C +-- > import qualified Data.HashTable.Class as H +-- > +-- > type HashTable s k v = C.HashTable s k v +-- > +-- > foo :: ST s (HashTable s k v) +-- > foo = do +-- > ht <- H.new +-- > H.insert ht 1 1 +-- > return ht +-- +-- Firstly, this makes it easy to switch to a different hash table +-- implementation, and secondly, using a concrete type rather than leaving your +-- functions abstract in the 'HashTable' class should allow GHC to optimize +-- away the typeclass dictionaries. +-- +-- Note that the functions in this typeclass are in the 'ST' monad; if you want +-- hash tables in 'IO', use the convenience wrappers in "Data.HashTable.IO". +-- +module Data.HashTable.Class + ( HashTable(..) + , fromList + , toList + ) where + + +import Control.Monad.ST +import Data.Hashable +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. +class HashTable h where + -- | Creates a new, default-sized hash table. /O(1)/. + new :: ST s (h s k v) + + -- | Creates a new hash table sized to hold @n@ elements. /O(n)/. + newSized :: Int -> ST s (h s k v) + + -- | Inserts a key/value mapping into a hash table, replacing any existing + -- mapping for that key. + -- + -- /O(n)/ worst case, /O(1)/ amortized. + insert :: (Eq k, Hashable k) => h s k v -> k -> v -> ST s () + + -- | Deletes a key-value mapping from a hash table. /O(n)/ worst case, + -- /O(1)/ amortized. + delete :: (Eq k, Hashable k) => h s k v -> k -> ST s () + + -- | Looks up a key-value mapping in a hash table. /O(n)/ worst case, + -- (/O(1)/ for cuckoo hash), /O(1)/ amortized. + lookup :: (Eq k, Hashable k) => h s k v -> k -> ST s (Maybe v) + + -- | A strict fold over the key-value records of a hash table in the 'ST' + -- monad. /O(n)/. + foldM :: (a -> (k,v) -> ST s a) -> a -> h s k v -> ST s a + + -- | 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 () + + -- | Computes the overhead (in words) per key-value mapping. Used for + -- debugging, etc; time complexity depends on the underlying hash table + -- implementation. /O(n)/. + computeOverhead :: h s k v -> ST s Double + + +------------------------------------------------------------------------------ +-- | Create a hash table from a list of key-value pairs. /O(n)/. +fromList :: (HashTable h, Eq k, Hashable k) => [(k,v)] -> ST s (h s k v) +fromList l = do + ht <- newSized (length l) + go ht l + + where + go ht = go' + where + go' [] = return ht + go' ((!k,!v):xs) = do + insert ht k v + go' xs +{-# INLINE fromList #-} + + +------------------------------------------------------------------------------ +-- | Given a hash table, produce a list of key-value pairs. /O(n)/. +toList :: (HashTable h) => h s k v -> ST s [(k,v)] +toList ht = do + l <- foldM f [] ht + return l + + where + f !l !t = return (t:l) +{-# INLINE toList #-} diff --git a/src/Data/HashTable/IO.hs b/src/Data/HashTable/IO.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/IO.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} + +-- | This module provides wrappers in 'IO' around the functions from +-- "Data.HashTable.Class". +-- +-- This module exports three concrete hash table types, one for each hash table +-- implementation in this package: +-- +-- > type BasicHashTable k v = IOHashTable (B.HashTable) k v +-- > type CuckooHashTable k v = IOHashTable (Cu.HashTable) k v +-- > type LinearHashTable k v = IOHashTable (L.HashTable) k v +-- +-- The 'IOHashTable' type can be thought of as a wrapper around a concrete +-- hashtable type, which sets the 'ST' monad state type to 'PrimState' 'IO', +-- a.k.a. 'RealWorld': +-- +-- > type IOHashTable tabletype k v = tabletype (PrimState IO) k v +-- +-- This module provides 'stToIO' wrappers around the hashtable functions (which +-- are in 'ST') to make it convenient to use them in 'IO'. It is intended to be +-- imported qualified and used with a user-defined type alias, i.e.: +-- +-- > import qualified Data.HashTable.IO as H +-- > +-- > type HashTable k v = H.CuckooHashTable k v +-- > +-- > foo :: IO (HashTable Int Int) +-- > foo = do +-- > ht <- H.new +-- > H.insert ht 1 1 +-- > return ht +-- +-- Essentially, anywhere you see @'IOHashTable' h k v@ in the type signatures +-- below, you can plug in any of @'BasicHashTable' k v@, @'CuckooHashTable' k +-- v@, or @'LinearHashTable' k v@. +-- +module Data.HashTable.IO + ( BasicHashTable + , CuckooHashTable + , LinearHashTable + , IOHashTable + , new + , newSized + , insert + , delete + , lookup + , fromList + , toList + , mapM_ + , foldM + , computeOverhead + ) where + + +------------------------------------------------------------------------------ +import Control.Monad.Primitive (PrimState) +import Control.Monad.ST +import Data.Hashable (Hashable) +import qualified Data.HashTable.Class as C +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 + + +------------------------------------------------------------------------------ +-- | A type alias for a basic open addressing hash table using linear +-- probing. See "Data.HashTable.ST.Basic". +type BasicHashTable k v = IOHashTable (B.HashTable) k v + +-- | A type alias for the cuckoo hash table. See "Data.HashTable.ST.Cuckoo". +type CuckooHashTable k v = IOHashTable (Cu.HashTable) k v + +-- | A type alias for the linear hash table. See "Data.HashTable.ST.Linear". +type LinearHashTable k v = IOHashTable (L.HashTable) k v + + +------------------------------------------------------------------------------ +-- | A type alias for our hash tables, which run in 'ST', to set the state +-- token type to 'PrimState' 'IO' (aka 'RealWorld') so that we can use them in +-- 'IO'. +type IOHashTable tabletype k v = tabletype (PrimState IO) k v + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in "Data.HashTable.Class#v:new". +new :: C.HashTable h => IO (IOHashTable h k v) +new = stToIO C.new +{-# INLINE new #-} +{-# SPECIALIZE INLINE new :: IO (BasicHashTable k v) #-} +{-# SPECIALIZE INLINE new :: IO (LinearHashTable k v) #-} +{-# SPECIALIZE INLINE new :: IO (CuckooHashTable k v) #-} + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:newSized". +newSized :: C.HashTable h => Int -> IO (IOHashTable h k v) +newSized = stToIO . C.newSized +{-# INLINE newSized #-} +{-# SPECIALIZE INLINE newSized :: Int -> IO (BasicHashTable k v) #-} +{-# SPECIALIZE INLINE newSized :: Int -> IO (LinearHashTable k v) #-} +{-# SPECIALIZE INLINE newSized :: Int -> IO (CuckooHashTable k v) #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in "Data.HashTable.Class#v:update". +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) => + BasicHashTable k v -> k -> v -> IO () #-} +{-# SPECIALIZE INLINE insert :: (Eq k, Hashable k) => + LinearHashTable k v -> k -> v -> IO () #-} +{-# SPECIALIZE INLINE insert :: (Eq k, Hashable k) => + CuckooHashTable k v -> k -> v -> IO () #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in "Data.HashTable.Class#v: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) => + BasicHashTable k v -> k -> IO () #-} +{-# SPECIALIZE INLINE delete :: (Eq k, Hashable k) => + LinearHashTable k v -> k -> IO () #-} +{-# SPECIALIZE INLINE delete :: (Eq k, Hashable k) => + CuckooHashTable k v -> k -> IO () #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in "Data.HashTable.Class#v: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) => + BasicHashTable k v -> k -> IO (Maybe v) #-} +{-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) => + LinearHashTable k v -> k -> IO (Maybe v) #-} +{-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) => + CuckooHashTable k v -> k -> IO (Maybe v) #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v: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) => + [(k,v)] -> IO (BasicHashTable k v) #-} +{-# SPECIALIZE INLINE fromList :: (Eq k, Hashable k) => + [(k,v)] -> IO (LinearHashTable k v) #-} +{-# SPECIALIZE INLINE fromList :: (Eq k, Hashable k) => + [(k,v)] -> IO (CuckooHashTable k v) #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in "Data.HashTable.Class#v: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) => + BasicHashTable k v -> IO [(k,v)] #-} +{-# SPECIALIZE INLINE toList :: (Eq k, Hashable k) => + LinearHashTable k v -> IO [(k,v)] #-} +{-# SPECIALIZE INLINE toList :: (Eq k, Hashable k) => + CuckooHashTable k v -> IO [(k,v)] #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in "Data.HashTable.Class#v:foldM". +foldM :: (C.HashTable h) => + (a -> (k,v) -> IO a) + -> a + -> IOHashTable h k v -> IO a +foldM f seed ht = stToIO $ C.foldM f' seed ht + where + f' !i !t = unsafeIOToST $ f i t +{-# INLINE foldM #-} +{-# SPECIALIZE INLINE foldM :: (a -> (k,v) -> IO a) -> a + -> BasicHashTable k v -> IO a #-} +{-# SPECIALIZE INLINE foldM :: (a -> (k,v) -> IO a) -> a + -> LinearHashTable k v -> IO a #-} +{-# SPECIALIZE INLINE foldM :: (a -> (k,v) -> IO a) -> a + -> CuckooHashTable k v -> IO a #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in "Data.HashTable.Class#v:mapM_". +mapM_ :: (C.HashTable h) => ((k,v) -> IO a) -> IOHashTable h k v -> IO () +mapM_ f ht = stToIO $ C.mapM_ f' ht + where + f' = unsafeIOToST . f +{-# INLINE mapM_ #-} +{-# SPECIALIZE INLINE mapM_ :: ((k,v) -> IO a) -> BasicHashTable k v + -> IO () #-} +{-# SPECIALIZE INLINE mapM_ :: ((k,v) -> IO a) -> LinearHashTable k v + -> IO () #-} +{-# SPECIALIZE INLINE mapM_ :: ((k,v) -> IO a) -> CuckooHashTable k v + -> IO () #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:computeOverhead". +computeOverhead :: (C.HashTable h) => IOHashTable h k v -> IO Double +computeOverhead = stToIO . C.computeOverhead +{-# INLINE computeOverhead #-} diff --git a/src/Data/HashTable/Internal/Array.hs b/src/Data/HashTable/Internal/Array.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/Internal/Array.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE CPP #-} + +module Data.HashTable.Internal.Array + ( MutableArray + , newArray + , readArray + , writeArray + ) where + + +import Control.Monad.ST +#ifdef BOUNDS_CHECKING +import qualified Data.Vector.Mutable as M +import Data.Vector.Mutable (MVector) +#else +import qualified Data.Primitive.Array as M +import Data.Primitive.Array (MutableArray) +#endif + + +#ifdef BOUNDS_CHECKING + +type MutableArray s a = MVector s a + +newArray :: Int -> a -> ST s (MutableArray s a) +newArray = M.replicate + +readArray :: MutableArray s a -> Int -> ST s a +readArray = M.read + +writeArray :: MutableArray s a -> Int -> a -> ST s () +writeArray = M.write + +#else + +newArray :: Int -> a -> ST s (MutableArray s a) +newArray = M.newArray + +readArray :: MutableArray s a -> Int -> ST s a +readArray = M.readArray + +writeArray :: MutableArray s a -> Int -> a -> ST s () +writeArray = M.writeArray + +#endif diff --git a/src/Data/HashTable/Internal/CacheLine.hs b/src/Data/HashTable/Internal/CacheLine.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/Internal/CacheLine.hs @@ -0,0 +1,843 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} + +module Data.HashTable.Internal.CacheLine + ( cacheLineSearch + , cacheLineSearch2 + , cacheLineSearch3 + , forwardSearch2 + , forwardSearch3 + , isCacheLineAligned + , advanceByCacheLineSize + , prefetchRead + , prefetchWrite + , bl_abs# + , sign# + , mask# + , maskw# + ) where + +import Control.Monad.ST +import Data.HashTable.Internal.IntArray (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 "lineSearch32" + c_lineSearch32 :: Ptr a -> CInt -> CUInt -> IO Int + +foreign import ccall unsafe "lineSearch64" + c_lineSearch64 :: Ptr a -> CInt -> CULong -> IO Int + +foreign import ccall unsafe "lineSearch32_2" + c_lineSearch32_2 :: Ptr a -> CInt -> CUInt -> CUInt -> IO Int + +foreign import ccall unsafe "lineSearch64_2" + c_lineSearch64_2 :: Ptr a -> CInt -> CULong -> CULong -> IO Int + +foreign import ccall unsafe "lineSearch32_3" + c_lineSearch32_3 :: Ptr a -> CInt -> CUInt -> CUInt -> CUInt -> IO Int + +foreign import ccall unsafe "lineSearch64_3" + c_lineSearch64_3 :: Ptr a -> CInt -> CULong -> CULong -> CULong -> IO Int + +foreign import ccall unsafe "forwardSearch32_2" + c_forwardSearch32_2 :: Ptr a -> CInt -> CInt -> CUInt -> CUInt -> IO Int + +foreign import ccall unsafe "forwardSearch32_3" + c_forwardSearch32_3 :: Ptr a -> CInt -> CInt -> CUInt -> CUInt -> CUInt + -> IO Int + +foreign import ccall unsafe "forwardSearch64_2" + c_forwardSearch64_2 :: Ptr a -> CInt -> CInt -> CULong -> CULong -> IO Int + +foreign import ccall unsafe "forwardSearch64_3" + c_forwardSearch64_3 :: Ptr a -> CInt -> CInt -> CULong -> CULong -> CULong + -> IO Int + +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 = + 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 = + 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 = + 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 = + 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 = + 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#) = 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 + where + next !i = let !j = i+1 + in if j == end then 0 else j + + go !i = do + h <- M.readArray vec i + if h == x1 || h == x2 + then return i + else go $ next i + + +{-# INLINE forwardSearch3 #-} +forwardSearch3 :: IntArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int +forwardSearch3 !vec !start !end !x1 !x2 !x3 = go start + where + next !i = let !j = i+1 + in if j == end then 0 else j + + go !i = do + h <- M.readArray vec i + if h == x1 || h == x2 || h == x3 + then return i + else go $ next i + + +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 diff --git a/src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs b/src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns #-} + +module Data.HashTable.Internal.CheapPseudoRandomBitStream + ( BitStream + , newBitStream + , getNextBit + , getNBits + ) where + +import Control.Applicative +import Control.Monad.ST +import Data.Bits +import Data.Int +import Data.STRef +import qualified Data.Vector.Unboxed as V +import Data.Vector.Unboxed (Vector) + +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 = V.fromList [ 0xe293c315 + , 0x82e2ff62 + , 0xcb1ef9ae + , 0x78850172 + , 0x551ee1ce + , 0x59d6bfd1 + , 0xb717ec44 + , 0xe7a3024e + , 0x02bb8976 + , 0x87e2f94f + , 0xfa156372 + , 0xe1325b17 + , 0xe005642a + , 0xc8d02eb3 + , 0xe90c0a87 + , 0x4cb9e6e2 + ] + + +------------------------------------------------------------------------------ +random64s :: Vector Int64 +random64s = V.fromList [ 0x62ef447e007e8732 + , 0x149d6acb499feef8 + , 0xca7725f9b404fbf8 + , 0x4b5dfad194e626a9 + , 0x6d76f2868359491b + , 0x6b2284e3645dcc87 + , 0x5b89b485013eaa16 + , 0x6e2d4308250c435b + , 0xc31e641a659e0013 + , 0xe237b85e9dc7276d + , 0x0b3bb7fa40d94f3f + , 0x4da446874d4ca023 + , 0x69240623fedbd26b + , 0x76fb6810dcf894d3 + , 0xa0da4e0ce57c8ea7 + , 0xeb76b84453dc3873 + ] + + +------------------------------------------------------------------------------ +numRandoms :: Int +numRandoms = 16 + + +------------------------------------------------------------------------------ +randoms :: Vector Int +randoms | wordSize == 32 = V.map fromEnum random32s + | otherwise = V.map fromEnum random64s + + +------------------------------------------------------------------------------ +data BitStream s = BitStream { + _curRandom :: !(STRef s Int) + , _bitsLeft :: !(STRef s Int) + , _randomPos :: !(STRef s Int) + } + + +------------------------------------------------------------------------------ +newBitStream :: ST s (BitStream s) +newBitStream = + unwrapMonad $ + BitStream <$> (WrapMonad $ newSTRef $ V.unsafeIndex randoms 0) + <*> (WrapMonad $ newSTRef wordSize) + <*> (WrapMonad $ newSTRef 1) + + +------------------------------------------------------------------------------ +getNextBit :: BitStream s -> ST s Int +getNextBit = getNBits 1 + + +------------------------------------------------------------------------------ +getNBits :: Int -> BitStream s -> ST s Int +getNBits nbits (BitStream crRef blRef rpRef) = do + !bl <- readSTRef blRef + if bl < nbits + then newWord + else nextBits bl + + where + newWord = do + !rp <- readSTRef rpRef + let r = V.unsafeIndex randoms rp + writeSTRef blRef $! wordSize - nbits + writeSTRef rpRef $! if rp == (numRandoms-1) then 0 else rp + 1 + extractBits r + + extractBits r = do + let !b = r .&. ((1 `iShiftL` nbits) - 1) + writeSTRef crRef $! (r `iShiftRL` nbits) + return b + + nextBits bl = do + !r <- readSTRef crRef + writeSTRef blRef $! bl - nbits + extractBits r diff --git a/src/Data/HashTable/Internal/IntArray.hs b/src/Data/HashTable/Internal/IntArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/Internal/IntArray.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module Data.HashTable.Internal.IntArray + ( IntArray + , newArray + , readArray + , writeArray + , length + , toPtr + ) where + +import Control.Monad.ST +import Data.Bits +import qualified Data.Primitive.ByteArray as A +import Data.Primitive.Types (Addr(..)) +import GHC.Exts +import Prelude hiding (length) + +#ifdef BOUNDS_CHECKING +#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))) \ + else return () +#else +#define BOUNDS_CHECK(arr,i) +#endif + +newtype IntArray s = IA (A.MutableByteArray s) + + +wordSizeInBytes :: Int +wordSizeInBytes = bitSize (0::Int) `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 + A.memsetByteArray arr 0 0 sz + return $! IA arr + + +readArray :: IntArray s -> Int -> ST s Int +readArray (IA a) idx = do + BOUNDS_CHECK(a,idx) + A.readByteArray a idx + + +writeArray :: IntArray s -> Int -> Int -> 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 + + +toPtr :: IntArray s -> Ptr a +toPtr (IA a) = Ptr a# + where + !(Addr !a#) = A.mutableByteArrayContents a diff --git a/src/Data/HashTable/Internal/Linear/Bucket.hs b/src/Data/HashTable/Internal/Linear/Bucket.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/Internal/Linear/Bucket.hs @@ -0,0 +1,355 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +module Data.HashTable.Internal.Linear.Bucket +( Bucket, + newBucketArray, + newBucketSize, + emptyWithSize, + growBucketTo, + snoc, + size, + lookup, + delete, + toList, + fromList, + mapM_, + foldM, + expandBucketArray, + expandArray, + nelemsAndOverheadInWords, + bucketSplitSize +) where + + +------------------------------------------------------------------------------ +import qualified Control.Monad +import Control.Monad hiding (mapM_, foldM) +import Control.Monad.ST +import Data.Maybe (fromMaybe) +import Data.HashTable.Internal.Array +import Data.STRef +import Prelude hiding (lookup, mapM_) +------------------------------------------------------------------------------ +import Data.HashTable.Internal.UnsafeTricks + + +#ifdef DEBUG +import System.IO +#endif + + +type Bucket s k v = Key (Bucket_ s k v) + +------------------------------------------------------------------------------ +data Bucket_ s k v = Bucket { _bucketSize :: {-# UNPACK #-} !Int + , _highwater :: {-# UNPACK #-} !(STRef s Int) + , _keys :: {-# UNPACK #-} !(MutableArray s k) + , _values :: {-# UNPACK #-} !(MutableArray s v) + } + + +------------------------------------------------------------------------------ +bucketSplitSize :: Int +bucketSplitSize = 16 + + +------------------------------------------------------------------------------ +newBucketArray :: Int -> ST s (MutableArray s (Bucket s k v)) +newBucketArray k = newArray k emptyRecord + +------------------------------------------------------------------------------ +nelemsAndOverheadInWords :: Bucket s k v -> ST s (Int,Int) +nelemsAndOverheadInWords bKey = do + if (not $ keyIsEmpty bKey) + then do + !hw <- readSTRef hwRef + let !w = sz - hw + return (hw, constOverhead + 2*w) + else + return (0, 0) + + where + constOverhead = 8 + b = fromKey bKey + sz = _bucketSize b + hwRef = _highwater b + + +------------------------------------------------------------------------------ +emptyWithSize :: Int -> ST s (Bucket s k v) +emptyWithSize !sz = do + !keys <- newArray sz undefined + !values <- newArray sz undefined + !ref <- newSTRef 0 + + return $ toKey $ Bucket sz ref keys values + + +------------------------------------------------------------------------------ +newBucketSize :: Int +newBucketSize = 4 + + +------------------------------------------------------------------------------ +expandArray :: a -- ^ default value + -> Int -- ^ new size + -> Int -- ^ number of elements to copy + -> MutableArray s a -- ^ old array + -> ST s (MutableArray s a) +expandArray def !sz !hw !arr = do + newArr <- newArray sz def + cp newArr + + where + cp !newArr = go 0 + where + go !i + | i >= hw = return newArr + | otherwise = do + readArray arr i >>= writeArray newArr i + go (i+1) + + +------------------------------------------------------------------------------ +expandBucketArray :: Int + -> Int + -> MutableArray s (Bucket s k v) + -> ST s (MutableArray s (Bucket s k v)) +expandBucketArray = expandArray emptyRecord + + +------------------------------------------------------------------------------ +growBucketTo :: Int -> Bucket s k v -> ST s (Bucket s k v) +growBucketTo !sz bk | keyIsEmpty bk = emptyWithSize sz + | otherwise = do + if osz >= sz + then return bk + else do + hw <- readSTRef hwRef + k' <- expandArray undefined sz hw keys + v' <- expandArray undefined sz hw values + return $ toKey $ Bucket sz hwRef k' v' + + where + bucket = fromKey bk + osz = _bucketSize bucket + hwRef = _highwater bucket + keys = _keys bucket + values = _values bucket + + +------------------------------------------------------------------------------ +{-# INLINE snoc #-} +-- Just return == new bucket object +snoc :: Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v)) +snoc bucket | keyIsEmpty bucket = mkNew + | otherwise = snoc' (fromKey bucket) + where + mkNew !k !v = do + debug "Bucket.snoc: mkNew" + keys <- newArray newBucketSize undefined + values <- newArray newBucketSize undefined + + writeArray keys 0 k + writeArray values 0 v + ref <- newSTRef 1 + return (1, Just $ toKey $ Bucket newBucketSize ref keys values) + + snoc' (Bucket bsz hwRef keys values) !k !v = + readSTRef hwRef >>= check + where + check !hw + | hw < bsz = bump hw + | otherwise = spill hw + + bump hw = do + debug $ "Bucket.snoc: bumping hw, bsz=" ++ show bsz ++ ", hw=" + ++ show hw + + writeArray keys hw k + writeArray values hw v + let !hw' = hw + 1 + writeSTRef hwRef hw' + debug "Bucket.snoc: finished" + return (hw', Nothing) + + doublingThreshold = bucketSplitSize `div` 2 + growFactor = 1.5 :: Double + newSize z | z == 0 = newBucketSize + | z < doublingThreshold = z * 2 + | otherwise = ceiling $ growFactor * fromIntegral z + + spill !hw = do + let sz = newSize bsz + debug $ "Bucket.snoc: spilling, old size=" ++ show bsz ++ ", new size=" + ++ show sz + + bk <- growBucketTo sz bucket + + 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 + writeSTRef hwRef' hw' + + return (hw', Just bk) + + + +------------------------------------------------------------------------------ +{-# INLINE size #-} +size :: Bucket s k v -> ST s Int +size b | keyIsEmpty b = return 0 + | otherwise = readSTRef $ _highwater $ fromKey b + + +------------------------------------------------------------------------------ +-- note: search in reverse order! We prefer recently snoc'd keys. +lookup :: (Eq k) => Bucket s k v -> k -> ST s (Maybe v) +lookup 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 do + !v <- readArray values i + return $! Just v + else go (i-1) + + +------------------------------------------------------------------------------ +{-# INLINE toList #-} +toList :: Bucket s k v -> ST s [(k,v)] +toList bucketKey | keyIsEmpty bucketKey = return [] + | otherwise = toList' $ fromKey bucketKey + where + toList' (Bucket _ hwRef keys values) = do + hw <- readSTRef hwRef + go [] hw 0 + where + go !l !hw !i | i >= hw = return l + | otherwise = do + k <- readArray keys i + v <- readArray values i + go ((k,v):l) hw $ i+1 + + +------------------------------------------------------------------------------ +-- fromList needs to reverse the input in order to make fromList . toList == id +{-# INLINE fromList #-} +fromList :: [(k,v)] -> ST s (Bucket s k v) +fromList l = Control.Monad.foldM f emptyRecord (reverse l) + where + f bucket (k,v) = do + (_,m) <- snoc bucket k v + return $ fromMaybe bucket m + +------------------------------------------------------------------------------ +delete :: (Eq k) => Bucket s k v -> k -> ST s Bool +delete bucketKey !k | keyIsEmpty bucketKey = do + debug $ "Bucket.delete: empty bucket" + return False + | otherwise = do + debug "Bucket.delete: start" + del $ fromKey bucketKey + where + del (Bucket sz hwRef keys values) = do + hw <- readSTRef hwRef + debug $ "Bucket.delete: hw=" ++ show hw ++ ", sz=" ++ show sz + go hw $ hw - 1 + + where + go !hw !i | i < 0 = return False + | otherwise = do + k' <- readArray keys i + if k == k' + then do + debug $ "found entry to delete at " ++ show i + move (hw-1) i keys + move (hw-1) i values + let !hw' = hw-1 + writeSTRef hwRef hw' + return True + else go hw (i-1) + + +------------------------------------------------------------------------------ +{-# INLINE mapM_ #-} +mapM_ :: ((k,v) -> ST s a) -> Bucket s k v -> ST s () +mapM_ f bucketKey + | keyIsEmpty bucketKey = do + debug $ "Bucket.mapM_: bucket was empty" + return () + | otherwise = doMap $ fromKey bucketKey + where + doMap (Bucket sz hwRef keys values) = do + hw <- readSTRef hwRef + debug $ "Bucket.mapM_: hw was " ++ show hw ++ ", sz was " ++ show sz + go hw 0 + where + go !hw !i | i >= hw = return () + | otherwise = do + k <- readArray keys i + v <- readArray values i + _ <- f (k,v) + go hw $ i+1 + + +------------------------------------------------------------------------------ +{-# INLINE foldM #-} +foldM :: (a -> (k,v) -> ST s a) -> a -> Bucket s k v -> ST s a +foldM f !seed0 bucketKey + | keyIsEmpty bucketKey = return seed0 + | otherwise = doMap $ fromKey bucketKey + where + doMap (Bucket _ hwRef keys values) = do + hw <- readSTRef hwRef + go hw seed0 0 + where + go !hw !seed !i | i >= hw = return seed + | otherwise = do + k <- readArray keys i + v <- readArray values i + seed' <- f seed (k,v) + go hw seed' (i+1) + + +------------------------------------------------------------------------------ +-- move i into j +move :: Int -> Int -> MutableArray s a -> ST s () +move i j arr | i == j = do + debug $ "move " ++ show i ++ " into " ++ show j + return () + | otherwise = do + debug $ "move " ++ show i ++ " into " ++ show j + readArray arr i >>= writeArray arr j + + + +{-# INLINE debug #-} +debug :: String -> ST s () + +#ifdef DEBUG +debug s = unsafeIOToST $ do + putStrLn s + hFlush stdout +#else +#ifdef TESTSUITE +debug !s = do + let !_ = length s + return $! () +#else +debug _ = return () +#endif +#endif + diff --git a/src/Data/HashTable/Internal/UnsafeTricks.hs b/src/Data/HashTable/Internal/UnsafeTricks.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/Internal/UnsafeTricks.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +#ifdef UNSAFETRICKS +{-# LANGUAGE MagicHash #-} +#endif + +module Data.HashTable.Internal.UnsafeTricks + ( Key + , toKey + , fromKey + , emptyRecord + , deletedRecord + , keyIsEmpty + , keyIsDeleted + , writeDeletedElement + , makeEmptyVector + ) where + +import Control.Monad.Primitive +import Data.Vector.Mutable (MVector) +import qualified Data.Vector.Mutable as M +#ifdef UNSAFETRICKS +import GHC.Exts +import Unsafe.Coerce +#endif + + +------------------------------------------------------------------------------ +#ifdef UNSAFETRICKS +type Key a = Any + +#else +data Key a = Key !a + | EmptyElement + | DeletedElement + deriving (Show) +#endif + + +------------------------------------------------------------------------------ +-- Type signatures +emptyRecord :: Key a +deletedRecord :: Key a +keyIsEmpty :: Key a -> Bool +keyIsDeleted :: Key a -> Bool +makeEmptyVector :: PrimMonad m => Int -> m (MVector (PrimState m) (Key a)) +writeDeletedElement :: PrimMonad m => + MVector (PrimState m) (Key a) -> Int -> m () +toKey :: a -> Key a +fromKey :: Key a -> a + + +#ifdef UNSAFETRICKS +data TombStone = EmptyElement + | DeletedElement + +{-# NOINLINE emptyRecord #-} +emptyRecord = unsafeCoerce EmptyElement + +{-# NOINLINE deletedRecord #-} +deletedRecord = unsafeCoerce DeletedElement + +{-# INLINE keyIsEmpty #-} +keyIsEmpty a = x# ==# 1# + where + !x# = reallyUnsafePtrEquality# a emptyRecord + +{-# INLINE keyIsDeleted #-} +keyIsDeleted a = x# ==# 1# + where + !x# = reallyUnsafePtrEquality# a deletedRecord + +{-# INLINE toKey #-} +toKey = unsafeCoerce + +{-# INLINE fromKey #-} +fromKey = unsafeCoerce + +#else + +emptyRecord = EmptyElement + +deletedRecord = DeletedElement + +keyIsEmpty EmptyElement = True +keyIsEmpty _ = False + +keyIsDeleted DeletedElement = True +keyIsDeleted _ = False + +toKey = Key + +fromKey (Key x) = x +fromKey _ = error "impossible" + +#endif + + +------------------------------------------------------------------------------ +{-# INLINE makeEmptyVector #-} +makeEmptyVector m = M.replicate m emptyRecord + +------------------------------------------------------------------------------ +{-# INLINE writeDeletedElement #-} +writeDeletedElement v i = M.unsafeWrite v i deletedRecord diff --git a/src/Data/HashTable/Internal/Utils.hs b/src/Data/HashTable/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/Internal/Utils.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +module Data.HashTable.Internal.Utils + ( whichBucket + , nextBestPrime + , bumpSize + , shiftRL + , iShiftL + , iShiftRL + , nextHighestPowerOf2 + , log2 + , highestBitMask + , wordSize + , cacheLineSize + , numWordsInCacheLine + , cacheLineIntMask + , cacheLineIntBits + , forceSameType + ) where + +import Data.Bits +import Data.Vector (Vector) +import qualified Data.Vector as V +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import Data.Word +#endif + + +------------------------------------------------------------------------------ +wordSize :: Int +wordSize = bitSize (0::Int) + + +cacheLineSize :: Int +cacheLineSize = 64 + + +numWordsInCacheLine :: Int +numWordsInCacheLine = z + where + !z = cacheLineSize `div` (wordSize `div` 8) + + +-- | What you have to mask an integer index by to tell if it's +-- cacheline-aligned +cacheLineIntMask :: Int +cacheLineIntMask = z + where + !z = numWordsInCacheLine - 1 + + +cacheLineIntBits :: Int +cacheLineIntBits = log2 $ toEnum numWordsInCacheLine + + +------------------------------------------------------------------------------ +{-# INLINE whichBucket #-} +whichBucket :: Int -> Int -> Int +whichBucket !h !sz = o + where + !o = h `mod` sz + + +------------------------------------------------------------------------------ +binarySearch :: (Ord e) => Vector e -> e -> Int +binarySearch = binarySearchBy compare +{-# INLINE binarySearch #-} + + +------------------------------------------------------------------------------ +binarySearchBy :: (e -> e -> Ordering) + -> Vector e + -> e + -> Int +binarySearchBy cmp vec e = binarySearchByBounds cmp vec e 0 (V.length vec) +{-# INLINE binarySearchBy #-} + + +------------------------------------------------------------------------------ +binarySearchByBounds :: (e -> e -> Ordering) + -> Vector e + -> e + -> Int + -> Int + -> Int +binarySearchByBounds cmp vec e = loop + where + loop !l !u + | u <= l = l + | otherwise = let e' = V.unsafeIndex vec k + in case cmp e' e of + LT -> loop (k+1) u + EQ -> k + GT -> loop l k + where k = (u + l) `shiftR` 1 +{-# INLINE binarySearchByBounds #-} + + +------------------------------------------------------------------------------ +primeSizes :: Vector Integer +primeSizes = V.fromList [ 19 + , 31 + , 37 + , 43 + , 47 + , 53 + , 61 + , 67 + , 79 + , 89 + , 97 + , 107 + , 113 + , 127 + , 137 + , 149 + , 157 + , 167 + , 181 + , 193 + , 211 + , 233 + , 257 + , 281 + , 307 + , 331 + , 353 + , 389 + , 409 + , 421 + , 443 + , 467 + , 503 + , 523 + , 563 + , 593 + , 631 + , 653 + , 673 + , 701 + , 733 + , 769 + , 811 + , 877 + , 937 + , 1039 + , 1117 + , 1229 + , 1367 + , 1543 + , 1637 + , 1747 + , 1873 + , 2003 + , 2153 + , 2311 + , 2503 + , 2777 + , 3079 + , 3343 + , 3697 + , 5281 + , 6151 + , 7411 + , 9901 + , 12289 + , 18397 + , 24593 + , 34651 + , 49157 + , 66569 + , 73009 + , 98317 + , 118081 + , 151051 + , 196613 + , 246011 + , 393241 + , 600011 + , 786433 + , 1050013 + , 1572869 + , 2203657 + , 3145739 + , 4000813 + , 6291469 + , 7801379 + , 10004947 + , 12582917 + , 19004989 + , 22752641 + , 25165843 + , 39351667 + , 50331653 + , 69004951 + , 83004629 + , 100663319 + , 133004881 + , 173850851 + , 201326611 + , 293954587 + , 402653189 + , 550001761 + , 702952391 + , 805306457 + , 1102951999 + , 1402951337 + , 1610612741 + , 1902802801 + , 2147483647 + , 3002954501 + , 3902954959 + , 4294967291 + , 5002902979 + , 6402754181 + , 8589934583 + , 17179869143 + , 34359738337 + , 68719476731 + , 137438953447 + , 274877906899 ] + + +------------------------------------------------------------------------------ +nextBestPrime :: Int -> Int +nextBestPrime x = fromEnum yi + where + xi = toEnum x + idx = binarySearch primeSizes xi + yi = V.unsafeIndex primeSizes idx + + +------------------------------------------------------------------------------ +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 + + + +------------------------------------------------------------------------------ +shiftRL :: Word -> Int -> Word +iShiftL :: Int -> Int -> Int +iShiftRL :: Int -> Int -> Int +#if __GLASGOW_HASKELL__ +{-------------------------------------------------------------------- + GHC: use unboxing to get @shiftRL@ inlined. +--------------------------------------------------------------------} +{-# INLINE shiftRL #-} +shiftRL (W# x) (I# i) + = W# (uncheckedShiftRL# x i) + +{-# INLINE iShiftL #-} +iShiftL (I# x) (I# i) + = I# (uncheckedIShiftL# x i) + +{-# INLINE iShiftRL #-} +iShiftRL (I# x) (I# i) + = I# (uncheckedIShiftRL# x i) + +#else +shiftRL x i = shiftR x i +iShiftL x i = shiftL x i +iShiftRL x i = shiftRL x i +#endif + + +------------------------------------------------------------------------------ +{-# INLINE nextHighestPowerOf2 #-} +nextHighestPowerOf2 :: Word -> Word +nextHighestPowerOf2 w = highestBitMask (w-1) + 1 + + +------------------------------------------------------------------------------ +log2 :: Word -> Int +log2 w = go (nextHighestPowerOf2 w) 0 + where + go 0 !i = i-1 + go !n !i = go (shiftRL n 1) (i+1) + + +------------------------------------------------------------------------------ +{-# INLINE highestBitMask #-} +highestBitMask :: Word -> Word +highestBitMask !x0 = case (x0 .|. shiftRL x0 1) of + x1 -> case (x1 .|. shiftRL x1 2) of + x2 -> case (x2 .|. shiftRL x2 4) of + x3 -> case (x3 .|. shiftRL x3 8) of + x4 -> case (x4 .|. shiftRL x4 16) of + x5 -> x5 .|. shiftRL x5 32 + + +------------------------------------------------------------------------------ +forceSameType :: Monad m => a -> a -> m () +forceSameType _ _ = return () +{-# INLINE forceSameType #-} diff --git a/src/Data/HashTable/ST/Basic.hs b/src/Data/HashTable/ST/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/ST/Basic.hs @@ -0,0 +1,506 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +{-| + +A basic open-addressing hash table using linear probing. Use this hash table if +you... + + * want the fastest possible lookups, and very fast inserts. + + * don't care about wasting a little bit of memory to get it. + + * don't care that a table resize might pause for a long time to rehash all + of the key-value mappings. + +/Details:/ + +Of the hash tables in this collection, this hash table has the best insert and +lookup performance, with the following caveats. + +/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. + +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: + +@ +w(n) = 1*n + 3(m-n) +@ + +Since @m=n\/k@, + +@ +w(n) = n + 3(n\/k - n) += n (3\/k-2) +@ + +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. + +/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. + +/Expensive resizes/ + +If enough elements are inserted into the table to make it exceed the maximum +load factor, the table is resized. A resize involves a complete rehash of all +the elements in the table, which means that any given call to 'insert' might +take /O(n)/ time in the size of the table, with a large constant factor. If a +long pause waiting for the table to resize is unacceptable for your +application, you should choose the included linear hash table instead. + + +/References:/ + + * Knuth, Donald E. /The Art of Computer Programming/, vol. 3 Sorting and + Searching. Addison-Wesley Publishing Company, 1973. +-} + + +module Data.HashTable.ST.Basic + ( HashTable + , new + , newSized + , delete + , lookup + , insert + , mapM_ + , foldM + , computeOverhead + ) where + + +------------------------------------------------------------------------------ +import Control.Monad hiding (mapM_, foldM) +import Control.Monad.ST +import Data.Hashable (Hashable) +import qualified Data.Hashable as H +import Data.Maybe +import Data.STRef +import GHC.Exts +import Prelude hiding (lookup, read, mapM_) +------------------------------------------------------------------------------ +import Data.HashTable.Internal.Array +import qualified Data.HashTable.Internal.IntArray as U +import Data.HashTable.Internal.CacheLine +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)) + +data HashTable_ s k v = HashTable + { _size :: {-# UNPACK #-} !Int + , _load :: !(U.IntArray s) -- ^ prefer unboxed vector here to STRef + -- because I know it will be appropriately + -- strict + , _hashes :: !(U.IntArray s) + , _keys :: {-# UNPACK #-} !(MutableArray s k) + , _values :: {-# UNPACK #-} !(MutableArray s v) + } + + +------------------------------------------------------------------------------ +instance C.HashTable HashTable where + new = new + newSized = newSized + insert = insert + delete = delete + lookup = lookup + foldM = foldM + mapM_ = mapM_ + computeOverhead = computeOverhead + + +------------------------------------------------------------------------------ +instance Show (HashTable s k v) where + show _ = "" + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:new". +new :: ST s (HashTable s k v) +new = newSized 30 +{-# INLINE new #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:newSized". +newSized :: Int -> ST s (HashTable s k v) +newSized n = do + 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 + h <- U.newArray m' + k <- newArray m undefined + v <- newArray m undefined + ld <- U.newArray 1 + return $! HashTable m ld h k v + + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v: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 () + where + !h = hash k +{-# INLINE delete #-} + + + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v: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 + let !b = whichBucket h sz + debug $ "lookup sz=" ++ show sz ++ " h=" ++ show h ++ " b=" ++ show b + go b + + where + !h = hash k + + go !b = {-# SCC "lookup/go" #-} do + idx <- forwardSearch2 hashes b sz h emptyMarker + debug $ "forwardSearch2 returned " ++ show idx + h0 <- U.readArray hashes idx + debug $ "h0 was " ++ show h0 + + if recordIsEmpty h0 + then return Nothing + else do + k' <- readArray keys idx + if k == k' + then do + debug $ "value found at " ++ show idx + v <- readArray values idx + return $! Just v + else go $! idx + 1 +{-# INLINE lookup #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:insert". +insert :: (Eq k, Hashable k) => + (HashTable s k v) + -> k + -> v + -> ST s () +insert htRef !k !v = do + ht <- readRef htRef + !ht' <- insert' ht + writeRef htRef ht' + + where + insert' ht = do + debug "insert': calling delete'" + b <- delete' ht False k h + + debug $ "insert': writing h=" ++ show h ++ " b=" ++ show b + U.writeArray hashes b h + writeArray keys b k + writeArray values b v + + checkOverflow ht + + 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#v: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 + where + go !i !seed | i >= sz = return seed + | otherwise = do + h <- U.readArray hashes i + if recordIsEmpty h || recordIsDeleted h + then go (i+1) seed + else do + k <- readArray keys i + v <- readArray values i + !seed' <- f seed (k, v) + go (i+1) seed' + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v: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 + where + go !i | i >= sz = return () + | 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 + _ <- f (k, v) + go (i+1) + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v: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 + let k = fromIntegral ld / sz + return $ constOverhead / sz + overhead k + where + sz = fromIntegral sz' + -- Change these if you change the representation + constOverhead = 10 + overhead k = 3 / k - 2 + + +------------------------------ +-- Private functions follow -- +------------------------------ + + +------------------------------------------------------------------------------ +{-# INLINE insertRecord #-} +insertRecord :: Int + -> U.IntArray s + -> MutableArray s k + -> MutableArray s v + -> Int + -> k + -> v + -> ST s () +insertRecord !sz !hashes !keys !values !h !key !value = do + let !b = whichBucket h sz + debug $ "insertRecord sz=" ++ show sz ++ "h=" ++ show h ++ " b=" ++ show b + probe b + + where + probe !i = {-# SCC "insertRecord/probe" #-} do + !idx <- forwardSearch2 hashes i sz emptyMarker deletedMarker + debug $ "forwardSearch2 returned " ++ show idx + U.writeArray hashes idx h + writeArray keys idx key + writeArray values idx value + + +------------------------------------------------------------------------------ +checkOverflow :: (Eq k, Hashable k) => + (HashTable_ s k v) + -> ST s (HashTable_ s k v) +checkOverflow ht@(HashTable sz ldRef _ _ _) = do + !ld <- U.readArray ldRef 0 + let !ld' = ld + 1 + U.writeArray ldRef 0 ld' + + if fromIntegral ld / fromIntegral sz > maxLoad + then growTable ht + else return ht + + +------------------------------------------------------------------------------ +growTable :: Hashable k => HashTable_ s k v -> ST s (HashTable_ s k v) +growTable (HashTable sz loadRef hashes keys values) = do + let !sz' = bumpSize sz + ht' <- newSizedReal sz' + let (HashTable _ loadRef' newHashes newKeys newValues) = ht' + U.readArray loadRef 0 >>= U.writeArray loadRef' 0 + rehash sz' newHashes newKeys newValues + return ht' + + where + rehash sz' newHashes newKeys newValues = go 0 + where + go !i | i >= sz = return () + | otherwise = {-# SCC "growTable/rehash" #-} do + h0 <- U.readArray hashes i + when (not (recordIsEmpty h0 || recordIsDeleted h0)) $ do + k <- readArray keys i + v <- readArray values i + insertRecord sz' newHashes newKeys newValues + (hash k) k v + go $ i+1 + + +------------------------------------------------------------------------------ +-- Returns the slot in the array where it would be safe to write the given key. +delete' :: (Hashable k, Eq k) => + (HashTable_ s k v) + -> Bool + -> k + -> Int + -> ST s Int +delete' (HashTable sz loadRef hashes keys values) clearOut k h = do + let !b = whichBucket h sz + debug $ "delete': sz=" ++ show sz ++ " h=" ++ show h + ++ " b=" ++ show b + (found,b') <- go Nothing b + when found $ do + !ld <- U.readArray loadRef 0 + let !ld' = ld - 1 + U.writeArray loadRef 0 ld' + return b' + + where + delPlace !fp !b = maybe (Just b) (const fp) fp + choosePlace !fp !b = fromMaybe b fp + samePlace !fp !b = maybe (True) (== b) fp + + go !fp !b = do + debug $ "go: fp=" ++ show fp ++ " b=" ++ show b + !idx <- forwardSearch3 hashes b sz h emptyMarker deletedMarker + debug $ "forwardSearch3 returned " ++ show idx + h0 <- U.readArray hashes idx + debug $ "h0 was " ++ show h0 + + if recordIsEmpty h0 + then do + let pl = choosePlace fp idx + debug $ "empty, returning " ++ show pl + return (False, pl) + else + if recordIsDeleted h0 + then do + let pl = delPlace fp idx + debug $ "deleted, cont with pl=" ++ show pl + go pl $ idx + 1 + else + if h == h0 + then do + k' <- readArray keys idx + if k == k' + then do + debug $ "found at " ++ show idx + debug $ "clearout=" ++ show clearOut + debug $ "sp? " ++ show (samePlace fp idx) + -- "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 fp idx)) $ do + U.writeArray hashes idx 1 + writeArray keys idx undefined + writeArray values idx undefined + return (True, choosePlace fp idx) + else go fp $ idx + 1 + else go fp $ idx + 1 + +------------------------------------------------------------------------------ +maxLoad :: Double +maxLoad = 0.82 + + +------------------------------------------------------------------------------ +emptyMarker :: Int +emptyMarker = 0 + +------------------------------------------------------------------------------ +deletedMarker :: Int +deletedMarker = 1 + + +------------------------------------------------------------------------------ +{-# INLINE recordIsEmpty #-} +recordIsEmpty :: Int -> Bool +recordIsEmpty = (== emptyMarker) + + +------------------------------------------------------------------------------ +{-# INLINE recordIsDeleted #-} +recordIsDeleted :: Int -> Bool +recordIsDeleted = (== deletedMarker) + + +------------------------------------------------------------------------------ +{-# INLINE hash #-} +hash :: (Hashable k) => k -> Int +hash k = out + where + !(I# h#) = H.hash k + + !m# = maskw# h# 0# `or#` maskw# h# 1# + !nm# = not# m# + + !r# = ((int2Word# 2#) `and#` m#) `or#` (int2Word# h# `and#` nm#) + !out = I# (word2Int# r#) + + +------------------------------------------------------------------------------ +newRef :: HashTable_ s k v -> ST s (HashTable s k v) +newRef = liftM HT . newSTRef +{-# INLINE newRef #-} + +writeRef :: HashTable s k v -> HashTable_ s k v -> ST s () +writeRef (HT ref) ht = writeSTRef ref ht +{-# INLINE writeRef #-} + +readRef :: HashTable s k v -> ST s (HashTable_ s k v) +readRef (HT ref) = readSTRef ref +{-# INLINE readRef #-} + + +------------------------------------------------------------------------------ +{-# INLINE debug #-} +debug :: String -> ST s () +--debug s = unsafeIOToST (putStrLn s) +debug _ = return () diff --git a/src/Data/HashTable/ST/Cuckoo.hs b/src/Data/HashTable/ST/Cuckoo.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/ST/Cuckoo.hs @@ -0,0 +1,671 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} + +{-| + +A hash table using the cuckoo strategy. (See +). Use this hash table if you... + + * 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". + + * don't care that a table resize might pause for a long time to rehash all + of the key-value mappings. + + +/Details:/ + +The basic idea of cuckoo hashing, first introduced by Pagh and Rodler in 2001, +is to use /d/ hash functions instead of only one; in this implementation d=2 +and the strategy we use is to split up a flat array of slots into @k@ buckets, +each cache-line-sized: + +@ ++--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+----------+ +|x0|x1|x2|x3|x4|x5|x6|x7|y0|y1|y2|y3|y4|y5|y6|y7|z0|z1|z2........| ++--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+--+----------+ +[ ^^^ bucket 0 ^^^ ][ ^^^ bucket 1 ^^^ ]... +@ + +There are actually three parallel arrays: one unboxed array of 'Int's for hash +codes, one boxed array for keys, and one boxed array for values. When looking +up a key-value mapping, we hash the key using two hash functions and look in +both buckets in the hash code array for the key. Each bucket is cache-line +sized, with its keys in no particular order. Because the hash code array is +unboxed, we can search it for the key using a highly-efficient branchless +strategy in C code, using SSE instructions if available. + +On insert, if both buckets are full, we knock out a randomly-selected entry +from one of the buckets (using a random walk ensures that \"key cycles\" are +broken with maximum probability) and try to repeat the insert procedure. This +process may not succeed; if all items have not successfully found a home after +some number of tries, we give up and rehash all of the elements into a larger +table. + +/Space overhead: experimental results/ + +The implementation of cuckoo hash given here is almost as fast for lookups as +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. + + +/References:/ + + * A. Pagh and F. Rodler. Cuckoo hashing. In /Proceedings of the 9th + Annual European Symposium on Algorithms/, pp. 121-133, 2001. +-} + + +module Data.HashTable.ST.Cuckoo + ( HashTable + , new + , newSized + , delete + , lookup + , insert + , mapM_ + , foldM + ) where + + +------------------------------------------------------------------------------ +import Control.Monad hiding (foldM, mapM_) +import Control.Monad.ST +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 qualified Data.HashTable.Class as C +import Data.HashTable.Internal.CheapPseudoRandomBitStream +import Data.HashTable.Internal.CacheLine +import qualified Data.HashTable.Internal.IntArray as U +import Data.HashTable.Internal.Utils + +#ifdef DEBUG +import System.IO +#endif + + +------------------------------------------------------------------------------ +-- | A cuckoo hash table. +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) + , _maxAttempts :: {-# UNPACK #-} !Int + } + + +------------------------------------------------------------------------------ +instance C.HashTable HashTable where + new = new + newSized = newSized + insert = insert + delete = delete + lookup = lookup + foldM = foldM + mapM_ = mapM_ + computeOverhead = computeOverhead + + +------------------------------------------------------------------------------ +instance Show (HashTable s k v) where + show _ = "" + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:new". +new :: ST s (HashTable s k v) +new = newSizedReal 2 >>= newRef +{-# INLINE new #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:newSized". +newSized :: Int -> ST s (HashTable s k v) +newSized n = do + let n' = (n + numWordsInCacheLine - 1) `div` numWordsInCacheLine + let k = nextBestPrime $ ceiling $ fromIntegral n' / maxLoad + newSizedReal k >>= newRef +{-# INLINE newSized #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v: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 + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v: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 + + return $! fromIntegral (oh::Int) / fromIntegral nFilled + + where + totSz = numWordsInCacheLine * sz + + f !a _ = return $! a+1 + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:delete". +delete :: (Hashable k, Eq k) => + HashTable s k v + -> k + -> ST s () +delete htRef k = readRef htRef >>= go + where + go ht@(HashTable sz _ _ _ _ _) = do + _ <- delete' ht False k b1 b2 h1 h2 + return () + + where + h1 = hash1 k + h2 = hash2 k + + b1 = whichLine h1 sz + b2 = whichLine h2 sz + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:lookup". +lookup :: (Eq k, Hashable k) => + HashTable s k v + -> k + -> ST s (Maybe v) +lookup htRef k = do + ht <- readRef htRef + lookup' ht k +{-# INLINE lookup #-} + + +------------------------------------------------------------------------------ +lookup' :: (Eq k, Hashable k) => + HashTable_ s k v + -> k + -> ST s (Maybe v) +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 + + if idx1 >= 0 + then do + v <- readArray values idx1 + return $! Just v + else do + idx2 <- searchOne keys hashes k b2 h2 + if idx2 >= 0 + then do + v <- readArray values idx2 + return $! Just v + else + return Nothing + + where + h1 = hash1 k + h2 = hash2 k + + b1 = whichLine h1 sz + b2 = whichLine h2 sz +{-# INLINE lookup' #-} + + +------------------------------------------------------------------------------ +searchOne :: (Eq k) => + MutableArray s k + -> U.IntArray s + -> k + -> Int + -> Int + -> ST s Int +searchOne !keys !hashes !k = go + where + go !b !h = do + idx <- cacheLineSearch hashes b h + + case idx of + -1 -> return (-1) + _ -> do + k' <- readArray keys idx + if k == k' + then return idx + else do + let !idx' = idx + 1 + if isCacheLineAligned idx' + then return (-1) + else go idx' h +{-# INLINE searchOne #-} + + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:foldM". +foldM :: (a -> (k,v) -> ST s a) + -> a + -> HashTable s k v + -> ST s a +foldM f seed0 htRef = readRef htRef >>= foldMWork f seed0 +{-# INLINE foldM #-} + + +------------------------------------------------------------------------------ +foldMWork :: (a -> (k,v) -> ST s a) + -> a + -> HashTable_ s k v + -> ST s a +foldMWork f seed0 (HashTable sz _ hashes keys values _) = go 0 seed0 + where + totSz = numWordsInCacheLine * sz + + go !i !seed | i >= totSz = return seed + | otherwise = do + h <- U.readArray hashes i + if h /= emptyMarker + then do + k <- readArray keys i + v <- readArray values i + !seed' <- f seed (k,v) + go (i+1) seed' + + else + go (i+1) seed +{-# INLINE foldMWork #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:mapM_". +mapM_ :: ((k,v) -> ST s a) + -> HashTable s k v + -> ST s () +mapM_ f htRef = readRef htRef >>= mapMWork f +{-# INLINE mapM_ #-} + + +------------------------------------------------------------------------------ +mapMWork :: ((k,v) -> ST s a) + -> HashTable_ s k v + -> ST s () +mapMWork f (HashTable sz _ hashes keys values _) = go 0 + where + totSz = numWordsInCacheLine * sz + + go !i | i >= totSz = return () + | otherwise = do + h <- U.readArray hashes i + if h /= emptyMarker + then do + k <- readArray keys i + v <- readArray values i + _ <- f (k,v) + go (i+1) + else + go (i+1) +{-# INLINE mapMWork #-} + + +--------------------------------- +-- Private declarations follow -- +--------------------------------- + + +------------------------------------------------------------------------------ +newSizedReal :: Int -> ST s (HashTable_ s k v) +newSizedReal nbuckets = do + let !ntotal = nbuckets * numWordsInCacheLine + let !maxAttempts = 12 + (log2 $ toEnum nbuckets) + + debug $ "creating cuckoo hash table with " ++ + show nbuckets ++ " buckets having " ++ + show ntotal ++ " total slots" + + rng <- newBitStream + hashes <- U.newArray ntotal + keys <- newArray ntotal undefined + values <- newArray ntotal undefined + + return $! HashTable nbuckets rng hashes keys values maxAttempts + + +insert' :: (Eq k, Hashable k) => + HashTable_ s k v + -> k + -> v + -> ST s (HashTable_ s k v) +insert' ht k v = do + debug "insert': begin" + mbX <- updateOrFail ht k v + z <- maybe (return ht) + (\(k',v') -> grow ht k' v') + mbX + debug "insert': end" + return z +{-# INLINE insert #-} + + +------------------------------------------------------------------------------ +updateOrFail :: (Eq k, Hashable k) => + HashTable_ s k v + -> k + -> v + -> ST s (Maybe (k,v)) +updateOrFail ht@(HashTable sz _ hashes keys values _) k v = do + debug $ "updateOrFail: begin: sz = " ++ show sz + debug $ " h1=" ++ show h1 ++ ", h2=" ++ show h2 + ++ ", b1=" ++ show b1 ++ ", b2=" ++ show b2 + (didx, hashCode) <- delete' ht True k b1 b2 h1 h2 + + debug $ "delete' returned (" ++ show didx ++ "," ++ show hashCode ++ ")" + + if didx >= 0 + then do + U.writeArray hashes didx hashCode + writeArray keys didx k + writeArray values didx v + return Nothing + else cuckoo + + where + h1 = hash1 k + h2 = hash2 k + + b1 = whichLine h1 sz + b2 = whichLine h2 sz + + cuckoo = do + debug "cuckoo: calling cuckooOrFail" + result <- cuckooOrFail ht h1 h2 b1 b2 k v + debug $ "cuckoo: cuckooOrFail returned " ++ + (if isJust result then "Just _" else "Nothing") + + -- if cuckoo failed we need to grow the table. + maybe (return Nothing) + (return . Just) + result +{-# INLINE updateOrFail #-} + + +------------------------------------------------------------------------------ +-- Returns either (-1,-1) (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) => + HashTable_ s k v -- ^ hash table + -> Bool -- ^ are we updating? + -> k -- ^ key + -> Int -- ^ cache line start address 1 + -> Int -- ^ cache line start address 2 + -> Int -- ^ hash1 + -> Int -- ^ hash2 + -> ST s (Int, Int) +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 + if idx1 < 0 + then do + idx2 <- searchOne keys hashes k b2 h2 + if idx2 < 0 + then if updating + then do + debug $ "delete': looking for empty element" + -- if we're updating, we look for an empty element + idxE1 <- cacheLineSearch hashes b1 emptyMarker + debug $ "delete': idxE1 was " ++ show idxE1 + if idxE1 >= 0 + then return (idxE1, h1) + 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 + + where + deleteIt !idx !h = do + if not updating + then do + U.writeArray hashes idx emptyMarker + writeArray keys idx undefined + writeArray values idx undefined + else return () + return $! (idx, h) +{-# INLINE delete' #-} + + +------------------------------------------------------------------------------ +cuckooOrFail :: (Hashable k, Eq k) => + HashTable_ s k v -- ^ hash table + -> Int -- ^ hash code 1 + -> Int -- ^ hash code 2 + -> Int -- ^ cache line 1 + -> Int -- ^ cache line 2 + -> k -- ^ key + -> v -- ^ value + -> ST s (Maybe (k,v)) +cuckooOrFail (HashTable sz rng hashes keys values maxAttempts0) + !h1_0 !h2_0 !b1_0 !b2_0 !k0 !v0 = do + -- at this point we know: + -- + -- * there is no empty slot in either cache line + -- + -- * the key doesn't already exist in the table + -- + -- next things to do: + -- + -- * decide which element to bump + -- + -- * read that element, and write (k,v) in there + -- + -- * attempt to write the bumped element into its other cache slot + -- + -- * if it fails, recurse. + + debug $ "cuckooOrFail h1_0=" ++ show h1_0 + ++ " h2_0=" ++ show h2_0 + ++ " b1_0=" ++ show b1_0 + ++ " b2_0=" ++ show b2_0 + + !lineChoice <- getNextBit rng + + debug $ "chose line " ++ show lineChoice + let (!b, !h) = if lineChoice == 0 then (b1_0, h1_0) else (b2_0, h2_0) + go b h k0 v0 maxAttempts0 + + + where + randomIdx !b = do + !z <- getNBits cacheLineIntBits rng + return $! b + z + + bumpIdx !idx !h !k !v = do + debug $ "bumpIdx idx=" ++ show idx ++ " h=" ++ show h + !h' <- U.readArray hashes idx + debug $ "bumpIdx: h' was " ++ show h' + !k' <- readArray keys idx + v' <- readArray values idx + U.writeArray hashes idx h + writeArray keys idx k + writeArray values idx v + debug $ "bumped key with h'=" ++ show h' + return $! (h', k', v') + + otherHash h k = if h2 == h then h1 else h2 + where + h1 = hash1 k + h2 = hash2 k + + tryWrite !b !h k v maxAttempts = do + debug $ "tryWrite b=" ++ show b ++ " h=" ++ show h + idx <- cacheLineSearch hashes b emptyMarker + debug $ "cacheLineSearch returned " ++ show idx + + if idx >= 0 + then do + U.writeArray hashes idx h + writeArray keys idx k + writeArray values idx v + return Nothing + else go b h k v $! maxAttempts - 1 + + 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' + let !b' = whichLine h' sz + + tryWrite b' h' k' v' maxAttempts + + +------------------------------------------------------------------------------ +grow :: (Eq k, Hashable k) => + HashTable_ s k v + -> k + -> v + -> ST s (HashTable_ s k v) +grow (HashTable sz _ hashes keys values _) k0 v0 = do + newHt <- grow' $! bumpSize sz + + mbR <- updateOrFail newHt k0 v0 + maybe (return newHt) + (\_ -> grow' $ bumpSize $ _size newHt) + mbR + + where + grow' newSz = do + debug $ "growing table, oldsz = " ++ show sz ++ + ", newsz=" ++ show newSz + newHt <- newSizedReal newSz + rehash newSz newHt + + + rehash !newSz !newHt = go 0 + where + totSz = numWordsInCacheLine * sz + + go !i | i >= totSz = return newHt + | otherwise = do + h <- U.readArray hashes i + if (h /= emptyMarker) + then do + k <- readArray keys i + v <- readArray values i + + mbR <- updateOrFail newHt k v + maybe (go $ i + 1) + (\_ -> grow' $ bumpSize newSz) + mbR + else go $ i + 1 + + +------------------------------------------------------------------------------ +hashPrime :: Int +hashPrime = if wordSize == 32 then hashPrime32 else hashPrime64 + where + hashPrime32 = 0xedf2a025 + hashPrime64 = 0x3971ca9c8b3722e9 + + +------------------------------------------------------------------------------ +hash1 :: Hashable k => k -> Int +hash1 = hashF H.hash +{-# INLINE hash1 #-} + + +hash2 :: Hashable k => k -> Int +hash2 = hashF (H.hashWithSalt hashPrime) +{-# INLINE hash2 #-} + + +hashF :: (k -> Int) -> k -> Int +hashF f k = out + where + !(I# h#) = f k + + !m# = maskw# h# 0# + !nm# = not# m# + + !r# = ((int2Word# 1#) `and#` m#) `or#` (int2Word# h# `and#` nm#) + !out = I# (word2Int# r#) +{-# INLINE hashF #-} + + +------------------------------------------------------------------------------ +emptyMarker :: Int +emptyMarker = 0 + + +------------------------------------------------------------------------------ +maxLoad :: Double +maxLoad = 0.88 + + +------------------------------------------------------------------------------ +debug :: String -> ST s () +#ifdef DEBUG +debug s = unsafeIOToST (putStrLn s >> hFlush stdout) +#else +debug _ = return () +#endif +{-# INLINE debug #-} + + +------------------------------------------------------------------------------ +whichLine :: Int -> Int -> Int +whichLine !h !sz = whichBucket h sz `iShiftL` cacheLineIntBits +{-# INLINE whichLine #-} + + +------------------------------------------------------------------------------ +newRef :: HashTable_ s k v -> ST s (HashTable s k v) +newRef = liftM HT . newSTRef +{-# INLINE newRef #-} + +writeRef :: HashTable s k v -> HashTable_ s k v -> ST s () +writeRef (HT ref) ht = writeSTRef ref ht +{-# INLINE writeRef #-} + +readRef :: HashTable s k v -> ST s (HashTable_ s k v) +readRef (HT ref) = readSTRef ref +{-# INLINE readRef #-} + diff --git a/src/Data/HashTable/ST/Linear.hs b/src/Data/HashTable/ST/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashTable/ST/Linear.hs @@ -0,0 +1,464 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} + +{-| 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) + + * have a soft real-time or interactive application for which the risk of + introducing a long pause on insert while all of the keys are rehashed is + unacceptable. + + +/Details:/ + +Linear hashing allows for the expansion of the hash table one slot at a time, +by moving a \"split\" pointer across an array of pointers to buckets. The +number of buckets is always a power of two, and the bucket to look in is +defined as: + +@ +bucket(level,key) = hash(key) mod (2^level) +@ + +The \"split pointer\" controls the expansion of the hash table. If the hash +table is at level @k@ (i.e. @2^k@ buckets have been allocated), we first +calculate @b=bucket(level-1,key)@. If @b < splitptr@, the destination bucket is +calculated as @b'=bucket(level,key)@, otherwise the original value @b@ is used. + +The split pointer is incremented once an insert causes some bucket to become +fuller than some predetermined threshold; the bucket at the split pointer +(*not* the bucket which triggered the split!) is then rehashed, and half of its +keys can be expected to be rehashed into the upper half of the table. + +When the split pointer reaches the middle of the bucket array, the size of the +bucket array is doubled, the level increases, and the split pointer is reset to +zero. + +Linear hashing, although not quite as fast for inserts or lookups as the +implementation of linear probing included in this package, is well suited for +interactive applications because it has much better worst case behaviour on +inserts. Other hash table implementations can suffer from long pauses, because +it is occasionally necessary to rehash all of the keys when the table grows. +Linear hashing, on the other hand, only ever rehashes a bounded (effectively +constant) number of keys when an insert forces a bucket split. + +/Space overhead: experimental results/ + +In randomized testing (see @test\/compute-overhead\/ComputeOverhead.hs@ in the +source distribution), mean overhead is approximately 1.51 machine words per +key-value mapping with a very low standard deviation of about 0.06 words, 1.60 +words per mapping at the 95th percentile. + +/Unsafe tricks/ + +Then the @unsafe-tricks@ flag is on when this package is built (and it is on by +default), we use some unsafe tricks (namely 'unsafeCoerce#' and +'reallyUnsafePtrEquality#') to save indirections in this table. These +techniques rely on assumptions about the behaviour of the GHC runtime system +and, although they've been tested and should be safe under normal conditions, +are slightly dangerous. Caveat emptor. In particular, these techniques are +incompatible with HPC code coverage reports. + + +References: + + * W. Litwin. Linear hashing: a new tool for file and table addressing. In + /Proc. 6th International Conference on Very Large Data Bases, Volume 6/, + pp. 212-223, 1980. + + * P-A. Larson. Dynamic hash tables. /Communications of the ACM/ 31: + 446-457, 1988. +-} + +module Data.HashTable.ST.Linear + ( HashTable + , new + , newSized + , delete + , lookup + , insert + , mapM_ + , foldM + , computeOverhead + ) where + +------------------------------------------------------------------------------ +import Control.Monad hiding (mapM_, foldM) +import Control.Monad.ST +import Data.Bits +import Data.Hashable +import Data.STRef +import Prelude hiding (mapM_, lookup) +------------------------------------------------------------------------------ +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 Data.HashTable.Internal.Utils + +#ifdef DEBUG +import System.IO +#endif + + +------------------------------------------------------------------------------ +-- | A linear hash table. +newtype HashTable s k v = HT (STRef s (HashTable_ s k v)) + +data HashTable_ s k v = HashTable + { _level :: {-# UNPACK #-} !Int + , _splitptr :: {-# UNPACK #-} !Int + , _buckets :: {-# UNPACK #-} !(MutableArray s (Bucket s k v)) + } + + +------------------------------------------------------------------------------ +instance C.HashTable HashTable where + new = new + newSized = newSized + insert = insert + delete = delete + lookup = lookup + foldM = foldM + mapM_ = mapM_ + computeOverhead = computeOverhead + + +------------------------------------------------------------------------------ +instance Show (HashTable s k v) where + show _ = "" + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:new". +new :: ST s (HashTable s k v) +new = do + v <- Bucket.newBucketArray 2 + newRef $ HashTable 1 0 v + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:newSized". +newSized :: Int -> ST s (HashTable s k v) +newSized n = do + v <- Bucket.newBucketArray sz + newRef $ HashTable lvl 0 v + + where + k = ceiling (fromIntegral n * fillFactor / fromIntegral bucketSplitSize) + lvl = max 1 (fromEnum $ log2 k) + sz = power2 lvl + + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:delete". +delete :: (Hashable k, Eq k) => + (HashTable s k v) + -> k + -> ST s () +delete htRef !k = readRef htRef >>= work + where + work (HashTable lvl splitptr buckets) = do + let !h0 = hashKey lvl splitptr k + debug $ "delete: size=" ++ show (power2 lvl) ++ ", h0=" ++ show h0 + ++ "splitptr: " ++ show splitptr + delete' buckets h0 k +{-# INLINE delete #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:lookup". +lookup :: (Eq k, Hashable k) => (HashTable s k v) -> k -> ST s (Maybe v) +lookup htRef !k = readRef htRef >>= work + where + work (HashTable lvl splitptr buckets) = do + let h0 = hashKey lvl splitptr k + bucket <- readArray buckets h0 + Bucket.lookup bucket k +{-# INLINE lookup #-} + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:insert". +insert :: (Eq k, Hashable k) => + (HashTable s k v) + -> k + -> v + -> ST s () +insert htRef k v = do + ht' <- readRef htRef >>= work + writeRef htRef ht' + where + work ht@(HashTable lvl splitptr buckets) = do + let !h0 = hashKey lvl splitptr k + delete' buckets h0 k + bsz <- primitiveInsert' buckets h0 k v + + if checkOverflow bsz + then do + debug $ "insert: splitting" + h <- split ht + debug $ "insert: done splitting" + return h + else do + debug $ "insert: done" + return ht +{-# INLINE insert #-} + + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:mapM_". +mapM_ :: ((k,v) -> ST s b) -> HashTable s k v -> ST s () +mapM_ f htRef = readRef htRef >>= work + where + work (HashTable lvl _ buckets) = go 0 + where + !sz = power2 lvl + + go !i | i >= sz = return () + | otherwise = do + b <- readArray buckets i + Bucket.mapM_ f b + go $ i+1 + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v: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 lvl _ buckets) = go seed0 0 + where + !sz = power2 lvl + + go !seed !i | i >= sz = return seed + | otherwise = do + b <- readArray buckets i + !seed' <- Bucket.foldM f seed b + go seed' $ i+1 + + +------------------------------------------------------------------------------ +-- | See the documentation for this function in +-- "Data.HashTable.Class#v:computeOverhead". +computeOverhead :: HashTable s k v -> ST s Double +computeOverhead htRef = readRef htRef >>= work + where + work (HashTable lvl _ buckets) = do + (totElems, overhead) <- go 0 0 0 + + let n = fromIntegral totElems + let o = fromIntegral overhead + + return $ (fromIntegral sz + constOverhead + o) / n + + where + constOverhead = 5.0 + + !sz = power2 lvl + + go !nelems !overhead !i | i >= sz = return (nelems, overhead) + | otherwise = do + b <- readArray buckets i + (!n,!o) <- Bucket.nelemsAndOverheadInWords b + let !n' = n + nelems + let !o' = o + overhead + + go n' o' (i+1) + + +------------------------------ +-- Private functions follow -- +------------------------------ + +------------------------------------------------------------------------------ +delete' :: Eq k => + MutableArray s (Bucket s k v) + -> Int + -> k + -> ST s () +delete' buckets h0 k = do + bucket <- readArray buckets h0 + _ <- Bucket.delete bucket k + return () + + +------------------------------------------------------------------------------ +split :: (Hashable k) => + (HashTable_ s k v) + -> ST s (HashTable_ s k v) +split ht@(HashTable lvl splitptr buckets) = do + debug $ "split: start: nbuck=" ++ show (power2 lvl) + ++ ", splitptr=" ++ show splitptr + + -- grab bucket at splitPtr + oldBucket <- readArray buckets splitptr + + nelems <- Bucket.size oldBucket + let !bsz = max Bucket.newBucketSize $ + ceiling $ (0.625 :: Double) * fromIntegral nelems + + -- write an empty bucket there + dbucket1 <- Bucket.emptyWithSize bsz + writeArray buckets splitptr dbucket1 + + -- grow the buckets? + let lvl2 = power2 lvl + let lvl1 = power2 $ lvl-1 + + (!buckets',!lvl',!sp') <- + if splitptr+1 >= lvl1 + then do + debug $ "split: resizing bucket array" + let lvl3 = 2*lvl2 + b <- Bucket.expandBucketArray lvl3 lvl2 buckets + debug $ "split: resizing bucket array: done" + return (b,lvl+1,0) + else return (buckets,lvl,splitptr+1) + + let ht' = HashTable lvl' sp' buckets' + + -- make sure the other split bucket has enough room in it also + let splitOffs = splitptr + lvl1 + db2 <- readArray buckets' splitOffs + db2sz <- Bucket.size db2 + let db2sz' = db2sz + bsz + db2' <- Bucket.growBucketTo db2sz' db2 + debug $ "growing bucket at " ++ show splitOffs ++ " to size " + ++ show db2sz' + writeArray buckets' splitOffs db2' + + -- rehash old bucket + debug $ "split: rehashing bucket" + let f = uncurry $ primitiveInsert ht' + forceSameType f (uncurry $ primitiveInsert ht) + + Bucket.mapM_ f oldBucket + debug $ "split: done" + return ht' + + +------------------------------------------------------------------------------ +checkOverflow :: Int -> Bool +checkOverflow sz = sz > bucketSplitSize + + +------------------------------------------------------------------------------ +-- insert w/o splitting +primitiveInsert :: (Hashable k) => + (HashTable_ s k v) + -> k + -> v + -> ST s Int +primitiveInsert (HashTable lvl splitptr buckets) k v = do + debug $ "primitiveInsert start: nbuckets=" ++ show (power2 lvl) + let h0 = hashKey lvl splitptr k + primitiveInsert' buckets h0 k v + + +------------------------------------------------------------------------------ +primitiveInsert' :: MutableArray s (Bucket s k v) + -> Int + -> k + -> v + -> ST s Int +primitiveInsert' buckets !h0 !k !v = do + debug $ "primitiveInsert': bucket number=" ++ show h0 + bucket <- readArray buckets h0 + debug $ "primitiveInsert': snoccing bucket" + (!hw,m) <- Bucket.snoc bucket k v + debug $ "primitiveInsert': bucket snoc'd" + maybe (return ()) + (writeArray buckets h0) + m + return hw + + + + +------------------------------------------------------------------------------ +fillFactor :: Double +fillFactor = 1.3 + + +------------------------------------------------------------------------------ +bucketSplitSize :: Int +bucketSplitSize = Bucket.bucketSplitSize + + +------------------------------------------------------------------------------ +{-# INLINE power2 #-} +power2 :: Int -> Int +power2 i = 1 `iShiftL` i + + +------------------------------------------------------------------------------ +{-# INLINE hashKey #-} +hashKey :: (Hashable k) => Int -> Int -> k -> Int +hashKey !lvl !splitptr !k = h1 + where + !h0 = hashAtLvl (lvl-1) k + !h1 = if (h0 < splitptr) + then hashAtLvl lvl k + else h0 + + +------------------------------------------------------------------------------ +{-# INLINE hashAtLvl #-} +hashAtLvl :: (Hashable k) => Int -> k -> Int +hashAtLvl !lvl !k = h + where + !h = hashcode .&. mask + !hashcode = hash k + !mask = power2 lvl - 1 + + +------------------------------------------------------------------------------ +newRef :: HashTable_ s k v -> ST s (HashTable s k v) +newRef = liftM HT . newSTRef + +writeRef :: HashTable s k v -> HashTable_ s k v -> ST s () +writeRef (HT ref) ht = writeSTRef ref ht + +readRef :: HashTable s k v -> ST s (HashTable_ s k v) +readRef (HT ref) = readSTRef ref + + +------------------------------------------------------------------------------ +{-# INLINE debug #-} +debug :: String -> ST s () + +#ifdef DEBUG +debug s = unsafeIOToST $ do + putStrLn s + hFlush stdout +#else +#ifdef TESTSUITE +debug !s = do + let !_ = length s + return $! () +#else +debug _ = return () +#endif +#endif + diff --git a/test/compute-overhead/ComputeOverhead.hs b/test/compute-overhead/ComputeOverhead.hs new file mode 100644 --- /dev/null +++ b/test/compute-overhead/ComputeOverhead.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} + +module Main where + +import qualified Data.HashTable.Class as C +import Data.HashTable.IO +import Data.HashTable.Test.Common +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as VM +import Statistics.Quantile (continuousBy, cadpw) +import Statistics.Sample +import System.Environment +import System.Random.MWC + + +overhead :: C.HashTable h => + FixedTableType h -> + GenIO -> + IO Double +overhead dummy rng = do + size <- uniformR (1000,50000) rng + !v <- replicateM' size $ uniform rng + let _ = v :: [(Int,Int)] + + !ht <- fromList v + forceType dummy ht + + x <- computeOverhead ht + return x + + where + replicateM' :: Int -> IO a -> IO [a] + replicateM' !sz f = go sz [] + where + go !i !l | i == 0 = return l + | otherwise = do + !x <- f + go (i-1) (x:l) + + +-- Returns mean / stddev +runTrials :: C.HashTable h => + FixedTableType h + -> GenIO + -> Int + -> IO (Double, Double, Double, Double) +runTrials dummy rng ntrials = do + sample <- rep ntrials $ overhead dummy rng + + let (m, v) = meanVarianceUnb sample + return (m, sqrt v, p95 sample, pMax sample) + where + p95 sample = continuousBy cadpw 19 20 sample + + pMax sample = V.foldl' max (-1) sample + + rep !n !f = do + mv <- VM.new n + go mv + + where + go !mv = go' 0 + where + go' !i | i >= n = V.unsafeFreeze mv + | otherwise = do + !d <- f + VM.unsafeWrite mv i d + go' $ i+1 + + +main :: IO () +main = do + rng <- do + args <- getArgs + if null args + then withSystemRandom (\x -> (return x) :: IO GenIO) + else initialize $ V.fromList [read $ head args] + + runTrials dummyLinearTable rng nTrials >>= report "linear hash table" + runTrials dummyBasicTable rng nTrials >>= report "basic hash table" + runTrials dummyCuckooTable rng nTrials >>= report "cuckoo hash table" + + where + nTrials = 200 + + report name md = putStrLn msg + where msg = concat [ "\n(Mean,StdDev,95%,Max) for overhead of " + , name + , " (" + , show nTrials + , " trials): " + , show md + , "\n" ] + + dummyBasicTable = dummyTable + :: forall k v . BasicHashTable k v + + dummyLinearTable = dummyTable + :: forall k v . LinearHashTable k v + + dummyCuckooTable = dummyTable + :: forall k v . CuckooHashTable k v + diff --git a/test/hashtables-test.cabal b/test/hashtables-test.cabal new file mode 100644 --- /dev/null +++ b/test/hashtables-test.cabal @@ -0,0 +1,129 @@ +Name: hashtables-test +Version: 0.1 +Author: Gregory Collins +Maintainer: greg@gregorycollins.net +Copyright: (c) 2011, Google, Inc. +Category: Data +Build-type: Simple +Cabal-version: >= 1.8 + +------------------------------------------------------------------------------ +Flag debug + Description: if on, spew debugging output to stdout + Default: False + + +Flag unsafe-tricks + Description: turn on unsafe GHC tricks + Default: False + + +Flag bounds-checking + 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 + 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 + + 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 && <2, + mwc-random == 0.8.*, + primitive, + QuickCheck >= 2.3.0.2, + test-framework >= 0.3.1 && <0.4, + test-framework-quickcheck2 >= 0.2.6 && < 0.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 + + ghc-prof-options: -prof -auto-all + + if flag(portable) + cpp-options: -DNO_C_SEARCH + + 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 && <2, + mwc-random == 0.8.*, + QuickCheck >= 2.3.0.2, + test-framework >= 0.3.1 && <0.4, + test-framework-quickcheck2 >= 0.2.6 && < 0.3, + statistics == 0.8.*, + primitive, + vector >= 0.7 + + 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 + diff --git a/test/runTestsAndCoverage.sh b/test/runTestsAndCoverage.sh new file mode 100644 --- /dev/null +++ b/test/runTestsAndCoverage.sh @@ -0,0 +1,46 @@ +#!/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 < String -> FixedTableType h -> Test +data SomeTest = SomeTest HashTest + + +------------------------------------------------------------------------------ +assertEq :: (Eq a, Show a) => + String -> a -> a -> PropertyM IO () +assertEq s expected got = + when (expected /= got) $ do + fail $ s ++ ": expected '" ++ show expected ++ "', got '" + ++ show got ++ "'" + + +------------------------------------------------------------------------------ +forceType :: forall m h k1 k2 v1 v2 . (Monad m, C.HashTable h) => + IOHashTable h k1 v1 -> IOHashTable h k2 v2 -> m () +forceType _ _ = return () + + +------------------------------------------------------------------------------ +dummyTable :: forall k v h . C.HashTable h => IOHashTable h k v +dummyTable = undefined + + +------------------------------------------------------------------------------ +tests :: C.HashTable h => String -> FixedTableType h -> Test +tests prefix dummyArg = testGroup prefix $ map f ts + where + f (SomeTest ht) = ht prefix dummyArg + + ts = [ SomeTest testFromListToList + , SomeTest testInsert + , SomeTest testInsert2 + , SomeTest testNewAndInsert + , SomeTest testGrowTable + , SomeTest testDelete + ] + + +------------------------------------------------------------------------------ +testFromListToList :: HashTest +testFromListToList prefix dummyArg = + testProperty (prefix ++ "/fromListToList") $ + monadicIO $ do + rng <- initializeRNG + forAllM arbitrary $ prop rng + + where + prop :: GenIO -> [(Int, Int)] -> PropertyM IO () + prop rng origL = do + let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL + ht <- run $ fromList l + l' <- run $ toList ht + assertEq "fromList . toList == id" (sort l) (sort l') + forceType dummyArg ht + + +------------------------------------------------------------------------------ +testInsert :: HashTest +testInsert prefix dummyArg = + testProperty (prefix ++ "/insert") $ + monadicIO $ do + rng <- initializeRNG + forAllM arbitrary $ prop rng + + 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 + assert $ all (\t -> fst t /= k) l + + ht <- run $ fromList l + nothing <- run $ lookup ht k + assertEq ("lookup " ++ show k) Nothing nothing + + run $ insert ht k v + r <- run $ lookup ht k + assertEq ("lookup2 " ++ show k) (Just v) r + + forceType dummyArg ht + + +------------------------------------------------------------------------------ +testInsert2 :: HashTest +testInsert2 prefix dummyArg = + testProperty (prefix ++ "/insert2") $ + monadicIO $ do + rng <- initializeRNG + forAllM arbitrary $ prop rng + + 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 + ht <- run $ fromList l + + run $ insert ht k v + r <- run $ lookup ht k + assertEq ("lookup1 " ++ show k) (Just v) r + + run $ insert ht k v2 + r' <- run $ lookup ht k + assertEq ("lookup2 " ++ show k) (Just v2) r' + + forceType dummyArg ht + + +------------------------------------------------------------------------------ +testNewAndInsert :: HashTest +testNewAndInsert prefix dummyArg = + testProperty (prefix ++ "/newAndInsert") $ + monadicIO $ forAllM arbitrary prop + + where + prop :: (Int,Int,Int) -> PropertyM IO () + prop (k,v,v2) = do + ht <- run new + + nothing <- run $ lookup ht k + assertEq ("lookup " ++ show k) Nothing nothing + + run $ insert ht k v + r <- run $ lookup ht k + assertEq ("lookup2 " ++ show k) (Just v) r + + run $ insert ht k v2 + r' <- run $ lookup ht k + assertEq ("lookup3 " ++ show k) (Just v2) r' + + ctRef <- run $ newIORef (0::Int) + run $ mapM_ (const $ modifyIORef ctRef (+1)) ht + + ct <- run $ readIORef ctRef + assertEq "count = 1" 1 ct + + ct' <- run $ foldM (\i _ -> return $! i+1) (0::Int) ht + assertEq "count2 = 1" 1 ct' + + forceType dummyArg ht + + +------------------------------------------------------------------------------ +testGrowTable :: HashTest +testGrowTable prefix dummyArg = + testProperty (prefix ++ "/growTable") $ + monadicIO $ forAllM generator prop + + where + generator = choose (32,2048) + + go n = new >>= go' (0::Int) + where + go' !i !ht | i >= n = return ht + | otherwise = do + insert ht i i + go' (i+1) ht + + + f (!m,!s) (!k,!v) = return $! (max m k, v `seq` s+1) + + prop :: Int -> PropertyM IO () + prop n = do + ht <- run $ go n + i <- liftM head $ run $ sample' $ choose (0,n-1) + + v <- run $ lookup ht i + assertEq ("lookup " ++ show i) (Just i) v + + ct <- run $ foldM f (0::Int, 0::Int) ht + assertEq "max + count" (n-1,n) ct + forceType dummyArg ht + + +------------------------------------------------------------------------------ +testDelete :: HashTest +testDelete prefix dummyArg = + testProperty (prefix ++ "/delete") $ + monadicIO $ forAllM generator prop + + where + generator = choose (32,2048) + + go n = new >>= go' (0::Int) + where + go' !i !ht | i >= n = return ht + | otherwise = do + insert ht i i + + case i of + 3 -> do + delete ht 2 + delete ht 3 + insert ht 2 2 + + _ -> if i `mod` 2 == 0 + then do + delete ht i + insert ht i i + else return () + + go' (i+1) ht + + + f (!m,!s) (!k,!v) = return $! (max m k, v `seq` s+1) + + prop :: Int -> PropertyM IO () + prop n = do + ht <- run $ go n + + i <- liftM head $ run $ sample' $ choose (4,n-1) + v <- run $ lookup ht i + assertEq ("lookup " ++ show i) (Just i) v + + v3 <- run $ lookup ht 3 + assertEq ("lookup 3") Nothing v3 + + ct <- run $ foldM f (0::Int, 0::Int) ht + assertEq "max + count" (n-1,n-1) ct + forceType dummyArg ht + + +------------------------------------------------------------------------------ +initializeRNG :: PropertyM IO GenIO +initializeRNG = run $ withSystemRandom (return :: GenIO -> IO GenIO) + + +------------------------------------------------------------------------------ +dedupe :: (Ord k, Ord v, Eq k) => [(k,v)] -> [(k,v)] +dedupe l = go0 $ sort l + where + go0 [] = [] + go0 (x:xs) = go id x xs + + go !dl !lastOne [] = (dl . (lastOne:)) [] + + go !dl !lastOne@(!lx,_) ((x,v):xs) = + if lx == x + then go dl lastOne xs + else go (dl . (lastOne:)) (x,v) xs + + +------------------------------------------------------------------------------ +-- assumption: list is sorted. +remove :: (Ord k, Eq k) => k -> [(k,v)] -> [(k,v)] +remove m l = go id l + where + go !dl [] = dl [] + go !dl ll@((k,v):xs) = + case compare k m of + LT -> go (dl . ((k,v):)) xs + EQ -> go dl xs + GT -> dl ll + + +------------------------------------------------------------------------------ +shuffle :: GenIO -> Vector k -> Vector k +shuffle rng v = if V.null v then v else V.modify go v + where + !n = V.length v + + go mv = f (n-1) + where + -- note: inclusive + pickOne b = unsafeIOToST $ uniformR (0,b) rng + + swap = MV.unsafeSwap mv + + f 0 = return () + f !k = do + idx <- pickOne k + swap k idx + f (k-1) + diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs new file mode 100644 --- /dev/null +++ b/test/suite/TestSuite.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE RankNTypes #-} + +module Main where + +import Test.Framework (defaultMain) +------------------------------------------------------------------------------ +import qualified Data.HashTable.Test.Common as Common +import qualified Data.HashTable.ST.Basic as B +import qualified Data.HashTable.ST.Cuckoo as C +import qualified Data.HashTable.ST.Linear as L +import qualified Data.HashTable.IO as IO + + +------------------------------------------------------------------------------ +main :: IO () +main = defaultMain tests + where + dummyBasicTable = Common.dummyTable + :: forall k v . IO.IOHashTable (B.HashTable) k v + + dummyCuckooTable = Common.dummyTable + :: forall k v . IO.IOHashTable (C.HashTable) k v + + dummyLinearTable = Common.dummyTable + :: forall k v . IO.IOHashTable (L.HashTable) k v + + + basicTests = Common.tests "basic" dummyBasicTable + cuckooTests = Common.tests "cuckoo" dummyCuckooTable + linearTests = Common.tests "linear" dummyLinearTable + + tests = [basicTests, linearTests, cuckooTests]