{-# 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
    { 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             = forall s k v. ST s (HashTable s k v)
new
    newSized :: forall s k v. Int -> ST s (HashTable s k v)
newSized        = 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          = 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          = 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          = 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           = 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_           = 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     = 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     = 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 = 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          = 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        = 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 :: forall s k v. ST s (HashTable s k v)
new = do
    MutableArray s (Bucket s k v)
v <- forall s k v. Int -> ST s (MutableArray s (Bucket s k v))
Bucket.newBucketArray Int
2
    forall s k v. HashTable_ s k v -> ST s (HashTable s k v)
newRef forall a b. (a -> b) -> a -> b
$ 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 :: forall s k v. Int -> ST s (HashTable s k v)
newSized Int
n = do
    MutableArray s (Bucket s k v)
v <- forall s k v. Int -> ST s (MutableArray s (Bucket s k v))
Bucket.newBucketArray Int
sz
    forall s k v. HashTable_ s k v -> ST s (HashTable s k v)
newRef forall a b. (a -> b) -> a -> b
$ 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   = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n forall a. Num a => a -> a -> a
* Double
fillFactor forall a. Fractional a => a -> a -> a
/ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bucketSplitSize)
    lvl :: Int
lvl = forall a. Ord a => a -> a -> a
max Int
1 (forall a. Enum a => a -> Int
fromEnum 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 :: forall k s v. (Hashable k, Eq k) => HashTable s k v -> k -> ST s ()
delete HashTable s k v
htRef !k
k = forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
        forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"delete: size=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int -> Int
power2 Int
lvl) forall a. [a] -> [a] -> [a]
++ String
", h0=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
h0
                  forall a. [a] -> [a] -> [a]
++ String
"splitptr: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
splitptr
        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 :: 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 = forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
        Bucket s k v
bucket <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h0
        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 :: 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
    HashTable_ s k v
ht' <- forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} {s} {v}.
Hashable k =>
HashTable_ s k v -> ST s (HashTable_ s k v)
work
    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 = forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
        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 <- 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
            forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"insert: splitting"
            HashTable_ s k v
h <- forall {k} {s} {v}.
Hashable k =>
HashTable_ s k v -> ST s (HashTable_ s k v)
split HashTable_ s k v
ht
            forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"insert: done splitting"
            forall (m :: * -> *) a. Monad m => a -> m a
return HashTable_ s k v
h
          else do
            forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"insert: done"
            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 :: 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 = 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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
    (HashTable_ s k v
ht, a
a) <- forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} {v}.
Hashable k =>
HashTable_ s k v -> ST s (HashTable_ s k v, a)
work
    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
    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 = forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
        Bucket s k v
bucket <- 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) <- 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
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
              (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' <- forall {k} {s} {v}.
Hashable k =>
HashTable_ s k v -> ST s (HashTable_ s k v)
split HashTable_ s k v
ht
            forall (m :: * -> *) a. Monad m => a -> m a
return (HashTable_ s k v
ht', a
a)
          else 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_ :: 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 = forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 forall a. Ord a => a -> a -> Bool
>= Int
sz = forall (m :: * -> *) a. Monad m => a -> m a
return ()
              | Bool
otherwise = do
            Bucket s k v
b <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
i
            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 forall a b. (a -> b) -> a -> b
$ Int
iforall 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 :: 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 = forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 forall a. Ord a => a -> a -> Bool
>= Int
sz   = forall (m :: * -> *) a. Monad m => a -> m a
return a
seed
                    | Bool
otherwise = do
            Bucket s k v
b <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
i
            !a
seed' <- 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' forall a b. (a -> b) -> a -> b
$ Int
iforall 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 :: forall s k v. HashTable s k v -> ST s Double
computeOverhead HashTable s k v
htRef = forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totElems
        let o :: b
o = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
overhead

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

            Int -> Int -> Int -> ST s (Int, Int)
go Int
n' Int
o' (Int
iforall 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' :: 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 s k v
bucket <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h0
    Bool
_ <- forall k s v. Eq k => Bucket s k v -> k -> ST s Bool
Bucket.delete Bucket s k v
bucket k
k
    forall (m :: * -> *) a. Monad m => a -> m a
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
    forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"split: start: nbuck=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int -> Int
power2 Int
lvl)
              forall a. [a] -> [a] -> [a]
++ String
", splitptr=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
splitptr

    -- grab bucket at splitPtr
    Bucket s k v
oldBucket <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
splitptr

    Int
nelems <- forall s k v. Bucket s k v -> ST s Int
Bucket.size Bucket s k v
oldBucket
    let !bsz :: Int
bsz = forall a. Ord a => a -> a -> a
max Int
Bucket.newBucketSize forall a b. (a -> b) -> a -> b
$
                   forall a b. (RealFrac a, Integral b) => a -> b
ceiling forall a b. (a -> b) -> a -> b
$ (Double
0.625 :: Double) forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nelems

    -- write an empty bucket there
    Bucket s k v
