hashtables (empty) → 1.0.0.0
raw patch · 24 files changed
+5235/−0 lines, 24 filesdep +basedep +ghc-primdep +hashablesetup-changed
Dependencies added: base, ghc-prim, hashable, primitive, vector
Files
- LICENSE +28/−0
- README.md +79/−0
- Setup.hs +2/−0
- cbits/cfuncs.c +471/−0
- haddock.sh +9/−0
- hashtables.cabal +191/−0
- src/Data/HashTable/Class.hs +115/−0
- src/Data/HashTable/IO.hs +217/−0
- src/Data/HashTable/Internal/Array.hs +45/−0
- src/Data/HashTable/Internal/CacheLine.hs +843/−0
- src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs +122/−0
- src/Data/HashTable/Internal/IntArray.hs +74/−0
- src/Data/HashTable/Internal/Linear/Bucket.hs +355/−0
- src/Data/HashTable/Internal/UnsafeTricks.hs +105/−0
- src/Data/HashTable/Internal/Utils.hs +301/−0
- src/Data/HashTable/ST/Basic.hs +506/−0
- src/Data/HashTable/ST/Cuckoo.hs +671/−0
- src/Data/HashTable/ST/Linear.hs +464/−0
- test/compute-overhead/ComputeOverhead.hs +104/−0
- test/hashtables-test.cabal +129/−0
- test/runTestsAndCoverage.sh +46/−0
- test/runTestsNoCoverage.sh +20/−0
- test/suite/Data/HashTable/Test/Common.hs +306/−0
- test/suite/TestSuite.hs +32/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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*.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/cfuncs.c view
@@ -0,0 +1,471 @@+#include <stdint.h>+++#if defined(USE_SSE_4_1)+#include <smmintrin.h>+#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);+}+
+ haddock.sh view
@@ -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 $@
+ hashtables.cabal view
@@ -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+ <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>), 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>, 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+ <https://github.com/gregorycollins/hashtables/issues>.++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+
+ src/Data/HashTable/Class.hs view
@@ -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 #-}
+ src/Data/HashTable/IO.hs view
@@ -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 #-}
+ src/Data/HashTable/Internal/Array.hs view
@@ -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
+ src/Data/HashTable/Internal/CacheLine.hs view
@@ -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
+ src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs view
@@ -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
+ src/Data/HashTable/Internal/IntArray.hs view
@@ -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
+ src/Data/HashTable/Internal/Linear/Bucket.hs view
@@ -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+
+ src/Data/HashTable/Internal/UnsafeTricks.hs view
@@ -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
+ src/Data/HashTable/Internal/Utils.hs view
@@ -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 #-}
+ src/Data/HashTable/ST/Basic.hs view
@@ -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 _ = "<HashTable>"+++------------------------------------------------------------------------------+-- | 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 ()
+ src/Data/HashTable/ST/Cuckoo.hs view
@@ -0,0 +1,671 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++{-|++A hash table using the cuckoo strategy. (See+<http://en.wikipedia.org/wiki/Cuckoo_hashing>). 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 _ = "<HashTable>"+++------------------------------------------------------------------------------+-- | 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 #-}+
+ src/Data/HashTable/ST/Linear.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE RankNTypes #-}++{-| An implementation of linear hash tables. (See+<http://en.wikipedia.org/wiki/Linear_hashing>). 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 _ = "<HashTable>"+++------------------------------------------------------------------------------+-- | 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+
+ test/compute-overhead/ComputeOverhead.hs view
@@ -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+
+ test/hashtables-test.cabal view
@@ -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+
+ test/runTestsAndCoverage.sh view
@@ -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 <<EOF+Testsuite executable not found, please run:+ cabal configure -ftest+then+ cabal build+EOF+ exit;+fi++./dist/build/testsuite/testsuite -j4 -a1000 $*++DIR=dist/hpc++rm -Rf $DIR+mkdir -p $DIR++EXCLUDES='Main+Data.HashTable.Test.Common+'++EXCL=""++for m in $EXCLUDES; do+ EXCL="$EXCL --exclude=$m"+done++hpc markup $EXCL --destdir=$DIR testsuite >/dev/null 2>&1++rm -f testsuite.tix++cat <<EOF++Test coverage report written to $DIR.+EOF
+ test/runTestsNoCoverage.sh view
@@ -0,0 +1,20 @@+#!/bin/sh++set -e++SUITE=./dist/build/testsuite/testsuite++export LC_ALL=C+export LANG=C++if [ ! -f $SUITE ]; then+ cat <<EOF+Testsuite executable not found, please run:+ cabal configure -ftest+then+ cabal build+EOF+ exit;+fi++./dist/build/testsuite/testsuite -j4 -a1000 $*
+ test/suite/Data/HashTable/Test/Common.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RankNTypes #-}++module Data.HashTable.Test.Common+ ( FixedTableType+ , dummyTable+ , forceType+ , tests+ ) where++------------------------------------------------------------------------------+import Control.Monad (liftM, when)+import Control.Monad.ST (unsafeIOToST)+import Data.IORef+import Data.List hiding ( insert+ , delete+ , lookup )+import Data.Vector (Vector)+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import Prelude hiding (lookup, mapM_)+import System.Random.MWC+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Test.QuickCheck.Monadic+------------------------------------------------------------------------------+import qualified Data.HashTable.Class as C+import Data.HashTable.IO+++------------------------------------------------------------------------------+type FixedTableType h = forall k v . IOHashTable h k v+type HashTest = forall h . C.HashTable h => 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)+
+ test/suite/TestSuite.hs view
@@ -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]