hashtables-1.4.2: src/Data/HashTable/ST/Linear.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-| An implementation of linear hash tables. (See
<http://en.wikipedia.org/wiki/Linear_hashing>). Use this hash table if you...
* don't care that inserts and lookups are slower than the other hash table
implementations in this collection (this one is slightly faster than
@Data.HashTable@ from the base library in most cases)
* have a soft real-time or interactive application for which the risk of
introducing a long pause on insert while all of the keys are rehashed is
unacceptable.
/Details:/
Linear hashing allows for the expansion of the hash table one slot at a time,
by moving a \"split\" pointer across an array of pointers to buckets. The
number of buckets is always a power of two, and the bucket to look in is
defined as:
@
bucket(level,key) = hash(key) mod (2^level)
@
The \"split pointer\" controls the expansion of the hash table. If the hash
table is at level @k@ (i.e. @2^k@ buckets have been allocated), we first
calculate @b=bucket(level-1,key)@. If @b < splitptr@, the destination bucket is
calculated as @b'=bucket(level,key)@, otherwise the original value @b@ is used.
The split pointer is incremented once an insert causes some bucket to become
fuller than some predetermined threshold; the bucket at the split pointer
(*not* the bucket which triggered the split!) is then rehashed, and half of its
keys can be expected to be rehashed into the upper half of the table.
When the split pointer reaches the middle of the bucket array, the size of the
bucket array is doubled, the level increases, and the split pointer is reset to
zero.
Linear hashing, although not quite as fast for inserts or lookups as the
implementation of linear probing included in this package, is well suited for
interactive applications because it has much better worst case behaviour on
inserts. Other hash table implementations can suffer from long pauses, because
it is occasionally necessary to rehash all of the keys when the table grows.
Linear hashing, on the other hand, only ever rehashes a bounded (effectively
constant) number of keys when an insert forces a bucket split.
/Space overhead: experimental results/
In randomized testing (see @test\/compute-overhead\/ComputeOverhead.hs@ in the
source distribution), mean overhead is approximately 1.51 machine words per
key-value mapping with a very low standard deviation of about 0.06 words, 1.60
words per mapping at the 95th percentile.
/Unsafe tricks/
Then the @unsafe-tricks@ flag is on when this package is built (and it is on by
default), we use some unsafe tricks (namely 'unsafeCoerce#' and
'reallyUnsafePtrEquality#') to save indirections in this table. These
techniques rely on assumptions about the behaviour of the GHC runtime system
and, although they've been tested and should be safe under normal conditions,
are slightly dangerous. Caveat emptor. In particular, these techniques are
incompatible with HPC code coverage reports.
References:
* W. Litwin. Linear hashing: a new tool for file and table addressing. In
/Proc. 6th International Conference on Very Large Data Bases, Volume 6/,
pp. 212-223, 1980.
* P-A. Larson. Dynamic hash tables. /Communications of the ACM/ 31:
446-457, 1988.
-}
module Data.HashTable.ST.Linear
( HashTable
, new
, newSized
, delete
, lookup
, insert
, mutate
, mutateST
, mapM_
, foldM
, computeOverhead
) where
------------------------------------------------------------------------------
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
import Data.Word
#endif
import Control.Monad hiding (foldM, mapM_)
import Control.Monad.ST
import Data.Bits
import Data.Hashable
import Data.STRef
import Prelude hiding (lookup, mapM_)
------------------------------------------------------------------------------
import qualified Data.HashTable.Class as C
import Data.HashTable.Internal.Array
import Data.HashTable.Internal.Linear.Bucket (Bucket)
import qualified Data.HashTable.Internal.Linear.Bucket as Bucket
import Data.HashTable.Internal.Utils
#ifdef DEBUG
import System.IO
#endif
------------------------------------------------------------------------------
-- | A linear hash table.
newtype HashTable s k v = HT (STRef s (HashTable_ s k v))
data HashTable_ s k v = HashTable
{ _level :: {-# UNPACK #-} !Int
, _splitptr :: {-# UNPACK #-} !Int
, _buckets :: {-# UNPACK #-} !(MutableArray s (Bucket s k v))
}
------------------------------------------------------------------------------
instance C.HashTable HashTable where
new = new
newSized = newSized
insert = insert
delete = delete
lookup = lookup
foldM = foldM
mapM_ = mapM_
lookupIndex = lookupIndex
nextByIndex = nextByIndex
computeOverhead = computeOverhead
mutate = mutate
mutateST = mutateST
------------------------------------------------------------------------------
instance Show (HashTable s k v) where
show _ = "<HashTable>"
------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:new".
new :: ST s (HashTable s k v)
new = do
v <- Bucket.newBucketArray 2
newRef $ HashTable 1 0 v
------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:newSized".
newSized :: Int -> ST s (HashTable s k v)
newSized n = do
v <- Bucket.newBucketArray sz
newRef $ HashTable lvl 0 v
where
k = ceiling (fromIntegral n * fillFactor / fromIntegral bucketSplitSize)
lvl = max 1 (fromEnum $ log2 k)
sz = power2 lvl
------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:delete".
delete :: (Hashable k, Eq k) =>
(HashTable s k v)
-> k
-> ST s ()
delete htRef !k = readRef htRef >>= work
where
work (HashTable lvl splitptr buckets) = do
let !h0 = hashKey lvl splitptr k
debug $ "delete: size=" ++ show (power2 lvl) ++ ", h0=" ++ show h0
++ "splitptr: " ++ show splitptr
delete' buckets h0 k
{-# INLINE delete #-}
------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:lookup".
lookup :: (Eq k, Hashable k) => (HashTable s k v) -> k -> ST s (Maybe v)
lookup htRef !k = readRef htRef >>= work
where
work (HashTable lvl splitptr buckets) = do
let h0 = hashKey lvl splitptr k
bucket <- readArray buckets h0
Bucket.lookup bucket k
{-# INLINE lookup #-}
------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:insert".
insert :: (Eq k, Hashable k) =>
(HashTable s k v)
-> k
-> v
-> ST s ()
insert htRef k v = do
ht' <- readRef htRef >>= work
writeRef htRef ht'
where
work ht@(HashTable lvl splitptr buckets) = do
let !h0 = hashKey lvl splitptr k
delete' buckets h0 k
bsz <- primitiveInsert' buckets h0 k v
if checkOverflow bsz
then do
debug $ "insert: splitting"
h <- split ht
debug $ "insert: done splitting"
return h
else do
debug $ "insert: done"
return ht
{-# INLINE insert #-}
------------------------------------------------------------------------------
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 ()
mapM_ f htRef = readRef htRef >>= work
where
work (HashTable lvl _ buckets) = go 0
where
!sz = power2 lvl
go !i | i >= sz = return ()
| otherwise = do
b <- readArray buckets i
Bucket.mapM_ f b
go $ i+1
------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:foldM".
foldM :: (a -> (k,v) -> ST s a)
-> a -> HashTable s k v
-> ST s a
foldM f seed0 htRef = readRef htRef >>= work
where
work (HashTable lvl _ buckets) = go seed0 0
where
!sz = power2 lvl
go !seed !i | i >= sz = return seed
| otherwise = do
b <- readArray buckets i
!seed' <- Bucket.foldM f seed b
go seed' $ i+1
------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:computeOverhead".
computeOverhead :: HashTable s k v -> ST s Double
computeOverhead htRef = readRef htRef >>= work
where
work (HashTable lvl _ buckets) = do
(totElems, overhead) <- go 0 0 0
let n = fromIntegral totElems
let o = fromIntegral overhead
return $ (fromIntegral sz + constOverhead + o) / n
where
constOverhead = 5.0
!sz = power2 lvl
go !nelems !overhead !i | i >= sz = return (nelems, overhead)
| otherwise = do
b <- readArray buckets i
(!n,!o) <- Bucket.nelemsAndOverheadInWords b
let !n' = n + nelems
let !o' = o + overhead
go n' o' (i+1)
------------------------------
-- Private functions follow --
------------------------------
------------------------------------------------------------------------------
delete' :: Eq k =>
MutableArray s (Bucket s k v)
-> Int
-> k
-> ST s ()
delete' buckets h0 k = do
bucket <- readArray buckets h0
_ <- Bucket.delete bucket k
return ()
------------------------------------------------------------------------------
split :: (Hashable k) =>
(HashTable_ s k v)
-> ST s (HashTable_ s k v)
split ht@(HashTable lvl splitptr buckets) = do
debug $ "split: start: nbuck=" ++ show (power2 lvl)
++ ", splitptr=" ++ show splitptr
-- grab bucket at splitPtr
oldBucket <- readArray buckets splitptr
nelems <- Bucket.size oldBucket
let !bsz = max Bucket.newBucketSize $
ceiling $ (0.625 :: Double) * fromIntegral nelems
-- write an empty bucket there
dbucket1 <- Bucket.emptyWithSize bsz
writeArray buckets splitptr dbucket1
-- grow the buckets?
let lvl2 = power2 lvl
let lvl1 = power2 $ lvl-1
(!buckets',!lvl',!sp') <-
if splitptr+1 >= lvl1
then do
debug $ "split: resizing bucket array"
let lvl3 = 2*lvl2
b <- Bucket.expandBucketArray lvl3 lvl2 buckets
debug $ "split: resizing bucket array: done"
return (b,lvl+1,0)
else return (buckets,lvl,splitptr+1)
let ht' = HashTable lvl' sp' buckets'
-- make sure the other split bucket has enough room in it also
let splitOffs = splitptr + lvl1
db2 <- readArray buckets' splitOffs
db2sz <- Bucket.size db2
let db2sz' = db2sz + bsz
db2' <- Bucket.growBucketTo db2sz' db2
debug $ "growing bucket at " ++ show splitOffs ++ " to size "
++ show db2sz'
writeArray buckets' splitOffs db2'
-- rehash old bucket
debug $ "split: rehashing bucket"
let f = uncurry $ primitiveInsert ht'
forceSameType f (uncurry $ primitiveInsert ht)
Bucket.mapM_ f oldBucket
debug $ "split: done"
return ht'
------------------------------------------------------------------------------
checkOverflow :: Int -> Bool
checkOverflow sz = sz > bucketSplitSize
------------------------------------------------------------------------------
-- insert w/o splitting
primitiveInsert :: (Hashable k) =>
(HashTable_ s k v)
-> k
-> v
-> ST s Int
primitiveInsert (HashTable lvl splitptr buckets) k v = do
debug $ "primitiveInsert start: nbuckets=" ++ show (power2 lvl)
let h0 = hashKey lvl splitptr k
primitiveInsert' buckets h0 k v
------------------------------------------------------------------------------
primitiveInsert' :: MutableArray s (Bucket s k v)
-> Int
-> k
-> v
-> ST s Int
primitiveInsert' buckets !h0 !k !v = do
debug $ "primitiveInsert': bucket number=" ++ show h0
bucket <- readArray buckets h0
debug $ "primitiveInsert': snoccing bucket"
(!hw,m) <- Bucket.snoc bucket k v
debug $ "primitiveInsert': bucket snoc'd"
maybe (return ())
(writeArray buckets h0)
m
return hw
------------------------------------------------------------------------------
fillFactor :: Double
fillFactor = 1.3
------------------------------------------------------------------------------
bucketSplitSize :: Int
bucketSplitSize = Bucket.bucketSplitSize
------------------------------------------------------------------------------
{-# INLINE power2 #-}
power2 :: Int -> Int
power2 i = 1 `iShiftL` i
------------------------------------------------------------------------------
{-# INLINE hashKey #-}
hashKey :: (Hashable k) => Int -> Int -> k -> Int
hashKey !lvl !splitptr !k = h1
where
!h0 = hashAtLvl (lvl-1) k
!h1 = if (h0 < splitptr)
then hashAtLvl lvl k
else h0
------------------------------------------------------------------------------
{-# INLINE hashAtLvl #-}
hashAtLvl :: (Hashable k) => Int -> k -> Int
hashAtLvl !lvl !k = h
where
!h = hashcode .&. mask
!hashcode = hash k
!mask = power2 lvl - 1
------------------------------------------------------------------------------
newRef :: HashTable_ s k v -> ST s (HashTable s k v)
newRef = liftM HT . newSTRef
writeRef :: HashTable s k v -> HashTable_ s k v -> ST s ()
writeRef (HT ref) ht = writeSTRef ref ht
readRef :: HashTable s k v -> ST s (HashTable_ s k v)
readRef (HT ref) = readSTRef ref
------------------------------------------------------------------------------
{-# INLINE debug #-}
debug :: String -> ST s ()
#ifdef DEBUG
debug s = unsafeIOToST $ do
putStrLn s
hFlush stdout
#else
#ifdef TESTSUITE
debug !s = do
let !_ = length s
return $! ()
#else
debug _ = return ()
#endif
#endif
------------------------------------------------------------------------------
-- | 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 #-}