hashtables 1.0.1.8 → 1.4.2
raw patch · 34 files changed
Files
- LICENSE +1/−1
- benchmark/hashtable-benchmark.cabal +10/−10
- benchmark/src/Criterion/Collection/Internal/Types.hs +1/−1
- benchmark/src/Criterion/Collection/Sample.hs +10/−10
- benchmark/src/Data/Vector/Algorithms/Shuffle.hs +1/−1
- benchmark/src/Main.hs +16/−31
- cabal.project +8/−0
- cbits/Makefile +14/−0
- cbits/cfuncs.c +0/−517
- cbits/check.c +185/−0
- cbits/common.c +79/−0
- cbits/default.c +203/−0
- cbits/defs.h +35/−0
- cbits/sse-42-check.c +38/−0
- cbits/sse-42.c +172/−0
- changelog.md +191/−0
- hashtables.cabal +143/−43
- src/Data/HashTable/Class.hs +56/−3
- src/Data/HashTable/IO.hs +113/−34
- src/Data/HashTable/Internal/CacheLine.hs +807/−834
- src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs +21/−16
- src/Data/HashTable/Internal/IntArray.hs +76/−15
- src/Data/HashTable/Internal/Linear/Bucket.hs +108/−9
- src/Data/HashTable/Internal/UnsafeTricks.hs +3/−3
- src/Data/HashTable/Internal/Utils.hs +20/−17
- src/Data/HashTable/ST/Basic.hs +424/−166
- src/Data/HashTable/ST/Cuckoo.hs +268/−75
- src/Data/HashTable/ST/Linear.hs +102/−7
- test/compute-overhead/ComputeOverhead.hs +1/−0
- test/hashtables-test.cabal +22/−70
- test/runTestsAndCoverage.sh +0/−46
- test/runTestsNoCoverage.sh +0/−20
- test/suite/Data/HashTable/Test/Common.hs +104/−30
- test/suite/TestSuite.hs +2/−2
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2012, Google, Inc.+Copyright (c) 2011-2013, Google, Inc. All rights reserved.
benchmark/hashtable-benchmark.cabal view
@@ -15,26 +15,26 @@ Executable hashtable-benchmark main-is: Main.hs- hs-source-dirs: src ../src+ hs-source-dirs: src - build-depends: base == 4.*,+ build-depends: base >= 4 && <5, base16-bytestring == 0.1.*, bytestring >= 0.9 && <0.11, containers >= 0.4 && <0.6,- criterion >= 0.5 && <0.7,+ criterion >= 1.2 && <1.3, csv == 0.1.*,- deepseq >= 1.1 && <1.4,+ deepseq >= 1.1 && <1.5, filepath == 1.*,- hashable >= 1.1 && <2,- hashtables >= 1.0.1.3 && <1.1,+ hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,+ hashtables >= 1.2 && <1.3, mtl == 2.*,- mwc-random >= 0.8 && <0.13,+ mwc-random >= 0.8 && <0.14, primitive,- statistics >= 0.8 && <0.11,+ statistics >= 0.14 && <0.15, threads >= 0.4 && <0.6, unordered-containers >= 0.2 && <0.3,- vector >= 0.7 && <0.10,- vector-algorithms >= 0.5 && <0.6+ vector >= 0.7 && <0.13,+ vector-algorithms >= 0.5 && <0.8 if flag(chart) Build-depends: Chart == 0.14.*,
benchmark/src/Criterion/Collection/Internal/Types.hs view
@@ -38,7 +38,7 @@ ------------------------------------------------------------------------------ newtype WorkloadMonad a = WM (ReaderT GenIO IO a)- deriving (Monad, MonadIO)+ deriving (Functor, Applicative, Monad, MonadIO) ------------------------------------------------------------------------------
benchmark/src/Criterion/Collection/Sample.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RankNTypes #-} module Criterion.Collection.Sample ( Benchmark(..)@@ -16,23 +16,23 @@ import Control.DeepSeq import Control.Monad import Control.Monad.Trans-import Criterion hiding (Benchmark)+import Criterion hiding (Benchmark)+import Criterion.Collection.Internal.Types import Criterion.Config import Criterion.Environment-import Criterion.IO+import Criterion.IO.Printf import Criterion.Measurement import Criterion.Monad-import Criterion.Collection.Internal.Types import Data.IORef-import Data.List (foldl')+import Data.List (foldl') import Data.Monoid-import qualified Data.Vector as V-import qualified Data.Vector.Unboxed as U-import Statistics.Quantile (continuousBy, cadpw)+import qualified Data.Vector as V+import qualified Data.Vector.Unboxed as U+import Statistics.Quantile (cadpw, continuousBy) import Statistics.Sample-import System.Mem (performGC)+import System.Mem (performGC) import System.Random.MWC-import Text.Printf (printf)+import Text.Printf (printf) ------------------------------------------------------------------------------ data MeasurementMode = PerBatch | PerOperation
benchmark/src/Data/Vector/Algorithms/Shuffle.hs view
@@ -2,7 +2,7 @@ module Data.Vector.Algorithms.Shuffle ( shuffle ) where -import Control.Monad.ST (unsafeIOToST)+import Control.Monad.ST.Unsafe (unsafeIOToST) import Data.Vector (Vector) import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV
benchmark/src/Main.hs view
@@ -4,22 +4,21 @@ module Main (main) where -import Data.Bits-import qualified Data.ByteString as B-import Data.ByteString (ByteString)-import qualified Data.ByteString.Base16 as B16-import Data.Hashable-import Data.IORef import Control.DeepSeq import Control.Monad import Control.Monad.ST import Control.Monad.Trans-import qualified Data.HashMap.Strict as UC-import qualified Data.HashTable as H-import qualified Data.Map as Map-import qualified Data.HashTable.IO as IOH import Data.Benchmarks.UnorderedCollections.Distributions import Data.Benchmarks.UnorderedCollections.Types+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import Data.Hashable+import qualified Data.HashMap.Strict as UC+import qualified Data.HashTable.IO as IOH+import Data.IORef+import qualified Data.Map as Map import System.Environment import System.FilePath import System.Random.MWC@@ -30,6 +29,11 @@ ------------------------------------------------------------------------------+#if !MIN_VERSION_bytestring(0,10,0)+instance NFData ByteString+#endif++------------------------------------------------------------------------------ dataMap :: (Ord k, Eq k) => DataStructure (Operation k) dataMap = setupData Map.empty f where@@ -52,21 +56,6 @@ -------------------------------------------------------------------------------hashTable :: (Hashable k, Eq k) => DataStructure (Operation k)-hashTable = setupDataIO (const (H.new (==) (toEnum . (.&. 0x7fffffff) . hash))) f- where- f !m !op = case op of- (Insert k v) -> H.update m k v >> return m- (Lookup k) -> do- !_ <- H.lookup m k- return m- (Delete k) -> do- !_ <- H.delete m k- return m-{-# INLINE hashTable #-}--------------------------------------------------------------------------------- basicHashTable :: (Hashable k, Eq k) => DataStructure (Operation k) basicHashTable = setupDataIO (IOH.newSized :: Int -> IO (IOH.BasicHashTable k v)) f@@ -118,9 +107,6 @@ return $! B16.encode s -instance NFData ByteString where- rnf s = rnf $! B.unpack s- ------------------------------------------------------------------------------ mkConsecutiveIntegers :: IORef Int -> GenIO -> IO Int mkConsecutiveIntegers ref _ = do@@ -157,7 +143,6 @@ ------------------------------------------------------------------------------ testStructures = [ ("Data.Map" , dataMap )- , ("Data.Hashtable" , hashTable ) , ("Data.HashMap" , hashMap ) , ("Data.BasicHashTable" , basicHashTable ) , ("Data.LinearHashTable" , linearHashTable)@@ -165,20 +150,20 @@ ] intStructures = [ ("Data.Map" , dataMap )- , ("Data.Hashtable" , hashTable ) , ("Data.HashMap" , hashMap ) , ("Data.BasicHashTable" , basicHashTable ) , ("Data.CuckooHashTable", cuckooHashTable) ] intStructures' = [ ("Data.Map" , dataMap )- , ("Data.Hashtable" , hashTable ) , ("Data.HashMap" , hashMap ) , ("Data.BasicHashTable" , basicHashTable ) , ("Data.CuckooHashTable", cuckooHashTable) ] +------------------------------------------------------------------------------+testSizes :: [Int] testSizes = [ 250 , 500 , 1000
+ cabal.project view
@@ -0,0 +1,8 @@+packages: .++tests: True++test-show-details: direct++allow-newer:+ , *:base
+ cbits/Makefile view
@@ -0,0 +1,14 @@+check: default.c common.c check.c sse-42.c+ @echo "Testing portable version..."+ @gcc -o check -O3 default.c common.c check.c+ @./check+ @rm check++ @echo+ @echo "Testing SSE 4.2 version..."+ @gcc -o check -O3 -msse4.2 sse-42.c common.c check.c sse-42-check.c+ @./check+ @rm check++clean:+ rm -f *.o check
− cbits/cfuncs.c
@@ -1,517 +0,0 @@-#include <signal.h>-#include <stdint.h>-#include <stdio.h>-#ifdef WIN32-#include <windows.h>-#else-#include <unistd.h>-#endif--#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;- int wrapped = 0;- while (1) {- if (p == ep) {- if (wrapped) return -1;- ep = array + start;- p = array;- wrapped = 1;- }- if (*p == x1 || *p == x2) return p - array;- ++p;- }-}---int forwardSearch32_3(uint32_t* array, int start, int end,- uint32_t x1, uint32_t x2, uint32_t x3) {- uint32_t* ep = array + end;- uint32_t* p = array + start;- int wrapped = 0;- while (1) {- if (p == ep) {- if (wrapped) return -1;- ep = array + start;- p = array;- wrapped = 1;- }- if (*p == x1 || *p == x2 || *p == x3) return p - array;- ++p;- }-}---int forwardSearch64_2(uint64_t* array, int start, int end,- uint64_t x1, uint64_t x2) {- uint64_t* ep = array + end;- uint64_t* p = array + start;- int wrapped = 0;- while (1) {- if (p == ep) {- if (wrapped) return -1;- ep = array + start;- p = array;- wrapped = 1;- }- if (*p == x1 || *p == x2) return p - array;- ++p;- }-}---int forwardSearch64_3(uint64_t* array, int start, int end,- uint64_t x1, uint64_t x2, uint64_t x3) {- uint64_t* ep = array + end;- uint64_t* p = array + start;- int wrapped = 0;- while (1) {- if (p == ep) {- if (wrapped) return -1;- ep = array + start;- p = array;- wrapped = 1;- }- if (*p == x1 || *p == x2 || *p == x3) return p - array;- ++p;- }-}---//-----------------------------------------------------------------------------// cache line search functions-// First: 32 bit--inline int mask(int a, int b) { return -(a == b); }---uint8_t deBruijnBitPositions[] = {- 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,- 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9-};---int firstBitSet(int a) {- int zeroCase = mask(0, a);- uint32_t x = (uint32_t) (a & -a);- x *= 0x077CB531;- x >>= 27;- return zeroCase | deBruijnBitPositions[x];-}---int32_t lineResult32(int m, int start) {- int p = firstBitSet(m);- int32_t mm = mask(p, -1);- return mm | (~mm & (start + p));-}---uint32_t lineMask32(uint32_t* array, int start, uint32_t value) {- uint32_t* p = array + start;- uint32_t m = 0;- int offset = start & 0xf;-- switch (offset) {- case 0: m |= mask(*p++, value) & 0x1;- case 1: m |= mask(*p++, value) & 0x2;- case 2: m |= mask(*p++, value) & 0x4;- case 3: m |= mask(*p++, value) & 0x8;- case 4: m |= mask(*p++, value) & 0x10;- case 5: m |= mask(*p++, value) & 0x20;- case 6: m |= mask(*p++, value) & 0x40;- case 7: m |= mask(*p++, value) & 0x80;- case 8: m |= mask(*p++, value) & 0x100;- case 9: m |= mask(*p++, value) & 0x200;- case 10: m |= mask(*p++, value) & 0x400;- case 11: m |= mask(*p++, value) & 0x800;- case 12: m |= mask(*p++, value) & 0x1000;- case 13: m |= mask(*p++, value) & 0x2000;- case 14: m |= mask(*p++, value) & 0x4000;- case 15: m |= mask(*p++, value) & 0x8000;- }-- return m >> offset;-}---int lineSearch32(uint32_t* array, int start, uint32_t value) {- uint32_t m = lineMask32(array, start, value);- return lineResult32((int)m, start);-}---uint32_t lineMask32_2(uint32_t* array, int start, uint32_t x1, uint32_t x2) {- uint32_t* p = array + start;- uint32_t m = 0;- int offset = start & 0xf;-- switch (offset) {- case 0: m |= (mask(*p, x1) | mask(*p, x2)) & 0x1; ++p;- case 1: m |= (mask(*p, x1) | mask(*p, x2)) & 0x2; ++p;- case 2: m |= (mask(*p, x1) | mask(*p, x2)) & 0x4; ++p;- case 3: m |= (mask(*p, x1) | mask(*p, x2)) & 0x8; ++p;- case 4: m |= (mask(*p, x1) | mask(*p, x2)) & 0x10; ++p;- case 5: m |= (mask(*p, x1) | mask(*p, x2)) & 0x20; ++p;- case 6: m |= (mask(*p, x1) | mask(*p, x2)) & 0x40; ++p;- case 7: m |= (mask(*p, x1) | mask(*p, x2)) & 0x80; ++p;- case 8: m |= (mask(*p, x1) | mask(*p, x2)) & 0x100; ++p;- case 9: m |= (mask(*p, x1) | mask(*p, x2)) & 0x200; ++p;- case 10: m |= (mask(*p, x1) | mask(*p, x2)) & 0x400; ++p;- case 11: m |= (mask(*p, x1) | mask(*p, x2)) & 0x800; ++p;- case 12: m |= (mask(*p, x1) | mask(*p, x2)) & 0x1000; ++p;- case 13: m |= (mask(*p, x1) | mask(*p, x2)) & 0x2000; ++p;- case 14: m |= (mask(*p, x1) | mask(*p, x2)) & 0x4000; ++p;- case 15: m |= (mask(*p, x1) | mask(*p, x2)) & 0x8000; ++p;- }-- return m >> offset;-}---int lineSearch32_2(uint32_t* array, int start, uint32_t x1, uint32_t x2) {- uint32_t m = lineMask32_2(array, start, x1, x2);- return lineResult32((int)m, start);-}---uint32_t lineMask32_3(uint32_t* array, int start,- uint32_t x1, uint32_t x2, uint32_t x3) {- uint32_t* p = array + start;- uint32_t m = 0;- int offset = start & 0xf;-- switch (offset) {- case 0: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x1; ++p;- case 1: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x2; ++p;- case 2: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x4; ++p;- case 3: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x8; ++p;- case 4: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x10; ++p;- case 5: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x20; ++p;- case 6: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x40; ++p;- case 7: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x80; ++p;- case 8: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x100; ++p;- case 9: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x200; ++p;- case 10: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x400; ++p;- case 11: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x800; ++p;- case 12: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x1000; ++p;- case 13: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x2000; ++p;- case 14: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x4000; ++p;- case 15: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x8000; ++p;- }-- return m >> offset;-}---int lineSearch32_3(uint32_t* array, int start,- uint32_t x1, uint32_t x2, uint32_t x3) {- uint32_t m = lineMask32_3(array, start, x1, x2, x3);- return lineResult32((int)m, start);-}---//-----------------------------------------------------------------------------// Now: 64-bit. If USE_SSE_4_1 is on, we will use SSE4.1 SIMD instructions to-// search the cache line super-efficiently.--#if defined(USE_SSE_4_1)--inline uint64_t mask_to_mask2(__m128i m) {- int mask16 = _mm_movemask_epi8(m);- // output of _mm_movemask_epi8 is a 16-bit word where bit i is 1 iff the- // most significant bit of byte i of the mask is 1- int m1 = mask16 & 0x1;- int m2 = (mask16 & 0x100) >> 7;- return (uint64_t) (m1 | m2);-}---inline uint64_t cmp_and_mask(__m128i val, __m128i x0) {- __m128i mask1 = _mm_cmpeq_epi64(val, x0);- return mask_to_mask2(mask1);-}---inline uint64_t cmp_and_mask_2(__m128i val, __m128i x0, __m128i x1) {- __m128i mask1 = _mm_cmpeq_epi64(val, x0);- __m128i mask2 = _mm_cmpeq_epi64(val, x1);- mask1 = _mm_or_si128(mask1, mask2);- return mask_to_mask2(mask1);-}---inline uint64_t cmp_and_mask_3(__m128i val, __m128i x0, __m128i x1,- __m128i x2) {- __m128i mask1 = _mm_cmpeq_epi64(val, x0);- __m128i mask2 = _mm_cmpeq_epi64(val, x1);- __m128i mask3 = _mm_cmpeq_epi64(val, x2);- mask1 = _mm_or_si128(mask1, mask2);- mask1 = _mm_or_si128(mask1, mask3);- return mask_to_mask2(mask1);-}---uint64_t lineMask64(uint64_t* array, int start0, uint64_t v1) {- int offset = start0 & 0x7;- int start = start0 & ~0x7;-- __m128i* p = (__m128i*) (&array[start]);- __m128i x1 = _mm_cvtsi32_si128(0);- x1 = _mm_insert_epi64(x1, v1, 0);- x1 = _mm_insert_epi64(x1, v1, 1);- uint64_t dest_mask = 0;-- // x1 contains two 64-bit copies of the value to look for-- // words 0, 1- __m128i x = _mm_load_si128(p);- dest_mask = cmp_and_mask(x, x1);- p = (__m128i*) (&array[start+2]);-- // words 2, 3- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask(x, x1) << 2);- p = (__m128i*) (&array[start+4]);-- // words 4, 5- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask(x, x1) << 4);- p = (__m128i*) (&array[start+6]);-- // words 6, 7- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask(x, x1) << 6);-- return dest_mask >> offset;-}---uint64_t lineMask64_2(uint64_t* array, int start0, uint64_t v1, uint64_t v2) {- int offset = start0 & 0x7;- int start = start0 & ~0x7;-- __m128i* p = (__m128i*) (&array[start]);- __m128i x1 = _mm_cvtsi32_si128(0);- x1 = _mm_insert_epi64(x1, v1, 0);- x1 = _mm_insert_epi64(x1, v1, 1);-- __m128i x2 = _mm_cvtsi32_si128(0);- x2 = _mm_insert_epi64(x2, v2, 0);- x2 = _mm_insert_epi64(x2, v2, 1);-- uint64_t dest_mask = 0;-- // words 0, 1- __m128i x = _mm_load_si128(p);- dest_mask = cmp_and_mask_2(x, x1, x2);- p = (__m128i*) (&array[start+2]);-- // words 2, 3- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask_2(x, x1, x2) << 2);- p = (__m128i*) (&array[start+4]);-- // words 4, 5- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask_2(x, x1, x2) << 4);- p = (__m128i*) (&array[start+6]);-- // words 6, 7- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask_2(x, x1, x2) << 6);-- return dest_mask >> offset;-}---uint64_t lineMask64_3(uint64_t* array, int start0,- uint64_t v1, uint64_t v2, uint64_t v3) {- int offset = start0 & 0x7;- int start = start0 & ~0x7;-- __m128i* p = (__m128i*) (&array[start]);- __m128i x1 = _mm_cvtsi32_si128(0);- x1 = _mm_insert_epi64(x1, v1, 0);- x1 = _mm_insert_epi64(x1, v1, 1);-- __m128i x2 = _mm_cvtsi32_si128(0);- x2 = _mm_insert_epi64(x2, v2, 0);- x2 = _mm_insert_epi64(x2, v2, 1);-- __m128i x3 = _mm_cvtsi32_si128(0);- x3 = _mm_insert_epi64(x3, v3, 0);- x3 = _mm_insert_epi64(x3, v3, 1);-- uint64_t dest_mask = 0;-- // words 0, 1- __m128i x = _mm_load_si128(p);- dest_mask = cmp_and_mask_3(x, x1, x2, x3);- p = (__m128i*) (&array[start+2]);-- // words 2, 3- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask_3(x, x1, x2, x3) << 2);- p = (__m128i*) (&array[start+4]);-- // words 4, 5- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask_3(x, x1, x2, x3) << 4);- p = (__m128i*) (&array[start+6]);-- // words 6, 7- x = _mm_load_si128(p);- dest_mask |= (cmp_and_mask_3(x, x1, x2, x3) << 6);-- return dest_mask >> offset;-}---#else----uint64_t lineMask64(uint64_t* array, int start, uint64_t value) {- uint64_t* p = array + start;- uint64_t m = 0;- int offset = start & 0x7;-- switch (offset) {- case 0: m |= mask(*p++, value) & 0x1;- case 1: m |= mask(*p++, value) & 0x2;- case 2: m |= mask(*p++, value) & 0x4;- case 3: m |= mask(*p++, value) & 0x8;- case 4: m |= mask(*p++, value) & 0x10;- case 5: m |= mask(*p++, value) & 0x20;- case 6: m |= mask(*p++, value) & 0x40;- case 7: m |= mask(*p++, value) & 0x80;- }-- return m >> offset;-}---uint64_t lineMask64_2(uint64_t* array, int start, uint64_t x1, uint64_t x2) {- uint64_t* p = array + start;- uint64_t m = 0;- int offset = start & 0x7;-- switch (offset) {- case 0: m |= (mask(*p, x1) | mask(*p, x2)) & 0x1; ++p;- case 1: m |= (mask(*p, x1) | mask(*p, x2)) & 0x2; ++p;- case 2: m |= (mask(*p, x1) | mask(*p, x2)) & 0x4; ++p;- case 3: m |= (mask(*p, x1) | mask(*p, x2)) & 0x8; ++p;- case 4: m |= (mask(*p, x1) | mask(*p, x2)) & 0x10; ++p;- case 5: m |= (mask(*p, x1) | mask(*p, x2)) & 0x20; ++p;- case 6: m |= (mask(*p, x1) | mask(*p, x2)) & 0x40; ++p;- case 7: m |= (mask(*p, x1) | mask(*p, x2)) & 0x80; ++p;- }-- return m >> offset;-}---uint64_t lineMask64_3(uint64_t* array, int start,- uint64_t x1, uint64_t x2, uint64_t x3) {- uint64_t* p = array + start;- uint64_t m = 0;- int offset = start & 0x7;-- switch (offset) {- case 0: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x1; ++p;- case 1: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x2; ++p;- case 2: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x4; ++p;- case 3: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x8; ++p;- case 4: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x10; ++p;- case 5: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x20; ++p;- case 6: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x40; ++p;- case 7: m |= (mask(*p, x1) | mask(*p, x2) | mask(*p, x3)) & 0x80; ++p;- }-- return m >> offset;-}---#endif // USE_SSE_4_1---int64_t lineResult64(int64_t m, int64_t start) {- int p = firstBitSet((int)m);- int64_t mm = (int64_t) mask(p, -1);- return mm | (~mm & (start + p));-}---int lineSearch64(uint64_t* array, int start, uint64_t value) {- uint64_t m = lineMask64(array, start, value);- return lineResult64((int)m, start);-}---int lineSearch64_2(uint64_t* array, int start, uint64_t x1, uint64_t x2) {- uint64_t m = lineMask64_2(array, start, x1, x2);- return lineResult64((int)m, start);-}---int lineSearch64_3(uint64_t* array, int start,- uint64_t x1, uint64_t x2, uint64_t x3) {- uint64_t m = lineMask64_3(array, start, x1, x2, x3);- return lineResult64((int)m, start);-}--void suicide(volatile int* check, int t) {- int secs = (3*t + 999999) / 1000000;- if (secs < 1) secs = 1;-#ifdef WIN32- Sleep(secs * 1000);-#else- sleep(secs);-#endif- if (*check) {- printf("timeout expired, dying!!\n");-#ifdef WIN32- abort();-#else- raise(SIGKILL);-#endif- }-}
+ cbits/check.c view
@@ -0,0 +1,185 @@+#include <stdlib.h>+#include <stdio.h>+#include "defs.h"++static const int NUMH = 64 / sizeof(small_hash_t);++static small_hash_t t_sevens[32] =+ { 7,7,7,7,7,7,7,7,+ 7,7,7,7,7,7,7,7,+ 7,7,7,7,7,7,7,7,+ 7,7,7,7,7,7,7,7 };++static small_hash_t t_zeroes[32] =+ { 0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0,+ 0,0,0,0,0,0,0,0 };++static small_hash_t t_mixed[32] =+ { 7,1,7,7,2,7,7,7,+ 7,7,3,7,7,7,7,7,+ 7,7,7,7,1,7,7,7,+ 7,7,7,7,3,7,7,9 };++static int num_tests = 0;+static int num_errors = 0;++void CHECK(int actual, int expected, char* what) {+ ++num_tests;+ if (actual != expected) {+ fprintf(stderr, "%s: expected %d, got %d\n", what, expected, actual);++ ++num_errors;+ }+}+++void check_forward_search_2() {+ /* forward_search_2 */+ /* - offset zero */+ CHECK(forward_search_2(t_sevens, 0, NUMH, 0, 7 ), 0, "fs2-sevens-ok-1" );+ CHECK(forward_search_2(t_sevens, 0, NUMH, 7, 0 ), 0, "fs2-sevens-ok-2" );+ CHECK(forward_search_2(t_sevens, 0, NUMH, 7, 7 ), 0, "fs2-sevens-ok-3" );+ CHECK(forward_search_2(t_sevens, 0, NUMH, 3, 0 ), -1, "fs2-sevens-fail-1");+ CHECK(forward_search_2(t_zeroes, 0, NUMH, 0, 1 ), 0, "fs2-zeroes-ok-1" );+ CHECK(forward_search_2(t_zeroes, 0, NUMH, 2, 0 ), 0, "fs2-zeroes-ok-2" );+ CHECK(forward_search_2(t_zeroes, 0, NUMH, 2, 0xf0), -1, "fs2-zeroes-fail-1");++ /* - offset 5 */+ CHECK(forward_search_2(t_sevens, 5, NUMH, 0, 7), 5, "fs2-o-sevens-ok-1" );+ CHECK(forward_search_2(t_sevens, 5, NUMH, 7, 0), 5, "fs2-o-sevens-ok-2" );+ CHECK(forward_search_2(t_sevens, 5, NUMH, 7, 7), 5, "fs2-o-sevens-ok-3" );+ CHECK(forward_search_2(t_sevens, 5, NUMH, 3, 0), -1, "fs2-o-sevens-fail-1");+ CHECK(forward_search_2(t_zeroes, 5, NUMH, 0, 1), 5, "fs2-o-zeroes-ok-1" );+ CHECK(forward_search_2(t_zeroes, 5, NUMH, 2, 0), 5, "fs2-o-zeroes-ok-2" );+ CHECK(forward_search_2(t_zeroes, 5, NUMH, 2, 0xf0), -1, "fs2-o-zeroes-fail-1");++ /* - mixed, offset zero */+ CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 0xf0), 4, "fs2-mixed-ok-1" );+ CHECK(forward_search_2(t_mixed, 0, NUMH, 4, 0xf0), -1, "fs2-mixed-fail-1");+ CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 1), 1, "fs2-mixed-ok-2" );+ CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 7), 0, "fs2-mixed-ok-3" );+ CHECK(forward_search_2(t_mixed, 0, NUMH, 2, 3), 4, "fs2-mixed-ok-4" );+ CHECK(forward_search_2(t_mixed, 0, NUMH, 9, 3), 10, "fs2-mixed-ok-5" );+ CHECK(forward_search_2(t_mixed, 0, NUMH, 3, 9), 10, "fs2-mixed-ok-5" );+ CHECK(forward_search_2(t_mixed, 0, NUMH, 8, 9), 31, "fs2-mixed-ok-6" );++ /* - mixed, offset 16 */+ CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 0xf0), 4, "fs2-o-mixed-ok-1" );+ CHECK(forward_search_2(t_mixed, 16, NUMH, 4, 0xf0), -1, "fs2-o-mixed-fail-1");+ CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 1), 20, "fs2-o-mixed-ok-2" );+ CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 7), 16, "fs2-o-mixed-ok-3" );+ CHECK(forward_search_2(t_mixed, 16, NUMH, 2, 3), 28, "fs2-o-mixed-ok-4" );+ CHECK(forward_search_2(t_mixed, 16, NUMH, 9, 3), 28, "fs2-o-mixed-ok-5" );+ CHECK(forward_search_2(t_mixed, 16, NUMH, 3, 9), 28, "fs2-o-mixed-ok-5" );+ CHECK(forward_search_2(t_mixed, 16, NUMH, 8, 9), 31, "fs2-o-mixed-ok-6" );+}++void check_forward_search_3() {+ /* forward_search_3 */+ /* - offset zero */+ CHECK(forward_search_3(t_sevens, 0, NUMH, 0, 7, 88), 0, "fs3-sevens-ok-1" );+ CHECK(forward_search_3(t_sevens, 0, NUMH, 7, 0, 88), 0, "fs3-sevens-ok-2" );+ CHECK(forward_search_3(t_sevens, 0, NUMH, 7, 7, 88), 0, "fs3-sevens-ok-3" );+ CHECK(forward_search_3(t_sevens, 0, NUMH, 3, 0, 88), -1, "fs3-sevens-fail-1");+ CHECK(forward_search_3(t_zeroes, 0, NUMH, 0, 1, 88), 0, "fs3-zeroes-ok-1" );+ CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 0, 88), 0, "fs3-zeroes-ok-2" );+ CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 11, 0 ), 0, "fs3-zeroes-ok-3" );+ CHECK(forward_search_3(t_zeroes, 0, NUMH, 2, 32, 88), -1, "fs3-zeroes-fail-1");++ /* - offset 5 */+ CHECK(forward_search_3(t_sevens, 5, NUMH, 0, 7, 7 ), 5, "fs3-o-sevens-ok-1" );+ CHECK(forward_search_3(t_sevens, 5, NUMH, 7, 0, 21), 5, "fs3-o-sevens-ok-2" );+ CHECK(forward_search_3(t_sevens, 5, NUMH, 7, 7, 21), 5, "fs3-o-sevens-ok-3" );+ CHECK(forward_search_3(t_sevens, 5, NUMH, 3, 0, 21), -1, "fs3-o-sevens-fail-1");+ CHECK(forward_search_3(t_zeroes, 5, NUMH, 0, 1, 21), 5, "fs3-o-zeroes-ok-1" );+ CHECK(forward_search_3(t_zeroes, 5, NUMH, 2, 0, 21), 5, "fs3-o-zeroes-ok-2" );+ CHECK(forward_search_3(t_zeroes, 5, NUMH, 2, 0xf0, 21), -1, "fs3-o-zeroes-fail-1");++ /* - mixed, offset zero */+ CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 0xf0, -1), 4, "fs3-mixed-ok-1" );+ CHECK(forward_search_3(t_mixed, 0, NUMH, 4, 0xf0, -1), -1, "fs3-mixed-fail-1");+ CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 1, -1), 1, "fs3-mixed-ok-2" );+ CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 7, -1), 0, "fs3-mixed-ok-3" );+ CHECK(forward_search_3(t_mixed, 0, NUMH, 2, 3, -1), 4, "fs3-mixed-ok-4" );+ CHECK(forward_search_3(t_mixed, 0, NUMH, 9, 3, -1), 10, "fs3-mixed-ok-5" );+ CHECK(forward_search_3(t_mixed, 0, NUMH, 3, 9, -1), 10, "fs3-mixed-ok-5" );+ CHECK(forward_search_3(t_mixed, 0, NUMH, 8, 9, -1), 31, "fs3-mixed-ok-6" );++ /* - mixed, offset 16 */+ CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 96, 33), 4, "fs3-o-mixed-ok-1" );+ CHECK(forward_search_3(t_mixed, 16, NUMH, 4, 96, 33), -1, "fs3-o-mixed-fail-1");+ CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 1, 33), 20, "fs3-o-mixed-ok-2" );+ CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 7, 33), 16, "fs3-o-mixed-ok-3" );+ CHECK(forward_search_3(t_mixed, 16, NUMH, 2, 3, 33), 28, "fs3-o-mixed-ok-4" );+ CHECK(forward_search_3(t_mixed, 16, NUMH, 9, 3, 33), 28, "fs3-o-mixed-ok-5" );+ CHECK(forward_search_3(t_mixed, 16, NUMH, 3, 9, 33), 28, "fs3-o-mixed-ok-5" );+ CHECK(forward_search_3(t_mixed, 16, NUMH, 8, 9, 33), 31, "fs3-o-mixed-ok-6" );+ CHECK(forward_search_3(t_mixed, 16, NUMH, 8, 33, 9 ), 31, "fs3-o-mixed-ok-7" );+}++void check_line_search() {+ CHECK(line_search(t_sevens, 0, 7), 0, "ls-7s-ok-1");+ CHECK(line_search(t_sevens, 5, 7), 5, "ls-7s-ok-2");+ CHECK(line_search(t_sevens, 31, 7), 31, "ls-7s-ok-3");+ CHECK(line_search(t_sevens, 0, 1), -1, "ls-7s-fail-1");+ CHECK(line_search(t_sevens, 31, 1), -1, "ls-7s-fail-2");++ CHECK(line_search(t_mixed, 0, 7), 0, "ls-m-ok-1");+ CHECK(line_search(t_mixed, 0, 1), 1, "ls-m-ok-2");+ CHECK(line_search(t_mixed, 1, 7), 2, "ls-m-ok-3");+ CHECK(line_search(t_mixed, 0, 9), 31, "ls-m-ok-4");+ CHECK(line_search(t_mixed, 0, 8), -1, "ls-m-fail-1");++ CHECK(line_search(t_mixed, 16, 1), 20, "ls-m-ok-5");+}++void check_line_search_2() {+ CHECK(line_search_2(t_sevens, 0, 7, 3), 0, "ls2-7s-ok-1");+ CHECK(line_search_2(t_sevens, 5, 7, 9), 5, "ls2-7s-ok-2");+ CHECK(line_search_2(t_sevens, 31, 0, 7), 31, "ls2-7s-ok-3");+ CHECK(line_search_2(t_sevens, 0, 1, 3), -1, "ls2-7s-fail-1");+ CHECK(line_search_2(t_sevens, 31, 6, 1), -1, "ls2-7s-fail-2");++ CHECK(line_search_2(t_mixed, 0, 7, 9), 0, "ls2-m-ok-1");+ CHECK(line_search_2(t_mixed, 0, 9, 1), 1, "ls2-m-ok-2");+ CHECK(line_search_2(t_mixed, 1, 7, 9), 2, "ls2-m-ok-3");+ CHECK(line_search_2(t_mixed, 0, 8, 9), 31, "ls2-m-ok-4");+ CHECK(line_search_2(t_mixed, 0, 8, 4), -1, "ls2-m-fail-1");++ CHECK(line_search_2(t_mixed, 16, 3, 1), 20, "ls2-m-ok-5");+}++void check_line_search_3() {+ CHECK(line_search_3(t_sevens, 0, 4, 7, 3), 0, "ls2-7s-ok-1");+ CHECK(line_search_3(t_sevens, 5, 7, 4, 9), 5, "ls2-7s-ok-2");+ CHECK(line_search_3(t_sevens, 31, 0, 7, 4), 31, "ls2-7s-ok-3");+ CHECK(line_search_3(t_sevens, 0, 1, 4, 3), -1, "ls2-7s-fail-1");+ CHECK(line_search_3(t_sevens, 31, 4, 6, 1), -1, "ls2-7s-fail-2");++ CHECK(line_search_3(t_mixed, 0, 4, 7, 9), 0, "ls2-m-ok-1");+ CHECK(line_search_3(t_mixed, 0, 9, 4, 1), 1, "ls2-m-ok-2");+ CHECK(line_search_3(t_mixed, 1, 7, 9, 4), 2, "ls2-m-ok-3");+ CHECK(line_search_3(t_mixed, 0, 8, 4, 9), 31, "ls2-m-ok-4");+ CHECK(line_search_3(t_mixed, 0, 8, 4, 6), -1, "ls2-m-fail-1");++ CHECK(line_search_3(t_mixed, 16, 3, 1, 6), 20, "ls2-m-ok-5");+}+++int main() {+ check_forward_search_2();+ check_forward_search_3();+ check_line_search();+ check_line_search_2();+ check_line_search_3();+ check_impl_specific();++ if (num_errors > 0) {+ printf("\n*** %d/%d tests failed.\n", num_errors, num_tests);+ } else {+ printf("All %d tests passed.\n", num_tests);+ }+ exit(num_errors < 255 ? num_errors : 255);+}
+ cbits/common.c view
@@ -0,0 +1,79 @@+#include "defs.h"++#ifdef WIN32+#include <windows.h>+#else+#include <stdlib.h>+#include <unistd.h>+#endif++#include <stdio.h>++void suicide(volatile int* check, int t) {+ int secs = (3*t + 999999) / 1000000;+ if (secs < 1) secs = 1;+#ifdef WIN32+ Sleep(secs * 1000);+#else+ sleep(secs);+#endif+ if (*check) {+ printf("timeout expired, dying!!\n");+ exit(1);+ }+}++#if defined(__GNUC__)+#define PREFETCH_READ(x) (__builtin_prefetch(x, 0, 3))+#define PREFETCH_WRITE(x) (__builtin_prefetch(x, 1, 3))+#else+#define PREFETCH_READ(x)+#define PREFETCH_WRITE(x)+#endif++void prefetch_cacheline_read(small_hash_t* line, int start)+{+ PREFETCH_READ((void*)(&line[start]));+}++void prefetch_cacheline_write(small_hash_t* line, int start)+{+ PREFETCH_WRITE((void*)(&line[start]));+}++int forward_search_2(small_hash_t* array, int start, int end,+ small_hash_t x1, small_hash_t x2) {+ small_hash_t* ep = array + end;+ small_hash_t* p = array + start;+ int wrapped = 0;+ while (1) {+ if (p >= ep) {+ if (wrapped) return -1;+ ep = array + start;+ p = array;+ wrapped = 1;+ continue;+ }+ if (*p == x1 || *p == x2) return p - array;+ ++p;+ }+}++int forward_search_3(small_hash_t* array, int start, int end,+ small_hash_t x1, small_hash_t x2, small_hash_t x3) {+ small_hash_t* ep = array + end;+ small_hash_t* p = array + start;+ int wrapped = 0;+ while (1) {+ if (p >= ep) {+ if (wrapped) return -1;+ ep = array + start;+ p = array;+ wrapped = 1;+ continue;+ }+ if (*p == x1 || *p == x2 || *p == x3) return p - array;+ ++p;+ }+}+
+ cbits/default.c view
@@ -0,0 +1,203 @@+// Specialized i686 versions of the cache line search functions.++#include "defs.h"++static inline int32_t mask(int32_t a, int32_t b) { return -(a == b); }++#if defined(__GNUC__)+static inline int32_t first_bit_set(int32_t a) {+ return __builtin_ffs(a) - 1;+}+#else+static uint8_t de_bruijn_table[] = {+ 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,+ 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9+};++static inline int32_t first_bit_set(int32_t a) {+ int32_t zero_case = mask(0, a);+ uint32_t x = (uint32_t) (a & -a);+ x *= 0x077CB531;+ x >>= 27;+ return zero_case | de_bruijn_table[x];+}+#endif++static inline uint32_t line_mask(small_hash_t* array, int start,+ small_hash_t x1) {+ small_hash_t* p = array + start;+ uint32_t m1 = 0;+ uint32_t m2 = 0;+ uint32_t m3 = 0;+ int offset = start & 0x1f;++#define M (mask(*p, x1))++ switch (offset) {+ case 0: m1 |= M & 0x1; ++p;+ case 1: m2 |= M & 0x2; ++p;+ case 2: m3 |= M & 0x4; ++p;+ case 3: m1 |= M & 0x8; ++p;+ case 4: m2 |= M & 0x10; ++p;+ case 5: m3 |= M & 0x20; ++p;+ case 6: m1 |= M & 0x40; ++p;+ case 7: m2 |= M & 0x80; ++p;+ case 8: m3 |= M & 0x100; ++p;+ case 9: m1 |= M & 0x200; ++p;+ case 10: m2 |= M & 0x400; ++p;+ case 11: m3 |= M & 0x800; ++p;+ case 12: m1 |= M & 0x1000; ++p;+ case 13: m2 |= M & 0x2000; ++p;+ case 14: m3 |= M & 0x4000; ++p;+ case 15: m1 |= M & 0x8000; ++p;+ case 16: m2 |= M & 0x10000; ++p;+ case 17: m3 |= M & 0x20000; ++p;+ case 18: m1 |= M & 0x40000; ++p;+ case 19: m2 |= M & 0x80000; ++p;+ case 20: m3 |= M & 0x100000; ++p;+ case 21: m1 |= M & 0x200000; ++p;+ case 22: m2 |= M & 0x400000; ++p;+ case 23: m3 |= M & 0x800000; ++p;+ case 24: m1 |= M & 0x1000000; ++p;+ case 25: m2 |= M & 0x2000000; ++p;+ case 26: m3 |= M & 0x4000000; ++p;+ case 27: m1 |= M & 0x8000000; ++p;+ case 28: m2 |= M & 0x10000000; ++p;+ case 29: m3 |= M & 0x20000000; ++p;+ case 30: m1 |= M & 0x40000000; ++p;+ case 31: m2 |= M & 0x80000000; ++p;+ }++#undef M++ return (m1 | m2 | m3) >> offset;+}++static inline uint32_t line_mask_2(small_hash_t* array, int start,+ small_hash_t x1, small_hash_t x2) {+ small_hash_t* p = array + start;+ uint32_t m1 = 0;+ uint32_t m2 = 0;+ uint32_t m3 = 0;+ int offset = start & 0x1f;++#define M (mask(*p, x1) | mask(*p, x2))++ switch (offset) {+ case 0: m1 |= M & 0x1; ++p;+ case 1: m2 |= M & 0x2; ++p;+ case 2: m3 |= M & 0x4; ++p;+ case 3: m1 |= M & 0x8; ++p;+ case 4: m2 |= M & 0x10; ++p;+ case 5: m3 |= M & 0x20; ++p;+ case 6: m1 |= M & 0x40; ++p;+ case 7: m2 |= M & 0x80; ++p;+ case 8: m3 |= M & 0x100; ++p;+ case 9: m1 |= M & 0x200; ++p;+ case 10: m2 |= M & 0x400; ++p;+ case 11: m3 |= M & 0x800; ++p;+ case 12: m1 |= M & 0x1000; ++p;+ case 13: m2 |= M & 0x2000; ++p;+ case 14: m3 |= M & 0x4000; ++p;+ case 15: m1 |= M & 0x8000; ++p;+ case 16: m2 |= M & 0x10000; ++p;+ case 17: m3 |= M & 0x20000; ++p;+ case 18: m1 |= M & 0x40000; ++p;+ case 19: m2 |= M & 0x80000; ++p;+ case 20: m3 |= M & 0x100000; ++p;+ case 21: m1 |= M & 0x200000; ++p;+ case 22: m2 |= M & 0x400000; ++p;+ case 23: m3 |= M & 0x800000; ++p;+ case 24: m1 |= M & 0x1000000; ++p;+ case 25: m2 |= M & 0x2000000; ++p;+ case 26: m3 |= M & 0x4000000; ++p;+ case 27: m1 |= M & 0x8000000; ++p;+ case 28: m2 |= M & 0x10000000; ++p;+ case 29: m3 |= M & 0x20000000; ++p;+ case 30: m1 |= M & 0x40000000; ++p;+ case 31: m2 |= M & 0x80000000; ++p;+ }++#undef M++ return (m1 | m2 | m3) >> offset;+}++static inline uint32_t line_mask_3(small_hash_t* array, int start,+ small_hash_t x1, small_hash_t x2,+ small_hash_t x3) {+ small_hash_t* p = array + start;+ uint32_t m1 = 0;+ uint32_t m2 = 0;+ uint32_t m3 = 0;+ int offset = start & 0x1f;++#define M (mask(*p, x1) | mask(*p, x2) | mask(*p, x3))++ switch (offset) {+ case 0: m1 |= M & 0x1; ++p;+ case 1: m2 |= M & 0x2; ++p;+ case 2: m3 |= M & 0x4; ++p;+ case 3: m1 |= M & 0x8; ++p;+ case 4: m2 |= M & 0x10; ++p;+ case 5: m3 |= M & 0x20; ++p;+ case 6: m1 |= M & 0x40; ++p;+ case 7: m2 |= M & 0x80; ++p;+ case 8: m3 |= M & 0x100; ++p;+ case 9: m1 |= M & 0x200; ++p;+ case 10: m2 |= M & 0x400; ++p;+ case 11: m3 |= M & 0x800; ++p;+ case 12: m1 |= M & 0x1000; ++p;+ case 13: m2 |= M & 0x2000; ++p;+ case 14: m3 |= M & 0x4000; ++p;+ case 15: m1 |= M & 0x8000; ++p;+ case 16: m2 |= M & 0x10000; ++p;+ case 17: m3 |= M & 0x20000; ++p;+ case 18: m1 |= M & 0x40000; ++p;+ case 19: m2 |= M & 0x80000; ++p;+ case 20: m3 |= M & 0x100000; ++p;+ case 21: m1 |= M & 0x200000; ++p;+ case 22: m2 |= M & 0x400000; ++p;+ case 23: m3 |= M & 0x800000; ++p;+ case 24: m1 |= M & 0x1000000; ++p;+ case 25: m2 |= M & 0x2000000; ++p;+ case 26: m3 |= M & 0x4000000; ++p;+ case 27: m1 |= M & 0x8000000; ++p;+ case 28: m2 |= M & 0x10000000; ++p;+ case 29: m3 |= M & 0x20000000; ++p;+ case 30: m1 |= M & 0x40000000; ++p;+ case 31: m2 |= M & 0x80000000; ++p;+ }+#undef M++ return (m1 | m2 | m3) >> offset;+}+++static inline int32_t line_result(uint32_t m, int start) {+ int32_t p = first_bit_set((int32_t) m);+ int32_t mm = mask(p, -1);+ return mm | (start + p);+}+++int line_search(small_hash_t* array, int start, small_hash_t x1) {+ uint32_t m = line_mask(array, start, x1);+ return line_result(m, start);+}++int line_search_2(small_hash_t* array, int start, small_hash_t x1,+ small_hash_t x2) {+ uint32_t m = line_mask_2(array, start, x1, x2);+ return line_result(m, start);+}++int line_search_3(small_hash_t* array, int start, small_hash_t x1,+ small_hash_t x2, small_hash_t x3) {+ uint32_t m = line_mask_3(array, start, x1, x2, x3);+ return line_result(m, start);+}++void check_impl_specific(int* num_tests, int* num_errors) {++}
+ cbits/defs.h view
@@ -0,0 +1,35 @@+#ifndef HASHTABLES_DEFS_H+#define HASHTABLES_DEFS_H++#include <stdint.h>+#include <strings.h>++typedef uintptr_t full_hash_t;+typedef uint16_t small_hash_t;++void prefetch_cacheline_write(small_hash_t* line, int start);+void prefetch_cacheline_read(small_hash_t* line, int start);++int forward_search_2(small_hash_t* array,+ int start,+ int end,+ small_hash_t x1,+ small_hash_t x2);+int forward_search_3(small_hash_t* array,+ int start,+ int end,+ small_hash_t x1,+ small_hash_t x2,+ small_hash_t x3);++int line_search(small_hash_t* array, int start, small_hash_t x1);+int line_search_2(small_hash_t* array, int start, small_hash_t x1,+ small_hash_t x2);+int line_search_3(small_hash_t* array, int start, small_hash_t x1,+ small_hash_t x2, small_hash_t x3);+void suicide(volatile int* check, int i);++void CHECK(int actual, int expected, char* what);+void check_impl_specific(int* num_tests, int* num_errors);++#endif /* HASHTABLES_DEFS_H */
+ cbits/sse-42-check.c view
@@ -0,0 +1,38 @@+#include "defs.h"++#include <smmintrin.h>+#include <stdio.h>++extern __m128i fill(small_hash_t v);++static void check_fill(small_hash_t v) {+ int i;+ char buf[256];+ small_hash_t v2;++ __m128i x = fill(v);++#define F(i) do { \+ v2 = _mm_extract_epi16(x, i); \+ sprintf(buf, "fill-%x-%d-of-8", (int) v, i+1); \+ CHECK(v2, v, buf); \+ } while(0);++ F(0);+ F(1);+ F(2);+ F(3);+ F(4);+ F(5);+ F(6);+ F(7);+#undef F+}++void check_impl_specific(int* num_tests, int* num_errors) {+ check_fill(0);+ check_fill((small_hash_t) (-1));+ check_fill((small_hash_t) (-5));+ check_fill(7);+ check_fill(0xff);+}
+ cbits/sse-42.c view
@@ -0,0 +1,172 @@+#include "defs.h"++#include <smmintrin.h>+#include <stdio.h>++/* Straight-line branchless SSE 4.2 code for searching an array of uint16_t+ hash codes. */++static inline int32_t mask(int32_t a, int32_t b) { return -(a == b); }++#if defined(__GNUC__)+static inline int32_t first_bit_set(int32_t a) {+ return __builtin_ffs(a) - 1;+}+#else+static uint8_t de_bruijn_table[] = {+ 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,+ 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9+};++static inline int32_t first_bit_set(int32_t a) {+ int32_t zero_case = mask(0, a);+ uint32_t x = (uint32_t) (a & -a);+ x *= 0x077CB531;+ x >>= 27;+ return zero_case | de_bruijn_table[x];+}+#endif++static inline __m128i fill(small_hash_t v) {+ int32_t v1 = (((int)v) << 16) | v;+ __m128i x = _mm_cvtsi32_si128(0);+ x = _mm_insert_epi32(x, v1, 0);+ return _mm_shuffle_epi32(x, _MM_SHUFFLE(0,0,0,0));+}++#ifndef SIDD_UWORD_OPS+#define SIDD_UWORD_OPS _SIDD_UWORD_OPS+#endif++#ifndef SIDD_CMP_EQUAL_EACH+#define SIDD_CMP_EQUAL_EACH _SIDD_CMP_EQUAL_EACH+#endif++#ifndef SIDD_BIT_MASK+#define SIDD_BIT_MASK _SIDD_BIT_MASK+#endif++#define _MODE (SIDD_UWORD_OPS | SIDD_CMP_EQUAL_EACH)++static inline __m128i cmp_mask(__m128i a, __m128i b) {+ const int mode = SIDD_UWORD_OPS | SIDD_CMP_EQUAL_EACH | SIDD_BIT_MASK;+ return _mm_cmpistrm(a, b, mode);+}++static inline int32_t line_result(uint32_t m, int start) {+ int32_t p = first_bit_set((int32_t) m);+ int32_t mm = mask(p, -1);+ return mm | (start + p);+}++#define DUMP(xval) do { \+ uint16_t xval##_x0 = _mm_extract_epi16(xval, 0); \+ uint16_t xval##_x1 = _mm_extract_epi16(xval, 1); \+ uint16_t xval##_x2 = _mm_extract_epi16(xval, 2); \+ uint16_t xval##_x3 = _mm_extract_epi16(xval, 3); \+ uint16_t xval##_x4 = _mm_extract_epi16(xval, 4); \+ uint16_t xval##_x5 = _mm_extract_epi16(xval, 5); \+ uint16_t xval##_x6 = _mm_extract_epi16(xval, 6); \+ uint16_t xval##_x7 = _mm_extract_epi16(xval, 7); \+ printf(" % 10s: %04x-%04x-%04x-%04x-%04x-%04x-%04x-%04x\n", \+ #xval, xval##_x0, xval##_x1, xval##_x2, xval##_x3, \+ xval##_x4, xval##_x5, xval##_x6, xval##_x7); \+ } while(0);+++int line_search(small_hash_t* array, int start0, small_hash_t v1) {+ int offset = start0 & 31;+ int start = start0 & ~31;+ __m128i* p = (__m128i*) &array[start];+ __m128i x1, val1, val2, val3, val4;+ __m128i m1, m2, m3, m4, dmask;++ x1 = fill(v1);++ val1 = *p++;+ m1 = cmp_mask(x1, val1);+ val2 = *p++;+ m2 = _mm_slli_si128(cmp_mask(x1, val2), 1);+ val3 = *p++;+ m3 = _mm_slli_si128(cmp_mask(x1, val3), 2);+ val4 = *p;+ m4 = _mm_slli_si128(cmp_mask(x1, val4), 3);++ dmask = _mm_or_si128(_mm_or_si128(m1, m2),+ _mm_or_si128(m3, m4));+ uint32_t imask = _mm_extract_epi32(dmask, 0);++ const uint32_t p2 = 1 << offset;+ const uint32_t dest_mask = imask & ~(p2 - 1);++ return line_result(dest_mask, start);+}++int line_search_2(small_hash_t* array, int start0, small_hash_t v1,+ small_hash_t v2) {+ int offset = start0 & 31;+ int start = start0 & ~31;+ __m128i* p = (__m128i*) &array[start];+ __m128i x1, x2, val1, val2, val3, val4;+ __m128i m1, m2, m3, m4, dmask;++ x1 = fill(v1);+ x2 = fill(v2);++#define M(v) _mm_or_si128(cmp_mask(x1,(v)), \+ cmp_mask(x2,(v)))+ val1 = *p++;+ m1 = M(val1);+ val2 = *p++;+ m2 = _mm_slli_si128(M(val2), 1);+ val3 = *p++;+ m3 = _mm_slli_si128(M(val3), 2);+ val4 = *p;+ m4 = _mm_slli_si128(M(val4), 3);+#undef M++ dmask = _mm_or_si128(_mm_or_si128(m1, m2),+ _mm_or_si128(m3, m4));+ uint32_t imask = _mm_extract_epi32(dmask, 0);++ const uint32_t p2 = 1 << offset;+ const uint32_t dest_mask = imask & ~(p2 - 1);++ return line_result(dest_mask, start);+}++int line_search_3(small_hash_t* array, int start0, small_hash_t v1,+ small_hash_t v2, small_hash_t v3) {+ int offset = start0 & 31;+ int start = start0 & ~31;+ __m128i* p = (__m128i*) &array[start];+ __m128i x1, x2, x3, val1, val2, val3, val4;+ __m128i m1, m2, m3, m4, dmask;++ x1 = fill(v1);+ x2 = fill(v2);+ x3 = fill(v3);++#define M(v) _mm_or_si128( \+ cmp_mask(x1,(v)), \+ _mm_or_si128(cmp_mask(x2,(v)), \+ cmp_mask(x3,(v))))+ val1 = *p++;+ m1 = M(val1);+ val2 = *p++;+ m2 = _mm_slli_si128(M(val2), 1);+ val3 = *p++;+ m3 = _mm_slli_si128(M(val3), 2);+ val4 = *p;+ m4 = _mm_slli_si128(M(val4), 3);+#undef M++ dmask = _mm_or_si128(_mm_or_si128(m1, m2),+ _mm_or_si128(m3, m4));+ uint32_t imask = _mm_extract_epi32(dmask, 0);++ const uint32_t p2 = 1 << offset;+ const uint32_t dest_mask = imask & ~(p2 - 1);++ return line_result(dest_mask, start);+}
+ changelog.md view
@@ -0,0 +1,191 @@+# Hashtables changelog++## 1.4.2++ - Fix C compile errors in cbits.+ - Bump lower bound for QuickCheck.++## 1.4.1++ - Fix broken compile when compiling with `-fportable` flag.+ - Make it build with GHC WASM (Bodigrim).++## 1.4.0++ - Replace deprecated Mutable Array function, which modifies the signature of the `length`+ function and hence the API.+ - Support more recent compilers.++## 1.3.1++ - Fix Noncanonical mappend definition warning.+ - Support more recent compilers.+++## 1.3++ - Support Hashable 1.4. This new version of Hashable drops the Eq constraint, so the Eq constraint+ needs to be dropped in the SPECIALIZE statements in Hashtables.++## 1.2.4.2++ - Cabal file: add missing other-modules+ - Silence import warnings. Know that we require ghc >= 7.8.+ - Fix build with GHC 9.2++## 1.2.4.1++ - Update some test suite dep upper bounds.++## 1.2.4.0++ - Fix a [correctness bug](https://github.com/gregorycollins/hashtables/issues/55)+with cuckoo hash tables and the new `mutate` function introduced in 1.2.3.0.++ - Bring test suite into main .cabal file++## 1.2.3.4++Fix build with GHC 8.8.++## 1.2.3.3++Fix build with certain versions of `primitive` (thx again Carter)++## 1.2.3.2++ - CPP fix for breakage caused by primitive 0.7 (thx Carter)++ - Fix some haddock syntax errors (thx Frederik Hanghøj Iversen)++ - Fix typo in module reference (thx Don Allen)++## 1.2.3.1++ - Fix building with GHC <7.10 (thx Vanessa McHale)++## 1.2.3.0++ - update for Semigroup/monoid breakage with GHC 8.4 (thx Fumiaki Kinoshita)++ - Implement mutateST and mutateIO (thx Andy Morris)++ - Fix build breakage w/ "pre" function (thx Andy Morris)++## 1.2.2.1++ - Adjusted base lower bound (it was incorrect), bumped some testsuite ++ benchmark bounds.++## 1.2.2.0+ - Bumped vector bounds.++ - Added `lookupIndex` and `nextByIndex` functions.+ - Add `mutate` function.++Thanks to contributors:++ - Vykintas Baltrušaitis.+ - Franklin Chen+ - Iavor Diatchki+ - Eric Mertins++## 1.2.1.1+ - Bumped vector bounds.++## 1.2.1.0++ - Fixed an FFI import typo bug+ (https://github.com/gregorycollins/hashtables/pull/27), thanks to Thijs+ Alkemade for the fix.++## 1.2.0.2++ - Fixed serious bug (https://github.com/gregorycollins/hashtables/issues/24)+ in basic hash table making it impossible to reliably store more than 64k+ elements (after shortening the hash code arrays to 16 bits I neglected to+ realize that I was storing item counts using the same array type).++## 1.2.0.1++ - Fixed bug in C code re: clang interpreting "inline" strictly according to+ (insane) C99 semantics: http://clang.llvm.org/compatibility.html#inline++ - Fixed a compile bug affecting versions of base older than 4.4.++ - Changed int type from Int to Word in CheapPseudoRandomBitStream to fix an+ integer overflow warning.++## 1.2.0.0++### Switch to smaller hash codes to go faster and save space.++Before, in the basic and cuckoo hash tables, we were storing full+machine-word-sized hash codes in the table so that we could quickly search a+whole cache line for a key (or a combination of keys) without branching.++It turns out that a full machine word is not really necessary for this+application; switching to a 16-bit key will very slightly increase the number+of hash collisions within buckets (meaning that we'll compare more keys), but+will pay big dividends in terms of:++ - reduced wastage of RAM++ - searching more keys at once, allowing buckets to grow bigger++ - more cache hits on the hash codes array.++### Other++ - Dependency bumps++ - Fix definitions of forwardSearch2 and forwardSearch3 in PORTABLE mode (also+ used on Windows) to match C implementations.++## 1.1.2.1+ - Fixes for GHC 7.8 compatibility.++## 1.1.2.0+ - Bump allowable versions of hashable, primitive, and vector, blacklisting+ some bad hashable versions++ - Add specialize pragmas for fromListWithSizeHint++## 1.1.0.2+ - Use CPP to allow compilation against base 4.2/4.3.++## 1.1.0.1+ - Re-added SPECIALIZE pragmas that were previously removed.++## 1.1.0.0+ - Add 'fromListWithSizeHint'+ - 'fromList': don't be strict in the list argument++## 1.0.1.8+Bump vector and primitive dependencies.++## 1.0.1.7+Fix bug in C FFI code (not correctly promoting CInt to Int).++## 1.0.1.6+Fix for benchmark suite .cabal file.++## 1.0.1.5+Added benchmark suite.++## 1.0.1.4+Bump test-framework dependency.++## 1.0.1.3+Bump testsuite dependencies.++## 1.0.1.2+Fix testsuite on Windows.++## 1.0.1.1+Build fix for Windows.++## 1.0.1.0++Bugfix for http://github.com/gregorycollins/hashtables/issues/1 (Basic.lookup+loops).
hashtables.cabal view
@@ -1,16 +1,32 @@+Cabal-Version: 2.2 Name: hashtables-Version: 1.0.1.8+Version: 1.4.2 Synopsis: Mutable hash tables in the ST monad Homepage: http://github.com/gregorycollins/hashtables-License: BSD3+License: BSD-3-Clause License-file: LICENSE Author: Gregory Collins-Maintainer: greg@gregorycollins.net-Copyright: (c) 2011-2012, Google, Inc.+Maintainer: greg@gregorycollins.net, mgoremeier@gmail.com, erikd@mega-nerd.com+Copyright: (c) 2011-2014, Google, Inc., 2016-present contributors Category: Data Build-type: Simple-Cabal-version: >= 1.8 ++tested-with:+ GHC == 9.12.1+ GHC == 9.10.1+ GHC == 9.8.2+ GHC == 9.6.6+ GHC == 9.4.8+ GHC == 9.2.8+ GHC == 9.0.2+ GHC == 8.10.7+ GHC == 8.8.4+ GHC == 8.6.5+ GHC == 8.4.4+ GHC == 8.2.2+ GHC == 8.0.2+ Description: This package provides a couple of different implementations of mutable hash tables in the ST monad, as well as a typeclass abstracting their common@@ -22,25 +38,25 @@ . This package currently contains three hash table implementations: .- 1. "Data.HashTable.ST.Basic" contains a basic open-addressing hash table- using linear probing as the collision strategy. On a pure speed basis it- should currently be the fastest available Haskell hash table- implementation for lookups, although it has a higher memory overhead- than the other tables and can suffer from long delays when the table is- resized because all of the elements in the table need to be rehashed.- .- 2. "Data.HashTable.ST.Cuckoo" contains an implementation of \"cuckoo+ 1. "Data.HashTable.ST.Cuckoo" contains an implementation of \"cuckoo hashing\" as introduced by Pagh and Rodler in 2001 (see <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.+ the table can perform acceptably well even when approaching 90% full. Randomized testing shows this implementation of cuckoo hashing to be slightly faster on insert and slightly slower on lookup than- "Data.Hashtable.ST.Basic", while being more space efficient by about a+ "Data.HashTable.ST.Basic", while being more space efficient by about a half-word per key-value mapping. Cuckoo hashing, like the basic hash table implementation using linear probing, can suffer from long delays when the table is resized. .+ 2. "Data.HashTable.ST.Basic" contains a basic open-addressing hash table+ using linear probing as the collision strategy. On a pure speed basis it+ should currently be the fastest available Haskell hash table+ implementation for lookups, although it has a higher memory overhead+ than the other tables and can suffer from long delays when the table is+ resized because all of the elements in the table need to be rehashed.+ . 3. "Data.HashTable.ST.Linear" contains a linear hash table (see <http://en.wikipedia.org/wiki/Linear_hashing>), which trades some insert and lookup performance for higher space efficiency and much shorter@@ -76,7 +92,7 @@ dangerous. Caveat emptor. In particular, these techniques are incompatible with HPC code coverage reports. .- * @sse41@, default /OFF/. If this flag is enabled, we use some SSE 4.1+ * @sse42@, default /OFF/. If this flag is enabled, we use some SSE 4.2 instructions (see <http://en.wikipedia.org/wiki/SSE4>, first available on Intel Core 2 processors) to speed up cache-line searches for cuckoo hashing.@@ -89,23 +105,14 @@ . * @portable@, default /OFF/. If this flag is enabled, we use only pure Haskell code and try not to use unportable GHC extensions. Turning this- flag on forces @unsafe-tricks@ and @sse41@ /OFF/.- .- This package has been tested with GHC 7.0.3, on:- .- * a MacBook Pro running Snow Leopard with an Intel Core i5 processor,- running GHC 7.0.3 in 64-bit mode.- .- * an Arch Linux desktop with an AMD Phenom II X4 940 quad-core processor.- .- * a MacBook Pro running Snow Leopard with an Intel Core 2 Duo processor,- running GHC 6.12.3 in 32-bit mode.+ flag on forces @unsafe-tricks@ and @sse42@ /OFF/. . Please send bug reports to <https://github.com/gregorycollins/hashtables/issues>. Extra-Source-Files: README.md,+ cabal.project, haddock.sh, benchmark/hashtable-benchmark.cabal, benchmark/LICENSE,@@ -118,10 +125,13 @@ benchmark/src/Data/Vector/Algorithms/Shuffle.hs, benchmark/src/Data/Benchmarks/UnorderedCollections/Distributions.hs, benchmark/src/Data/Benchmarks/UnorderedCollections/Types.hs,+ cbits/Makefile,+ cbits/check.c,+ cbits/defs.h,+ cbits/sse-42-check.c,+ changelog.md, test/compute-overhead/ComputeOverhead.hs, test/hashtables-test.cabal,- test/runTestsAndCoverage.sh,- test/runTestsNoCoverage.sh, test/suite/Data/HashTable/Test/Common.hs, test/suite/TestSuite.hs @@ -138,9 +148,15 @@ Flag debug Description: if on, spew debugging output to stdout Default: False+ Manual: True -Flag sse41- Description: if on, use SSE 4.1 extensions to search cache lines very+Flag detailed-profiling+ Description: add detailed profiling information to profiled build-depends+ Default: False+ Manual: True++Flag sse42+ Description: if on, use SSE 4.2 extensions to search cache lines very efficiently. The portable flag forces this off. Default: False @@ -150,10 +166,19 @@ Library+ Default-Language: Haskell2010 hs-source-dirs: src + if flag(sse42) && !flag(portable)+ cc-options: -DUSE_SSE_4_2 -msse4.2+ cpp-options: -DUSE_SSE_4_2+ C-sources: cbits/sse-42.c++ if !flag(portable) && !flag(sse42)+ C-sources: cbits/default.c+ if !flag(portable)- C-sources: cbits/cfuncs.c+ C-sources: cbits/common.c Exposed-modules: Data.HashTable.Class, Data.HashTable.IO,@@ -169,17 +194,17 @@ Data.HashTable.Internal.Utils, Data.HashTable.Internal.Linear.Bucket - Build-depends: base >= 4 && <5,- hashable >= 1.1 && <2,- primitive >= 0.4 && <0.6,- vector >= 0.7 && <0.11+ Build-depends: base >= 4.7 && <5,+ hashable >= 1.4 && < 1.6,+ primitive,+ vector >= 0.7 && <0.14 if flag(portable) cpp-options: -DNO_C_SEARCH -DPORTABLE if !flag(portable) && flag(unsafe-tricks) && impl(ghc) build-depends: ghc-prim- cpp-options = -DUNSAFETRICKS+ cpp-options: -DUNSAFETRICKS if flag(debug) cpp-options: -DDEBUG@@ -187,15 +212,90 @@ if flag(bounds-checking) cpp-options: -DBOUNDS_CHECKING - if flag(sse41) && !flag(portable)- cc-options: -DUSE_SSE_4_1 -msse4.1- cpp-options: -DUSE_SSE_4_1+ if flag(detailed-profiling)+ if impl(ghc >= 7.4.1)+ ghc-prof-options: -fprof-auto+ if impl(ghc < 7.4.1)+ ghc-prof-options: -auto-all - ghc-prof-options: -prof -auto-all+ if impl(ghc >= 6.12.0)+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields+ -fno-warn-unused-do-bind+ else+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields +test-suite testsuite+ Default-Language: Haskell2010+ hs-source-dirs: src test/suite+ main-is: TestSuite.hs+ type: exitcode-stdio-1.0++ other-modules:+ Data.HashTable.Class+ Data.HashTable.IO+ Data.HashTable.Internal.Array+ Data.HashTable.Internal.CacheLine+ Data.HashTable.Internal.CheapPseudoRandomBitStream+ Data.HashTable.Internal.IntArray+ Data.HashTable.Internal.Linear.Bucket+ Data.HashTable.Internal.UnsafeTricks+ Data.HashTable.Internal.Utils+ Data.HashTable.ST.Basic+ Data.HashTable.ST.Cuckoo+ Data.HashTable.ST.Linear+ Data.HashTable.Test.Common++ if flag(sse42) && !flag(portable)+ cc-options: -DUSE_SSE_4_2 -msse4.2+ cpp-options: -DUSE_SSE_4_2+ C-sources: cbits/sse-42.c++ if !flag(portable) && !flag(sse42)+ C-sources: cbits/default.c++ if !flag(portable)+ C-sources: cbits/common.c++ if flag(detailed-profiling)+ ghc-prof-options: -auto-all++ if flag(portable)+ cpp-options: -DNO_C_SEARCH -DPORTABLE++ if !flag(portable) && flag(unsafe-tricks) && impl(ghc)+ cpp-options: -DUNSAFETRICKS+ build-depends: ghc-prim++ if flag(debug)+ cpp-options: -DDEBUG++ if flag(bounds-checking)+ cpp-options: -DBOUNDS_CHECKING++ Build-depends: base >= 4 && <5,+ hashable >= 1.4 && < 1.6,+ mwc-random >= 0.8 && <0.16,+ primitive,+ QuickCheck >= 2.9,+ tasty >= 1.4 && <= 1.6,+ tasty-quickcheck >= 0.10 && <0.12,+ tasty-hunit >= 0.10 && <0.11,+ vector >= 0.7++ cpp-options: -DTESTSUITE++ if impl(ghc >= 7)+ ghc-options: -rtsopts+ if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields + if !arch(wasm32)+ ghc-options: -threaded++source-repository head+ type: git+ location: https://github.com/gregorycollins/hashtables.git
src/Data/HashTable/Class.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} -- | This module contains a 'HashTable' typeclass for the hash table -- implementations in this package. This allows you to provide functions which@@ -41,13 +42,17 @@ module Data.HashTable.Class ( HashTable(..) , fromList+ , fromListWithSizeHint , toList ) where -+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+import Data.Word (Word)+#endif import Control.Monad.ST import Data.Hashable-import Prelude hiding (mapM_)+import Prelude hiding (mapM_) -- | A typeclass for hash tables in the 'ST' monad. The operations on these -- hash tables are typically both key- and value-strict.@@ -58,6 +63,25 @@ -- | Creates a new hash table sized to hold @n@ elements. /O(n)/. newSized :: Int -> ST s (h s k v) + -- | Generalized update. Given a key /k/, and a user function /f/, calls:+ --+ -- - `f Nothing` if the key did not exist in the hash table+ -- - `f (Just v)` otherwise+ --+ -- If the user function returns @(Nothing, _)@, then the value is deleted+ -- from the hash table. Otherwise the mapping for /k/ is inserted or+ -- replaced with the provided value.+ --+ -- Returns the second part of the tuple returned by /f/.+ mutate :: (Eq k, Hashable k) =>+ h s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a+ mutate tbl k f = mutateST tbl k (pure . f)++ -- | As 'mutate', except that the action can perform additional side+ -- effects.+ mutateST :: (Eq k, Hashable k) =>+ h s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a+ -- | Inserts a key/value mapping into a hash table, replacing any existing -- mapping for that key. --@@ -80,6 +104,15 @@ -- table. /O(n)/. mapM_ :: ((k,v) -> ST s b) -> h s k v -> ST s () + -- | Looks up the index of a key-value mapping in a hash table suitable+ -- for passing to 'nextByIndex'.+ lookupIndex :: (Eq k, Hashable k) => h s k v -> k -> ST s (Maybe Word)++ -- | Returns the next key-value mapping stored at the given index or at+ -- a greater index. The index, key, and value of the next record are+ -- returned.+ nextByIndex :: h s k v -> Word -> ST s (Maybe (Word,k,v))+ -- | Computes the overhead (in words) per key-value mapping. Used for -- debugging, etc; time complexity depends on the underlying hash table -- implementation. /O(n)/.@@ -90,7 +123,7 @@ -- | 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)+ ht <- new go ht l where@@ -101,6 +134,26 @@ insert ht k v go' xs {-# INLINE fromList #-}+++------------------------------------------------------------------------------+-- | Create a hash table from a list of key-value pairs, with a size hint. /O(n)/.+fromListWithSizeHint :: (HashTable h, Eq k, Hashable k) =>+ Int+ -> [(k,v)]+ -> ST s (h s k v)+fromListWithSizeHint n l = do+ ht <- newSized n+ go ht l++ where+ go ht = go'+ where+ go' [] = return ht+ go' ((!k,!v):xs) = do+ insert ht k v+ go' xs+{-# INLINE fromListWithSizeHint #-} ------------------------------------------------------------------------------
src/Data/HashTable/IO.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExplicitForAll #-} -- | This module provides wrappers in 'IO' around the functions from -- "Data.HashTable.Class".@@ -35,7 +37,7 @@ -- below, you can plug in any of @'BasicHashTable' k v@, @'CuckooHashTable' k -- v@, or @'LinearHashTable' k v@. ---module Data.HashTable.IO +module Data.HashTable.IO ( BasicHashTable , CuckooHashTable , LinearHashTable@@ -45,25 +47,35 @@ , insert , delete , lookup+ , mutate+ , mutateIO , fromList+ , fromListWithSizeHint , toList , mapM_ , foldM , computeOverhead+ , lookupIndex+ , nextByIndex ) 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_)+#if !MIN_VERSION_base(4,8,0)+import Data.Word+#endif+import Control.Monad.Primitive (PrimState)+import Control.Monad.ST (stToIO)+import Data.Hashable (Hashable)+import qualified Data.HashTable.Class as C+import GHC.IO (ioToST)+import Prelude hiding (lookup, mapM_) -------------------------------------------------------------------------------import qualified Data.HashTable.ST.Basic as B-import qualified Data.HashTable.ST.Cuckoo as Cu-import qualified Data.HashTable.ST.Linear as L+import Data.HashTable.Internal.Utils (unsafeIOToST)+import qualified Data.HashTable.ST.Basic as B+import qualified Data.HashTable.ST.Cuckoo as Cu+import qualified Data.HashTable.ST.Linear as L ------------------------------------------------------------------------------@@ -86,7 +98,7 @@ --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:new".+-- | See the documentation for this function in 'Data.HashTable.Class.new'. new :: C.HashTable h => IO (IOHashTable h k v) new = stToIO C.new {-# INLINE new #-}@@ -96,7 +108,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:newSized".+-- 'Data.HashTable.Class.newSized'. newSized :: C.HashTable h => Int -> IO (IOHashTable h k v) newSized = stToIO . C.newSized {-# INLINE newSized #-}@@ -106,78 +118,145 @@ --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:update".+-- | See the documentation for this function in 'Data.HashTable.Class.insert'. insert :: (C.HashTable h, Eq k, Hashable k) => IOHashTable h k v -> k -> v -> IO () insert h k v = stToIO $ C.insert h k v {-# INLINE insert #-}-{-# SPECIALIZE INLINE insert :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE insert :: Hashable k => BasicHashTable k v -> k -> v -> IO () #-}-{-# SPECIALIZE INLINE insert :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE insert :: Hashable k => LinearHashTable k v -> k -> v -> IO () #-}-{-# SPECIALIZE INLINE insert :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE insert :: Hashable k => CuckooHashTable k v -> k -> v -> IO () #-} --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:delete".+-- | See the documentation for this function in 'Data.HashTable.Class.delete'. delete :: (C.HashTable h, Eq k, Hashable k) => IOHashTable h k v -> k -> IO () delete h k = stToIO $ C.delete h k {-# INLINE delete #-}-{-# SPECIALIZE INLINE delete :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE delete :: Hashable k => BasicHashTable k v -> k -> IO () #-}-{-# SPECIALIZE INLINE delete :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE delete :: Hashable k => LinearHashTable k v -> k -> IO () #-}-{-# SPECIALIZE INLINE delete :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE delete :: Hashable k => CuckooHashTable k v -> k -> IO () #-} --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:lookup".+-- | See the documentation for this function in 'Data.HashTable.Class.lookup'. lookup :: (C.HashTable h, Eq k, Hashable k) => IOHashTable h k v -> k -> IO (Maybe v) lookup h k = stToIO $ C.lookup h k {-# INLINE lookup #-}-{-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE lookup :: Hashable k => BasicHashTable k v -> k -> IO (Maybe v) #-}-{-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE lookup :: Hashable k => LinearHashTable k v -> k -> IO (Maybe v) #-}-{-# SPECIALIZE INLINE lookup :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE lookup :: Hashable k => CuckooHashTable k v -> k -> IO (Maybe v) #-} +------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.lookupIndex'.+lookupIndex :: (C.HashTable h, Eq k, Hashable k) =>+ IOHashTable h k v -> k -> IO (Maybe Word)+lookupIndex h k = stToIO $ C.lookupIndex h k+{-# INLINE lookupIndex #-}+{-# SPECIALIZE INLINE lookupIndex :: Hashable k =>+ BasicHashTable k v -> k -> IO (Maybe Word) #-}+{-# SPECIALIZE INLINE lookupIndex :: Hashable k =>+ LinearHashTable k v -> k -> IO (Maybe Word) #-}+{-# SPECIALIZE INLINE lookupIndex :: Hashable k =>+ CuckooHashTable k v -> k -> IO (Maybe Word) #-} ------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.nextByIndex'.+nextByIndex :: (C.HashTable h, Eq k, Hashable k) =>+ IOHashTable h k v -> Word -> IO (Maybe (Word,k,v))+nextByIndex h k = stToIO $ C.nextByIndex h k+{-# INLINE nextByIndex #-}+{-# SPECIALIZE INLINE nextByIndex :: Hashable k =>+ BasicHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}+{-# SPECIALIZE INLINE nextByIndex :: Hashable k =>+ LinearHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}+{-# SPECIALIZE INLINE nextByIndex :: Hashable k =>+ CuckooHashTable k v -> Word -> IO (Maybe (Word,k,v)) #-}++------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.mutateST'.+mutateIO :: (C.HashTable h, Eq k, Hashable k) =>+ IOHashTable h k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a+mutateIO h k f = stToIO $ C.mutateST h k (ioToST . f)+{-# INLINE mutateIO #-}+{-# SPECIALIZE INLINE mutateIO :: Hashable k =>+ BasicHashTable k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutateIO :: Hashable k =>+ LinearHashTable k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutateIO :: Hashable k =>+ CuckooHashTable k v -> k -> (Maybe v -> IO (Maybe v, a)) -> IO a #-}++------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.mutate'.+mutate :: (C.HashTable h, Eq k, Hashable k) =>+ IOHashTable h k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a+mutate h k f = stToIO $ C.mutate h k f+{-# INLINE mutate #-}+{-# SPECIALIZE INLINE mutate :: Hashable k =>+ BasicHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutate :: Hashable k =>+ LinearHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-}+{-# SPECIALIZE INLINE mutate :: Hashable k =>+ CuckooHashTable k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a #-}+++------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:fromList".+-- 'Data.HashTable.Class.fromList'. fromList :: (C.HashTable h, Eq k, Hashable k) => [(k,v)] -> IO (IOHashTable h k v) fromList = stToIO . C.fromList {-# INLINE fromList #-}-{-# SPECIALIZE INLINE fromList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromList :: Hashable k => [(k,v)] -> IO (BasicHashTable k v) #-}-{-# SPECIALIZE INLINE fromList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromList :: Hashable k => [(k,v)] -> IO (LinearHashTable k v) #-}-{-# SPECIALIZE INLINE fromList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE fromList :: Hashable k => [(k,v)] -> IO (CuckooHashTable k v) #-} --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:toList".+-- | See the documentation for this function in+-- 'Data.HashTable.Class.fromListWithSizeHint'.+fromListWithSizeHint :: (C.HashTable h, Eq k, Hashable k) =>+ Int -> [(k,v)] -> IO (IOHashTable h k v)+fromListWithSizeHint n = stToIO . C.fromListWithSizeHint n+{-# INLINE fromListWithSizeHint #-}+{-# SPECIALIZE INLINE fromListWithSizeHint :: Hashable k =>+ Int -> [(k,v)] -> IO (BasicHashTable k v) #-}+{-# SPECIALIZE INLINE fromListWithSizeHint :: Hashable k =>+ Int -> [(k,v)] -> IO (LinearHashTable k v) #-}+{-# SPECIALIZE INLINE fromListWithSizeHint :: Hashable k =>+ Int -> [(k,v)] -> IO (CuckooHashTable k v) #-}+++------------------------------------------------------------------------------+-- | See the documentation for this function in 'Data.HashTable.Class.toList'. toList :: (C.HashTable h, Eq k, Hashable k) => IOHashTable h k v -> IO [(k,v)] toList = stToIO . C.toList {-# INLINE toList #-}-{-# SPECIALIZE INLINE toList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE toList :: Hashable k => BasicHashTable k v -> IO [(k,v)] #-}-{-# SPECIALIZE INLINE toList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE toList :: Hashable k => LinearHashTable k v -> IO [(k,v)] #-}-{-# SPECIALIZE INLINE toList :: (Eq k, Hashable k) =>+{-# SPECIALIZE INLINE toList :: Hashable k => CuckooHashTable k v -> IO [(k,v)] #-} --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:foldM".+-- | See the documentation for this function in 'Data.HashTable.Class.foldM'. foldM :: (C.HashTable h) => (a -> (k,v) -> IO a) -> a@@ -195,7 +274,7 @@ --------------------------------------------------------------------------------- | See the documentation for this function in "Data.HashTable.Class#v:mapM_".+-- | See the documentation for this function in 'Data.HashTable.Class.mapM_'. mapM_ :: (C.HashTable h) => ((k,v) -> IO a) -> IOHashTable h k v -> IO () mapM_ f ht = stToIO $ C.mapM_ f' ht where@@ -211,7 +290,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:computeOverhead".+-- 'Data.HashTable.Class.computeOverhead'. computeOverhead :: (C.HashTable h) => IOHashTable h k v -> IO Double computeOverhead = stToIO . C.computeOverhead {-# INLINE computeOverhead #-}
src/Data/HashTable/Internal/CacheLine.hs view
@@ -16,837 +16,810 @@ , 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 Control.Monad-import Foreign.C.Types-#else-import Data.Bits-import Data.Int-import qualified Data.Vector.Unboxed as U-import GHC.Int-#endif--import Data.HashTable.Internal.Utils-import GHC.Exts---{-# INLINE prefetchRead #-}-{-# INLINE prefetchWrite #-}-prefetchRead :: IntArray s -> Int -> ST s ()-prefetchWrite :: IntArray s -> Int -> ST s ()--#ifndef NO_C_SEARCH-foreign import ccall unsafe "lineSearch32"- c_lineSearch32 :: Ptr a -> CInt -> CUInt -> IO CInt--foreign import ccall unsafe "lineSearch64"- c_lineSearch64 :: Ptr a -> CInt -> CULong -> IO CInt--foreign import ccall unsafe "lineSearch32_2"- c_lineSearch32_2 :: Ptr a -> CInt -> CUInt -> CUInt -> IO CInt--foreign import ccall unsafe "lineSearch64_2"- c_lineSearch64_2 :: Ptr a -> CInt -> CULong -> CULong -> IO CInt--foreign import ccall unsafe "lineSearch32_3"- c_lineSearch32_3 :: Ptr a -> CInt -> CUInt -> CUInt -> CUInt -> IO CInt--foreign import ccall unsafe "lineSearch64_3"- c_lineSearch64_3 :: Ptr a -> CInt -> CULong -> CULong -> CULong -> IO CInt--foreign import ccall unsafe "forwardSearch32_2"- c_forwardSearch32_2 :: Ptr a -> CInt -> CInt -> CUInt -> CUInt -> IO CInt--foreign import ccall unsafe "forwardSearch32_3"- c_forwardSearch32_3 :: Ptr a -> CInt -> CInt -> CUInt -> CUInt -> CUInt- -> IO CInt--foreign import ccall unsafe "forwardSearch64_2"- c_forwardSearch64_2 :: Ptr a -> CInt -> CInt -> CULong -> CULong -> IO CInt--foreign import ccall unsafe "forwardSearch64_3"- c_forwardSearch64_3 :: Ptr a -> CInt -> CInt -> CULong -> CULong -> CULong- -> IO CInt--foreign import ccall unsafe "prefetchCacheLine32_read"- prefetchCacheLine32_read :: Ptr a -> CInt -> IO ()--foreign import ccall unsafe "prefetchCacheLine64_read"- prefetchCacheLine64_read :: Ptr a -> CInt -> IO ()--foreign import ccall unsafe "prefetchCacheLine32_write"- prefetchCacheLine32_write :: Ptr a -> CInt -> IO ()--foreign import ccall unsafe "prefetchCacheLine64_write"- prefetchCacheLine64_write :: Ptr a -> CInt -> IO ()---fI :: (Num b, Integral a) => a -> b-fI = fromIntegral---prefetchRead a i = unsafeIOToST c- where- v = M.toPtr a- x = fI i- c32 = prefetchCacheLine32_read v x- c64 = prefetchCacheLine64_read v x- c = if wordSize == 32 then c32 else c64---prefetchWrite a i = unsafeIOToST c- where- v = M.toPtr a- x = fI i- c32 = prefetchCacheLine32_write v x- c64 = prefetchCacheLine64_write v x- c = if wordSize == 32 then c32 else c64---{-# INLINE forwardSearch2 #-}-forwardSearch2 :: IntArray s -> Int -> Int -> Int -> Int -> ST s Int-forwardSearch2 !vec !start !end !x1 !x2 =- liftM fromEnum $! unsafeIOToST c- where- c32 = c_forwardSearch32_2 (M.toPtr vec) (fI start) (fI end) (fI x1) (fI x2)- c64 = c_forwardSearch64_2 (M.toPtr vec) (fI start) (fI end) (fI x1) (fI x2)- c = if wordSize == 32 then c32 else c64---{-# INLINE forwardSearch3 #-}-forwardSearch3 :: IntArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int-forwardSearch3 !vec !start !end !x1 !x2 !x3 =- liftM fromEnum $! unsafeIOToST c- where- c32 = c_forwardSearch32_3 (M.toPtr vec) (fI start) (fI end)- (fI x1) (fI x2) (fI x3)- c64 = c_forwardSearch64_3 (M.toPtr vec) (fI start) (fI end)- (fI x1) (fI x2) (fI x3)- c = if wordSize == 32 then c32 else c64---{-# INLINE lineSearch #-}-lineSearch :: IntArray s -> Int -> Int -> ST s Int-lineSearch !vec !start !value =- liftM fromEnum $! unsafeIOToST c- where- c32 = c_lineSearch32 (M.toPtr vec) (fI start) (fI value)- c64 = c_lineSearch64 (M.toPtr vec) (fI start) (fI value)- c = if wordSize == 32 then c32 else c64--{-# INLINE lineSearch2 #-}-lineSearch2 :: IntArray s -> Int -> Int -> Int -> ST s Int-lineSearch2 !vec !start !x1 !x2 =- liftM fromEnum $! unsafeIOToST c- where- c32 = c_lineSearch32_2 (M.toPtr vec) (fI start) (fI x1) (fI x2)- c64 = c_lineSearch64_2 (M.toPtr vec) (fI start) (fI x1) (fI x2)- c = if wordSize == 32 then c32 else c64--{-# INLINE lineSearch3 #-}-lineSearch3 :: IntArray s -> Int -> Int -> Int -> Int -> ST s Int-lineSearch3 !vec !start !x1 !x2 !x3 =- liftM fromEnum $! unsafeIOToST c- where- c32 = c_lineSearch32_3 (M.toPtr vec) (fI start) (fI x1) (fI x2) (fI x3)- c64 = c_lineSearch64_3 (M.toPtr vec) (fI start) (fI x1) (fI x2) (fI x3)- c = if wordSize == 32 then c32 else c64-#endif--{-# INLINE advanceByCacheLineSize #-}-advanceByCacheLineSize :: Int -> Int -> Int-advanceByCacheLineSize !(I# start0#) !(I# vecSize#) = out- where- !(I# clm#) = cacheLineIntMask- !clmm# = not# (int2Word# clm#)- !start# = word2Int# (clmm# `and#` int2Word# start0#)- !(I# nw#) = numWordsInCacheLine- !start'# = start# +# nw#- !s# = sign# (vecSize# -# start'# -# 1#)- !m# = not# (int2Word# s#)- !r# = int2Word# start'# `and#` m#- !out = I# (word2Int# r#)---{-# INLINE isCacheLineAligned #-}-isCacheLineAligned :: Int -> Bool-isCacheLineAligned (I# x#) = r# ==# 0#- where- !(I# m#) = cacheLineIntMask- !mw# = int2Word# m#- !w# = int2Word# x#- !r# = word2Int# (mw# `and#` w#)---{-# INLINE sign# #-}--- | Returns 0 if x is positive, -1 otherwise-sign# :: Int# -> Int#-sign# !x# = x# `uncheckedIShiftRA#` wordSizeMinus1#- where- !(I# wordSizeMinus1#) = wordSize-1---{-# INLINE bl_abs# #-}--- | Abs of an integer, branchless-bl_abs# :: Int# -> Int#-bl_abs# !x# = word2Int# r#- where- !m# = sign# x#- !r# = (int2Word# (m# +# x#)) `xor#` int2Word# m#---{-# INLINE mask# #-}--- | Returns 0xfff..fff (aka -1) if a# == b#, 0 otherwise.-mask# :: Int# -> Int# -> Int#-mask# !a# !b# = dest#- where- !d# = a# -# b#- !r# = bl_abs# d# -# 1#- !dest# = sign# r#---{- note: this code should be:--mask# :: Int# -> Int# -> Int#-mask# !a# !b# = let !(I# z#) = fromEnum (a# ==# b#)- !q# = negateInt# z#- in q#--but GHC doesn't properly optimize this as straight-line code at the moment.---}---{-# INLINE maskw# #-}-maskw# :: Int# -> Int# -> Word#-maskw# !a# !b# = int2Word# (mask# a# b#)---#ifdef NO_C_SEARCH-prefetchRead _ _ = return ()-prefetchWrite _ _ = return ()--{-# INLINE forwardSearch2 #-}-forwardSearch2 :: IntArray s -> Int -> Int -> Int -> Int -> ST s Int-forwardSearch2 !vec !start !end !x1 !x2 = go start end False- where- next !i !e !b = let !j = i+1- in if j == e- then (if b then (-1,e,True) else (0,start,True))- else (j,e,b)-- go !i !e !b = do- h <- M.readArray vec i- if h == x1 || h == x2- then return i- else do- let (!i',!e',!b') = next i e b- if (i' < 0) then return (-1) else go i' e' b'---{-# INLINE forwardSearch3 #-}-forwardSearch3 :: IntArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int-forwardSearch3 !vec !start !end !x1 !x2 !x3 = go start end False- where- next !i !e !b = let !j = i+1- in if j == e- then (if b then (-1,e,True) else (0,start,True))- else (j,e,b)-- go !i !e !b = do- h <- M.readArray vec i- if h == x1 || h == x2 || h == x3- then return i- else do- let (!i',!e',!b') = next i e b- if (i' < 0) then return (-1) else go i' e' b'---deBruijnBitPositions :: U.Vector Int8-deBruijnBitPositions =- U.fromList [- 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,- 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9- ]---{-# INLINE firstBitSet# #-}--- only works with 32-bit values -- ok for us here-firstBitSet# :: Int# -> Int#-firstBitSet# i# = word2Int# ((or# zeroCase# posw#))- where- !zeroCase# = int2Word# (mask# 0# i#)- !w# = int2Word# i#- !iLowest# = word2Int# (and# w# (int2Word# (negateInt# i#)))- !idxW# = uncheckedShiftRL#- (narrow32Word# (timesWord# (int2Word# iLowest#)- (int2Word# 0x077CB531#)))- 27#- !idx = I# (word2Int# idxW#)- !(I8# pos8#) = U.unsafeIndex deBruijnBitPositions idx- !posw# = int2Word# pos8#--#endif------------------------------------------------------------------------------------ | Search through a mutable vector for a given int value, cache-line aligned.--- If the start index is cache-line aligned, and there is more than a--- cache-line's room between the start index and the end of the vector, we will--- search the cache-line all at once using an efficient branchless--- bit-twiddling technique. Otherwise, we will use a typical loop.----cacheLineSearch :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-cacheLineSearch !vec !start !value = do-#ifdef NO_C_SEARCH- let !vlen = M.length vec- let !st1 = vlen - start- let !nvlen = numWordsInCacheLine - st1- let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask- let st2 = adv - start--- if nvlen > 0 || not (isCacheLineAligned start)- then naiveSearch vec start (min st1 st2) value- else lineSearch vec start value-#else- lineSearch vec start value-#endif-{-# INLINE cacheLineSearch #-}---#ifdef NO_C_SEARCH--- | Search through a mutable vector for a given int value. The number of--- things to search for must be at most the number of things remaining in the--- vector.-naiveSearch :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ number of things to search- -> Int -- ^ value to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-naiveSearch !vec !start !nThings !value = go start- where- !doneIdx = start + nThings-- go !i | i >= doneIdx = return (-1)- | otherwise = do- x <- M.readArray vec i- if x == value then return i else go (i+1)-{-# INLINE naiveSearch #-}---lineResult# :: Word# -- ^ mask- -> Int -- ^ start value- -> Int-lineResult# bitmask# (I# start#) = I# (word2Int# rv#)- where- !p# = firstBitSet# (word2Int# bitmask#)- !mm# = maskw# p# (-1#)- !nmm# = not# mm#- !rv# = mm# `or#` (nmm# `and#` (int2Word# (start# +# p#)))-{-# INLINE lineResult# #-}---lineSearch :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch | wordSize == 32 = lineSearch32- | otherwise = lineSearch64-{-# INLINE lineSearch #-}---lineSearch64 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch64 !vec !start !(I# v#) = do- (I# x1#) <- M.readArray vec $! start + 0- let !p1# = maskw# x1# v# `and#` int2Word# 0x1#-- (I# x2#) <- M.readArray vec $! start + 1- let !p2# = p1# `or#` (maskw# x2# v# `and#` int2Word# 0x2#)-- (I# x3#) <- M.readArray vec $! start + 2- let !p3# = p2# `or#` (maskw# x3# v# `and#` int2Word# 0x4#)-- (I# x4#) <- M.readArray vec $! start + 3- let !p4# = p3# `or#` (maskw# x4# v# `and#` int2Word# 0x8#)-- (I# x5#) <- M.readArray vec $! start + 4- let !p5# = p4# `or#` (maskw# x5# v# `and#` int2Word# 0x10#)-- (I# x6#) <- M.readArray vec $! start + 5- let !p6# = p5# `or#` (maskw# x6# v# `and#` int2Word# 0x20#)-- (I# x7#) <- M.readArray vec $! start + 6- let !p7# = p6# `or#` (maskw# x7# v# `and#` int2Word# 0x40#)-- (I# x8#) <- M.readArray vec $! start + 7- let !p8# = p7# `or#` (maskw# x8# v# `and#` int2Word# 0x80#)-- return $! lineResult# p8# start-{-# INLINE lineSearch64 #-}----lineSearch32 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch32 !vec !start !(I# v#) = do- (I# x1#) <- M.readArray vec $! start + 0- let !p1# = maskw# x1# v# `and#` int2Word# 0x1#-- (I# x2#) <- M.readArray vec $! start + 1- let !p2# = p1# `or#` (maskw# x2# v# `and#` int2Word# 0x2#)-- (I# x3#) <- M.readArray vec $! start + 2- let !p3# = p2# `or#` (maskw# x3# v# `and#` int2Word# 0x4#)-- (I# x4#) <- M.readArray vec $! start + 3- let !p4# = p3# `or#` (maskw# x4# v# `and#` int2Word# 0x8#)-- (I# x5#) <- M.readArray vec $! start + 4- let !p5# = p4# `or#` (maskw# x5# v# `and#` int2Word# 0x10#)-- (I# x6#) <- M.readArray vec $! start + 5- let !p6# = p5# `or#` (maskw# x6# v# `and#` int2Word# 0x20#)-- (I# x7#) <- M.readArray vec $! start + 6- let !p7# = p6# `or#` (maskw# x7# v# `and#` int2Word# 0x40#)-- (I# x8#) <- M.readArray vec $! start + 7- let !p8# = p7# `or#` (maskw# x8# v# `and#` int2Word# 0x80#)-- (I# x9#) <- M.readArray vec $! start + 8- let !p9# = p8# `or#` (maskw# x9# v# `and#` int2Word# 0x100#)-- (I# x10#) <- M.readArray vec $! start + 9- let !p10# = p9# `or#` (maskw# x10# v# `and#` int2Word# 0x200#)-- (I# x11#) <- M.readArray vec $! start + 10- let !p11# = p10# `or#` (maskw# x11# v# `and#` int2Word# 0x400#)-- (I# x12#) <- M.readArray vec $! start + 11- let !p12# = p11# `or#` (maskw# x12# v# `and#` int2Word# 0x800#)-- (I# x13#) <- M.readArray vec $! start + 12- let !p13# = p12# `or#` (maskw# x13# v# `and#` int2Word# 0x1000#)-- (I# x14#) <- M.readArray vec $! start + 13- let !p14# = p13# `or#` (maskw# x14# v# `and#` int2Word# 0x2000#)-- (I# x15#) <- M.readArray vec $! start + 14- let !p15# = p14# `or#` (maskw# x15# v# `and#` int2Word# 0x4000#)-- (I# x16#) <- M.readArray vec $! start + 15- let !p16# = p15# `or#` (maskw# x16# v# `and#` int2Word# 0x8000#)-- return $! lineResult# p16# start-{-# INLINE lineSearch32 #-}--#endif----------------------------------------------------------------------------------- | Search through a mutable vector for one of two given int values,--- cache-line aligned. If the start index is cache-line aligned, and there is--- more than a cache-line's room between the start index and the end of the--- vector, we will search the cache-line all at once using an efficient--- branchless bit-twiddling technique. Otherwise, we will use a typical loop.----cacheLineSearch2 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-cacheLineSearch2 !vec !start !value !value2 = do-#ifdef NO_C_SEARCH- let !vlen = M.length vec- let !st1 = vlen - start- let !nvlen = numWordsInCacheLine - st1- let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask- let st2 = adv - start-- if nvlen > 0 || not (isCacheLineAligned start)- then naiveSearch2 vec start (min st1 st2) value value2- else lineSearch2 vec start value value2-#else- lineSearch2 vec start value value2-#endif-{-# INLINE cacheLineSearch2 #-}---#ifdef NO_C_SEARCH--naiveSearch2 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ number of things to search- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-naiveSearch2 !vec !start !nThings !value1 !value2 = go start- where- !doneIdx = start + nThings-- go !i | i >= doneIdx = return (-1)- | otherwise = do- x <- M.readArray vec i- if x == value1 || x == value2 then return i else go (i+1)-{-# INLINE naiveSearch2 #-}---lineSearch2 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch2 | wordSize == 32 = lineSearch32_2- | otherwise = lineSearch64_2----lineSearch64_2 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch64_2 !vec !start !(I# v#) !(I# v2#) = do- (I# x1#) <- M.readArray vec $! start + 0- let !p1# = (maskw# x1# v# `or#` maskw# x1# v2#) `and#` int2Word# 0x1#-- (I# x2#) <- M.readArray vec $! start + 1- let !p2# = p1# `or#` ((maskw# x2# v# `or#` maskw# x2# v2#)- `and#` int2Word# 0x2#)-- (I# x3#) <- M.readArray vec $! start + 2- let !p3# = p2# `or#` ((maskw# x3# v# `or#` maskw# x3# v2#)- `and#` int2Word# 0x4#)-- (I# x4#) <- M.readArray vec $! start + 3- let !p4# = p3# `or#` ((maskw# x4# v# `or#` maskw# x4# v2#)- `and#` int2Word# 0x8#)-- (I# x5#) <- M.readArray vec $! start + 4- let !p5# = p4# `or#` ((maskw# x5# v# `or#` maskw# x5# v2#)- `and#` int2Word# 0x10#)-- (I# x6#) <- M.readArray vec $! start + 5- let !p6# = p5# `or#` ((maskw# x6# v# `or#` maskw# x6# v2#)- `and#` int2Word# 0x20#)-- (I# x7#) <- M.readArray vec $! start + 6- let !p7# = p6# `or#` ((maskw# x7# v# `or#` maskw# x7# v2#)- `and#` int2Word# 0x40#)-- (I# x8#) <- M.readArray vec $! start + 7- let !p8# = p7# `or#` ((maskw# x8# v# `or#` maskw# x8# v2#)- `and#` int2Word# 0x80#)-- return $! lineResult# p8# start-{-# INLINE lineSearch64_2 #-}---lineSearch32_2 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch32_2 !vec !start !(I# v#) !(I# v2#) = do- (I# x1#) <- M.readArray vec $! start + 0- let !p1# = (maskw# x1# v# `or#` maskw# x1# v2#) `and#` int2Word# 0x1#-- (I# x2#) <- M.readArray vec $! start + 1- let !p2# = p1# `or#` ((maskw# x2# v# `or#` maskw# x2# v2#)- `and#` int2Word# 0x2#)-- (I# x3#) <- M.readArray vec $! start + 2- let !p3# = p2# `or#` ((maskw# x3# v# `or#` maskw# x3# v2#)- `and#` int2Word# 0x4#)-- (I# x4#) <- M.readArray vec $! start + 3- let !p4# = p3# `or#` ((maskw# x4# v# `or#` maskw# x4# v2#)- `and#` int2Word# 0x8#)-- (I# x5#) <- M.readArray vec $! start + 4- let !p5# = p4# `or#` ((maskw# x5# v# `or#` maskw# x5# v2#)- `and#` int2Word# 0x10#)-- (I# x6#) <- M.readArray vec $! start + 5- let !p6# = p5# `or#` ((maskw# x6# v# `or#` maskw# x6# v2#)- `and#` int2Word# 0x20#)-- (I# x7#) <- M.readArray vec $! start + 6- let !p7# = p6# `or#` ((maskw# x7# v# `or#` maskw# x7# v2#)- `and#` int2Word# 0x40#)-- (I# x8#) <- M.readArray vec $! start + 7- let !p8# = p7# `or#` ((maskw# x8# v# `or#` maskw# x8# v2#)- `and#` int2Word# 0x80#)-- (I# x9#) <- M.readArray vec $! start + 8- let !p9# = p8# `or#` ((maskw# x9# v# `or#` maskw# x9# v2#)- `and#` int2Word# 0x100#)-- (I# x10#) <- M.readArray vec $! start + 9- let !p10# = p9# `or#` ((maskw# x10# v# `or#` maskw# x10# v2#)- `and#` int2Word# 0x200#)-- (I# x11#) <- M.readArray vec $! start + 10- let !p11# = p10# `or#` ((maskw# x11# v# `or#` maskw# x11# v2#)- `and#` int2Word# 0x400#)-- (I# x12#) <- M.readArray vec $! start + 11- let !p12# = p11# `or#` ((maskw# x12# v# `or#` maskw# x12# v2#)- `and#` int2Word# 0x800#)-- (I# x13#) <- M.readArray vec $! start + 12- let !p13# = p12# `or#` ((maskw# x13# v# `or#` maskw# x13# v2#)- `and#` int2Word# 0x1000#)-- (I# x14#) <- M.readArray vec $! start + 13- let !p14# = p13# `or#` ((maskw# x14# v# `or#` maskw# x14# v2#)- `and#` int2Word# 0x2000#)-- (I# x15#) <- M.readArray vec $! start + 14- let !p15# = p14# `or#` ((maskw# x15# v# `or#` maskw# x15# v2#)- `and#` int2Word# 0x4000#)-- (I# x16#) <- M.readArray vec $! start + 15- let !p16# = p15# `or#` ((maskw# x16# v# `or#` maskw# x16# v2#)- `and#` int2Word# 0x8000#)-- return $! lineResult# p16# start-{-# INLINE lineSearch32_2 #-}--#endif------------------------------------------------------------------------------------ | Search through a mutable vector for one of three given int values,--- cache-line aligned. If the start index is cache-line aligned, and there is--- more than a cache-line's room between the start index and the end of the--- vector, we will search the cache-line all at once using an efficient--- branchless bit-twiddling technique. Otherwise, we will use a typical loop.----cacheLineSearch3 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> Int -- ^ value 3 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-cacheLineSearch3 !vec !start !value !value2 !value3 = do-#ifdef NO_C_SEARCH- let !vlen = M.length vec- let !st1 = vlen - start- let !nvlen = numWordsInCacheLine - st1- let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask- let st2 = adv - start-- if nvlen > 0 || not (isCacheLineAligned start)- then naiveSearch3 vec start (min st1 st2) value value2 value3- else lineSearch3 vec start value value2 value3-#else- lineSearch3 vec start value value2 value3-#endif-{-# INLINE cacheLineSearch3 #-}---#ifdef NO_C_SEARCH--naiveSearch3 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ number of things to search- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> Int -- ^ value 3 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-naiveSearch3 !vec !start !nThings !value1 !value2 !value3 = go start- where- !doneIdx = start + nThings-- go !i | i >= doneIdx = return (-1)- | otherwise = do- x <- M.readArray vec i- if x == value1 || x == value2 || x == value3- then return i- else go (i+1)-{-# INLINE naiveSearch3 #-}---lineSearch3 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> Int -- ^ value 3 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch3 | wordSize == 32 = lineSearch32_3- | otherwise = lineSearch64_3----lineSearch64_3 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> Int -- ^ value 3 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch64_3 !vec !start !(I# v#) !(I# v2#) !(I# v3#) = do- (I# x1#) <- M.readArray vec $! start + 0- let !p1# = (maskw# x1# v# `or#` maskw# x1# v2# `or#` maskw# x1# v3#)- `and#` int2Word# 0x1#-- (I# x2#) <- M.readArray vec $! start + 1- let !p2# = p1# `or#`- ((maskw# x2# v# `or#` maskw# x2# v2# `or#` maskw# x2# v3#)- `and#` int2Word# 0x2#)-- (I# x3#) <- M.readArray vec $! start + 2- let !p3# = p2# `or#`- ((maskw# x3# v# `or#` maskw# x3# v2# `or#` maskw# x3# v3#)- `and#` int2Word# 0x4#)-- (I# x4#) <- M.readArray vec $! start + 3- let !p4# = p3# `or#`- ((maskw# x4# v# `or#` maskw# x4# v2# `or#` maskw# x4# v3#)- `and#` int2Word# 0x8#)-- (I# x5#) <- M.readArray vec $! start + 4- let !p5# = p4# `or#`- ((maskw# x5# v# `or#` maskw# x5# v2# `or#` maskw# x5# v3#)- `and#` int2Word# 0x10#)-- (I# x6#) <- M.readArray vec $! start + 5- let !p6# = p5# `or#`- ((maskw# x6# v# `or#` maskw# x6# v2# `or#` maskw# x6# v3#)- `and#` int2Word# 0x20#)-- (I# x7#) <- M.readArray vec $! start + 6- let !p7# = p6# `or#`- ((maskw# x7# v# `or#` maskw# x7# v2# `or#` maskw# x7# v3#)- `and#` int2Word# 0x40#)-- (I# x8#) <- M.readArray vec $! start + 7- let !p8# = p7# `or#`- ((maskw# x8# v# `or#` maskw# x8# v2# `or#` maskw# x8# v3#)- `and#` int2Word# 0x80#)-- return $! lineResult# p8# start-{-# INLINE lineSearch64_3 #-}---lineSearch32_3 :: IntArray s -- ^ vector to search- -> Int -- ^ start index- -> Int -- ^ value to search for- -> Int -- ^ value 2 to search for- -> Int -- ^ value 3 to search for- -> ST s Int -- ^ dest index where it can be found, or- -- \"-1\" if not found-lineSearch32_3 !vec !start !(I# v#) !(I# v2#) !(I# v3#) = do- (I# x1#) <- M.readArray vec $! start + 0- let !p1# = (maskw# x1# v# `or#` maskw# x1# v2# `or#` maskw# x1# v3#)- `and#` int2Word# 0x1#-- (I# x2#) <- M.readArray vec $! start + 1- let !p2# = p1# `or#`- ((maskw# x2# v# `or#` maskw# x2# v2# `or#` maskw# x2# v3#)- `and#` int2Word# 0x2#)-- (I# x3#) <- M.readArray vec $! start + 2- let !p3# = p2# `or#`- ((maskw# x3# v# `or#` maskw# x3# v2# `or#` maskw# x3# v3#)- `and#` int2Word# 0x4#)-- (I# x4#) <- M.readArray vec $! start + 3- let !p4# = p3# `or#`- ((maskw# x4# v# `or#` maskw# x4# v2# `or#` maskw# x4# v3#)- `and#` int2Word# 0x8#)-- (I# x5#) <- M.readArray vec $! start + 4- let !p5# = p4# `or#`- ((maskw# x5# v# `or#` maskw# x5# v2# `or#` maskw# x5# v3#)- `and#` int2Word# 0x10#)-- (I# x6#) <- M.readArray vec $! start + 5- let !p6# = p5# `or#`- ((maskw# x6# v# `or#` maskw# x6# v2# `or#` maskw# x6# v3#)- `and#` int2Word# 0x20#)-- (I# x7#) <- M.readArray vec $! start + 6- let !p7# = p6# `or#`- ((maskw# x7# v# `or#` maskw# x7# v2# `or#` maskw# x7# v3#)- `and#` int2Word# 0x40#)-- (I# x8#) <- M.readArray vec $! start + 7- let !p8# = p7# `or#`- ((maskw# x8# v# `or#` maskw# x8# v2# `or#` maskw# x8# v3#)- `and#` int2Word# 0x80#)-- (I# x9#) <- M.readArray vec $! start + 8- let !p9# = p8# `or#`- ((maskw# x9# v# `or#` maskw# x9# v2# `or#` maskw# x9# v3#)- `and#` int2Word# 0x100#)-- (I# x10#) <- M.readArray vec $! start + 9- let !p10# = p9# `or#`- ((maskw# x10# v# `or#` maskw# x10# v2# `or#` maskw# x10# v3#)- `and#` int2Word# 0x200#)-- (I# x11#) <- M.readArray vec $! start + 10- let !p11# = p10# `or#`- ((maskw# x11# v# `or#` maskw# x11# v2# `or#` maskw# x11# v3#)- `and#` int2Word# 0x400#)-- (I# x12#) <- M.readArray vec $! start + 11- let !p12# = p11# `or#`- ((maskw# x12# v# `or#` maskw# x12# v2# `or#` maskw# x12# v3#)- `and#` int2Word# 0x800#)-- (I# x13#) <- M.readArray vec $! start + 12- let !p13# = p12# `or#`- ((maskw# x13# v# `or#` maskw# x13# v2# `or#` maskw# x13# v3#)- `and#` int2Word# 0x1000#)-- (I# x14#) <- M.readArray vec $! start + 13- let !p14# = p13# `or#`- ((maskw# x14# v# `or#` maskw# x14# v2# `or#` maskw# x14# v3#)- `and#` int2Word# 0x2000#)-- (I# x15#) <- M.readArray vec $! start + 14- let !p15# = p14# `or#`- ((maskw# x15# v# `or#` maskw# x15# v2# `or#` maskw# x15# v3#)- `and#` int2Word# 0x4000#)-- (I# x16#) <- M.readArray vec $! start + 15- let !p16# = p15# `or#`- ((maskw# x16# v# `or#` maskw# x16# v2# `or#` maskw# x16# v3#)- `and#` int2Word# 0x8000#)-- return $! lineResult# p16# start-{-# INLINE lineSearch32_3 #-}--#endif+ , mask+ , maskw#+ ) where++import Control.Monad+import Control.Monad.ST (ST)++import Data.HashTable.Internal.IntArray (Elem, IntArray)+import qualified Data.HashTable.Internal.IntArray as M++#ifndef NO_C_SEARCH+import Foreign.C.Types+#else+import Data.Bits+import Data.Int+import qualified Data.Vector.Unboxed as U+import GHC.Int+#endif++import Data.HashTable.Internal.Utils+import GHC.Exts++{-# INLINE prefetchRead #-}+{-# INLINE prefetchWrite #-}+prefetchRead :: IntArray s -> Int -> ST s ()+prefetchWrite :: IntArray s -> Int -> ST s ()++#ifndef NO_C_SEARCH+foreign import ccall unsafe "line_search"+ c_lineSearch :: Ptr a -> CInt -> CUShort -> IO CInt++foreign import ccall unsafe "line_search_2"+ c_lineSearch_2 :: Ptr a -> CInt -> CUShort -> CUShort -> IO CInt++foreign import ccall unsafe "line_search_3"+ c_lineSearch_3 :: Ptr a -> CInt -> CUShort -> CUShort -> CUShort -> IO CInt++foreign import ccall unsafe "forward_search_2"+ c_forwardSearch_2 :: Ptr a -> CInt -> CInt -> CUShort -> CUShort -> IO CInt++foreign import ccall unsafe "forward_search_3"+ c_forwardSearch_3 :: Ptr a -> CInt -> CInt -> CUShort -> CUShort -> CUShort+ -> IO CInt++foreign import ccall unsafe "prefetch_cacheline_read"+ prefetchCacheLine_read :: Ptr a -> CInt -> IO ()++foreign import ccall unsafe "prefetch_cacheline_write"+ prefetchCacheLine_write :: Ptr a -> CInt -> IO ()+++fI :: (Num b, Integral a) => a -> b+fI = fromIntegral++prefetchRead a i = unsafeIOToST $ prefetchCacheLine_read v x+ where+ v = M.toPtr a+ x = fI i++prefetchWrite a i = unsafeIOToST $ prefetchCacheLine_write v x+ where+ v = M.toPtr a+ x = fI i+++{-# INLINE forwardSearch2 #-}+forwardSearch2 :: IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int+forwardSearch2 !vec !start !end !x1 !x2 =+ liftM fromEnum $! unsafeIOToST c+ where+ c = c_forwardSearch_2 (M.toPtr vec) (fI start) (fI end) (fI x1) (fI x2)+++{-# INLINE forwardSearch3 #-}+forwardSearch3 :: IntArray s -> Int -> Int -> Elem -> Elem -> Elem -> ST s Int+forwardSearch3 !vec !start !end !x1 !x2 !x3 =+ liftM fromEnum $! unsafeIOToST c+ where+ c = c_forwardSearch_3 (M.toPtr vec) (fI start) (fI end)+ (fI x1) (fI x2) (fI x3)+++{-# INLINE lineSearch #-}+lineSearch :: IntArray s -> Int -> Elem -> ST s Int+lineSearch !vec !start !value =+ liftM fromEnum $! unsafeIOToST c+ where+ c = c_lineSearch (M.toPtr vec) (fI start) (fI value)+++{-# INLINE lineSearch2 #-}+lineSearch2 :: IntArray s -> Int -> Elem -> Elem -> ST s Int+lineSearch2 !vec !start !x1 !x2 =+ liftM fromEnum $! unsafeIOToST c+ where+ c = c_lineSearch_2 (M.toPtr vec) (fI start) (fI x1) (fI x2)+++{-# INLINE lineSearch3 #-}+lineSearch3 :: IntArray s -> Int -> Elem -> Elem -> Elem -> ST s Int+lineSearch3 !vec !start !x1 !x2 !x3 =+ liftM fromEnum $! unsafeIOToST c+ where+ c = c_lineSearch_3 (M.toPtr vec) (fI start) (fI x1) (fI x2) (fI x3)+#endif++{-# INLINE advanceByCacheLineSize #-}+advanceByCacheLineSize :: Int -> Int -> Int+advanceByCacheLineSize !(I# start0#) !(I# vecSize#) = out+ where+ !(I# clm#) = cacheLineIntMask+ !clmm# = not# (int2Word# clm#)+ !start# = word2Int# (clmm# `and#` int2Word# start0#)+ !(I# nw#) = numElemsInCacheLine+ !start'# = start# +# nw#+ !s# = sign# (vecSize# -# start'# -# 1#)+ !m# = not# (int2Word# s#)+ !r# = int2Word# start'# `and#` m#+ !out = I# (word2Int# r#)+++{-# INLINE isCacheLineAligned #-}+isCacheLineAligned :: Int -> Bool+isCacheLineAligned (I# x#) = isTrue# (r# ==# 0#)+ where+ !(I# m#) = cacheLineIntMask+ !mw# = int2Word# m#+ !w# = int2Word# x#+ !r# = word2Int# (mw# `and#` w#)+++{-# INLINE sign# #-}+-- | Returns 0 if x is positive, -1 otherwise+sign# :: Int# -> Int#+sign# !x# = x# `uncheckedIShiftRA#` wordSizeMinus1#+ where+ !(I# wordSizeMinus1#) = wordSize-1+++{-# INLINE bl_abs# #-}+-- | Abs of an integer, branchless+bl_abs# :: Int# -> Int#+bl_abs# !x# = word2Int# r#+ where+ !m# = sign# x#+ !r# = (int2Word# (m# +# x#)) `xor#` int2Word# m#+++{-# INLINE mask# #-}+-- | Returns 0xfff..fff (aka -1) if a# == b#, 0 otherwise.+mask# :: Int# -> Int# -> Int#+mask# !a# !b# = dest#+ where+ !d# = a# -# b#+ !r# = bl_abs# d# -# 1#+ !dest# = sign# r#+++{- note: this code should be:++mask# :: Int# -> Int# -> Int#+mask# !a# !b# = let !(I# z#) = fromEnum (a# ==# b#)+ !q# = negateInt# z#+ in q#++but GHC doesn't properly optimize this as straight-line code at the moment.++-}+++{-# INLINE mask #-}+-- | Returns 0xfff..fff (aka -1) if a == b, 0 otherwise.+mask :: Int -> Int -> Int+mask (I# a#) (I# b#) = I# (mask# a# b#)+++{-# INLINE maskw# #-}+maskw# :: Int# -> Int# -> Word#+maskw# !a# !b# = int2Word# (mask# a# b#)+++#ifdef NO_C_SEARCH+prefetchRead _ _ = return ()+prefetchWrite _ _ = return ()++{-# INLINE forwardSearch2 #-}+forwardSearch2 :: IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int+forwardSearch2 !vec !start !end !x1 !x2 = go start end False+ where+ go !i !e !b =+ if i >= e then+ if b then return (-1) else go 0 start True+ else do+ h <- M.readArray vec i+ if h == x1 || h == x2+ then return i+ else go (i+1) e b+++{-# INLINE forwardSearch3 #-}+forwardSearch3 :: IntArray s -> Int -> Int -> Elem -> Elem -> Elem -> ST s Int+forwardSearch3 !vec !start !end !x1 !x2 !x3 = go start end False+ where+ go !i !e !b =+ if i >= e then+ if b then return (-1) else go 0 start True+ else do+ h <- M.readArray vec i+ if h == x1 || h == x2 || h == x3+ then return i+ else go (i+1) e b+++deBruijnBitPositions :: U.Vector Int8+deBruijnBitPositions =+ U.fromList [+ 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8,+ 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9+ ]+++{-# INLINE firstBitSet# #-}+-- only works with 32-bit values -- ok for us here+firstBitSet# :: Int# -> Int#+firstBitSet# i# = word2Int# ((or# zeroCase# posw#))+ where+ !zeroCase# = int2Word# (mask# 0# i#)+ !w# = int2Word# i#+ !iLowest# = word2Int# (and# w# (int2Word# (negateInt# i#)))+ !idxW# = uncheckedShiftRL#+ (narrow32Word# (timesWord# (int2Word# iLowest#)+ (int2Word# 0x077CB531#)))+ 27#+ !idx = I# (word2Int# idxW#)+ !(I8# pos8#) = U.unsafeIndex deBruijnBitPositions idx+#if __GLASGOW_HASKELL__ >= 900+ !posw# = int2Word# (int8ToInt# pos8#)+#else+ !posw# = int2Word# pos8#+#endif+#endif+++#ifdef NO_C_SEARCH+lineResult# :: Word# -- ^ mask+ -> Int -- ^ start value+ -> Int+lineResult# bitmask# (I# start#) = I# (word2Int# rv#)+ where+ !p# = firstBitSet# (word2Int# bitmask#)+ !mm# = maskw# p# (-1#)+ !nmm# = not# mm#+ !rv# = mm# `or#` (nmm# `and#` (int2Word# (start# +# p#)))+{-# INLINE lineResult# #-}+++-- Required: unlike in C search, required that the start index is+-- cache-line-aligned and array has at least 32 elements after the start index+lineSearch :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Elem -- ^ value to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+lineSearch !vec !start !elem1 = do+ let !(I# v1#) = fromIntegral elem1++ !(I# x1#) <- liftM fromIntegral $ M.readArray vec start+ let !p1# = (and# (maskw# x1# v1#) (int2Word# 0x1#))++ !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1+ let !p2# = or# p1# (and# (maskw# x2# v1#) (int2Word# 0x2#))++ !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2+ let !p3# = or# p2# (and# (maskw# x3# v1#) (int2Word# 0x4#))++ !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3+ let !p4# = or# p3# (and# (maskw# x4# v1#) (int2Word# 0x8#))++ !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4+ let !p5# = or# p4# (and# (maskw# x5# v1#) (int2Word# 0x10#))++ !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5+ let !p6# = or# p5# (and# (maskw# x6# v1#) (int2Word# 0x20#))++ !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6+ let !p7# = or# p6# (and# (maskw# x7# v1#) (int2Word# 0x40#))++ !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7+ let !p8# = or# p7# (and# (maskw# x8# v1#) (int2Word# 0x80#))++ !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8+ let !p9# = or# p8# (and# (maskw# x9# v1#) (int2Word# 0x100#))++ !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9+ let !p10# = or# p9# (and# (maskw# x10# v1#) (int2Word# 0x200#))++ !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10+ let !p11# = or# p10# (and# (maskw# x11# v1#) (int2Word# 0x400#))++ !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11+ let !p12# = or# p11# (and# (maskw# x12# v1#) (int2Word# 0x800#))++ !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12+ let !p13# = or# p12# (and# (maskw# x13# v1#) (int2Word# 0x1000#))++ !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13+ let !p14# = or# p13# (and# (maskw# x14# v1#) (int2Word# 0x2000#))++ !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14+ let !p15# = or# p14# (and# (maskw# x15# v1#) (int2Word# 0x4000#))++ !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15+ let !p16# = or# p15# (and# (maskw# x16# v1#) (int2Word# 0x8000#))++ !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16+ let !p17# = or# p16# (and# (maskw# x17# v1#) (int2Word# 0x10000#))++ !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17+ let !p18# = or# p17# (and# (maskw# x18# v1#) (int2Word# 0x20000#))++ !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18+ let !p19# = or# p18# (and# (maskw# x19# v1#) (int2Word# 0x40000#))++ !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19+ let !p20# = or# p19# (and# (maskw# x20# v1#) (int2Word# 0x80000#))++ !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20+ let !p21# = or# p20# (and# (maskw# x21# v1#) (int2Word# 0x100000#))++ !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21+ let !p22# = or# p21# (and# (maskw# x22# v1#) (int2Word# 0x200000#))++ !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22+ let !p23# = or# p22# (and# (maskw# x23# v1#) (int2Word# 0x400000#))++ !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23+ let !p24# = or# p23# (and# (maskw# x24# v1#) (int2Word# 0x800000#))++ !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24+ let !p25# = or# p24# (and# (maskw# x25# v1#) (int2Word# 0x1000000#))++ !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25+ let !p26# = or# p25# (and# (maskw# x26# v1#) (int2Word# 0x2000000#))++ !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26+ let !p27# = or# p26# (and# (maskw# x27# v1#) (int2Word# 0x4000000#))++ !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27+ let !p28# = or# p27# (and# (maskw# x28# v1#) (int2Word# 0x8000000#))++ !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28+ let !p29# = or# p28# (and# (maskw# x29# v1#) (int2Word# 0x10000000#))++ !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29+ let !p30# = or# p29# (and# (maskw# x30# v1#) (int2Word# 0x20000000#))++ !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30+ let !p31# = or# p30# (and# (maskw# x31# v1#) (int2Word# 0x40000000#))++ !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31+ let !p32# = or# p31# (and# (maskw# x32# v1#) (int2Word# 0x80000000#))++ return $! lineResult# p32# start+++-- Required: unlike in C search, required that the start index is+-- cache-line-aligned and array has at least 32 elements after the start index+lineSearch2 :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Elem -- ^ value to search for+ -> Elem -- ^ second value to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+lineSearch2 !vec !start !elem1 !elem2 = do+ let !(I# v1#) = fromIntegral elem1+ let !(I# v2#) = fromIntegral elem2++ !(I# x1#) <- liftM fromIntegral $ M.readArray vec start+ let !p1# = (and# (int2Word# 0x1#)+ (or# (maskw# x1# v1#) (maskw# x1# v2#)))+ !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1+ let !p2# = or# p1# (and# (int2Word# 0x2#)+ (or# (maskw# x2# v1#) (maskw# x2# v2#)))+ !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2+ let !p3# = or# p2# (and# (int2Word# 0x4#)+ (or# (maskw# x3# v1#) (maskw# x3# v2#)))+ !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3+ let !p4# = or# p3# (and# (int2Word# 0x8#)+ (or# (maskw# x4# v1#) (maskw# x4# v2#)))+ !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4+ let !p5# = or# p4# (and# (int2Word# 0x10#)+ (or# (maskw# x5# v1#) (maskw# x5# v2#)))+ !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5+ let !p6# = or# p5# (and# (int2Word# 0x20#)+ (or# (maskw# x6# v1#) (maskw# x6# v2#)))+ !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6+ let !p7# = or# p6# (and# (int2Word# 0x40#)+ (or# (maskw# x7# v1#) (maskw# x7# v2#)))+ !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7+ let !p8# = or# p7# (and# (int2Word# 0x80#)+ (or# (maskw# x8# v1#) (maskw# x8# v2#)))+ !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8+ let !p9# = or# p8# (and# (int2Word# 0x100#)+ (or# (maskw# x9# v1#) (maskw# x9# v2#)))+ !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9+ let !p10# = or# p9# (and# (int2Word# 0x200#)+ (or# (maskw# x10# v1#) (maskw# x10# v2#)))+ !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10+ let !p11# = or# p10# (and# (int2Word# 0x400#)+ (or# (maskw# x11# v1#) (maskw# x11# v2#)))+ !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11+ let !p12# = or# p11# (and# (int2Word# 0x800#)+ (or# (maskw# x12# v1#) (maskw# x12# v2#)))+ !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12+ let !p13# = or# p12# (and# (int2Word# 0x1000#)+ (or# (maskw# x13# v1#) (maskw# x13# v2#)))+ !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13+ let !p14# = or# p13# (and# (int2Word# 0x2000#)+ (or# (maskw# x14# v1#) (maskw# x14# v2#)))+ !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14+ let !p15# = or# p14# (and# (int2Word# 0x4000#)+ (or# (maskw# x15# v1#) (maskw# x15# v2#)))+ !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15+ let !p16# = or# p15# (and# (int2Word# 0x8000#)+ (or# (maskw# x16# v1#) (maskw# x16# v2#)))+ !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16+ let !p17# = or# p16# (and# (int2Word# 0x10000#)+ (or# (maskw# x17# v1#) (maskw# x17# v2#)))+ !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17+ let !p18# = or# p17# (and# (int2Word# 0x20000#)+ (or# (maskw# x18# v1#) (maskw# x18# v2#)))+ !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18+ let !p19# = or# p18# (and# (int2Word# 0x40000#)+ (or# (maskw# x19# v1#) (maskw# x19# v2#)))+ !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19+ let !p20# = or# p19# (and# (int2Word# 0x80000#)+ (or# (maskw# x20# v1#) (maskw# x20# v2#)))+ !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20+ let !p21# = or# p20# (and# (int2Word# 0x100000#)+ (or# (maskw# x21# v1#) (maskw# x21# v2#)))+ !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21+ let !p22# = or# p21# (and# (int2Word# 0x200000#)+ (or# (maskw# x22# v1#) (maskw# x22# v2#)))+ !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22+ let !p23# = or# p22# (and# (int2Word# 0x400000#)+ (or# (maskw# x23# v1#) (maskw# x23# v2#)))+ !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23+ let !p24# = or# p23# (and# (int2Word# 0x800000#)+ (or# (maskw# x24# v1#) (maskw# x24# v2#)))+ !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24+ let !p25# = or# p24# (and# (int2Word# 0x1000000#)+ (or# (maskw# x25# v1#) (maskw# x25# v2#)))+ !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25+ let !p26# = or# p25# (and# (int2Word# 0x2000000#)+ (or# (maskw# x26# v1#) (maskw# x26# v2#)))+ !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26+ let !p27# = or# p26# (and# (int2Word# 0x4000000#)+ (or# (maskw# x27# v1#) (maskw# x27# v2#)))+ !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27+ let !p28# = or# p27# (and# (int2Word# 0x8000000#)+ (or# (maskw# x28# v1#) (maskw# x28# v2#)))+ !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28+ let !p29# = or# p28# (and# (int2Word# 0x10000000#)+ (or# (maskw# x29# v1#) (maskw# x29# v2#)))+ !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29+ let !p30# = or# p29# (and# (int2Word# 0x20000000#)+ (or# (maskw# x30# v1#) (maskw# x30# v2#)))+ !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30+ let !p31# = or# p30# (and# (int2Word# 0x40000000#)+ (or# (maskw# x31# v1#) (maskw# x31# v2#)))+ !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31+ let !p32# = or# p31# (and# (int2Word# 0x80000000#)+ (or# (maskw# x32# v1#) (maskw# x32# v2#)))++ return $! lineResult# p32# start+++-- Required: unlike in C search, required that the start index is+-- cache-line-aligned and array has at least 32 elements after the start index+lineSearch3 :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Elem -- ^ value to search for+ -> Elem -- ^ second value to search for+ -> Elem -- ^ third value to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+lineSearch3 !vec !start !elem1 !elem2 !elem3 = do+ let !(I# v1#) = fromIntegral elem1+ let !(I# v2#) = fromIntegral elem2+ let !(I# v3#) = fromIntegral elem3++ !(I# x1#) <- liftM fromIntegral $ M.readArray vec start+ let !p1# = (and# (int2Word# 0x1#)+ (or# (maskw# x1# v1#)+ (or# (maskw# x1# v2#) (maskw# x1# v3#))))++ !(I# x2#) <- liftM fromIntegral $ M.readArray vec $! start + 1+ let !p2# = or# p1# (and# (int2Word# 0x2#)+ (or# (maskw# x2# v1#)+ (or# (maskw# x2# v2#) (maskw# x2# v3#))))++ !(I# x3#) <- liftM fromIntegral $ M.readArray vec $! start + 2+ let !p3# = or# p2# (and# (int2Word# 0x4#)+ (or# (maskw# x3# v1#)+ (or# (maskw# x3# v2#) (maskw# x3# v3#))))++ !(I# x4#) <- liftM fromIntegral $ M.readArray vec $! start + 3+ let !p4# = or# p3# (and# (int2Word# 0x8#)+ (or# (maskw# x4# v1#)+ (or# (maskw# x4# v2#) (maskw# x4# v3#))))++ !(I# x5#) <- liftM fromIntegral $ M.readArray vec $! start + 4+ let !p5# = or# p4# (and# (int2Word# 0x10#)+ (or# (maskw# x5# v1#)+ (or# (maskw# x5# v2#) (maskw# x5# v3#))))++ !(I# x6#) <- liftM fromIntegral $ M.readArray vec $! start + 5+ let !p6# = or# p5# (and# (int2Word# 0x20#)+ (or# (maskw# x6# v1#)+ (or# (maskw# x6# v2#) (maskw# x6# v3#))))++ !(I# x7#) <- liftM fromIntegral $ M.readArray vec $! start + 6+ let !p7# = or# p6# (and# (int2Word# 0x40#)+ (or# (maskw# x7# v1#)+ (or# (maskw# x7# v2#) (maskw# x7# v3#))))++ !(I# x8#) <- liftM fromIntegral $ M.readArray vec $! start + 7+ let !p8# = or# p7# (and# (int2Word# 0x80#)+ (or# (maskw# x8# v1#)+ (or# (maskw# x8# v2#) (maskw# x8# v3#))))++ !(I# x9#) <- liftM fromIntegral $ M.readArray vec $! start + 8+ let !p9# = or# p8# (and# (int2Word# 0x100#)+ (or# (maskw# x9# v1#)+ (or# (maskw# x9# v2#) (maskw# x9# v3#))))++ !(I# x10#) <- liftM fromIntegral $ M.readArray vec $! start + 9+ let !p10# = or# p9# (and# (int2Word# 0x200#)+ (or# (maskw# x10# v1#)+ (or# (maskw# x10# v2#) (maskw# x10# v3#))))++ !(I# x11#) <- liftM fromIntegral $ M.readArray vec $! start + 10+ let !p11# = or# p10# (and# (int2Word# 0x400#)+ (or# (maskw# x11# v1#)+ (or# (maskw# x11# v2#) (maskw# x11# v3#))))++ !(I# x12#) <- liftM fromIntegral $ M.readArray vec $! start + 11+ let !p12# = or# p11# (and# (int2Word# 0x800#)+ (or# (maskw# x12# v1#)+ (or# (maskw# x12# v2#) (maskw# x12# v3#))))++ !(I# x13#) <- liftM fromIntegral $ M.readArray vec $! start + 12+ let !p13# = or# p12# (and# (int2Word# 0x1000#)+ (or# (maskw# x13# v1#)+ (or# (maskw# x13# v2#) (maskw# x13# v3#))))++ !(I# x14#) <- liftM fromIntegral $ M.readArray vec $! start + 13+ let !p14# = or# p13# (and# (int2Word# 0x2000#)+ (or# (maskw# x14# v1#)+ (or# (maskw# x14# v2#) (maskw# x14# v3#))))++ !(I# x15#) <- liftM fromIntegral $ M.readArray vec $! start + 14+ let !p15# = or# p14# (and# (int2Word# 0x4000#)+ (or# (maskw# x15# v1#)+ (or# (maskw# x15# v2#) (maskw# x15# v3#))))++ !(I# x16#) <- liftM fromIntegral $ M.readArray vec $! start + 15+ let !p16# = or# p15# (and# (int2Word# 0x8000#)+ (or# (maskw# x16# v1#)+ (or# (maskw# x16# v2#) (maskw# x16# v3#))))++ !(I# x17#) <- liftM fromIntegral $ M.readArray vec $! start + 16+ let !p17# = or# p16# (and# (int2Word# 0x10000#)+ (or# (maskw# x17# v1#)+ (or# (maskw# x17# v2#) (maskw# x17# v3#))))++ !(I# x18#) <- liftM fromIntegral $ M.readArray vec $! start + 17+ let !p18# = or# p17# (and# (int2Word# 0x20000#)+ (or# (maskw# x18# v1#)+ (or# (maskw# x18# v2#) (maskw# x18# v3#))))++ !(I# x19#) <- liftM fromIntegral $ M.readArray vec $! start + 18+ let !p19# = or# p18# (and# (int2Word# 0x40000#)+ (or# (maskw# x19# v1#)+ (or# (maskw# x19# v2#) (maskw# x19# v3#))))++ !(I# x20#) <- liftM fromIntegral $ M.readArray vec $! start + 19+ let !p20# = or# p19# (and# (int2Word# 0x80000#)+ (or# (maskw# x20# v1#)+ (or# (maskw# x20# v2#) (maskw# x20# v3#))))++ !(I# x21#) <- liftM fromIntegral $ M.readArray vec $! start + 20+ let !p21# = or# p20# (and# (int2Word# 0x100000#)+ (or# (maskw# x21# v1#)+ (or# (maskw# x21# v2#) (maskw# x21# v3#))))++ !(I# x22#) <- liftM fromIntegral $ M.readArray vec $! start + 21+ let !p22# = or# p21# (and# (int2Word# 0x200000#)+ (or# (maskw# x22# v1#)+ (or# (maskw# x22# v2#) (maskw# x22# v3#))))++ !(I# x23#) <- liftM fromIntegral $ M.readArray vec $! start + 22+ let !p23# = or# p22# (and# (int2Word# 0x400000#)+ (or# (maskw# x23# v1#)+ (or# (maskw# x23# v2#) (maskw# x23# v3#))))++ !(I# x24#) <- liftM fromIntegral $ M.readArray vec $! start + 23+ let !p24# = or# p23# (and# (int2Word# 0x800000#)+ (or# (maskw# x24# v1#)+ (or# (maskw# x24# v2#) (maskw# x24# v3#))))++ !(I# x25#) <- liftM fromIntegral $ M.readArray vec $! start + 24+ let !p25# = or# p24# (and# (int2Word# 0x1000000#)+ (or# (maskw# x25# v1#)+ (or# (maskw# x25# v2#) (maskw# x25# v3#))))++ !(I# x26#) <- liftM fromIntegral $ M.readArray vec $! start + 25+ let !p26# = or# p25# (and# (int2Word# 0x2000000#)+ (or# (maskw# x26# v1#)+ (or# (maskw# x26# v2#) (maskw# x26# v3#))))++ !(I# x27#) <- liftM fromIntegral $ M.readArray vec $! start + 26+ let !p27# = or# p26# (and# (int2Word# 0x4000000#)+ (or# (maskw# x27# v1#)+ (or# (maskw# x27# v2#) (maskw# x27# v3#))))++ !(I# x28#) <- liftM fromIntegral $ M.readArray vec $! start + 27+ let !p28# = or# p27# (and# (int2Word# 0x8000000#)+ (or# (maskw# x28# v1#)+ (or# (maskw# x28# v2#) (maskw# x28# v3#))))++ !(I# x29#) <- liftM fromIntegral $ M.readArray vec $! start + 28+ let !p29# = or# p28# (and# (int2Word# 0x10000000#)+ (or# (maskw# x29# v1#)+ (or# (maskw# x29# v2#) (maskw# x29# v3#))))++ !(I# x30#) <- liftM fromIntegral $ M.readArray vec $! start + 29+ let !p30# = or# p29# (and# (int2Word# 0x20000000#)+ (or# (maskw# x30# v1#)+ (or# (maskw# x30# v2#) (maskw# x30# v3#))))++ !(I# x31#) <- liftM fromIntegral $ M.readArray vec $! start + 30+ let !p31# = or# p30# (and# (int2Word# 0x40000000#)+ (or# (maskw# x31# v1#)+ (or# (maskw# x31# v2#) (maskw# x31# v3#))))++ !(I# x32#) <- liftM fromIntegral $ M.readArray vec $! start + 31+ let !p32# = or# p31# (and# (int2Word# 0x80000000#)+ (or# (maskw# x32# v1#)+ (or# (maskw# x32# v2#) (maskw# x32# v3#))))++ return $! lineResult# p32# start+++------------------------------------------------------------------------------+-- | Search through a mutable vector for a given int value. The number of+-- things to search for must be at most the number of things remaining in the+-- vector.+naiveSearch :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Int -- ^ number of things to search+ -> Elem -- ^ value to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+naiveSearch !vec !start !nThings !value = go start+ where+ !doneIdx = start + nThings++ go !i | i >= doneIdx = return (-1)+ | otherwise = do+ x <- M.readArray vec i+ if x == value then return i else go (i+1)+{-# INLINE naiveSearch #-}+++------------------------------------------------------------------------------+naiveSearch2 :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Int -- ^ number of things to search+ -> Elem -- ^ value to search for+ -> Elem -- ^ value 2 to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+naiveSearch2 !vec !start !nThings !value1 !value2 = go start+ where+ !doneIdx = start + nThings++ go !i | i >= doneIdx = return (-1)+ | otherwise = do+ x <- M.readArray vec i+ if x == value1 || x == value2 then return i else go (i+1)+{-# INLINE naiveSearch2 #-}+++------------------------------------------------------------------------------+naiveSearch3 :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Int -- ^ number of things to search+ -> Elem -- ^ value to search for+ -> Elem -- ^ value 2 to search for+ -> Elem -- ^ value 3 to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+naiveSearch3 !vec !start !nThings !value1 !value2 !value3 = go start+ where+ !doneIdx = start + nThings++ go !i | i >= doneIdx = return (-1)+ | otherwise = do+ x <- M.readArray vec i+ if x == value1 || x == value2 || x == value3+ then return i+ else go (i+1)+{-# INLINE naiveSearch3 #-}++-- end #if NO_C_SEARCH+#endif++------------------------------------------------------------------------------+-- | Search through a mutable vector for a given int value, cache-line aligned.+-- If the start index is cache-line aligned, and there is more than a+-- cache-line's room between the start index and the end of the vector, we will+-- search the cache-line all at once using an efficient branchless+-- bit-twiddling technique. Otherwise, we will use a typical loop.+--+cacheLineSearch :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Elem -- ^ value to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+cacheLineSearch !vec !start !value = do+#ifdef NO_C_SEARCH+ vlen <- M.length vec+ let !st1 = vlen - start+ let !nvlen = numElemsInCacheLine - st1+ let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask+ let st2 = adv - start+++ if nvlen > 0 || not (isCacheLineAligned start)+ then naiveSearch vec start (min st1 st2) value+ else lineSearch vec start value+#else+ lineSearch vec start value+#endif+{-# INLINE cacheLineSearch #-}+++------------------------------------------------------------------------------+-- | Search through a mutable vector for one of two given int values,+-- cache-line aligned. If the start index is cache-line aligned, and there is+-- more than a cache-line's room between the start index and the end of the+-- vector, we will search the cache-line all at once using an efficient+-- branchless bit-twiddling technique. Otherwise, we will use a typical loop.+--+cacheLineSearch2 :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Elem -- ^ value to search for+ -> Elem -- ^ value 2 to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+cacheLineSearch2 !vec !start !value !value2 = do+#ifdef NO_C_SEARCH+ !vlen <- M.length vec+ let !st1 = vlen - start+ let !nvlen = numElemsInCacheLine - st1+ let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask+ let st2 = adv - start++ if nvlen > 0 || not (isCacheLineAligned start)+ then naiveSearch2 vec start (min st1 st2) value value2+ else lineSearch2 vec start value value2+#else+ lineSearch2 vec start value value2+#endif+{-# INLINE cacheLineSearch2 #-}+++------------------------------------------------------------------------------+-- | Search through a mutable vector for one of three given int values,+-- cache-line aligned. If the start index is cache-line aligned, and there is+-- more than a cache-line's room between the start index and the end of the+-- vector, we will search the cache-line all at once using an efficient+-- branchless bit-twiddling technique. Otherwise, we will use a typical loop.+--+cacheLineSearch3 :: IntArray s -- ^ vector to search+ -> Int -- ^ start index+ -> Elem -- ^ value to search for+ -> Elem -- ^ value 2 to search for+ -> Elem -- ^ value 3 to search for+ -> ST s Int -- ^ dest index where it can be found, or+ -- \"-1\" if not found+cacheLineSearch3 !vec !start !value !value2 !value3 = do+#ifdef NO_C_SEARCH+ !vlen <- M.length vec+ let !st1 = vlen - start+ let !nvlen = numElemsInCacheLine - st1+ let adv = (start + cacheLineIntMask) .&. complement cacheLineIntMask+ let st2 = adv - start++ if nvlen > 0 || not (isCacheLineAligned start)+ then naiveSearch3 vec start (min st1 st2) value value2 value3+ else lineSearch3 vec start value value2 value3+#else+ lineSearch3 vec start value value2 value3+#endif+{-# INLINE cacheLineSearch3 #-}
src/Data/HashTable/Internal/CheapPseudoRandomBitStream.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} module Data.HashTable.Internal.CheapPseudoRandomBitStream ( BitStream@@ -9,19 +10,23 @@ import Control.Applicative import Control.Monad.ST-import Data.Bits-import Data.Int+import Data.Bits ((.&.)) import Data.STRef-import qualified Data.Vector.Unboxed as V-import Data.Vector.Unboxed (Vector)+import Data.Vector.Unboxed (Vector)+import qualified Data.Vector.Unboxed as V +import Data.Word (Word32, Word64)+#if !MIN_VERSION_base(4,8,0)+import Data.Word (Word)+#endif+ import Data.HashTable.Internal.Utils ------------------------------------------------------------------------------ -- Chosen by fair dice roll. Guaranteed random. More importantly, there are an -- equal number of 0 and 1 bits in both of these vectors.-random32s :: Vector Int32+random32s :: Vector Word32 random32s = V.fromList [ 0xe293c315 , 0x82e2ff62 , 0xcb1ef9ae@@ -42,7 +47,7 @@ -------------------------------------------------------------------------------random64s :: Vector Int64+random64s :: Vector Word64 random64s = V.fromList [ 0x62ef447e007e8732 , 0x149d6acb499feef8 , 0xca7725f9b404fbf8@@ -68,16 +73,16 @@ -------------------------------------------------------------------------------randoms :: Vector Int-randoms | wordSize == 32 = V.map fromEnum random32s- | otherwise = V.map fromEnum random64s+randoms :: Vector Word+randoms | wordSize == 32 = V.map fromIntegral random32s+ | otherwise = V.map fromIntegral random64s ------------------------------------------------------------------------------ data BitStream s = BitStream {- _curRandom :: !(STRef s Int)- , _bitsLeft :: !(STRef s Int)- , _randomPos :: !(STRef s Int)+ _curRandom :: !(STRef s Word)+ , _bitsLeft :: !(STRef s Int )+ , _randomPos :: !(STRef s Int ) } @@ -91,12 +96,12 @@ -------------------------------------------------------------------------------getNextBit :: BitStream s -> ST s Int+getNextBit :: BitStream s -> ST s Word getNextBit = getNBits 1 -------------------------------------------------------------------------------getNBits :: Int -> BitStream s -> ST s Int+getNBits :: Int -> BitStream s -> ST s Word getNBits nbits (BitStream crRef blRef rpRef) = do !bl <- readSTRef blRef if bl < nbits@@ -112,8 +117,8 @@ extractBits r extractBits r = do- let !b = r .&. ((1 `iShiftL` nbits) - 1)- writeSTRef crRef $! (r `iShiftRL` nbits)+ let !b = r .&. ((1 `shiftL` nbits) - 1)+ writeSTRef crRef $! (r `shiftRL` nbits) return b nextBits bl = do
src/Data/HashTable/Internal/IntArray.hs view
@@ -4,6 +4,11 @@ module Data.HashTable.Internal.IntArray ( IntArray+ , Elem+ , elemMask+ , primWordToElem+ , elemToInt+ , elemToInt# , newArray , readArray , writeArray@@ -11,64 +16,120 @@ , toPtr ) where +------------------------------------------------------------------------------ import Control.Monad.ST import Data.Bits import qualified Data.Primitive.ByteArray as A-import Data.Primitive.Types (Addr(..))+#if !MIN_VERSION_primitive(0,7,0)+import Data.Primitive.Types (Addr (..))+#endif import GHC.Exts-import Prelude hiding (length)+import GHC.Word+import Prelude hiding (length)+------------------------------------------------------------------------------ + #ifdef BOUNDS_CHECKING-#define BOUNDS_MSG(sz,i) concat [ "[", __FILE__, ":", \- show (__LINE__ :: Int), \- "] bounds check exceeded: ",\+#define BOUNDS_MSG(sz,i) concat [ "[", __FILE__, ":", \+ show (__LINE__ :: Int), \+ "] bounds check exceeded: ", \ "size was ", show (sz), " i was ", show (i) ]-#define BOUNDS_CHECK(arr,i) let sz = (A.sizeofMutableByteArray (arr) \- `div` wordSizeInBytes) in \- if (i) < 0 || (i) >= sz \- then error (BOUNDS_MSG(sz,(i))) \++#define BOUNDS_CHECK(arr,i) let sz = (A.sizeofMutableByteArray (arr) \+ `div` wordSizeInBytes) in \+ if (i) < 0 || (i) >= sz \+ then error (BOUNDS_MSG(sz,(i))) \ else return () #else #define BOUNDS_CHECK(arr,i) #endif ++------------------------------------------------------------------------------ newtype IntArray s = IA (A.MutableByteArray s)+type Elem = Word16 +------------------------------------------------------------------------------+primWordToElem :: Word# -> Elem+primWordToElem w# = W16# (wordToWord16Compat# w#)+++------------------------------------------------------------------------------+elemToInt :: Elem -> Int+elemToInt e = let !i# = elemToInt# e+ in (I# i#)+++------------------------------------------------------------------------------+elemToInt# :: Elem -> Int#+elemToInt# (W16# w#) = word2Int# (word16ToWordCompat# w#)+++------------------------------------------------------------------------------+elemMask :: Int+elemMask = 0xffff+++------------------------------------------------------------------------------ wordSizeInBytes :: Int-wordSizeInBytes = bitSize (0::Int) `div` 8+wordSizeInBytes = finiteBitSize (0::Elem) `div` 8 +------------------------------------------------------------------------------ -- | Cache line size, in bytes cacheLineSize :: Int cacheLineSize = 64 +------------------------------------------------------------------------------ newArray :: Int -> ST s (IntArray s) newArray n = do let !sz = n * wordSizeInBytes- !arr <- A.newAlignedPinnedByteArray sz cacheLineSize+ !arr <- A.newAlignedPinnedByteArray sz cacheLineSize A.fillByteArray arr 0 sz 0 return $! IA arr -readArray :: IntArray s -> Int -> ST s Int+------------------------------------------------------------------------------+readArray :: IntArray s -> Int -> ST s Elem readArray (IA a) idx = do BOUNDS_CHECK(a,idx) A.readByteArray a idx -writeArray :: IntArray s -> Int -> Int -> ST s ()+------------------------------------------------------------------------------+writeArray :: IntArray s -> Int -> Elem -> ST s () writeArray (IA a) idx val = do BOUNDS_CHECK(a,idx) A.writeByteArray a idx val -length :: IntArray s -> Int-length (IA a) = A.sizeofMutableByteArray a `div` wordSizeInBytes+------------------------------------------------------------------------------+length :: IntArray s -> ST s Int+length (IA a) = (`div` wordSizeInBytes) <$> A.getSizeofMutableByteArray a +------------------------------------------------------------------------------ toPtr :: IntArray s -> Ptr a toPtr (IA a) = Ptr a# where+#if MIN_VERSION_primitive(0,7,0)+ !(Ptr !a#) = A.mutableByteArrayContents a+#else !(Addr !a#) = A.mutableByteArrayContents a+#endif++#if MIN_VERSION_base(4,16,0)+word16ToWordCompat# :: Word16# -> Word#+word16ToWordCompat# = word16ToWord#++wordToWord16Compat# :: Word# -> Word16#+wordToWord16Compat# = wordToWord16#+#else+word16ToWordCompat# :: Word# -> Word#+word16ToWordCompat# x = x++wordToWord16Compat# :: Word# -> Word#+wordToWord16Compat# x = x+#endif
src/Data/HashTable/Internal/Linear/Bucket.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} module Data.HashTable.Internal.Linear.Bucket ( Bucket,@@ -10,7 +10,11 @@ snoc, size, lookup,+ lookupIndex,+ elemAt, delete,+ mutate,+ mutateST, toList, fromList, mapM_,@@ -23,13 +27,19 @@ ------------------------------------------------------------------------------+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad hiding (foldM, mapM_) import qualified Control.Monad-import Control.Monad hiding (mapM_, foldM)-import Control.Monad.ST-import Data.Maybe (fromMaybe)+import Control.Monad.ST (ST)+#ifdef DEBUG+import Data.HashTable.Internal.Utils (unsafeIOToST)+#endif import Data.HashTable.Internal.Array+import Data.Maybe (fromMaybe) import Data.STRef-import Prelude hiding (lookup, mapM_)+import Prelude hiding (lookup, mapM_) ------------------------------------------------------------------------------ import Data.HashTable.Internal.UnsafeTricks @@ -189,7 +199,7 @@ debug "Bucket.snoc: spill finished, snoccing element" let (Bucket _ hwRef' keys' values') = fromKey bk- + let !hw' = hw+1 writeArray keys' hw k writeArray values' hw v@@ -226,7 +236,38 @@ return $! Just v else go (i-1) +------------------------------------------------------------------------------+-- note: search in reverse order! We prefer recently snoc'd keys.+lookupIndex :: (Eq k) => Bucket s k v -> k -> ST s (Maybe Int)+lookupIndex bucketKey !k+ | keyIsEmpty bucketKey = return Nothing+ | otherwise = lookup' $ fromKey bucketKey+ where+ lookup' (Bucket _ hwRef keys _values) = do+ hw <- readSTRef hwRef+ go (hw-1)+ where+ go !i+ | i < 0 = return Nothing+ | otherwise = do+ k' <- readArray keys i+ if k == k'+ then return (Just i)+ else go (i-1) +elemAt :: Bucket s k v -> Int -> ST s (Maybe (k,v))+elemAt bucketKey ix+ | keyIsEmpty bucketKey = return Nothing+ | otherwise = lookup' $ fromKey bucketKey+ where+ lookup' (Bucket _ hwRef keys values) = do+ hw <- readSTRef hwRef+ if 0 <= ix && ix < hw+ then do k <- readArray keys ix+ v <- readArray values ix+ return (Just (k,v))+ else return Nothing+ ------------------------------------------------------------------------------ {-# INLINE toList #-} toList :: Bucket s k v -> ST s [(k,v)]@@ -284,6 +325,64 @@ ------------------------------------------------------------------------------+mutate :: (Eq k) =>+ Bucket s k v+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s (Int, Maybe (Bucket s k v), a)+mutate bucketKey !k !f = mutateST bucketKey k (pure . f)+{-# INLINE mutate #-}+++------------------------------------------------------------------------------+mutateST :: (Eq k) =>+ Bucket s k v+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s (Int, Maybe (Bucket s k v), a)+mutateST bucketKey !k !f+ | keyIsEmpty bucketKey = do+ fRes <- f Nothing+ case fRes of+ (Nothing, a) -> return (0, Nothing, a)+ (Just v', a) -> do+ (!hw', mbk) <- snoc bucketKey k v'+ return (hw', mbk, a)+ | otherwise = mutate' $ fromKey bucketKey+ where+ mutate' (Bucket _sz hwRef keys values) = do+ hw <- readSTRef hwRef+ pos <- findPosition hw (hw-1)+ mv <- do+ if pos < 0+ then return Nothing+ else readArray values pos >>= return . Just+ fRes <- f mv+ case (mv, fRes) of+ (Nothing, (Nothing, a)) -> return (hw, Nothing, a)+ (Nothing, (Just v', a)) -> do+ (!hw', mbk) <- snoc bucketKey k v'+ return (hw', mbk, a)+ (Just _v, (Just v', a)) -> do+ writeArray values pos v'+ return (hw, Nothing, a)+ (Just _v, (Nothing, a)) -> do+ move (hw-1) pos keys+ move (hw-1) pos values+ let !hw' = hw-1+ writeSTRef hwRef hw'+ return (hw', Nothing, a)+ where+ findPosition !hw !i+ | i < 0 = return (-1)+ | otherwise = do+ k' <- readArray keys i+ if k == k'+ then return i+ else findPosition hw (i-1)+++------------------------------------------------------------------------------ {-# INLINE mapM_ #-} mapM_ :: ((k,v) -> ST s a) -> Bucket s k v -> ST s () mapM_ f bucketKey@@ -293,7 +392,7 @@ | otherwise = doMap $ fromKey bucketKey where doMap (Bucket sz hwRef keys values) = do- hw <- readSTRef hwRef + hw <- readSTRef hwRef debug $ "Bucket.mapM_: hw was " ++ show hw ++ ", sz was " ++ show sz go hw 0 where@@ -313,7 +412,7 @@ | otherwise = doMap $ fromKey bucketKey where doMap (Bucket _ hwRef keys values) = do- hw <- readSTRef hwRef + hw <- readSTRef hwRef go hw seed0 0 where go !hw !seed !i | i >= hw = return seed
src/Data/HashTable/Internal/UnsafeTricks.hs view
@@ -30,7 +30,7 @@ type Key a = Any #else-data Key a = Key !a +data Key a = Key !a | EmptyElement | DeletedElement deriving (Show)@@ -61,12 +61,12 @@ deletedRecord = unsafeCoerce DeletedElement {-# INLINE keyIsEmpty #-}-keyIsEmpty a = x# ==# 1#+keyIsEmpty a = isTrue# (x# ==# 1#) where !x# = reallyUnsafePtrEquality# a emptyRecord {-# INLINE keyIsDeleted #-}-keyIsDeleted a = x# ==# 1#+keyIsDeleted a = isTrue# (x# ==# 1#) where !x# = reallyUnsafePtrEquality# a deletedRecord
src/Data/HashTable/Internal/Utils.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -module Data.HashTable.Internal.Utils +module Data.HashTable.Internal.Utils ( whichBucket , nextBestPrime , bumpSize@@ -15,15 +15,17 @@ , highestBitMask , wordSize , cacheLineSize- , numWordsInCacheLine+ , numElemsInCacheLine , cacheLineIntMask , cacheLineIntBits , forceSameType+ , unsafeIOToST ) where -import Data.Bits hiding (shiftL)-import Data.Vector (Vector)-import qualified Data.Vector as V+import Data.Bits hiding (shiftL)+import Data.HashTable.Internal.IntArray (Elem)+import Data.Vector (Vector)+import qualified Data.Vector as V #if __GLASGOW_HASKELL__ >= 503 import GHC.Exts #else@@ -31,20 +33,25 @@ import Data.Word #endif +#if MIN_VERSION_base(4,4,0)+import Control.Monad.ST.Unsafe (unsafeIOToST)+#else+import Control.Monad.ST (unsafeIOToST)+#endif ------------------------------------------------------------------------------ wordSize :: Int-wordSize = bitSize (0::Int)+wordSize = finiteBitSize (0::Int) cacheLineSize :: Int cacheLineSize = 64 -numWordsInCacheLine :: Int-numWordsInCacheLine = z+numElemsInCacheLine :: Int+numElemsInCacheLine = z where- !z = cacheLineSize `div` (wordSize `div` 8)+ !z = cacheLineSize `div` (finiteBitSize (0::Elem) `div` 8) -- | What you have to mask an integer index by to tell if it's@@ -52,11 +59,11 @@ cacheLineIntMask :: Int cacheLineIntMask = z where- !z = numWordsInCacheLine - 1+ !z = numElemsInCacheLine - 1 cacheLineIntBits :: Int-cacheLineIntBits = log2 $ toEnum numWordsInCacheLine+cacheLineIntBits = log2 $ toEnum numElemsInCacheLine ------------------------------------------------------------------------------@@ -237,12 +244,8 @@ -------------------------------------------------------------------------------bumpSize :: Int -> Int-bumpSize !s = nextBestPrime s'- where- -- double at small sizes, then 3/2 thereafter- s' = if s < 24593 then 2*s else (s `div` 2) * 3-+bumpSize :: Double -> Int -> Int+bumpSize !maxLoad !s = nextBestPrime $! ceiling (fromIntegral s / maxLoad) ------------------------------------------------------------------------------
src/Data/HashTable/ST/Basic.hs view
@@ -18,49 +18,51 @@ with deleted markers and force the table to be completely rehashed fairly often. -/Details:/--Of the hash tables in this collection, this hash table has the best insert and-lookup performance, with the following caveats.+Of the hash tables in this collection, this hash table has the best lookup+performance, while maintaining competitive insert performance. /Space overhead/ This table is not especially memory-efficient; firstly, the table has a maximum load factor of 0.83 and will be resized if load exceeds this value. Secondly,-to improve insert and lookup performance, we store the hash code for each key-in the table.+to improve insert and lookup performance, we store a 16-bit hash code for each+key in the table. -Each hash table entry requires three words, two for the pointers to the key and-value and one for the hash code. We don't count key and value pointers as-overhead, because they have to be there -- so the overhead for a full slot is-one word -- but empty slots in the hash table count for a full three words of-overhead. Define @m@ as the number of slots in the table and @n@ as the number-of key value mappings. If the load factor is @k=n\/m@, the amount of space-wasted is:+Each hash table entry requires at least 2.25 words (on a 64-bit machine), two+for the pointers to the key and value and one quarter word for the hash code.+We don't count key and value pointers as overhead, because they have to be+there -- so the overhead for a full slot is at least one quarter word -- but+empty slots in the hash table count for a full 2.25 words of overhead. Define+@m@ as the number of slots in the table, @n@ as the number of key value+mappings, and @ws@ as the machine word size in /bytes/. If the load factor is+@k=n\/m@, the amount of space /wasted/ per mapping in words is: @-w(n) = 1*n + 3(m-n)+w(n) = (m*(2*ws + 2) - n*(2*ws)) / ws @ Since @m=n\/k@, @-w(n) = n + 3(n\/k - n)-= n (3\/k-2)+w(n) = n\/k * (2*ws + 2) - n*(2*ws)+ = (n * (2 + 2*ws*(1-k)) / k) / ws @ -Solving for @k=0.83@, the maximum load factor, gives a /minimum/ overhead of 2-words per mapping. If @k=0.5@, under normal usage the /maximum/ overhead-situation, then the overhead would be 4 words per mapping.+Solving for @k=0.83@, the maximum load factor, gives a /minimum/ overhead of+0.71 words per mapping on a 64-bit machine, or 1.01 words per mapping on a+32-bit machine. If @k=0.5@, which should be under normal usage the /maximum/+overhead situation, then the overhead would be 2.5 words per mapping on a+64-bit machine, or 3.0 words per mapping on a 32-bit machine. /Space overhead: experimental results/ -In randomized testing (see @test\/compute-overhead\/ComputeOverhead.hs@ in the-source distribution), mean overhead (that is, the number of words needed to-store the key-value mapping over and above the two words necessary for the key-and the value pointers) is approximately 2.29 machine words per key-value-mapping with a standard deviation of about 0.44 words, and 3.14 words per-mapping at the 95th percentile.+In randomized testing on a 64-bit machine (see+@test\/compute-overhead\/ComputeOverhead.hs@ in the source distribution), mean+overhead (that is, the number of words needed to store the key-value mapping+over and above the two words necessary for the key and the value pointers) is+approximately 1.24 machine words per key-value mapping with a standard+deviation of about 0.30 words, and 1.70 words per mapping at the 95th+percentile. /Expensive resizes/ @@ -78,14 +80,16 @@ Searching. Addison-Wesley Publishing Company, 1973. -} - module Data.HashTable.ST.Basic ( HashTable , new , newSized+ , size , delete , lookup , insert+ , mutate+ , mutateST , mapM_ , foldM , computeOverhead@@ -93,37 +97,69 @@ -------------------------------------------------------------------------------import Control.Exception (assert)-import Control.Monad hiding (mapM_, foldM)-import Control.Monad.ST-import Data.Hashable (Hashable)-import qualified Data.Hashable as H+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Exception (assert)+import Control.Monad hiding (foldM, mapM_)+import Control.Monad.ST (ST)+import Data.Bits+import Data.Hashable (Hashable)+import qualified Data.Hashable as H import Data.Maybe import Data.Monoid+#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)+import Data.Semigroup+#endif+import qualified Data.Primitive.ByteArray as A import Data.STRef import GHC.Exts-import Prelude hiding (lookup, read, mapM_)+import Prelude hiding (lookup, mapM_, read) ------------------------------------------------------------------------------+import qualified Data.HashTable.Class as C import Data.HashTable.Internal.Array-import qualified Data.HashTable.Internal.IntArray as U import Data.HashTable.Internal.CacheLine+import Data.HashTable.Internal.IntArray (Elem)+import qualified Data.HashTable.Internal.IntArray as U import Data.HashTable.Internal.Utils-import qualified Data.HashTable.Class as C ------------------------------------------------------------------------------ -- | An open addressing hash table using linear probing. newtype HashTable s k v = HT (STRef s (HashTable_ s k v)) +type SizeRefs s = A.MutableByteArray s++intSz :: Int+intSz = (finiteBitSize (0::Int) `div` 8)++readLoad :: SizeRefs s -> ST s Int+readLoad = flip A.readByteArray 0++writeLoad :: SizeRefs s -> Int -> ST s ()+writeLoad = flip A.writeByteArray 0++readDelLoad :: SizeRefs s -> ST s Int+readDelLoad = flip A.readByteArray 1++writeDelLoad :: SizeRefs s -> Int -> ST s ()+writeDelLoad = flip A.writeByteArray 1++newSizeRefs :: ST s (SizeRefs s)+newSizeRefs = do+ let asz = 2 * intSz+ a <- A.newAlignedPinnedByteArray asz intSz+ A.fillByteArray a 0 asz 0+ return a++ data HashTable_ s k v = HashTable- { _size :: {-# UNPACK #-} !Int- , _load :: !(U.IntArray s) -- ^ How many entries in the table? Prefer- -- unboxed vector here to STRef because I- -- know it will be appropriately strict- , _delLoad :: !(U.IntArray s) -- ^ How many deleted entries in the table?- , _hashes :: !(U.IntArray s)- , _keys :: {-# UNPACK #-} !(MutableArray s k)- , _values :: {-# UNPACK #-} !(MutableArray s v)+ { _size :: {-# UNPACK #-} !Int+ , _load :: !(SizeRefs s) -- ^ 2-element array, stores how many entries+ -- and deleted entries are in the table.+ , _hashes :: !(U.IntArray s)+ , _keys :: {-# UNPACK #-} !(MutableArray s k)+ , _values :: {-# UNPACK #-} !(MutableArray s v) } @@ -136,7 +172,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate+ mutateST = mutateST ------------------------------------------------------------------------------@@ -146,49 +186,56 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:new".+-- 'Data.HashTable.Class.new'. new :: ST s (HashTable s k v)-new = newSized 30+new = newSized 1 {-# INLINE new #-} ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:newSized".+-- 'Data.HashTable.Class.newSized'. newSized :: Int -> ST s (HashTable s k v) newSized n = do+ debug $ "entering: newSized " ++ show n let m = nextBestPrime $ ceiling (fromIntegral n / maxLoad) ht <- newSizedReal m newRef ht {-# INLINE newSized #-} - ------------------------------------------------------------------------------ newSizedReal :: Int -> ST s (HashTable_ s k v) newSizedReal m = do -- make sure the hash array is a multiple of cache-line sized so we can -- always search a whole cache line at once- let m' = ((m + numWordsInCacheLine - 1) `div` numWordsInCacheLine)- * numWordsInCacheLine+ let m' = ((m + numElemsInCacheLine - 1) `div` numElemsInCacheLine)+ * numElemsInCacheLine h <- U.newArray m' k <- newArray m undefined v <- newArray m undefined- ld <- U.newArray 1- dl <- U.newArray 1- return $! HashTable m ld dl h k v+ ld <- newSizeRefs+ return $! HashTable m ld h k v +------------------------------------------------------------------------------+-- | Returns the number of mappings currently stored in this table. /O(1)/+size :: HashTable s k v -> ST s Int+size htRef = do+ HashTable _ sizeRefs _ _ _ <- readRef htRef+ readLoad sizeRefs+{-# INLINE size #-} + ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:delete".+-- 'Data.HashTable.Class.delete'. delete :: (Hashable k, Eq k) => (HashTable s k v) -> k -> ST s () delete htRef k = do ht <- readRef htRef- _ <- delete' ht True k h- return ()+ slots <- findSafeSlots ht k h+ when (trueInt (_slotFound slots)) $ deleteFromSlot ht (_slotB1 slots) where !h = hash k {-# INLINE delete #-}@@ -196,22 +243,30 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:lookup".+-- 'Data.HashTable.Class.lookup'. lookup :: (Eq k, Hashable k) => (HashTable s k v) -> k -> ST s (Maybe v) lookup htRef !k = do ht <- readRef htRef lookup' ht where- lookup' (HashTable sz _ _ hashes keys values) = do+ lookup' (HashTable sz _ hashes keys values) = do let !b = whichBucket h sz- debug $ "lookup sz=" ++ show sz ++ " h=" ++ show h ++ " b=" ++ show b+ debug $ "lookup h=" ++ show h ++ " sz=" ++ show sz ++ " b=" ++ show b go b 0 sz where- !h = hash k+ !h = hash k+ !he = hashToElem h go !b !start !end = {-# SCC "lookup/go" #-} do- idx <- forwardSearch2 hashes b end h emptyMarker+ debug $ concat [ "lookup'/go: "+ , show b+ , "/"+ , show start+ , "/"+ , show end+ ]+ idx <- forwardSearch2 hashes b end he emptyMarker debug $ "forwardSearch2 returned " ++ show idx if (idx < 0 || idx < start || idx >= end) then return Nothing@@ -220,7 +275,9 @@ debug $ "h0 was " ++ show h0 if recordIsEmpty h0- then return Nothing+ then do+ debug $ "record empty, returning Nothing"+ return Nothing else do k' <- readArray keys idx if k == k'@@ -228,15 +285,17 @@ debug $ "value found at " ++ show idx v <- readArray values idx return $! Just v- else if idx < b- then go (idx + 1) (idx + 1) b- else go (idx + 1) start end+ else do+ debug $ "value not found, recursing"+ if idx < b+ then go (idx + 1) (idx + 1) b+ else go (idx + 1) start end {-# INLINE lookup #-} ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:insert".+-- 'Data.HashTable.Class.insert'. insert :: (Eq k, Hashable k) => (HashTable s k v) -> k@@ -244,36 +303,78 @@ -> ST s () insert htRef !k !v = do ht <- readRef htRef- !ht' <- insert' ht+ debug $ "insert: h=" ++ show h+ slots@(SlotFindResponse foundInt b0 b1) <- findSafeSlots ht k h+ let found = trueInt foundInt+ debug $ "insert: findSafeSlots returned " ++ show slots+ when (found && (b0 /= b1)) $ deleteFromSlot ht b1+ insertIntoSlot ht b0 he k v+ ht' <- checkOverflow ht writeRef htRef ht' where- insert' ht = do- debug "insert': calling delete'"- b <- delete' ht False k h+ !h = hash k+ !he = hashToElem h+{-# INLINE insert #-} - debug $ "insert': writing h=" ++ show h ++ " b=" ++ show b- U.writeArray hashes b h- writeArray keys b k- writeArray values b v - checkOverflow ht+------------------------------------------------------------------------------+-- | See the documentation for this function in+-- 'Data.HashTable.Class.mutate'.+mutate :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef !k !f = mutateST htRef k (pure . f)+{-# INLINE mutate #-} - where- !h = hash k- hashes = _hashes ht- keys = _keys ht- values = _values ht-{-# INLINE insert #-} +------------------------------------------------------------------------------+-- | See the documentation for this function in+-- 'Data.HashTable.Class.mutateST'.+mutateST :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s a+mutateST htRef !k !f = do+ ht <- readRef htRef+ let values = _values ht+ debug $ "mutate h=" ++ show h+ slots@(SlotFindResponse foundInt b0 b1) <- findSafeSlots ht k h+ let found = trueInt foundInt+ debug $ "findSafeSlots returned " ++ show slots+ !mv <- if found+ then fmap Just $ readArray values b1+ else return Nothing+ (!mv', !result) <- f mv+ case (mv, mv') of+ (Nothing, Nothing) -> return ()+ (Just _, Nothing) -> do+ deleteFromSlot ht b1+ (Nothing, Just v') -> do+ insertIntoSlot ht b0 he k v'+ ht' <- checkOverflow ht+ writeRef htRef ht'+ (Just _, Just v') -> do+ when (b0 /= b1) $+ deleteFromSlot ht b1+ insertIntoSlot ht b0 he k v'+ return result+ where+ !h = hash k+ !he = hashToElem h+{-# INLINE mutateST #-} + ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:foldM".+-- 'Data.HashTable.Class.foldM'. foldM :: (a -> (k,v) -> ST s a) -> a -> HashTable s k v -> ST s a foldM f seed0 htRef = readRef htRef >>= work where- work (HashTable sz _ _ hashes keys values) = go 0 seed0+ work (HashTable sz _ hashes keys values) = go 0 seed0 where go !i !seed | i >= sz = return seed | otherwise = do@@ -289,11 +390,11 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:mapM_".+-- 'Data.HashTable.Class.mapM_'. mapM_ :: ((k,v) -> ST s b) -> HashTable s k v -> ST s () mapM_ f htRef = readRef htRef >>= work where- work (HashTable sz _ _ hashes keys values) = go 0+ work (HashTable sz _ hashes keys values) = go 0 where go !i | i >= sz = return () | otherwise = do@@ -309,19 +410,19 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:computeOverhead".+-- 'Data.HashTable.Class.computeOverhead'. computeOverhead :: HashTable s k v -> ST s Double computeOverhead htRef = readRef htRef >>= work where- work (HashTable sz' loadRef _ _ _ _) = do- !ld <- U.readArray loadRef 0+ work (HashTable sz' loadRef _ _ _) = do+ !ld <- readLoad loadRef let k = fromIntegral ld / sz- return $ constOverhead / sz + overhead k+ return $ constOverhead/sz + (2 + 2*ws*(1-k)) / (k * ws) where+ ws = fromIntegral $! finiteBitSize (0::Int) `div` 8 sz = fromIntegral sz' -- Change these if you change the representation constOverhead = 14- overhead k = 3 / k - 2 ------------------------------@@ -345,11 +446,13 @@ probe b where+ he = hashToElem h+ probe !i = {-# SCC "insertRecord/probe" #-} do !idx <- forwardSearch2 hashes i sz emptyMarker deletedMarker debug $ "forwardSearch2 returned " ++ show idx assert (idx >= 0) $ do- U.writeArray hashes idx h+ U.writeArray hashes idx he writeArray keys idx key writeArray values idx value @@ -358,11 +461,9 @@ checkOverflow :: (Eq k, Hashable k) => (HashTable_ s k v) -> ST s (HashTable_ s k v)-checkOverflow ht@(HashTable sz ldRef delRef _ _ _) = do- !ld <- U.readArray ldRef 0- let !ld' = ld + 1- U.writeArray ldRef 0 ld'- !dl <- U.readArray delRef 0+checkOverflow ht@(HashTable sz ldRef _ _ _) = do+ !ld <- readLoad ldRef+ !dl <- readDelLoad ldRef debug $ concat [ "checkOverflow: sz=" , show sz@@ -380,11 +481,11 @@ ------------------------------------------------------------------------------ rehashAll :: Hashable k => HashTable_ s k v -> Int -> ST s (HashTable_ s k v)-rehashAll (HashTable sz loadRef _ hashes keys values) sz' = do+rehashAll (HashTable sz loadRef hashes keys values) sz' = do debug $ "rehashing: old size " ++ show sz ++ ", new size " ++ show sz' ht' <- newSizedReal sz'- let (HashTable _ loadRef' _ newHashes newKeys newValues) = ht'- U.readArray loadRef 0 >>= U.writeArray loadRef' 0+ let (HashTable _ loadRef' newHashes newKeys newValues) = ht'+ readLoad loadRef >>= writeLoad loadRef' rehash newHashes newKeys newValues return ht' @@ -404,57 +505,70 @@ ------------------------------------------------------------------------------ growTable :: Hashable k => HashTable_ s k v -> ST s (HashTable_ s k v)-growTable ht@(HashTable sz _ _ _ _ _) = do- let !sz' = bumpSize sz+growTable ht@(HashTable sz _ _ _ _) = do+ let !sz' = bumpSize maxLoad sz rehashAll ht sz' --------------------------------------------------------------------------------- Helper data structure for delete'-data Slot = Slot {- _slot :: {-# UNPACK #-} !Int- , _wasDeleted :: {-# UNPACK #-} !Int -- we use Int because Bool won't- -- unpack- }- deriving (Show)+-- Helper data structure for findSafeSlots+newtype Slot = Slot { _slot :: Int } deriving (Show) ------------------------------------------------------------------------------++#if MIN_VERSION_base(4,9,0)+instance Semigroup Slot where+ (<>) = slotMappend+#endif+ instance Monoid Slot where- mempty = Slot maxBound 0- (Slot x1 b1) `mappend` (Slot x2 b2) =- if x1 == maxBound then Slot x2 b2 else Slot x1 b1+ mempty = Slot maxBound+#if ! MIN_VERSION_base(4,11,0)+ mappend = slotMappend+#endif +slotMappend :: Slot -> Slot -> Slot+slotMappend (Slot x1) (Slot x2) =+ let !m = mask x1 maxBound+ in Slot $! (complement m .&. x1) .|. (m .&. x2) --------------------------------------------------------------------------------- Returns the slot in the array where it would be safe to write the given key.-delete' :: (Hashable k, Eq k) =>- (HashTable_ s k v)- -> Bool- -> k- -> Int- -> ST s Int-delete' (HashTable sz loadRef delRef hashes keys values) clearOut k h = do- debug $ "delete': sz=" ++ show sz ++ " h=" ++ show h- ++ " b0=" ++ show b0- (found, slot) <- go mempty b0 False+-- findSafeSlots return type+data SlotFindResponse = SlotFindResponse {+ _slotFound :: {-# UNPACK #-} !Int -- we use Int because Bool won't unpack+ , _slotB0 :: {-# UNPACK #-} !Int+ , _slotB1 :: {-# UNPACK #-} !Int+} deriving (Show) - let !b' = _slot slot - when found $ bump loadRef (-1)-- -- bump the delRef lower if we're writing over a deleted marker- when (not clearOut && _wasDeleted slot == 1) $ bump delRef (-1)- return b'+------------------------------------------------------------------------------+-- Returns ST s (SlotFoundResponse found b0 b1),+-- where+-- * found :: Int - 1 if key-value mapping is already in the table,+-- 0 otherwise.+-- * b0 :: Int - The index of a slot where it would be safe to write+-- the given key (if the key is already in the mapping,+-- you have to delete it before using this slot).+-- * b1 :: Int - The index of a slot where the key currently resides.+-- Or, if the key is not in the table, b1 is a slot+-- where it is safe to write the key (b1 == b0).+findSafeSlots :: (Hashable k, Eq k) =>+ (HashTable_ s k v)+ -> k+ -> Int+ -> ST s SlotFindResponse+findSafeSlots (HashTable !sz _ hashes keys _) k h = do+ debug $ "findSafeSlots: h=" ++ show h ++ " he=" ++ show he+ ++ " sz=" ++ show sz ++ " b0=" ++ show b0+ response <- go mempty b0 False+ debug $ "go returned " ++ show response+ return response where- bump ref i = do- !ld <- U.readArray ref 0- U.writeArray ref 0 $! ld + i-+ !he = hashToElem h !b0 = whichBucket h sz-- haveWrapped !(Slot fp _) !b = if fp == maxBound+ haveWrapped !(Slot fp) !b = if fp == maxBound then False else b <= fp @@ -466,10 +580,22 @@ -- * wrap True if we've wrapped around, False otherwise go !fp !b !wrap = do- debug $ "go: fp=" ++ show fp ++ " b=" ++ show b- ++ ", wrap=" ++ show wrap- !idx <- forwardSearch3 hashes b sz h emptyMarker deletedMarker+ debug $ concat [ "go: fp="+ , show fp+ , " b="+ , show b+ , ", wrap="+ , show wrap+ , ", he="+ , show he+ , ", emptyMarker="+ , show emptyMarker+ , ", deletedMarker="+ , show deletedMarker ]++ !idx <- forwardSearch3 hashes b sz he emptyMarker deletedMarker debug $ "forwardSearch3 returned " ++ show idx+ ++ " with sz=" ++ show sz ++ ", b=" ++ show b if wrap && idx >= b0 -- we wrapped around in the search and didn't find our hash code;@@ -478,8 +604,9 @@ -- -- TODO: if we get in this situation we should probably just rehash -- the table, because every insert is going to be O(n).- then return $!- (False, fp `mappend` (Slot (error "impossible") 0))+ then do+ let !sl = fp `mappend` (Slot (error "impossible"))+ return $! SlotFindResponse 0 (_slot sl) (_slot sl) else do -- because the table isn't full, we know that there must be either -- an empty or a deleted marker somewhere in the table. Assert this@@ -490,80 +617,146 @@ if recordIsEmpty h0 then do- let pl = fp `mappend` (Slot idx 0)+ let pl = fp `mappend` (Slot idx) debug $ "empty, returning " ++ show pl- return (False, pl)+ return $! SlotFindResponse 0 (_slot pl) (_slot pl) else do let !wrap' = haveWrapped fp idx if recordIsDeleted h0 then do- let pl = fp `mappend` (Slot idx 1)+ let !pl = fp `mappend` (Slot idx) debug $ "deleted, cont with pl=" ++ show pl go pl (idx + 1) wrap' else- if h == h0+ if he == h0 then do+ debug $ "found he == h0 == " ++ show h0 k' <- readArray keys idx if k == k' then do- let samePlace = _slot fp == idx debug $ "found at " ++ show idx- debug $ "clearout=" ++ show clearOut- debug $ "sp? " ++ show samePlace- -- "clearOut" is set if we intend to write a new- -- element into the slot. If we're doing an update- -- and we found the old key, instead of writing- -- "deleted" and then re-writing the new element- -- there, we can just write the new element. This- -- only works if we were planning on writing the- -- new element here.- when (clearOut || not samePlace) $ do- bump delRef 1- U.writeArray hashes idx 1- writeArray keys idx undefined- writeArray values idx undefined- return (True, fp `mappend` (Slot idx 0))+ let !sl = fp `mappend` (Slot idx)+ return $! SlotFindResponse 1 (_slot sl) idx else go fp (idx + 1) wrap' else go fp (idx + 1) wrap' + ------------------------------------------------------------------------------+{-# INLINE deleteFromSlot #-}+deleteFromSlot :: (HashTable_ s k v) -> Int -> ST s ()+deleteFromSlot (HashTable _ loadRef hashes keys values) idx = do+ !he <- U.readArray hashes idx+ when (recordIsFilled he) $ do+ bumpDelLoad loadRef 1+ bumpLoad loadRef (-1)+ U.writeArray hashes idx deletedMarker+ writeArray keys idx undefined+ writeArray values idx undefined+++------------------------------------------------------------------------------+{-# INLINE insertIntoSlot #-}+insertIntoSlot :: (HashTable_ s k v) -> Int -> Elem -> k -> v -> ST s ()+insertIntoSlot (HashTable _ loadRef hashes keys values) idx he k v = do+ !heOld <- U.readArray hashes idx+ let !heInt = fromIntegral heOld :: Int+ !delInt = fromIntegral deletedMarker :: Int+ !emptyInt = fromIntegral emptyMarker :: Int+ !delBump = mask heInt delInt -- -1 if heInt == delInt,+ -- 0 otherwise+ !mLoad = mask heInt delInt .|. mask heInt emptyInt+ !loadBump = mLoad .&. 1 -- 1 if heInt == delInt || heInt == emptyInt,+ -- 0 otherwise+ bumpDelLoad loadRef delBump+ bumpLoad loadRef loadBump+ U.writeArray hashes idx he+ writeArray keys idx k+ writeArray values idx v+++-------------------------------------------------------------------------------+{-# INLINE bumpLoad #-}+bumpLoad :: (SizeRefs s) -> Int -> ST s ()+bumpLoad ref i = do+ !ld <- readLoad ref+ writeLoad ref $! ld + i+++------------------------------------------------------------------------------+{-# INLINE bumpDelLoad #-}+bumpDelLoad :: (SizeRefs s) -> Int -> ST s ()+bumpDelLoad ref i = do+ !ld <- readDelLoad ref+ writeDelLoad ref $! ld + i+++----------------------------------------------------------------------------- maxLoad :: Double maxLoad = 0.82 -------------------------------------------------------------------------------emptyMarker :: Int+emptyMarker :: Elem emptyMarker = 0 + -------------------------------------------------------------------------------deletedMarker :: Int+deletedMarker :: Elem deletedMarker = 1 ------------------------------------------------------------------------------+{-# INLINE trueInt #-}+trueInt :: Int -> Bool+trueInt (I# i#) = tagToEnum# i#+++------------------------------------------------------------------------------ {-# INLINE recordIsEmpty #-}-recordIsEmpty :: Int -> Bool+recordIsEmpty :: Elem -> Bool recordIsEmpty = (== emptyMarker) ------------------------------------------------------------------------------ {-# INLINE recordIsDeleted #-}-recordIsDeleted :: Int -> Bool+recordIsDeleted :: Elem -> Bool recordIsDeleted = (== deletedMarker) ------------------------------------------------------------------------------+{-# INLINE recordIsFilled #-}+recordIsFilled :: Elem -> Bool+recordIsFilled !el = tagToEnum# isFilled#+ where+ !el# = U.elemToInt# el+ !deletedMarker# = U.elemToInt# deletedMarker+ !emptyMarker# = U.elemToInt# emptyMarker+#if __GLASGOW_HASKELL__ >= 708+ !isFilled# = (el# /=# deletedMarker#) `andI#` (el# /=# emptyMarker#)+#else+ !delOrEmpty# = mask# el# deletedMarker# `orI#` mask# el# emptyMarker#+ !isFilled# = 1# `andI#` notI# delOrEmpty#+#endif+++------------------------------------------------------------------------------ {-# INLINE hash #-} hash :: (Hashable k) => k -> Int-hash k = out+hash = H.hash+++------------------------------------------------------------------------------+{-# INLINE hashToElem #-}+hashToElem :: Int -> Elem+hashToElem !h = out where- !(I# h#) = H.hash k+ !(I# lo#) = h .&. U.elemMask - !m# = maskw# h# 0# `or#` maskw# h# 1#+ !m# = maskw# lo# 0# `or#` maskw# lo# 1# !nm# = not# m# - !r# = ((int2Word# 2#) `and#` m#) `or#` (int2Word# h# `and#` nm#)- !out = I# (word2Int# r#)+ !r# = ((int2Word# 2#) `and#` m#) `or#` (int2Word# lo# `and#` nm#)+ !out = U.primWordToElem r# ------------------------------------------------------------------------------@@ -588,3 +781,68 @@ #else debug _ = return () #endif++lookupIndex :: (Eq k, Hashable k) => HashTable s k v -> k -> ST s (Maybe Word)+lookupIndex htRef !k = do+ ht <- readRef htRef+ lookup' ht+ where+ lookup' (HashTable sz _ hashes keys _values) = do+ let !b = whichBucket h sz+ debug $ "lookup h=" ++ show h ++ " sz=" ++ show sz ++ " b=" ++ show b+ go b 0 sz++ where+ !h = hash k+ !he = hashToElem h++ go !b !start !end = {-# SCC "lookupIndex/go" #-} do+ debug $ concat [ "lookupIndex/go: "+ , show b+ , "/"+ , show start+ , "/"+ , show end+ ]+ idx <- forwardSearch2 hashes b end he emptyMarker+ debug $ "forwardSearch2 returned " ++ show idx+ if (idx < 0 || idx < start || idx >= end)+ then return Nothing+ else do+ h0 <- U.readArray hashes idx+ debug $ "h0 was " ++ show h0++ if recordIsEmpty h0+ then do+ debug $ "record empty, returning Nothing"+ return Nothing+ else do+ k' <- readArray keys idx+ if k == k'+ then do+ debug $ "value found at " ++ show idx+ return $! (Just $! fromIntegral idx)+ else do+ debug $ "value not found, recursing"+ if idx < b+ then go (idx + 1) (idx + 1) b+ else go (idx + 1) start end+{-# INLINE lookupIndex #-}++nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word, k, v))+nextByIndex htRef i0 = readRef htRef >>= work+ where+ work (HashTable sz _ hashes keys values) = go (fromIntegral i0)+ where+ go i | i >= sz = return Nothing+ | otherwise = do+ h <- U.readArray hashes i+ if recordIsEmpty h || recordIsDeleted h+ then go (i+1)+ else do+ k <- readArray keys i+ v <- readArray values i+ let !i' = fromIntegral i+ return (Just (i', k, v))+{-# INLINE nextByIndex #-}+
src/Data/HashTable/ST/Cuckoo.hs view
@@ -10,7 +10,7 @@ * want the fastest possible inserts, and very fast lookups. * are conscious of memory usage; this table has less space overhead than- "Data.HashTable.ST.Basic", but more than "Data.HashTable.ST.Linear".+ "Data.HashTable.ST.Basic" or "Data.HashTable.ST.Linear". * don't care that a table resize might pause for a long time to rehash all of the key-value mappings.@@ -51,9 +51,8 @@ the basic open-addressing hash table using linear probing, and on average is more space-efficient: in randomized testing on my 64-bit machine (see @test\/compute-overhead\/ComputeOverhead.hs@ in the source distribution), mean-overhead is 1.71 machine words per key-value mapping, with a standard deviation-of 0.30 words, and 2.46 words per mapping at the 95th percentile.-+overhead is 0.77 machine words per key-value mapping, with a standard deviation+of 0.29 words, and 1.23 words per mapping at the 95th percentile. /References:/ @@ -69,27 +68,42 @@ , delete , lookup , insert+ , mutate+ , mutateST , mapM_ , foldM+ , lookupIndex+ , nextByIndex ) where -------------------------------------------------------------------------------import Control.Monad hiding (foldM, mapM_)-import Control.Monad.ST-import Data.Hashable hiding (hash)-import qualified Data.Hashable as H+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif+import Control.Monad hiding+ (foldM,+ mapM_)+import Control.Monad.ST (ST)+import Data.Bits+import Data.Hashable hiding+ (hash)+import qualified Data.Hashable as H import Data.Int import Data.Maybe import Data.Primitive.Array import Data.STRef import GHC.Exts-import Prelude hiding ( lookup, read, mapM_ )+import Prelude hiding+ (lookup,+ mapM_,+ read) -------------------------------------------------------------------------------import qualified Data.HashTable.Class as C-import Data.HashTable.Internal.CheapPseudoRandomBitStream+import qualified Data.HashTable.Class as C import Data.HashTable.Internal.CacheLine-import qualified Data.HashTable.Internal.IntArray as U+import Data.HashTable.Internal.CheapPseudoRandomBitStream+import Data.HashTable.Internal.IntArray (Elem)+import qualified Data.HashTable.Internal.IntArray as U import Data.HashTable.Internal.Utils #ifdef DEBUG@@ -102,12 +116,12 @@ newtype HashTable s k v = HT (STRef s (HashTable_ s k v)) data HashTable_ s k v = HashTable- { _size :: {-# UNPACK #-} !Int -- ^ in buckets, total size is- -- numWordsInCacheLine * _size- , _rng :: {-# UNPACK #-} !(BitStream s)- , _hashes :: {-# UNPACK #-} !(U.IntArray s)- , _keys :: {-# UNPACK #-} !(MutableArray s k)- , _values :: {-# UNPACK #-} !(MutableArray s v)+ { _size :: {-# UNPACK #-} !Int -- ^ in buckets, total size is+ -- numElemsInCacheLine * _size+ , _rng :: {-# UNPACK #-} !(BitStream s)+ , _hashes :: {-# UNPACK #-} !(U.IntArray s)+ , _keys :: {-# UNPACK #-} !(MutableArray s k)+ , _values :: {-# UNPACK #-} !(MutableArray s v) , _maxAttempts :: {-# UNPACK #-} !Int } @@ -121,7 +135,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate+ mutateST = mutateST ------------------------------------------------------------------------------@@ -131,7 +149,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:new".+-- 'Data.HashTable.Class.new'. new :: ST s (HashTable s k v) new = newSizedReal 2 >>= newRef {-# INLINE new #-}@@ -139,10 +157,10 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:newSized".+-- 'Data.HashTable.Class.newSized'. newSized :: Int -> ST s (HashTable s k v) newSized n = do- let n' = (n + numWordsInCacheLine - 1) `div` numWordsInCacheLine+ let n' = (n + numElemsInCacheLine - 1) `div` numElemsInCacheLine let k = nextBestPrime $ ceiling $ fromIntegral n' / maxLoad newSizedReal k >>= newRef {-# INLINE newSized #-}@@ -150,35 +168,61 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:insert".+-- 'Data.HashTable.Class.insert'. insert :: (Eq k, Hashable k) => HashTable s k v -> k -> v -> ST s () insert ht !k !v = readRef ht >>= \h -> insert' h k v >>= writeRef ht ------------------------------------------------------------------------------+mutate :: (Eq k, Hashable k) =>+ HashTable s k v+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef !k !f = mutateST htRef k (pure . f)+{-# INLINE mutate #-}+++------------------------------------------------------------------------------+mutateST :: (Eq k, Hashable k) =>+ HashTable s k v+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s a+mutateST htRef !k !f = do+ ht <- readRef htRef+ (newHt, a) <- mutate' ht k f+ writeRef htRef newHt+ return a+{-# INLINE mutateST #-}+++------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:computeOverhead".+-- 'Data.HashTable.Class.computeOverhead'. computeOverhead :: HashTable s k v -> ST s Double computeOverhead htRef = readRef htRef >>= work where work (HashTable sz _ _ _ _ _) = do nFilled <- foldM f 0 htRef - let oh = totSz -- one word per element in hashes- + 2 * (totSz - nFilled) -- two words per non-filled entry- + 12 -- fixed overhead+ let oh = (totSz `div` hashCodesPerWord) -- one half or quarter word+ -- per element in hashes+ + 2 * (totSz - nFilled) -- two words per non-filled entry+ + 12 -- fixed overhead return $! fromIntegral (oh::Int) / fromIntegral nFilled where- totSz = numWordsInCacheLine * sz+ hashCodesPerWord = (finiteBitSize (0 :: Int)) `div` 16+ totSz = numElemsInCacheLine * sz f !a _ = return $! a+1 ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:delete".+-- 'Data.HashTable.Class.delete'. delete :: (Hashable k, Eq k) => HashTable s k v -> k@@ -199,7 +243,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:lookup".+-- 'Data.HashTable.Class.lookup'. lookup :: (Eq k, Hashable k) => HashTable s k v -> k@@ -218,14 +262,14 @@ lookup' (HashTable sz _ hashes keys values _) !k = do -- Unlike the write case, prefetch doesn't seem to help here for lookup. -- prefetchRead hashes b2- idx1 <- searchOne keys hashes k b1 h1+ idx1 <- searchOne keys hashes k b1 he1 if idx1 >= 0 then do v <- readArray values idx1 return $! Just v else do- idx2 <- searchOne keys hashes k b2 h2+ idx2 <- searchOne keys hashes k b2 he2 if idx2 >= 0 then do v <- readArray values idx2@@ -237,6 +281,9 @@ h1 = hash1 k h2 = hash2 k + he1 = hashToElem h1+ he2 = hashToElem h2+ b1 = whichLine h1 sz b2 = whichLine h2 sz {-# INLINE lookup' #-}@@ -248,12 +295,12 @@ -> U.IntArray s -> k -> Int- -> Int+ -> Elem -> ST s Int-searchOne !keys !hashes !k = go+searchOne !keys !hashes !k !b0 !h = go b0 where- go !b !h = do- debug $ "searchOne: go " ++ show b ++ " " ++ show h+ go !b = do+ debug $ "searchOne: go/" ++ show b ++ "/" ++ show h idx <- cacheLineSearch hashes b h debug $ "searchOne: cacheLineSearch returned " ++ show idx @@ -267,14 +314,14 @@ let !idx' = idx + 1 if isCacheLineAligned idx' then return (-1)- else go idx' h+ else go idx' {-# INLINE searchOne #-} ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:foldM".+-- 'Data.HashTable.Class.foldM'. foldM :: (a -> (k,v) -> ST s a) -> a -> HashTable s k v@@ -290,7 +337,7 @@ -> ST s a foldMWork f seed0 (HashTable sz _ hashes keys values _) = go 0 seed0 where- totSz = numWordsInCacheLine * sz+ totSz = numElemsInCacheLine * sz go !i !seed | i >= totSz = return seed | otherwise = do@@ -309,7 +356,7 @@ ------------------------------------------------------------------------------ -- | See the documentation for this function in--- "Data.HashTable.Class#v:mapM_".+-- 'Data.HashTable.Class.mapM_'. mapM_ :: ((k,v) -> ST s a) -> HashTable s k v -> ST s ()@@ -323,7 +370,7 @@ -> ST s () mapMWork f (HashTable sz _ hashes keys values _) = go 0 where- totSz = numWordsInCacheLine * sz+ totSz = numElemsInCacheLine * sz go !i | i >= totSz = return () | otherwise = do@@ -347,7 +394,7 @@ ------------------------------------------------------------------------------ newSizedReal :: Int -> ST s (HashTable_ s k v) newSizedReal nbuckets = do- let !ntotal = nbuckets * numWordsInCacheLine+ let !ntotal = nbuckets * numElemsInCacheLine let !maxAttempts = 12 + (log2 $ toEnum nbuckets) debug $ "creating cuckoo hash table with " ++@@ -379,6 +426,102 @@ ------------------------------------------------------------------------------+mutate' :: (Eq k, Hashable k) =>+ HashTable_ s k v+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s (HashTable_ s k v, a)+mutate' ht@(HashTable sz _ hashes keys values _) !k !f = do+ !(maybeVal, idx, _hashCode) <- lookupSlot+ !fRes <- f maybeVal+ case (maybeVal, fRes) of+ (Nothing, (Nothing, a)) -> return (ht, a)+ (Just _v, (Just v', a)) -> do+ writeArray values idx v'+ return (ht, a)+ (Just _v, (Nothing, a)) -> do+ deleteFromSlot ht idx+ return (ht, a)+ (Nothing, (Just v', a)) -> do+ newHt <- insertNew v'+ return (newHt, a)++ where+ h1 = hash1 k+ h2 = hash2 k++ b1 = whichLine h1 sz+ b2 = whichLine h2 sz++ he1 = hashToElem h1+ he2 = hashToElem h2++ lookupSlot = do+ idx1 <- searchOne keys hashes k b1 he1+ if idx1 >= 0+ then do+ v <- readArray values idx1+ return (Just v, idx1, h1)+ else do+ idx2 <- searchOne keys hashes k b2 he2+ if idx2 >= 0+ then do+ v <- readArray values idx2+ return (Just v, idx2, h2)+ else do+ return (Nothing, -1, -1)++ insertNew v = do+ idxE1 <- cacheLineSearch hashes b1 emptyMarker+ if idxE1 >= 0+ then do+ insertIntoSlot ht idxE1 he1 k v+ return ht+ else do+ idxE2 <- cacheLineSearch hashes b2 emptyMarker+ if idxE2 >= 0+ then do+ insertIntoSlot ht idxE2 he2 k v+ return ht+ else do+ result <- cuckooOrFail ht h1 h2 b1 b2 k v+ maybe (return ht)+ (\(k', v') -> do+ newHt <- grow ht k' v'+ return newHt)+ result+{-# INLINE mutate' #-}+++------------------------------------------------------------------------------+deleteFromSlot :: (Eq k, Hashable k) =>+ HashTable_ s k v+ -> Int+ -> ST s ()+deleteFromSlot _ht@(HashTable _ _ hashes keys values _) idx = do+ U.writeArray hashes idx emptyMarker+ writeArray keys idx undefined+ writeArray values idx undefined+{-# INLINE deleteFromSlot #-}+++------------------------------------------------------------------------------+insertIntoSlot :: (Eq k, Hashable k) =>+ HashTable_ s k v+ -> Int+ -> Elem+ -> k+ -> v+ -> ST s ()+insertIntoSlot _ht@(HashTable _ _ hashes keys values _) idx he k v = do+ U.writeArray hashes idx he+ writeArray keys idx k+ writeArray values idx v+{-# INLINE insertIntoSlot #-}++++------------------------------------------------------------------------------ updateOrFail :: (Eq k, Hashable k) => HashTable_ s k v -> k@@ -421,7 +564,7 @@ --------------------------------------------------------------------------------- Returns either (-1,-1) (not found, and both buckets full ==> trigger+-- Returns either (-1, 0) (not found, and both buckets full ==> trigger -- cuckoo), or the slot in the array where it would be safe to write the given -- key, and the hashcode to use there delete' :: (Hashable k, Eq k) =>@@ -432,17 +575,19 @@ -> Int -- ^ cache line start address 2 -> Int -- ^ hash1 -> Int -- ^ hash2- -> ST s (Int, Int)+ -> ST s (Int, Elem) delete' (HashTable _ _ hashes keys values _) !updating !k b1 b2 h1 h2 = do debug $ "delete' b1=" ++ show b1 ++ " b2=" ++ show b2 ++ " h1=" ++ show h1 ++ " h2=" ++ show h2 prefetchWrite hashes b2- idx1 <- searchOne keys hashes k b1 h1+ let !he1 = hashToElem h1+ let !he2 = hashToElem h2+ idx1 <- searchOne keys hashes k b1 he1 if idx1 < 0 then do- idx2 <- searchOne keys hashes k b2 h2+ idx2 <- searchOne keys hashes k b2 he2 if idx2 < 0 then if updating then do@@ -451,16 +596,16 @@ idxE1 <- cacheLineSearch hashes b1 emptyMarker debug $ "delete': idxE1 was " ++ show idxE1 if idxE1 >= 0- then return (idxE1, h1)+ then return (idxE1, he1) else do idxE2 <- cacheLineSearch hashes b2 emptyMarker debug $ "delete': idxE2 was " ++ show idxE1 if idxE2 >= 0- then return (idxE2, h2)- else return (-1, -1)- else return (-1,-1)- else deleteIt idx2 h2- else deleteIt idx1 h1+ then return (idxE2, he2)+ else return (-1, 0)+ else return (-1, 0)+ else deleteIt idx2 he2+ else deleteIt idx1 he1 where deleteIt !idx !h = do@@ -517,21 +662,23 @@ where randomIdx !b = do !z <- getNBits cacheLineIntBits rng- return $! b + z+ return $! b + fromIntegral z bumpIdx !idx !h !k !v = do+ let !he = hashToElem h debug $ "bumpIdx idx=" ++ show idx ++ " h=" ++ show h- !h' <- U.readArray hashes idx- debug $ "bumpIdx: h' was " ++ show h'+ ++ " he=" ++ show he+ !he' <- U.readArray hashes idx+ debug $ "bumpIdx: he' was " ++ show he' !k' <- readArray keys idx v' <- readArray values idx- U.writeArray hashes idx h+ U.writeArray hashes idx he writeArray keys idx k writeArray values idx v- debug $ "bumped key with h'=" ++ show h'- return $! (h', k', v')+ debug $ "bumped key with he'=" ++ show he'+ return $! (he', k', v') - otherHash h k = if h2 == h then h1 else h2+ otherHash he k = if hashToElem h1 == he then h2 else h1 where h1 = hash1 k h2 = hash2 k@@ -543,7 +690,7 @@ if idx >= 0 then do- U.writeArray hashes idx h+ U.writeArray hashes idx $! hashToElem h writeArray keys idx k writeArray values idx v return Nothing@@ -552,8 +699,8 @@ go !b !h !k v !maxAttempts | maxAttempts == 0 = return $! Just (k,v) | otherwise = do idx <- randomIdx b- (!h0', !k', v') <- bumpIdx idx h k v- let !h' = otherHash h0' k'+ (!he0', !k', v') <- bumpIdx idx h k v+ let !h' = otherHash he0' k' let !b' = whichLine h' sz tryWrite b' h' k' v' maxAttempts@@ -566,11 +713,11 @@ -> v -> ST s (HashTable_ s k v) grow (HashTable sz _ hashes keys values _) k0 v0 = do- newHt <- grow' $! bumpSize sz+ newHt <- grow' $! bumpSize bumpFactor sz mbR <- updateOrFail newHt k0 v0 maybe (return newHt)- (\_ -> grow' $ bumpSize $ _size newHt)+ (\_ -> grow' $ bumpSize bumpFactor $ _size newHt) mbR where@@ -583,7 +730,7 @@ rehash !newSz !newHt = go 0 where- totSz = numWordsInCacheLine * sz+ totSz = numElemsInCacheLine * sz go !i | i >= totSz = return newHt | otherwise = do@@ -595,7 +742,7 @@ mbR <- updateOrFail newHt k v maybe (go $ i + 1)- (\_ -> grow' $ bumpSize newSz)+ (\_ -> grow' $ bumpSize bumpFactor newSz) mbR else go $ i + 1 @@ -610,30 +757,31 @@ ------------------------------------------------------------------------------ hash1 :: Hashable k => k -> Int-hash1 = hashF H.hash+hash1 = H.hash {-# INLINE hash1 #-} hash2 :: Hashable k => k -> Int-hash2 = hashF (H.hashWithSalt hashPrime)+hash2 = H.hashWithSalt hashPrime {-# INLINE hash2 #-} -hashF :: (k -> Int) -> k -> Int-hashF f k = out+------------------------------------------------------------------------------+hashToElem :: Int -> Elem+hashToElem !h = out where- !(I# h#) = f k+ !(I# lo#) = h .&. U.elemMask - !m# = maskw# h# 0#+ !m# = maskw# lo# 0# !nm# = not# m# - !r# = ((int2Word# 1#) `and#` m#) `or#` (int2Word# h# `and#` nm#)- !out = I# (word2Int# r#)-{-# INLINE hashF #-}+ !r# = ((int2Word# 1#) `and#` m#) `or#` (int2Word# lo# `and#` nm#)+ !out = U.primWordToElem r#+{-# INLINE hashToElem #-} -------------------------------------------------------------------------------emptyMarker :: Int+emptyMarker :: Elem emptyMarker = 0 @@ -643,6 +791,11 @@ ------------------------------------------------------------------------------+bumpFactor :: Double+bumpFactor = 0.73+++------------------------------------------------------------------------------ debug :: String -> ST s () #ifdef DEBUG debug s = unsafeIOToST (putStrLn s >> hFlush stdout)@@ -671,3 +824,43 @@ readRef (HT ref) = readSTRef ref {-# INLINE readRef #-} ++------------------------------------------------------------------------------++-- | Find index of given key in the hashtable.+lookupIndex :: (Hashable k, Eq k) => HashTable s k v -> k -> ST s (Maybe Word)+lookupIndex htRef k =+ do HashTable sz _ hashes keys _ _ <- readRef htRef++ let !h1 = hash1 k+ !h2 = hash2 k+ !he1 = hashToElem h1+ !he2 = hashToElem h2+ !b1 = whichLine h1 sz+ !b2 = whichLine h2 sz++ idx1 <- searchOne keys hashes k b1 he1+ if idx1 >= 0+ then return $! (Just $! fromIntegral idx1)+ else do idx2 <- searchOne keys hashes k b2 he2+ if idx2 >= 0+ then return $! (Just $! fromIntegral idx2)+ else return Nothing++-- | Find the next entry in the hashtable starting at the given index.+nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word,k,v))+nextByIndex htRef i0 =+ do HashTable sz _ hashes keys values _ <- readRef htRef+ let totSz = numElemsInCacheLine * sz+ go i+ | i >= totSz = return Nothing+ | otherwise =+ do h <- U.readArray hashes i+ if h == emptyMarker+ then go (i+1)+ else do k <- readArray keys i+ v <- readArray values i+ let !i' = fromIntegral i+ return (Just (i',k,v))++ go (fromIntegral i0)
src/Data/HashTable/ST/Linear.hs view
@@ -6,9 +6,6 @@ {-| 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)@@ -86,23 +83,29 @@ , delete , lookup , insert+ , mutate+ , mutateST , mapM_ , foldM , computeOverhead ) where -------------------------------------------------------------------------------import Control.Monad hiding (mapM_, foldM)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+import Data.Word+#endif+import Control.Monad hiding (foldM, mapM_) import Control.Monad.ST import Data.Bits import Data.Hashable import Data.STRef-import Prelude hiding (mapM_, lookup)+import Prelude hiding (lookup, mapM_) -------------------------------------------------------------------------------import qualified Data.HashTable.Class as C+import qualified Data.HashTable.Class as C import Data.HashTable.Internal.Array-import qualified Data.HashTable.Internal.Linear.Bucket as Bucket import Data.HashTable.Internal.Linear.Bucket (Bucket)+import qualified Data.HashTable.Internal.Linear.Bucket as Bucket import Data.HashTable.Internal.Utils #ifdef DEBUG@@ -130,7 +133,11 @@ lookup = lookup foldM = foldM mapM_ = mapM_+ lookupIndex = lookupIndex+ nextByIndex = nextByIndex computeOverhead = computeOverhead+ mutate = mutate+ mutateST = mutateST ------------------------------------------------------------------------------@@ -221,8 +228,42 @@ {-# INLINE insert #-} +------------------------------------------------------------------------------+mutate :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> (Maybe v, a))+ -> ST s a+mutate htRef k f = mutateST htRef k (pure . f)+{-# INLINE mutate #-} + ------------------------------------------------------------------------------+mutateST :: (Eq k, Hashable k) =>+ (HashTable s k v)+ -> k+ -> (Maybe v -> ST s (Maybe v, a))+ -> ST s a+mutateST htRef k f = do+ (ht, a) <- readRef htRef >>= work+ writeRef htRef ht+ return a+ where+ work ht@(HashTable lvl splitptr buckets) = do+ let !h0 = hashKey lvl splitptr k+ bucket <- readArray buckets h0+ (!bsz, mbk, a) <- Bucket.mutateST bucket k f+ maybe (return ())+ (writeArray buckets h0)+ mbk+ if checkOverflow bsz+ then do+ ht' <- split ht+ return (ht', a)+ else return (ht, a)+++------------------------------------------------------------------------------ -- | See the documentation for this function in -- "Data.HashTable.Class#v:mapM_". mapM_ :: ((k,v) -> ST s b) -> HashTable s k v -> ST s ()@@ -462,3 +503,57 @@ #endif #endif ++------------------------------------------------------------------------------+-- | See the documentation for this function in+-- "Data.HashTable.Class#v:lookupIndex".+lookupIndex :: (Eq k, Hashable k) => HashTable s k v -> k -> ST s (Maybe Word)+lookupIndex htRef !k = readRef htRef >>= work+ where+ work (HashTable lvl splitptr buckets) = do+ let h0 = hashKey lvl splitptr k+ bucket <- readArray buckets h0+ mbIx <- Bucket.lookupIndex bucket k+ return $! do ix <- mbIx+ Just $! encodeIndex lvl h0 ix+{-# INLINE lookupIndex #-}++encodeIndex :: Int -> Int -> Int -> Word+encodeIndex lvl bucketIx elemIx =+ fromIntegral bucketIx `Data.Bits.shiftL` indexOffset lvl .|.+ fromIntegral elemIx+{-# INLINE encodeIndex #-}++decodeIndex :: Int -> Word -> (Int, Int)+decodeIndex lvl ix =+ ( fromIntegral (ix `Data.Bits.shiftR` offset)+ , fromIntegral ( (bit offset - 1) .&. ix )+ )+ where offset = indexOffset lvl+{-# INLINE decodeIndex #-}++indexOffset :: Int -> Int+indexOffset lvl = finiteBitSize (0 :: Word) - lvl+{-# INLINE indexOffset #-}++nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word,k,v))+nextByIndex htRef !k = readRef htRef >>= work+ where+ work (HashTable lvl _ buckets) = do+ let (h0,ix) = decodeIndex lvl k+ go h0 ix++ where+ bucketN = power2 lvl+ go h ix+ | h < 0 || bucketN <= h = return Nothing+ | otherwise = do+ bucket <- readArray buckets h+ mb <- Bucket.elemAt bucket ix+ case mb of+ Just (k',v) ->+ let !ix' = encodeIndex lvl h ix+ in return (Just (ix', k', v))+ Nothing -> go (h+1) 0++{-# INLINE nextByIndex #-}
test/compute-overhead/ComputeOverhead.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-} module Main where
test/hashtables-test.cabal view
@@ -2,10 +2,10 @@ Version: 0.2 Author: Gregory Collins Maintainer: greg@gregorycollins.net-Copyright: (c) 2011-2012, Google, Inc.+Copyright: (c) 2011-2013, Google, Inc. Category: Data Build-type: Simple-Cabal-version: >= 1.8+Cabal-version: >= 1.10 ------------------------------------------------------------------------------ Flag debug@@ -22,75 +22,31 @@ Description: if on, use bounds-checking array accesses Default: False --Flag sse41- Description: if on, use SSE 4.1 extensions to search cache lines very- efficiently+Flag sse42+ Description: if on, use SSE 4.2 extensions to search cache lines very+ efficiently. The portable flag forces this off. Default: False - Flag portable Description: if on, use only pure Haskell code and no GHC extensions. Default: False -Executable testsuite- hs-source-dirs: ../src suite- main-is: TestSuite.hs-- if !flag(portable)- C-sources: ../cbits/cfuncs.c-- ghc-prof-options: -prof -auto-all-- if flag(portable) || !flag(unsafe-tricks)- ghc-options: -fhpc-- if flag(portable)- cpp-options: -DNO_C_SEARCH -DPORTABLE-- if !flag(portable) && flag(unsafe-tricks) && impl(ghc)- cpp-options: -DUNSAFETRICKS- build-depends: ghc-prim-- if flag(debug)- cpp-options: -DDEBUG-- if flag(bounds-checking)- cpp-options: -DBOUNDS_CHECKING-- if !flag(portable) && flag(sse41)- cc-options: -DUSE_SSE_4_1 -msse4.1- cpp-options: -DUSE_SSE_4_1-- Build-depends: base >= 4 && <5,- hashable >= 1.1 && <2,- mwc-random >= 0.8 && <0.13,- primitive,- QuickCheck >= 2.3.0.2,- HUnit >= 1.2 && <2,- test-framework >= 0.3.1 && <0.7,- test-framework-quickcheck2 >= 0.2.6 && <0.3,- test-framework-hunit >= 0.2.6 && <3,- vector >= 0.7-- cpp-options: -DTESTSUITE-- if impl(ghc >= 7)- ghc-options: -rtsopts-- if impl(ghc >= 6.12.0)- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2- -fno-warn-unused-do-bind -threaded- else- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -threaded-- Executable compute-overhead hs-source-dirs: ../src suite compute-overhead main-is: ComputeOverhead.hs- C-sources: ../cbits/cfuncs.c + if flag(sse42) && !flag(portable)+ cc-options: -DUSE_SSE_4_2 -msse4.2+ cpp-options: -DUSE_SSE_4_2+ C-sources: ../cbits/sse-42.c++ if !flag(portable) && !flag(sse42)+ C-sources: ../cbits/default.c++ if !flag(portable)+ C-sources: ../cbits/common.c+ ghc-prof-options: -prof -auto-all if flag(portable)@@ -106,19 +62,15 @@ if flag(bounds-checking) cpp-options: -DBOUNDS_CHECKING - if !flag(portable) && flag(sse41)- cc-options: -DUSE_SSE_4_1 -msse4.1- cpp-options: -DUSE_SSE_4_1- Build-depends: base >= 4 && <5,- hashable >= 1.1 && <2,- mwc-random >= 0.8 && <0.13,- QuickCheck >= 2.3.0.2 && <3,+ hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,+ mwc-random >= 0.8 && <0.14,+ QuickCheck >= 2.9 && <3, HUnit >= 1.2 && <2,- test-framework >= 0.3.1 && <0.7,- test-framework-quickcheck2 >= 0.2.6 && <0.3,+ test-framework >= 0.3.1 && <0.9,+ test-framework-quickcheck2 >= 0.2.6 && <0.4, test-framework-hunit >= 0.2.6 && <3,- statistics >= 0.8 && <0.11,+ statistics >= 0.14 && <0.15, primitive, vector >= 0.7
− test/runTestsAndCoverage.sh
@@ -1,46 +0,0 @@-#!/bin/sh--set -e--SUITE=./dist/build/testsuite/testsuite--export LC_ALL=C-export LANG=C--rm -f testsuite.tix--if [ ! -f $SUITE ]; then- cat <<EOF-Testsuite executable not found, please run:- cabal configure -ftest-then- cabal build-EOF- exit;-fi--./dist/build/testsuite/testsuite -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
@@ -1,20 +0,0 @@-#!/bin/sh--set -e--SUITE=./dist/build/testsuite/testsuite--export LC_ALL=C-export LANG=C--if [ ! -f $SUITE ]; then- cat <<EOF-Testsuite executable not found, please run:- cabal configure -ftest-then- cabal build-EOF- exit;-fi--./dist/build/testsuite/testsuite -j4 -a1000 $*
test/suite/Data/HashTable/Test/Common.hs view
@@ -11,41 +11,66 @@ ) where -------------------------------------------------------------------------------import Control.Monad (foldM_, liftM, when)-import Control.Monad.ST (unsafeIOToST)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (pure, (<$>))+#endif+import Control.Applicative ((<|>))+import Control.Monad (foldM_, when)+import qualified Control.Monad as Monad import Data.IORef-import Data.List hiding ( insert- , delete- , lookup )+import Data.List hiding (delete, insert,+ 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 System.Timeout-import Test.Framework-import Test.Framework.Providers.HUnit-import Test.Framework.Providers.QuickCheck2-import Test.HUnit (assertFailure)-import Test.QuickCheck-import Test.QuickCheck.Monadic+import Test.Tasty+import Test.Tasty.HUnit hiding (assert)+import Test.Tasty.QuickCheck+import Test.QuickCheck.Monadic (PropertyM, assert,+ forAllM, monadicIO, pre,+ run) ------------------------------------------------------------------------------ import qualified Data.HashTable.Class as C+import Data.HashTable.Internal.Utils (unsafeIOToST) import Data.HashTable.IO #ifndef PORTABLE import Control.Concurrent-import Foreign (malloc, free, poke, Ptr)-import Foreign.C.Types (CInt)+import Foreign (Ptr, free, malloc, poke)+import Foreign.C.Types (CInt (..)) #endif ------------------------------------------------------------------------------ type FixedTableType h = forall k v . IOHashTable h k v-type HashTest = forall h . C.HashTable h => String -> FixedTableType h -> Test+type HashTest = forall h . C.HashTable h => String -> FixedTableType h -> TestTree data SomeTest = SomeTest HashTest ------------------------------------------------------------------------------+announce :: Show a => String -> a -> IO ()+#ifdef DEBUG+announce nm x = do+ putStrLn "\n============================="+ putStrLn $ concat [ "starting "+ , nm+ , " with "+ , show x+ ]+ putStrLn "============================="+#else+announce _ _ = return ()+#endif+++------------------------------------------------------------------------------+announceQ :: Show a => String -> a -> PropertyM IO ()+announceQ nm x = run $ announce nm x+++------------------------------------------------------------------------------ assertEq :: (Eq a, Show a) => String -> a -> a -> PropertyM IO () assertEq s expected got =@@ -66,7 +91,7 @@ -------------------------------------------------------------------------------tests :: C.HashTable h => String -> FixedTableType h -> Test+tests :: C.HashTable h => String -> FixedTableType h -> TestTree tests prefix dummyArg = testGroup prefix $ map f ts where f (SomeTest ht) = ht prefix dummyArg@@ -79,6 +104,8 @@ , SomeTest testDelete , SomeTest testNastyFullLookup , SomeTest testForwardSearch3+ , SomeTest testMutate+ , SomeTest testMutateGrow ] @@ -93,7 +120,8 @@ where prop :: GenIO -> [(Int, Int)] -> PropertyM IO () prop rng origL = do- let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL+ let l = V.toList $ shuffleVector rng $ V.fromList $ dedupe origL+ announceQ "fromListToList" l ht <- run $ fromList l l' <- run $ toList ht assertEq "fromList . toList == id" (sort l) (sort l')@@ -110,8 +138,9 @@ where prop :: GenIO -> ([(Int, Int)], (Int,Int)) -> PropertyM IO ()- prop rng (origL, (k,v)) = do- let l = V.toList $ shuffle rng $ V.fromList $ remove k $ dedupe origL+ prop rng o@(origL, (k,v)) = do+ announceQ "insert" o+ let l = V.toList $ shuffleVector rng $ V.fromList $ remove k $ dedupe origL assert $ all (\t -> fst t /= k) l ht <- run $ fromList l@@ -135,8 +164,9 @@ where prop :: GenIO -> ([(Int, Int)], (Int,Int,Int)) -> PropertyM IO ()- prop rng (origL, (k,v,v2)) = do- let l = V.toList $ shuffle rng $ V.fromList $ dedupe origL+ prop rng o@(origL, (k,v,v2)) = do+ announceQ "insert2" o+ let l = V.toList $ shuffleVector rng $ V.fromList $ dedupe origL ht <- run $ fromList l run $ insert ht k v@@ -158,7 +188,8 @@ where prop :: (Int,Int,Int) -> PropertyM IO ()- prop (k,v,v2) = do+ prop o@(k,v,v2) = do+ announceQ "newAndInsert" o ht <- run new nothing <- run $ lookup ht k@@ -205,8 +236,9 @@ prop :: Int -> PropertyM IO () prop n = do+ announceQ "growTable" n ht <- run $ go n- i <- liftM head $ run $ sample' $ choose (0,n-1)+ i <- run $ generate $ choose (0,n-1) v <- run $ lookup ht i assertEq ("lookup " ++ show i) (Just i) v@@ -236,7 +268,7 @@ delete ht 2 delete ht 3 insert ht 2 2- + _ -> if i `mod` 2 == 0 then do delete ht i@@ -250,9 +282,11 @@ prop :: Int -> PropertyM IO () prop n = do+ announceQ "delete" n+ ht <- run $ go n - i <- liftM head $ run $ sample' $ choose (4,n-1)+ i <- run $ generate $ choose (4,n-1) v <- run $ lookup ht i assertEq ("lookup " ++ show i) (Just i) v @@ -265,6 +299,47 @@ ------------------------------------------------------------------------------+testMutate :: HashTest+testMutate prefix dummyArg = testProperty (prefix ++ "/mutate") $+ monadicIO $ forAllM arbitrary prop+ where+ prop :: ([(Int, Int)], [(Int, [Int])]) -> PropertyM IO ()+ prop o@(seedList, testList) = do+ announceQ "mutate" o+ ht <- run $ fromList seedList+ Monad.mapM_ (testOne ht) testList+++ upd n v = (fmap (+ n) v <|> pure n, ())++ testOne ht (k, values) = do+ pre . not . null $ values+ run $ mutate ht k (const (Nothing, ()))+ out1 <- run $ lookup ht k+ assertEq ("mutate deletes " ++ show k) Nothing out1+ out2 <- run $ do+ Monad.mapM_ (mutate ht k . upd) values+ (Just v) <- lookup ht k+ return $! v+ let s = sum values+ assertEq "mutate inserts correctly folded list value" s out2+ forceType dummyArg ht++testMutateGrow :: HashTest+testMutateGrow prefix dummyArg = testCase (prefix ++ "/mutateGrow") go+ where+ go = do+ tbl <- new+ forceType tbl dummyArg+ timeout_ 3000000 $ do+ let inputs = [0..128 :: Int]+ Monad.mapM_ (mutIns tbl) inputs+ l <- sort <$> toList tbl+ let expected = map (\i -> (i, i)) inputs+ assertEqual "mutate-grow" expected l+ mutIns tbl i = mutate tbl i (const (Just i, ()))++------------------------------------------------------------------------------ data Action = Lookup Int | Insert Int | Delete Int@@ -272,7 +347,7 @@ timeout_ :: Int -> IO a -> IO ()-#ifdef PORTABLE+#if defined(PORTABLE) || defined(wasm32_HOST_ARCH) timeout_ t m = timeout t m >>= maybe (assertFailure "timeout") (const $ return ()) #else@@ -422,14 +497,14 @@ ------------------------------------------------------------------------------ initializeRNG :: PropertyM IO GenIO-initializeRNG = run $ withSystemRandom (return :: GenIO -> IO GenIO)+initializeRNG = run createSystemRandom ------------------------------------------------------------------------------ dedupe :: (Ord k, Ord v, Eq k) => [(k,v)] -> [(k,v)] dedupe l = go0 $ sort l where- go0 [] = []+ go0 [] = [] go0 (x:xs) = go id x xs go !dl !lastOne [] = (dl . (lastOne:)) []@@ -454,8 +529,8 @@ -------------------------------------------------------------------------------shuffle :: GenIO -> Vector k -> Vector k-shuffle rng v = if V.null v then v else V.modify go v+shuffleVector :: GenIO -> Vector k -> Vector k+shuffleVector rng v = if V.null v then v else V.modify go v where !n = V.length v @@ -471,4 +546,3 @@ idx <- pickOne k swap k idx f (k-1)-
test/suite/TestSuite.hs view
@@ -2,7 +2,7 @@ module Main where -import Test.Framework (defaultMain)+import Test.Tasty (defaultMain, testGroup) ------------------------------------------------------------------------------ import qualified Data.HashTable.Test.Common as Common import qualified Data.HashTable.ST.Basic as B@@ -13,7 +13,7 @@ ------------------------------------------------------------------------------ main :: IO ()-main = defaultMain tests+main = defaultMain $ testGroup "All" tests where dummyBasicTable = Common.dummyTable :: forall k v . IO.IOHashTable (B.HashTable) k v