{-# 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
    { HashTable_ s k v -> Int
_level    :: {-# UNPACK #-} !Int
    , HashTable_ s k v -> Int
_splitptr :: {-# UNPACK #-} !Int
    , HashTable_ s k v -> MutableArray s (Bucket s k v)
_buckets  :: {-# UNPACK #-} !(MutableArray s (Bucket s k v))
    }


------------------------------------------------------------------------------
instance C.HashTable HashTable where
    new :: 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 :: 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 :: 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 :: 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 :: 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 :: (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_ :: ((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 :: 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 :: 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 :: 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 :: 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 :: 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>"


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:new".
new :: ST s (HashTable s k v)
new :: ST s (HashTable s k v)
new = do
    MutableArray s (Bucket s k v)
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
    HashTable_ s k v -> ST s (HashTable s k v)
forall s k v. HashTable_ s k v -> ST s (HashTable s k v)
newRef (HashTable_ s k v -> ST s (HashTable s k v))
-> HashTable_ s k v -> ST s (HashTable s k v)
forall a b. (a -> b) -> a -> b
$ 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
1 Int
0 MutableArray s (Bucket s k v)
v


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:newSized".
newSized :: Int -> ST s (HashTable s k v)
newSized :: Int -> ST s (HashTable s k v)
newSized Int
n = do
    MutableArray s (Bucket s k v)
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
    HashTable_ s k v -> ST s (HashTable s k v)
forall s k v. HashTable_ s k v -> ST s (HashTable s k v)
newRef (HashTable_ s k v -> ST s (HashTable s k v))
-> HashTable_ s k v -> ST s (HashTable s k v)
forall a b. (a -> b) -> a -> b
$ 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
0 MutableArray s (Bucket s k v)
v

  where
    k :: Word
k   = Double -> Word
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



------------------------------------------------------------------------------
-- | 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 :: 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 (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 #-}


------------------------------------------------------------------------------
-- | 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 :: 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 (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 s k v
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 s k v -> k -> ST s (Maybe v)
forall k s v. Eq k => Bucket s k v -> k -> ST s (Maybe v)
Bucket.lookup Bucket s k v
bucket k
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 :: HashTable s k v -> k -> v -> ST s ()
insert HashTable s k v
htRef k
k v
v = do
    HashTable_ s k v
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 (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
    HashTable s k v -> HashTable_ s k v -> ST s ()
forall s k v. HashTable s k v -> HashTable_ s k v -> ST s ()
writeRef HashTable s k v
htRef HashTable_ s k v
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
        Int
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 Int -> Bool
checkOverflow Int
bsz
          then do
            String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"insert: splitting"
            HashTable_ s k v
h <- 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)
split HashTable_ s k v
ht
            String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"insert: done splitting"
            HashTable_ s k v -> ST s (HashTable_ s k v)
forall (m :: * -> *) a. Monad m => a -> m a
return HashTable_ s k v
h
          else do
            String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"insert: done"
            HashTable_ s k v -> ST s (HashTable_ s k v)
forall (m :: * -> *) a. Monad m => a -> m a
return HashTable_ s k v
ht
{-# INLINE insert #-}


------------------------------------------------------------------------------
mutate :: (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
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 (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 :: 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
    (HashTable_ s k v
ht, a
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 (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
    HashTable s k v -> HashTable_ s k v -> ST s ()
forall s k v. HashTable s k v -> HashTable_ s k v -> ST s ()
writeRef HashTable s k v
htRef HashTable_ s k v
ht
    a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 s k v
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
        (!Int
bsz, Maybe (Bucket s k v)
mbk, a
a) <- Bucket s k v
-> k
-> (Maybe v -> ST s (Maybe v, a))
-> ST s (Int, Maybe (Bucket s k v), a)
forall k s v a.
Eq k =>
Bucket s k v
-> k
-> (Maybe v -> ST s (Maybe v, a))
-> ST s (Int, Maybe (Bucket s k v), a)
Bucket.mutateST Bucket s k v
bucket k
k Maybe v -> ST s (Maybe v, a)
f
        ST s ()
-> (Bucket s k v -> ST s ()) -> Maybe (Bucket s k v) -> ST s ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
              (MutableArray s (Bucket s k v) -> Int -> Bucket s k v -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s (Bucket s k v)
buckets Int
h0)
              Maybe (Bucket s k v)
mbk
        if Int -> Bool
checkOverflow Int
bsz
          then do
            HashTable_ s k v
ht' <- 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)
split HashTable_ s k v
ht
            (HashTable_ s k v, a) -> ST s (HashTable_ s k v, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashTable_ s k v
ht', a
a)
          else (HashTable_ s k v, a) -> ST s (HashTable_ s k v, a)
forall (m :: * -> *) a. Monad m => a -> m a
return (HashTable_ s k v
ht, a
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_ :: ((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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()
              | Bool
otherwise = do
            Bucket s k v
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
            ((k, v) -> ST s b) -> Bucket s k v -> ST s ()
forall k v s a. ((k, v) -> ST s a) -> Bucket s k v -> ST s ()
Bucket.mapM_ (k, v) -> ST s b
f Bucket s k v
b
            Int -> ST s ()
go (Int -> ST s ()) -> Int -> ST s ()
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
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 :: (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 (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 (m :: * -> *) a. Monad m => a -> m a
return a
seed
                    | Bool
otherwise = do
            Bucket s k v
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
            !a
seed' <- (a -> (k, v) -> ST s a) -> a -> Bucket s k v -> ST s a
forall a k v s.
(a -> (k, v) -> ST s a) -> a -> Bucket s k v -> ST s a
Bucket.foldM a -> (k, v) -> ST s a
f a
seed Bucket s k v
b
            a -> Int -> ST s a
go a
seed' (Int -> ST s a) -> Int -> ST s a
forall a b. (a -> b) -> a -> b
$ Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- "Data.HashTable.Class#v:computeOverhead".
computeOverhead :: HashTable s k v -> ST s Double
computeOverhead :: 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 (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
        (Int
totElems, Int
overhead) <- Int -> Int -> Int -> ST s (Int, Int)
go Int
0 Int
0 Int
0

        let n :: b
n = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totElems
        let o :: b
o = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
overhead

        b -> ST s b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ST s b) -> b -> ST s b
forall a b. (a -> b) -> a -> b
$ (Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz b -> b -> b
forall a. Num a => a -> a -> a
+ b
constOverhead b -> b -> b
forall a. Num a => a -> a -> a
+ b
o) b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
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 (m :: * -> *) a. Monad m => a -> m a
return (Int
nelems, Int
overhead)
                                | Bool
otherwise = do
            Bucket s k v
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
            (!Int
n,!Int
o) <- Bucket s k v -> ST s (Int, Int)
forall s k v. Bucket s k v -> ST s (Int, Int)
Bucket.nelemsAndOverheadInWords Bucket s k v
b
            let !n' :: Int
n' = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nelems
            let !o' :: Int
o' = Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
overhead

            Int -> Int -> Int -> ST s (Int, Int)
go Int
n' Int
o' (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)


------------------------------
-- Private functions follow --
------------------------------

------------------------------------------------------------------------------
delete' :: Eq k =>
           MutableArray s (Bucket s k v)
        -> Int
        -> k
        -> ST s ()
delete' :: MutableArray s (Bucket s k v) -> Int -> k -> ST s ()
delete' MutableArray s (Bucket s k v)
buckets Int
h0 k
k = do
    Bucket s k v
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
    Bool
_ <- Bucket s k v -> k -> ST s Bool
forall k s v. Eq k => Bucket s k v -> k -> ST s Bool
Bucket.delete Bucket s k v
bucket k
k
    () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


------------------------------------------------------------------------------
split :: (Hashable k) =>
         (HashTable_ s k v)
      -> ST s (HashTable_ s k v)
split :: 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

    -- grab bucket at splitPtr
    Bucket s k v
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

    Int
nelems <- Bucket s k v -> ST s Int
forall s k v. Bucket s k v -> ST s Int
Bucket.size Bucket s k v
oldBucket
    let !bsz :: Int
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 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

    -- write an empty bucket there
    Bucket s k v
dbucket1 <- Int -> ST s (Bucket s k v)
forall s k v. Int -> ST s (Bucket s k v)
Bucket.emptyWithSize Int
bsz
    MutableArray s (Bucket s k v) -> Int -> Bucket s k v -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s (Bucket s k v)
buckets Int
splitptr Bucket s k v
dbucket1

    -- grow the buckets?
    let lvl2 :: Int
lvl2 = Int -> Int
power2 Int
lvl
    let lvl1 :: Int
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

    (!MutableArray s (Bucket s k v)
buckets',!Int
lvl',!Int
sp') <-
        if Int
splitptrInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
lvl1
          then 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: resizing bucket array"
            let lvl3 :: Int
lvl3 = Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
lvl2
            MutableArray s (Bucket s k v)
b <- Int
-> Int
-> MutableArray s (Bucket s k v)
-> ST s (MutableArray s (Bucket s k v))
forall s k v.
Int
-> Int
-> MutableArray s (Bucket s k v)
-> ST s (MutableArray s (Bucket s k v))
Bucket.expandBucketArray Int
lvl3 Int
lvl2 MutableArray s (Bucket s k v)
buckets
            String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"split: resizing bucket array: done"
            (MutableArray s (Bucket s k v), Int, Int)
-> ST s (MutableArray s (Bucket s k v), Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (MutableArray s (Bucket s k v)
b,Int
lvlInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1,Int
0)
          else (MutableArray s (Bucket s k v), Int, Int)
-> ST s (MutableArray s (Bucket s k v), Int, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (MutableArray s (Bucket s k v)
buckets,Int
lvl,Int
splitptrInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

    let ht' :: HashTable_ s k v
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'

    -- make sure the other split bucket has enough room in it also
    let splitOffs :: Int
splitOffs = Int
splitptr Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
lvl1
    Bucket s k v
db2   <- 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
splitOffs
    Int
db2sz <- Bucket s k v -> ST s Int
forall s k v. Bucket s k v -> ST s Int
Bucket.size Bucket s k v
db2
    let db2sz' :: Int
db2sz' = Int
db2sz Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bsz
    Bucket s k v
db2'  <- Int -> Bucket s k v -> ST s (Bucket s k v)
forall s k v. Int -> Bucket s k v -> ST s (Bucket s k v)
Bucket.growBucketTo Int
db2sz' Bucket s k v
db2
    String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"growing bucket at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
splitOffs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" to size "
              String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
db2sz'
    MutableArray s (Bucket s k v) -> Int -> Bucket s k v -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s (Bucket s k v)
buckets' Int
splitOffs Bucket s k v
db2'

    -- rehash old bucket
    String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"split: rehashing bucket"
    let f :: (k, v) -> ST s Int
f = (k -> v -> ST s Int) -> (k, v) -> ST s Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((k -> v -> ST s Int) -> (k, v) -> ST s Int)
-> (k -> v -> ST s Int) -> (k, v) -> ST s Int
forall a b. (a -> b) -> a -> b
$ HashTable_ s k v -> k -> v -> ST s Int
forall k s v. Hashable k => HashTable_ s k v -> k -> v -> ST s Int
primitiveInsert HashTable_ s k v
forall k v. HashTable_ s k v
ht'
    ((k, v) -> ST s Int) -> ((k, v) -> ST s Int) -> ST s ()
forall (m :: * -> *) a. Monad m => a -> a -> m ()
forceSameType (k, v) -> ST s Int
forall v. (k, v) -> ST s Int
f ((k -> v -> ST s Int) -> (k, v) -> ST s Int
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((k -> v -> ST s Int) -> (k, v) -> ST s Int)
-> (k -> v -> ST s Int) -> (k, v) -> ST s Int
forall a b. (a -> b) -> a -> b
$ HashTable_ s k v -> k -> v -> ST s Int
forall k s v. Hashable k => HashTable_ s k v -> k -> v -> ST s Int
primitiveInsert HashTable_ s k v
ht)

    ((k, Bucket s k v) -> ST s Int) -> Bucket s k v -> ST s ()
forall k v s a. ((k, v) -> ST s a) -> Bucket s k v -> ST s ()
Bucket.mapM_ (k, Bucket s k v) -> ST s Int
forall v. (k, v) -> ST s Int
f Bucket s k v
oldBucket
    String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"split: done"
    HashTable_ s k v -> ST s (HashTable_ s k v)
forall (m :: * -> *) a. Monad m => a -> m a
return HashTable_ s k v
forall k v. HashTable_ s k v
ht'


------------------------------------------------------------------------------
checkOverflow :: Int -> Bool
checkOverflow :: Int -> Bool
checkOverflow Int
sz = Int
sz Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
bucketSplitSize


------------------------------------------------------------------------------
-- insert w/o splitting
primitiveInsert :: (Hashable k) =>
                   (HashTable_ s k v)
                -> k
                -> v
                -> ST s Int
primitiveInsert :: 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' :: 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 s k v
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
    String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"primitiveInsert': snoccing bucket"
    (!Int
hw,Maybe (Bucket s k v)
m) <- Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
forall s k v.
Bucket s k v -> k -> v -> ST s (Int, Maybe (Bucket s k v))
Bucket.snoc Bucket s k v
bucket k
k v
v
    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 snoc'd"
    ST s ()
-> (Bucket s k v -> ST s ()) -> Maybe (Bucket s k v) -> ST s ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          (MutableArray s (Bucket s k v) -> Int -> Bucket s k v -> ST s ()
forall s a. MutableArray s a -> Int -> a -> ST s ()
writeArray MutableArray s (Bucket s k v)
buckets Int
h0)
          Maybe (Bucket s k v)
m
    Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
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 :: 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 :: 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 :: 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 :: 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 :: 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 :: String -> ST s ()
debug String
_ = () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
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 :: 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 (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 s k v
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
        Maybe Int
mbIx <- Bucket s k v -> k -> ST s (Maybe Int)
forall k s v. Eq k => Bucket s k v -> k -> ST s (Maybe Int)
Bucket.lookupIndex Bucket s k v
bucket k
k
        Maybe Word -> ST s (Maybe Word)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Word -> ST s (Maybe Word))
-> Maybe Word -> ST s (Maybe Word)
forall a b. (a -> b) -> a -> b
$! do Int
ix <- Maybe Int
mbIx
                     Word -> Maybe Word
forall a. a -> Maybe a
Just (Word -> Maybe Word) -> Word -> Maybe Word
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int -> Word
encodeIndex Int
lvl Int
h0 Int
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 :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (Word, b, c)
forall a. Maybe a
Nothing
          | Bool
otherwise = do
              Bucket s k v
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
              Maybe (b, c)
mb     <- Bucket s k v -> Int -> ST s (Maybe (b, c))
forall s k v. Bucket s k v -> Int -> ST s (Maybe (k, v))
Bucket.elemAt Bucket s k v
bucket Int
ix
              case Maybe (b, c)
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 (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 #-}