dbucket1 <- forall s k v. Int -> ST s (Bucket s k v)
Bucket.emptyWithSize Int
bsz
    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 forall a b. (a -> b) -> a -> b
$ Int
lvlforall a. Num a => a -> a -> a
-Int
1

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

    let ht' :: HashTable_ s k v
ht' = 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 forall a. Num a => a -> a -> a
+ Int
lvl1
    Bucket s k v
db2   <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets' Int
splitOffs
    Int
db2sz <- forall s k v. Bucket s k v -> ST s Int
Bucket.size Bucket s k v
db2
    let db2sz' :: Int
db2sz' = Int
db2sz forall a. Num a => a -> a -> a
+ Int
bsz
    Bucket s k v
db2'  <- forall s k v. Int -> Bucket s k v -> ST s (Bucket s k v)
Bucket.growBucketTo Int
db2sz' Bucket s k v
db2
    forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"growing bucket at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
splitOffs forall a. [a] -> [a] -> [a]
++ String
" to size "
              forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
db2sz'
    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
    forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"split: rehashing bucket"
    let f :: (k, b) -> ST s Int
f = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall k s v. Hashable k => HashTable_ s k v -> k -> v -> ST s Int
primitiveInsert forall {k} {v}. HashTable_ s k v
ht'
    forall (m :: * -> *) a. Monad m => a -> a -> m ()
forceSameType forall {b}. (k, b) -> ST s Int
f (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall k s v. Hashable k => HashTable_ s k v -> k -> v -> ST s Int
primitiveInsert HashTable_ s k v
ht)

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


------------------------------------------------------------------------------
checkOverflow :: Int -> Bool
checkOverflow :: Int -> Bool
checkOverflow Int
sz = Int
sz 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 :: 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
    forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"primitiveInsert start: nbuckets=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Int -> Int
power2 Int
lvl)
    let h0 :: Int
h0 = forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
    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
    forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"primitiveInsert': bucket number=" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
h0
    Bucket s k v
bucket <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h0
    forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"primitiveInsert': snoccing bucket"
    (!Int
hw,Maybe (Bucket s k v)
m) <- 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
    forall s. String -> ST s ()
debug forall a b. (a -> b) -> a -> b
$ String
"primitiveInsert': bucket snoc'd"
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ())
          (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
    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 :: forall k. Hashable k => Int -> Int -> k -> Int
hashKey !Int
lvl !Int
splitptr !k
k = Int
h1
  where
    !h0 :: Int
h0 = forall k. Hashable k => Int -> k -> Int
hashAtLvl (Int
lvlforall a. Num a => a -> a -> a
-Int
1) k
k
    !h1 :: Int
h1 = if (Int
h0 forall a. Ord a => a -> a -> Bool
< Int
splitptr)
            then 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 forall a. Bits a => a -> a -> a
.&. Int
mask
    !hashcode :: Int
hashcode = forall a. Hashable a => a -> Int
hash k
k
    !mask :: Int
mask     = Int -> Int
power2 Int
lvl 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 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall s k v. STRef s (HashTable_ s k v) -> HashTable s k v
HT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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) = 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
_ = 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 :: 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 = forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 = forall k. Hashable k => Int -> Int -> k -> Int
hashKey Int
lvl Int
splitptr k
k
        Bucket s k v
bucket <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h0
        Maybe Int
mbIx <- forall k s v. Eq k => Bucket s k v -> k -> ST s (Maybe Int)
Bucket.lookupIndex Bucket s k v
bucket k
k
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! do Int
ix <- Maybe Int
mbIx
                     forall a. a -> Maybe a
Just 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 =
  forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
bucketIx forall a. Bits a => a -> Int -> a
`Data.Bits.shiftL` Int -> Int
indexOffset Int
lvl forall a. Bits a => a -> a -> a
.|.
  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 =
  ( forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
ix forall a. Bits a => a -> Int -> a
`Data.Bits.shiftR` Int
offset)
  , forall a b. (Integral a, Num b) => a -> b
fromIntegral ( (forall a. Bits a => Int -> a
bit Int
offset forall a. Num a => a -> a -> a
- Word
1) 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 = forall b. FiniteBits b => b -> Int
finiteBitSize (Word
0 :: Word) 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 = forall s k v. HashTable s k v -> ST s (HashTable_ s k v)
readRef HashTable s k v
htRef forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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
        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 forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
bucketN forall a. Ord a => a -> a -> Bool
<= Int
h = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
          | Bool
otherwise = do
              Bucket s k v
bucket <- forall s a. MutableArray s a -> Int -> ST s a
readArray MutableArray s (Bucket s k v)
buckets Int
h
              Maybe (b, c)
mb     <- 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 forall (m :: * -> *) a. Monad m => a -> m a
return (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
hforall a. Num a => a -> a -> a
+Int
1) Int
0

{-# INLINE nextByIndex #-}