{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
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
newtype HashTable s k v = HT (STRef s (HashTable_ s k v))
data HashTable_ s k v = HashTable
{ forall s k v. HashTable_ s k v -> Int
_level :: {-# UNPACK #-} !Int
, forall s k v. HashTable_ s k v -> Int
_splitptr :: {-# UNPACK #-} !Int
, forall s k v. HashTable_ s k v -> MutableArray s (Bucket s k v)
_buckets :: {-# UNPACK #-} !(MutableArray s (Bucket s k v))
}
instance C.HashTable HashTable where
new :: forall s k v. ST s (HashTable s k v)
new = ST s (HashTable s k v)
forall s k v. ST s (HashTable s k v)
new
newSized :: forall s k v. Int -> ST s (HashTable s k v)
newSized = Int -> ST s (HashTable s k v)
forall s k v. Int -> ST s (HashTable s k v)
newSized
insert :: forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
insert = HashTable s k v -> k -> v -> ST s ()
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
insert
delete :: forall k s v. (Eq k, Hashable k) => HashTable s k v -> k -> ST s ()
delete = HashTable s k v -> k -> ST s ()
forall k s v. (Hashable k, Eq k) => HashTable s k v -> k -> ST s ()
delete
lookup :: forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
lookup = HashTable s k v -> k -> ST s (Maybe v)
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
lookup
foldM :: forall a k v s.
(a -> (k, v) -> ST s a) -> a -> HashTable s k v -> ST s a
foldM = (a -> (k, v) -> ST s a) -> a -> HashTable s k v -> ST s a
forall a k v s.
(a -> (k, v) -> ST s a) -> a -> HashTable s k v -> ST s a
foldM
mapM_ :: forall k v s b. ((k, v) -> ST s b) -> HashTable s k v -> ST s ()
mapM_ = ((k, v) -> ST s b) -> HashTable s k v -> ST s ()
forall k v s b. ((k, v) -> ST s b) -> HashTable s k v -> ST s ()
mapM_
lookupIndex :: forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe Word)
lookupIndex = HashTable s k v -> k -> ST s (Maybe Word)
forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe Word)
lookupIndex
nextByIndex :: forall s k v. HashTable s k v -> Word -> ST s (Maybe (Word, k, v))
nextByIndex = HashTable s k v -> Word -> ST s (Maybe (Word, k, v))
forall s k v. HashTable s k v -> Word -> ST s (Maybe (Word, k, v))
nextByIndex
computeOverhead :: forall s k v. HashTable s k v -> ST s Double
computeOverhead = HashTable s k v -> ST s Double
forall s k v. HashTable s k v -> ST s Double
computeOverhead
mutate :: forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
mutate = HashTable s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
mutate
mutateST :: forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST = HashTable s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST
instance Show (HashTable s k v) where
show :: HashTable s k v -> String
show HashTable s k v
_ = String
"<HashTable>"
new :: ST s (HashTable s k v)
new :: forall s k v. ST s (HashTable s k v)
new = do
v <- Int -> ST s (MutableArray s (Bucket s k v))
forall s k v. Int -> ST s (MutableArray s (Bucket s k v))
Bucket.newBucketArray Int
2
newRef $ HashTable 1 0 v
newSized :: Int -> ST s (HashTable s k v)
newSized :: forall s k v. Int -> ST s (HashTable s k v)
newSized Int
n = do
v <- Int -> ST s (MutableArray s (Bucket s k v))
forall s k v. Int -> ST s (MutableArray s (Bucket s k v))
Bucket.newBucketArray Int
sz
newRef $ HashTable lvl 0 v
where
k :: Word
k = Double -> Word
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
fillFactor Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bucketSplitSize)
lvl :: Int
lvl = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 (Int -> Int
forall a. Enum a => a -> Int
fromEnum (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Word -> Int
log2 Word
k)
sz :: Int
sz = Int -> Int
power2 Int
lvl
delete :: (Hashable k, Eq k) =>
(HashTable s k v)
-> k
-> ST s ()
delete :: forall k s v. (Hashable k, Eq k) => HashTable s k v -> k -> ST s ()
delete HashTable s k v
htRef !k
k = HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v) -> (HashTable_ s k v -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s ()
forall {s} {k} {v}. HashTable_ s k v -> ST s ()
work
where
work :: HashTable_ s k v -> ST s ()
work (HashTable Int
lvl Int
splitptr MutableArray s (Bucket s k v)
buckets) = do
let !h0 :: Int
h0 = Int -> Int -> k -> Int
forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"delete: size=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int
power2 Int
lvl) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", h0=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h0
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"splitptr: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
splitptr
MutableArray s (Bucket s k v) -> Int -> k -> ST s ()
forall k s v.
Eq k =>
MutableArray s (Bucket s k v) -> Int -> k -> ST s ()
delete' MutableArray s (Bucket s k v)
buckets Int
h0 k
k
{-# INLINE delete #-}
lookup :: (Eq k, Hashable k) => (HashTable s k v) -> k -> ST s (Maybe v)
lookup :: forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe v)
lookup HashTable s k v
htRef !k
k = HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v)
-> (HashTable_ s k v -> ST s (Maybe v)) -> ST s (Maybe v)
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s (Maybe v)
forall {s} {k} {v} {v}. HashTable_ s k v -> ST s (Maybe v)
work
where
work :: HashTable_ s k v -> ST s (Maybe v)
work (HashTable Int
lvl Int
splitptr MutableArray s (Bucket s k v)
buckets) = do
let h0 :: Int
h0 = Int -> Int -> k -> Int
forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
bucket <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h0
Bucket.lookup bucket k
{-# INLINE lookup #-}
insert :: (Eq k, Hashable k) =>
(HashTable s k v)
-> k
-> v
-> ST s ()
insert :: forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> v -> ST s ()
insert HashTable s k v
htRef k
k v
v = do
ht' <- HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v)
-> (HashTable_ s k v -> ST s (HashTable_ s k v))
-> ST s (HashTable_ s k v)
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s (HashTable_ s k v)
forall {k} {s} {v}.
Hashable k =>
HashTable_ s k v -> ST s (HashTable_ s k v)
work
writeRef htRef ht'
where
work :: HashTable_ s k v -> ST s (HashTable_ s k v)
work ht :: HashTable_ s k v
ht@(HashTable Int
lvl Int
splitptr MutableArray s (Bucket s k v)
buckets) = do
let !h0 :: Int
h0 = Int -> Int -> k -> Int
forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
MutableArray s (Bucket s k v) -> Int -> k -> ST s ()
forall k s v.
Eq k =>
MutableArray s (Bucket s k v) -> Int -> k -> ST s ()
delete' MutableArray s (Bucket s k v)
buckets Int
h0 k
k
bsz <- MutableArray s (Bucket s k v) -> Int -> k -> v -> ST s Int
forall s k v.
MutableArray s (Bucket s k v) -> Int -> k -> v -> ST s Int
primitiveInsert' MutableArray s (Bucket s k v)
buckets Int
h0 k
k v
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 :: forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
mutate HashTable s k v
htRef k
k Maybe v -> (Maybe v, a)
f = HashTable s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST HashTable s k v
htRef k
k ((Maybe v, a) -> ST s (Maybe v, a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe v, a) -> ST s (Maybe v, a))
-> (Maybe v -> (Maybe v, a)) -> Maybe v -> ST s (Maybe v, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe v -> (Maybe v, a)
f)
{-# INLINE mutate #-}
mutateST :: (Eq k, Hashable k) =>
(HashTable s k v)
-> k
-> (Maybe v -> ST s (Maybe v, a))
-> ST s a
mutateST :: forall k s v a.
(Eq k, Hashable k) =>
HashTable s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST HashTable s k v
htRef k
k Maybe v -> ST s (Maybe v, a)
f = do
(ht, a) <- HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v)
-> (HashTable_ s k v -> ST s (HashTable_ s k v, a))
-> ST s (HashTable_ s k v, a)
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s (HashTable_ s k v, a)
forall {k} {v}.
Hashable k =>
HashTable_ s k v -> ST s (HashTable_ s k v, a)
work
writeRef htRef ht
return a
where
work :: HashTable_ s k v -> ST s (HashTable_ s k v, a)
work ht :: HashTable_ s k v
ht@(HashTable Int
lvl Int
splitptr MutableArray s (Bucket s k v)
buckets) = do
let !h0 :: Int
h0 = Int -> Int -> k -> Int
forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
bucket <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
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)
mapM_ :: ((k,v) -> ST s b) -> HashTable s k v -> ST s ()
mapM_ :: forall k v s b. ((k, v) -> ST s b) -> HashTable s k v -> ST s ()
mapM_ (k, v) -> ST s b
f HashTable s k v
htRef = HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v) -> (HashTable_ s k v -> ST s ()) -> ST s ()
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s ()
forall {k} {v}. HashTable_ s k v -> ST s ()
work
where
work :: HashTable_ s k v -> ST s ()
work (HashTable Int
lvl Int
_ MutableArray s (Bucket s k v)
buckets) = Int -> ST s ()
go Int
0
where
!sz :: Int
sz = Int -> Int
power2 Int
lvl
go :: Int -> ST s ()
go !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = do
b <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
i
Bucket.mapM_ f b
go $ i+1
foldM :: (a -> (k,v) -> ST s a)
-> a -> HashTable s k v
-> ST s a
foldM :: forall a k v s.
(a -> (k, v) -> ST s a) -> a -> HashTable s k v -> ST s a
foldM a -> (k, v) -> ST s a
f a
seed0 HashTable s k v
htRef = HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v) -> (HashTable_ s k v -> ST s a) -> ST s a
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s a
forall {k} {v}. HashTable_ s k v -> ST s a
work
where
work :: HashTable_ s k v -> ST s a
work (HashTable Int
lvl Int
_ MutableArray s (Bucket s k v)
buckets) = a -> Int -> ST s a
go a
seed0 Int
0
where
!sz :: Int
sz = Int -> Int
power2 Int
lvl
go :: a -> Int -> ST s a
go !a
seed !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz = a -> ST s a
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
seed
| Bool
otherwise = do
b <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
i
!seed' <- Bucket.foldM f seed b
go seed' $ i+1
computeOverhead :: HashTable s k v -> ST s Double
computeOverhead :: forall s k v. HashTable s k v -> ST s Double
computeOverhead HashTable s k v
htRef = HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v)
-> (HashTable_ s k v -> ST s Double) -> ST s Double
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s Double
forall {b} {s} {k} {v}. Fractional b => HashTable_ s k v -> ST s b
work
where
work :: HashTable_ s k v -> ST s b
work (HashTable Int
lvl Int
_ MutableArray s (Bucket s k v)
buckets) = do
(totElems, overhead) <- Int -> Int -> Int -> ST s (Int, Int)
go Int
0 Int
0 Int
0
let n = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totElems
let o = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
overhead
return $ (fromIntegral sz + constOverhead + o) / n
where
constOverhead :: b
constOverhead = b
5.0
!sz :: Int
sz = Int -> Int
power2 Int
lvl
go :: Int -> Int -> Int -> ST s (Int, Int)
go !Int
nelems !Int
overhead !Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz = (Int, Int) -> ST s (Int, Int)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
nelems, Int
overhead)
| Bool
otherwise = do
b <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
i
(!n,!o) <- Bucket.nelemsAndOverheadInWords b
let !n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nelems
let !o' = Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
overhead
go n' o' (i+1)
delete' :: Eq k =>
MutableArray s (Bucket s k v)
-> Int
-> k
-> ST s ()
delete' :: forall k s v.
Eq k =>
MutableArray s (Bucket s k v) -> Int -> k -> ST s ()
delete' MutableArray s (Bucket s k v)
buckets Int
h0 k
k = do
bucket <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h0
_ <- Bucket.delete bucket k
return ()
split :: (Hashable k) =>
(HashTable_ s k v)
-> ST s (HashTable_ s k v)
split :: forall {k} {s} {v}.
Hashable k =>
HashTable_ s k v -> ST s (HashTable_ s k v)
split ht :: HashTable_ s k v
ht@(HashTable Int
lvl Int
splitptr MutableArray s (Bucket s k v)
buckets) = do
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"split: start: nbuck=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int
power2 Int
lvl)
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", splitptr=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
splitptr
oldBucket <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
splitptr
nelems <- Bucket.size oldBucket
let !bsz = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
Bucket.newBucketSize (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$
Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ (Double
0.625 :: Double) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nelems
dbucket1 <- Bucket.emptyWithSize bsz
writeArray buckets splitptr dbucket1
let lvl2 = Int -> Int
power2 Int
lvl
let lvl1 = Int -> Int
power2 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
lvlInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1
(!buckets',!lvl',!sp') <-
if splitptr+1 >= lvl1
then do
debug $ "split: resizing bucket array"
let lvl3 = Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
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' = Int -> Int -> MutableArray s (Bucket s k v) -> HashTable_ s k v
forall s k v.
Int -> Int -> MutableArray s (Bucket s k v) -> HashTable_ s k v
HashTable Int
lvl' Int
sp' MutableArray s (Bucket s k v)
buckets'
let splitOffs = Int
splitptr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lvl1
db2 <- readArray buckets' splitOffs
db2sz <- Bucket.size db2
let db2sz' = Int
db2sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bsz
db2' <- Bucket.growBucketTo db2sz' db2
debug $ "growing bucket at " ++ show splitOffs ++ " to size "
++ show db2sz'
writeArray buckets' splitOffs db2'
debug $ "split: rehashing bucket"
let f = (k -> b -> ST s Int) -> (k, b) -> ST s Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((k -> b -> ST s Int) -> (k, b) -> ST s Int)
-> (k -> b -> ST s Int) -> (k, b) -> ST s Int
forall a b. (a -> b) -> a -> b
$ HashTable_ s k b -> k -> b -> ST s Int
forall k s v. Hashable k => HashTable_ s k v -> k -> v -> ST s Int
primitiveInsert HashTable_ s k b
forall {k} {v}. HashTable_ s k v
ht'
forceSameType f (uncurry $ primitiveInsert ht)
Bucket.mapM_ f oldBucket
debug $ "split: done"
return ht'
checkOverflow :: Int -> Bool
checkOverflow :: Int -> Bool
checkOverflow Int
sz = Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bucketSplitSize
primitiveInsert :: (Hashable k) =>
(HashTable_ s k v)
-> k
-> v
-> ST s Int
primitiveInsert :: forall k s v. Hashable k => HashTable_ s k v -> k -> v -> ST s Int
primitiveInsert (HashTable Int
lvl Int
splitptr MutableArray s (Bucket s k v)
buckets) k
k v
v = do
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"primitiveInsert start: nbuckets=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int -> Int
power2 Int
lvl)
let h0 :: Int
h0 = Int -> Int -> k -> Int
forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
MutableArray s (Bucket s k v) -> Int -> k -> v -> ST s Int
forall s k v.
MutableArray s (Bucket s k v) -> Int -> k -> v -> ST s Int
primitiveInsert' MutableArray s (Bucket s k v)
buckets Int
h0 k
k v
v
primitiveInsert' :: MutableArray s (Bucket s k v)
-> Int
-> k
-> v
-> ST s Int
primitiveInsert' :: forall s k v.
MutableArray s (Bucket s k v) -> Int -> k -> v -> ST s Int
primitiveInsert' MutableArray s (Bucket s k v)
buckets !Int
h0 !k
k !v
v = do
String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"primitiveInsert': bucket number=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h0
bucket <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
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 :: Double
fillFactor = Double
1.3
bucketSplitSize :: Int
bucketSplitSize :: Int
bucketSplitSize = Int
Bucket.bucketSplitSize
{-# INLINE power2 #-}
power2 :: Int -> Int
power2 :: Int -> Int
power2 Int
i = Int
1 Int -> Int -> Int
`iShiftL` Int
i
{-# INLINE hashKey #-}
hashKey :: (Hashable k) => Int -> Int -> k -> Int
hashKey :: forall k. Hashable k => Int -> Int -> k -> Int
hashKey !Int
lvl !Int
splitptr !k
k = Int
h1
where
!h0 :: Int
h0 = Int -> k -> Int
forall k. Hashable k => Int -> k -> Int
hashAtLvl (Int
lvlInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) k
k
!h1 :: Int
h1 = if (Int
h0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
splitptr)
then Int -> k -> Int
forall k. Hashable k => Int -> k -> Int
hashAtLvl Int
lvl k
k
else Int
h0
{-# INLINE hashAtLvl #-}
hashAtLvl :: (Hashable k) => Int -> k -> Int
hashAtLvl :: forall k. Hashable k => Int -> k -> Int
hashAtLvl !Int
lvl !k
k = Int
h
where
!h :: Int
h = Int
hashcode Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
mask
!hashcode :: Int
hashcode = k -> Int
forall a. Hashable a => a -> Int
hash k
k
!mask :: Int
mask = Int -> Int
power2 Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
newRef :: HashTable_ s k v -> ST s (HashTable s k v)
newRef :: forall s k v. HashTable_ s k v -> ST s (HashTable s k v)
newRef = (STRef s (HashTable_ s k v) -> HashTable s k v)
-> ST s (STRef s (HashTable_ s k v)) -> ST s (HashTable s k v)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM STRef s (HashTable_ s k v) -> HashTable s k v
forall s k v. STRef s (HashTable_ s k v) -> HashTable s k v
HT (ST s (STRef s (HashTable_ s k v)) -> ST s (HashTable s k v))
-> (HashTable_ s k v -> ST s (STRef s (HashTable_ s k v)))
-> HashTable_ s k v
-> ST s (HashTable s k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashTable_ s k v -> ST s (STRef s (HashTable_ s k v))
forall a s. a -> ST s (STRef s a)
newSTRef
writeRef :: HashTable s k v -> HashTable_ s k v -> ST s ()
writeRef :: forall s k v. HashTable s k v -> HashTable_ s k v -> ST s ()
writeRef (HT STRef s (HashTable_ s k v)
ref) HashTable_ s k v
ht = STRef s (HashTable_ s k v) -> HashTable_ s k v -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (HashTable_ s k v)
ref HashTable_ s k v
ht
readRef :: HashTable s k v -> ST s (HashTable_ s k v)
readRef :: forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef (HT STRef s (HashTable_ s k v)
ref) = STRef s (HashTable_ s k v) -> ST s (HashTable_ s k v)
forall s a. STRef s a -> ST s a
readSTRef STRef s (HashTable_ s k v)
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 :: forall s. String -> ST s ()
debug String
_ = () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
#endif
lookupIndex :: (Eq k, Hashable k) => HashTable s k v -> k -> ST s (Maybe Word)
lookupIndex :: forall k s v.
(Eq k, Hashable k) =>
HashTable s k v -> k -> ST s (Maybe Word)
lookupIndex HashTable s k v
htRef !k
k = HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v)
-> (HashTable_ s k v -> ST s (Maybe Word)) -> ST s (Maybe Word)
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s (Maybe Word)
forall {s} {k} {v}. HashTable_ s k v -> ST s (Maybe Word)
work
where
work :: HashTable_ s k v -> ST s (Maybe Word)
work (HashTable Int
lvl Int
splitptr MutableArray s (Bucket s k v)
buckets) = do
let h0 :: Int
h0 = Int -> Int -> k -> Int
forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
bucket <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h0
mbIx <- Bucket.lookupIndex bucket k
return $! do ix <- mbIx
Just $! encodeIndex lvl h0 ix
{-# INLINE lookupIndex #-}
encodeIndex :: Int -> Int -> Int -> Word
encodeIndex :: Int -> Int -> Int -> Word
encodeIndex Int
lvl Int
bucketIx Int
elemIx =
Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bucketIx Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`Data.Bits.shiftL` Int -> Int
indexOffset Int
lvl Word -> Word -> Word
forall a. Bits a => a -> a -> a
.|.
Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
elemIx
{-# INLINE encodeIndex #-}
decodeIndex :: Int -> Word -> (Int, Int)
decodeIndex :: Int -> Word -> (Int, Int)
decodeIndex Int
lvl Word
ix =
( Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
ix Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`Data.Bits.shiftR` Int
offset)
, Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ( (Int -> Word
forall a. Bits a => Int -> a
bit Int
offset Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1) Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. Word
ix )
)
where offset :: Int
offset = Int -> Int
indexOffset Int
lvl
{-# INLINE decodeIndex #-}
indexOffset :: Int -> Int
indexOffset :: Int -> Int
indexOffset Int
lvl = Word -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Word
0 :: Word) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lvl
{-# INLINE indexOffset #-}
nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word,k,v))
nextByIndex :: forall s k v. HashTable s k v -> Word -> ST s (Maybe (Word, k, v))
nextByIndex HashTable s k v
htRef !Word
k = HashTable s k v -> ST s (HashTable_ s k v)
forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef ST s (HashTable_ s k v)
-> (HashTable_ s k v -> ST s (Maybe (Word, k, v)))
-> ST s (Maybe (Word, k, v))
forall a b. ST s a -> (a -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashTable_ s k v -> ST s (Maybe (Word, k, v))
forall {s} {k} {v} {b} {c}.
HashTable_ s k v -> ST s (Maybe (Word, b, c))
work
where
work :: HashTable_ s k v -> ST s (Maybe (Word, b, c))
work (HashTable Int
lvl Int
_ MutableArray s (Bucket s k v)
buckets) = do
let (Int
h0,Int
ix) = Int -> Word -> (Int, Int)
decodeIndex Int
lvl Word
k
Int -> Int -> ST s (Maybe (Word, b, c))
forall {b} {c}. Int -> Int -> ST s (Maybe (Word, b, c))
go Int
h0 Int
ix
where
bucketN :: Int
bucketN = Int -> Int
power2 Int
lvl
go :: Int -> Int -> ST s (Maybe (Word, b, c))
go Int
h Int
ix
| Int
h Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
bucketN Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
h = Maybe (Word, b, c) -> ST s (Maybe (Word, b, c))
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Word, b, c)
forall a. Maybe a
Nothing
| Bool
otherwise = do
bucket <- MutableArray s (Bucket s k v) -> Int -> ST s (Bucket s k v)
forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h
mb <- Bucket.elemAt bucket ix
case mb of
Just (b
k',c
v) ->
let !ix' :: Word
ix' = Int -> Int -> Int -> Word
encodeIndex Int
lvl Int
h Int
ix
in Maybe (Word, b, c) -> ST s (Maybe (Word, b, c))
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Word, b, c) -> Maybe (Word, b, c)
forall a. a -> Maybe a
Just (Word
ix', b
k', c
v))
Maybe (b, c)
Nothing -> Int -> Int -> ST s (Maybe (Word, b, c))
go (Int
hInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
0
{-# INLINE nextByIndex #-}