{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP          #-}
{-# LANGUAGE MagicHash    #-}

{-|

A basic open-addressing hash table using linear probing. Use this hash table if
you...

  * want the fastest possible lookups, and very fast inserts.

  * don't care about wasting a little bit of memory to get it.

  * don't care that a table resize might pause for a long time to rehash all
    of the key-value mappings.

  * have a workload which is not heavy with deletes; deletes clutter the table
    with deleted markers and force the table to be completely rehashed fairly
    often.

Of the hash tables in this collection, this hash table has the best lookup
performance, while maintaining competitive insert performance.

/Space overhead/

This table is not especially memory-efficient; firstly, the table has a maximum
load factor of 0.83 and will be resized if load exceeds this value. Secondly,
to improve insert and lookup performance, we store a 16-bit hash code for each
key in the table.

Each hash table entry requires at least 2.25 words (on a 64-bit machine), two
for the pointers to the key and value and one quarter word for the hash code.
We don't count key and value pointers as overhead, because they have to be
there -- so the overhead for a full slot is at least one quarter word -- but
empty slots in the hash table count for a full 2.25 words of overhead. Define
@m@ as the number of slots in the table, @n@ as the number of key value
mappings, and @ws@ as the machine word size in /bytes/. If the load factor is
@k=n\/m@, the amount of space /wasted/ per mapping in words is:

@
w(n) = (m*(2*ws + 2) - n*(2*ws)) / ws
@

Since @m=n\/k@,

@
w(n) = n\/k * (2*ws + 2) - n*(2*ws)
     = (n * (2 + 2*ws*(1-k)) / k) / ws
@

Solving for @k=0.83@, the maximum load factor, gives a /minimum/ overhead of
0.71 words per mapping on a 64-bit machine, or 1.01 words per mapping on a
32-bit machine. If @k=0.5@, which should be under normal usage the /maximum/
overhead situation, then the overhead would be 2.5 words per mapping on a
64-bit machine, or 3.0 words per mapping on a 32-bit machine.

/Space overhead: experimental results/

In randomized testing on a 64-bit machine (see
@test\/compute-overhead\/ComputeOverhead.hs@ in the source distribution), mean
overhead (that is, the number of words needed to store the key-value mapping
over and above the two words necessary for the key and the value pointers) is
approximately 1.24 machine words per key-value mapping with a standard
deviation of about 0.30 words, and 1.70 words per mapping at the 95th
percentile.

/Expensive resizes/

If enough elements are inserted into the table to make it exceed the maximum
load factor, the table is resized. A resize involves a complete rehash of all
the elements in the table, which means that any given call to 'insert' might
take /O(n)/ time in the size of the table, with a large constant factor. If a
long pause waiting for the table to resize is unacceptable for your
application, you should choose the included linear hash table instead.


/References:/

  * Knuth, Donald E. /The Art of Computer Programming/, vol. 3 Sorting and
    Searching. Addison-Wesley Publishing Company, 1973.
-}

module Data.HashTable.ST.Basic
  ( HashTable
  , new
  , newSized
  , size
  , delete
  , lookup
  , insert
  , mutate
  , mutateST
  , mapM_
  , foldM
  , computeOverhead
  ) where


------------------------------------------------------------------------------
#if !MIN_VERSION_base(4,8,0)
import           Control.Applicative
#endif
import           Control.Exception                 (assert)
import           Control.Monad                     hiding (foldM, mapM_)
import           Control.Monad.ST                  (ST)
import           Data.Bits
import           Data.Hashable                     (Hashable)
import qualified Data.Hashable                     as H
import           Data.Maybe
import           Data.Monoid
#if MIN_VERSION_base(4,9,0) && !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif
import qualified Data.Primitive.ByteArray          as A
import           Data.STRef
import           GHC.Exts
import           Prelude                           hiding (lookup, mapM_, read)
------------------------------------------------------------------------------
import qualified Data.HashTable.Class              as C
import           Data.HashTable.Internal.Array
import           Data.HashTable.Internal.CacheLine
import           Data.HashTable.Internal.IntArray  (Elem)
import qualified Data.HashTable.Internal.IntArray  as U
import           Data.HashTable.Internal.Utils


------------------------------------------------------------------------------
-- | An open addressing hash table using linear probing.
newtype HashTable s k v = HT (STRef s (HashTable_ s k v))

type SizeRefs s = A.MutableByteArray s

intSz :: Int
intSz :: Int
intSz = (Int -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Int
0::Int) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)

readLoad :: SizeRefs s -> ST s Int
readLoad :: forall s. SizeRefs s -> ST s Int
readLoad = (SizeRefs s -> Int -> ST s Int) -> Int -> SizeRefs s -> ST s Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip SizeRefs s -> Int -> ST s Int
MutableByteArray (PrimState (ST s)) -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
A.readByteArray Int
0

writeLoad :: SizeRefs s -> Int -> ST s ()
writeLoad :: forall s. SizeRefs s -> Int -> ST s ()
writeLoad = (SizeRefs s -> Int -> Int -> ST s ())
-> Int -> SizeRefs s -> Int -> ST s ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SizeRefs s -> Int -> Int -> ST s ()
MutableByteArray (PrimState (ST s)) -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
A.writeByteArray Int
0

readDelLoad :: SizeRefs s -> ST s Int
readDelLoad :: forall s. SizeRefs s -> ST s Int
readDelLoad = (SizeRefs s -> Int -> ST s Int) -> Int -> SizeRefs s -> ST s Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip SizeRefs s -> Int -> ST s Int
MutableByteArray (PrimState (ST s)) -> Int -> ST s Int
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
A.readByteArray Int
1

writeDelLoad :: SizeRefs s -> Int -> ST s ()
writeDelLoad :: forall s. SizeRefs s -> Int -> ST s ()
writeDelLoad = (SizeRefs s -> Int -> Int -> ST s ())
-> Int -> SizeRefs s -> Int -> ST s ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SizeRefs s -> Int -> Int -> ST s ()
MutableByteArray (PrimState (ST s)) -> Int -> Int -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
A.writeByteArray Int
1

newSizeRefs :: ST s (SizeRefs s)
newSizeRefs :: forall s. ST s (SizeRefs s)
newSizeRefs = do
    let asz :: Int
asz = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
intSz
    a <- Int -> Int -> ST s (MutableByteArray (PrimState (ST s)))
forall (m :: * -> *).
PrimMonad m =>
Int -> Int -> m (MutableByteArray (PrimState m))
A.newAlignedPinnedByteArray Int
asz Int
intSz
    A.fillByteArray a 0 asz 0
    return a


data HashTable_ s k v = HashTable
    { forall s k v. HashTable_ s k v -> Int
_size   :: {-# UNPACK #-} !Int
    , forall s k v. HashTable_ s k v -> SizeRefs s
_load   :: !(SizeRefs s)   -- ^ 2-element array, stores how many entries
                                  -- and deleted entries are in the table.
    , forall s k v. HashTable_ s k v -> IntArray s
_hashes :: !(U.IntArray s)
    , forall s k v. HashTable_ s k v -> MutableArray s k
_keys   :: {-# UNPACK #-} !(MutableArray s k)
    , forall s k v. HashTable_ s k v -> MutableArray s v
_values :: {-# UNPACK #-} !(MutableArray s 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>"


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.new'.
new :: ST s (HashTable s k v)
new :: forall s k v. ST s (HashTable s k v)
new = Int -> ST s (HashTable s k v)
forall s k v. Int -> ST s (HashTable s k v)
newSized Int
1
{-# INLINE new #-}


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.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
    String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"entering: newSized " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
    let m :: Int
m = Int -> Int
nextBestPrime (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 (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
maxLoad)
    ht <- Int -> ST s (HashTable_ s k v)
forall s k v. Int -> ST s (HashTable_ s k v)
newSizedReal Int
m
    newRef ht
{-# INLINE newSized #-}

------------------------------------------------------------------------------
newSizedReal :: Int -> ST s (HashTable_ s k v)
newSizedReal :: forall s k v. Int -> ST s (HashTable_ s k v)
newSizedReal Int
m = do
    -- make sure the hash array is a multiple of cache-line sized so we can
    -- always search a whole cache line at once
    let m' :: Int
m' = ((Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
numElemsInCacheLine Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
numElemsInCacheLine)
             Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
numElemsInCacheLine
    h  <- Int -> ST s (IntArray s)
forall s. Int -> ST s (IntArray s)
U.newArray Int
m'
    k  <- newArray m undefined
    v  <- newArray m undefined
    ld <- newSizeRefs
    return $! HashTable m ld h k v

------------------------------------------------------------------------------
-- | Returns the number of mappings currently stored in this table. /O(1)/
size :: HashTable s k v -> ST s Int
size :: forall s k v. HashTable s k v -> ST s Int
size HashTable s k v
htRef = do
    HashTable _ sizeRefs _ _ _ <- 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
    readLoad sizeRefs
{-# INLINE size #-}


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.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 = 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
    slots <- findSafeSlots ht k h
    when (trueInt (_slotFound slots)) $ deleteFromSlot ht (_slotB1 slots)
  where
    !h :: Int
h = k -> Int
forall k. Hashable k => k -> Int
hash k
k
{-# INLINE delete #-}


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.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 = 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
    lookup' ht
  where
    lookup' :: HashTable_ s k v -> ST s (Maybe v)
lookup' (HashTable Int
sz SizeRefs s
_ IntArray s
hashes MutableArray s k
keys MutableArray s v
values) = do
        let !b :: Int
b = Int -> Int -> Int
whichBucket Int
h Int
sz
        String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"lookup h=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" sz=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" b=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b
        Int -> Int -> Int -> ST s (Maybe v)
go Int
b Int
0 Int
sz

      where
        !h :: Int
h  = k -> Int
forall k. Hashable k => k -> Int
hash k
k
        !he :: Elem
he = Int -> Elem
hashToElem Int
h

        go :: Int -> Int -> Int -> ST s (Maybe v)
go !Int
b !Int
start !Int
end = {-# SCC "lookup/go" #-} do
            String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"lookup'/go: "
                           , Int -> String
forall a. Show a => a -> String
show Int
b
                           , String
"/"
                           , Int -> String
forall a. Show a => a -> String
show Int
start
                           , String
"/"
                           , Int -> String
forall a. Show a => a -> String
show Int
end
                           ]
            idx <- IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int
forall s. IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int
forwardSearch2 IntArray s
hashes Int
b Int
end Elem
he Elem
emptyMarker
            debug $ "forwardSearch2 returned " ++ show idx
            if (idx < 0 || idx < start || idx >= end)
               then return Nothing
               else do
                 h0  <- U.readArray hashes idx
                 debug $ "h0 was " ++ show h0

                 if recordIsEmpty h0
                   then do
                       debug $ "record empty, returning Nothing"
                       return Nothing
                   else do
                     k' <- readArray keys idx
                     if k == k'
                       then do
                         debug $ "value found at " ++ show idx
                         v <- readArray values idx
                         return $! Just v
                       else do
                         debug $ "value not found, recursing"
                         if idx < b
                           then go (idx + 1) (idx + 1) b
                           else go (idx + 1) start end
{-# INLINE lookup #-}


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.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
    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
    debug $ "insert: h=" ++ show h
    slots@(SlotFindResponse foundInt b0 b1) <- findSafeSlots ht k h
    let found = Int -> Bool
trueInt Int
foundInt
    debug $ "insert: findSafeSlots returned " ++ show slots
    when (found && (b0 /= b1)) $ deleteFromSlot ht b1
    insertIntoSlot ht b0 he k v
    ht' <- checkOverflow ht
    writeRef htRef ht'

  where
    !h :: Int
h = k -> Int
forall k. Hashable k => k -> Int
hash k
k
    !he :: Elem
he = Int -> Elem
hashToElem Int
h
{-# INLINE insert #-}


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.mutate'.
mutate :: (Eq k, Hashable k) =>
          (HashTable s k v)
       -> k
       -> (Maybe v -> (Maybe v, a))
       -> ST s a
mutate :: 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 #-}


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.mutateST'.
mutateST :: (Eq k, Hashable k) =>
            (HashTable s k v)
         -> k
         -> (Maybe v -> ST s (Maybe v, a))
         -> ST s a
mutateST :: 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 <- 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
    let values = HashTable_ s k v -> MutableArray s v
forall s k v. HashTable_ s k v -> MutableArray s v
_values HashTable_ s k v
ht
    debug $ "mutate h=" ++ show h
    slots@(SlotFindResponse foundInt b0 b1) <- findSafeSlots ht k h
    let found = Int -> Bool
trueInt Int
foundInt
    debug $ "findSafeSlots returned " ++ show slots
    !mv <- if found
              then fmap Just $ readArray values b1
              else return Nothing
    (!mv', !result) <- f mv
    case (mv, mv') of
        (Maybe v
Nothing, Maybe v
Nothing) -> () -> ST s ()
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        (Just v
_, Maybe v
Nothing)  -> do
            HashTable_ s k v -> Int -> ST s ()
forall s k v. HashTable_ s k v -> Int -> ST s ()
deleteFromSlot HashTable_ s k v
ht Int
b1
        (Maybe v
Nothing, Just v
v') -> do
            HashTable_ s k v -> Int -> Elem -> k -> v -> ST s ()
forall s k v. HashTable_ s k v -> Int -> Elem -> k -> v -> ST s ()
insertIntoSlot HashTable_ s k v
ht Int
b0 Elem
he k
k v
v'
            ht' <- HashTable_ s k v -> ST s (HashTable_ s k v)
forall k s v.
(Eq k, Hashable k) =>
HashTable_ s k v -> ST s (HashTable_ s k v)
checkOverflow HashTable_ s k v
ht
            writeRef htRef ht'
        (Just v
_, Just v
v')  -> do
            Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
b0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
b1) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$
                HashTable_ s k v -> Int -> ST s ()
forall s k v. HashTable_ s k v -> Int -> ST s ()
deleteFromSlot HashTable_ s k v
ht Int
b1
            HashTable_ s k v -> Int -> Elem -> k -> v -> ST s ()
forall s k v. HashTable_ s k v -> Int -> Elem -> k -> v -> ST s ()
insertIntoSlot HashTable_ s k v
ht Int
b0 Elem
he k
k v
v'
    return result
  where
    !h :: Int
h     = k -> Int
forall k. Hashable k => k -> Int
hash k
k
    !he :: Elem
he    = Int -> Elem
hashToElem Int
h
{-# INLINE mutateST #-}


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.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 = 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
work
  where
    work :: HashTable_ s k v -> ST s a
work (HashTable Int
sz SizeRefs s
_ IntArray s
hashes MutableArray s k
keys MutableArray s v
values) = Int -> a -> ST s a
go Int
0 a
seed0
      where
        go :: Int -> a -> ST s a
go !Int
i !a
seed | 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
            h <- IntArray s -> Int -> ST s Elem
forall s. IntArray s -> Int -> ST s Elem
U.readArray IntArray s
hashes Int
i
            if recordIsEmpty h || recordIsDeleted h
              then go (i+1) seed
              else do
                k <- readArray keys i
                v <- readArray values i
                !seed' <- f seed (k, v)
                go (i+1) seed'


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.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 = 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 ()
work
  where
    work :: HashTable_ s k v -> ST s ()
work (HashTable Int
sz SizeRefs s
_ IntArray s
hashes MutableArray s k
keys MutableArray s v
values) = Int -> ST s ()
go Int
0
      where
        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
            h <- IntArray s -> Int -> ST s Elem
forall s. IntArray s -> Int -> ST s Elem
U.readArray IntArray s
hashes Int
i
            if recordIsEmpty h || recordIsDeleted h
              then go (i+1)
              else do
                k <- readArray keys i
                v <- readArray values i
                _ <- f (k, v)
                go (i+1)


------------------------------------------------------------------------------
-- | See the documentation for this function in
-- 'Data.HashTable.Class.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 = 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
sz' SizeRefs s
loadRef IntArray s
_ MutableArray s k
_ MutableArray s v
_) = do
        !ld <- SizeRefs s -> ST s Int
forall s. SizeRefs s -> ST s Int
readLoad SizeRefs s
loadRef
        let k = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
ld b -> b -> b
forall a. Fractional a => a -> a -> a
/ b
sz
        return $ constOverhead/sz + (2 + 2*ws*(1-k)) / (k * ws)
      where
        ws :: b
ws = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> b) -> Int -> b
forall a b. (a -> b) -> a -> b
$! Int -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize (Int
0::Int) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
        sz :: b
sz = Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sz'
        -- Change these if you change the representation
        constOverhead :: b
constOverhead = b
14


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


------------------------------------------------------------------------------
{-# INLINE insertRecord #-}
insertRecord :: Int
             -> U.IntArray s
             -> MutableArray s k
             -> MutableArray s v
             -> Int
             -> k
             -> v
             -> ST s ()
insertRecord :: forall s k v.
Int
-> IntArray s
-> MutableArray s k
-> MutableArray s v
-> Int
-> k
-> v
-> ST s ()
insertRecord !Int
sz !IntArray s
hashes !MutableArray s k
keys !MutableArray s v
values !Int
h !k
key !v
value = do
    let !b :: Int
b = Int -> Int -> Int
whichBucket Int
h Int
sz
    String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"insertRecord sz=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" h=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" b=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b
    Int -> ST s ()
probe Int
b

  where
    he :: Elem
he = Int -> Elem
hashToElem Int
h

    probe :: Int -> ST s ()
probe !Int
i = {-# SCC "insertRecord/probe" #-} do
        !idx <- IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int
forall s. IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int
forwardSearch2 IntArray s
hashes Int
i Int
sz Elem
emptyMarker Elem
deletedMarker
        debug $ "forwardSearch2 returned " ++ show idx
        assert (idx >= 0) $ do
            U.writeArray hashes idx he
            writeArray keys idx key
            writeArray values idx value


------------------------------------------------------------------------------
checkOverflow :: (Eq k, Hashable k) =>
                 (HashTable_ s k v)
              -> ST s (HashTable_ s k v)
checkOverflow :: forall k s v.
(Eq k, Hashable k) =>
HashTable_ s k v -> ST s (HashTable_ s k v)
checkOverflow ht :: HashTable_ s k v
ht@(HashTable Int
sz SizeRefs s
ldRef IntArray s
_ MutableArray s k
_ MutableArray s v
_) = do
    !ld <- SizeRefs s -> ST s Int
forall s. SizeRefs s -> ST s Int
readLoad SizeRefs s
ldRef
    !dl <- readDelLoad ldRef

    debug $ concat [ "checkOverflow: sz="
                   , show sz
                   , " entries="
                   , show ld
                   , " deleted="
                   , show dl ]

    if fromIntegral (ld + dl) / fromIntegral sz > maxLoad
      then if dl > ld `div` 2
             then rehashAll ht sz
             else growTable ht
      else return ht


------------------------------------------------------------------------------
rehashAll :: Hashable k => HashTable_ s k v -> Int -> ST s (HashTable_ s k v)
rehashAll :: forall k s v.
Hashable k =>
HashTable_ s k v -> Int -> ST s (HashTable_ s k v)
rehashAll (HashTable Int
sz SizeRefs s
loadRef IntArray s
hashes MutableArray s k
keys MutableArray s v
values) Int
sz' = do
    String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"rehashing: old size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", new size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz'
    ht' <- Int -> ST s (HashTable_ s k v)
forall s k v. Int -> ST s (HashTable_ s k v)
newSizedReal Int
sz'
    let (HashTable _ loadRef' newHashes newKeys newValues) = ht'
    readLoad loadRef >>= writeLoad loadRef'
    rehash newHashes newKeys newValues
    return ht'

  where
    rehash :: IntArray s -> MutableArray s k -> MutableArray s v -> ST s ()
rehash IntArray s
newHashes MutableArray s k
newKeys MutableArray s v
newValues = Int -> ST s ()
go Int
0
      where
        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 = {-# SCC "growTable/rehash" #-} do
                    h0 <- IntArray s -> Int -> ST s Elem
forall s. IntArray s -> Int -> ST s Elem
U.readArray IntArray s
hashes Int
i
                    when (not (recordIsEmpty h0 || recordIsDeleted h0)) $ do
                        k <- readArray keys i
                        v <- readArray values i
                        insertRecord sz' newHashes newKeys newValues
                                     (hash k) k v
                    go $ i+1


------------------------------------------------------------------------------
growTable :: Hashable k => HashTable_ s k v -> ST s (HashTable_ s k v)
growTable :: forall k s v.
Hashable k =>
HashTable_ s k v -> ST s (HashTable_ s k v)
growTable ht :: HashTable_ s k v
ht@(HashTable Int
sz SizeRefs s
_ IntArray s
_ MutableArray s k
_ MutableArray s v
_) = do
    let !sz' :: Int
sz' = Double -> Int -> Int
bumpSize Double
maxLoad Int
sz
    HashTable_ s k v -> Int -> ST s (HashTable_ s k v)
forall k s v.
Hashable k =>
HashTable_ s k v -> Int -> ST s (HashTable_ s k v)
rehashAll HashTable_ s k v
ht Int
sz'


------------------------------------------------------------------------------
-- Helper data structure for findSafeSlots
newtype Slot = Slot { Slot -> Int
_slot :: Int } deriving (Int -> Slot -> ShowS
[Slot] -> ShowS
Slot -> String
(Int -> Slot -> ShowS)
-> (Slot -> String) -> ([Slot] -> ShowS) -> Show Slot
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Slot -> ShowS
showsPrec :: Int -> Slot -> ShowS
$cshow :: Slot -> String
show :: Slot -> String
$cshowList :: [Slot] -> ShowS
showList :: [Slot] -> ShowS
Show)


------------------------------------------------------------------------------

#if MIN_VERSION_base(4,9,0)
instance Semigroup Slot where
  <> :: Slot -> Slot -> Slot
(<>) = Slot -> Slot -> Slot
slotMappend
#endif

instance Monoid Slot where
  mempty :: Slot
mempty = Int -> Slot
Slot Int
forall a. Bounded a => a
maxBound
#if ! MIN_VERSION_base(4,11,0)
  mappend = slotMappend
#endif

slotMappend :: Slot -> Slot -> Slot
slotMappend :: Slot -> Slot -> Slot
slotMappend (Slot Int
x1) (Slot Int
x2) =
  let !m :: Int
m = Int -> Int -> Int
mask Int
x1 Int
forall a. Bounded a => a
maxBound
  in Int -> Slot
Slot (Int -> Slot) -> Int -> Slot
forall a b. (a -> b) -> a -> b
$! (Int -> Int
forall a. Bits a => a -> a
complement Int
m Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
x1) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Int
m Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
x2)

------------------------------------------------------------------------------
-- findSafeSlots return type
data SlotFindResponse = SlotFindResponse {
    SlotFindResponse -> Int
_slotFound :: {-# UNPACK #-} !Int -- we use Int because Bool won't unpack
  , SlotFindResponse -> Int
_slotB0    :: {-# UNPACK #-} !Int
  , SlotFindResponse -> Int
_slotB1    :: {-# UNPACK #-} !Int
} deriving (Int -> SlotFindResponse -> ShowS
[SlotFindResponse] -> ShowS
SlotFindResponse -> String
(Int -> SlotFindResponse -> ShowS)
-> (SlotFindResponse -> String)
-> ([SlotFindResponse] -> ShowS)
-> Show SlotFindResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SlotFindResponse -> ShowS
showsPrec :: Int -> SlotFindResponse -> ShowS
$cshow :: SlotFindResponse -> String
show :: SlotFindResponse -> String
$cshowList :: [SlotFindResponse] -> ShowS
showList :: [SlotFindResponse] -> ShowS
Show)


------------------------------------------------------------------------------
-- Returns ST s (SlotFoundResponse found b0 b1),
-- where
--     * found :: Int  - 1 if key-value mapping is already in the table,
--                       0 otherwise.
--     * b0    :: Int  - The index of a slot where it would be safe to write
--                       the given key (if the key is already in the mapping,
--                       you have to delete it before using this slot).
--     * b1    :: Int  - The index of a slot where the key currently resides.
--                       Or, if the key is not in the table, b1 is a slot
--                       where it is safe to write the key (b1 == b0).
findSafeSlots :: (Hashable k, Eq k) =>
                 (HashTable_ s k v)
              -> k
              -> Int
              -> ST s SlotFindResponse
findSafeSlots :: forall k s v.
(Hashable k, Eq k) =>
HashTable_ s k v -> k -> Int -> ST s SlotFindResponse
findSafeSlots (HashTable !Int
sz SizeRefs s
_ IntArray s
hashes MutableArray s k
keys MutableArray s v
_) k
k Int
h = do
    String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"findSafeSlots: h=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" he=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Elem -> String
forall a. Show a => a -> String
show Elem
he
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" sz=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" b0=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b0
    response <- Slot -> Int -> Bool -> ST s SlotFindResponse
go Slot
forall a. Monoid a => a
mempty Int
b0 Bool
False
    debug $ "go returned " ++ show response
    return response

  where
    !he :: Elem
he = Int -> Elem
hashToElem Int
h
    !b0 :: Int
b0 = Int -> Int -> Int
whichBucket Int
h Int
sz
    haveWrapped :: Slot -> Int -> Bool
haveWrapped !(Slot Int
fp) !Int
b = if Int
fp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Bounded a => a
maxBound
                                    then Bool
False
                                    else Int
b Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
fp

    -- arguments:

    --   * fp    maintains the slot in the array where it would be safe to
    --           write the given key
    --   * b     search the buckets array starting at this index.
    --   * wrap  True if we've wrapped around, False otherwise

    go :: Slot -> Int -> Bool -> ST s SlotFindResponse
go !Slot
fp !Int
b !Bool
wrap = do
        String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"go: fp="
                       , Slot -> String
forall a. Show a => a -> String
show Slot
fp
                       , String
" b="
                       , Int -> String
forall a. Show a => a -> String
show Int
b
                       , String
", wrap="
                       , Bool -> String
forall a. Show a => a -> String
show Bool
wrap
                       , String
", he="
                       , Elem -> String
forall a. Show a => a -> String
show Elem
he
                       , String
", emptyMarker="
                       , Elem -> String
forall a. Show a => a -> String
show Elem
emptyMarker
                       , String
", deletedMarker="
                       , Elem -> String
forall a. Show a => a -> String
show Elem
deletedMarker ]

        !idx <- IntArray s -> Int -> Int -> Elem -> Elem -> Elem -> ST s Int
forall s.
IntArray s -> Int -> Int -> Elem -> Elem -> Elem -> ST s Int
forwardSearch3 IntArray s
hashes Int
b Int
sz Elem
he Elem
emptyMarker Elem
deletedMarker
        debug $ "forwardSearch3 returned " ++ show idx
                ++ " with sz=" ++ show sz ++ ", b=" ++ show b

        if wrap && idx >= b0
          -- we wrapped around in the search and didn't find our hash code;
          -- this means that the table is full of deleted elements. Just return
          -- the first place we'd be allowed to insert.
          --
          -- TODO: if we get in this situation we should probably just rehash
          -- the table, because every insert is going to be O(n).
          then do
            let !sl = Slot
fp Slot -> Slot -> Slot
forall a. Monoid a => a -> a -> a
`mappend` (Int -> Slot
Slot (String -> Int
forall a. HasCallStack => String -> a
error String
"impossible"))
            return $! SlotFindResponse 0 (_slot sl) (_slot sl)
          else do
            -- because the table isn't full, we know that there must be either
            -- an empty or a deleted marker somewhere in the table. Assert this
            -- here.
            assert (idx >= 0) $ return ()
            h0 <- U.readArray hashes idx
            debug $ "h0 was " ++ show h0

            if recordIsEmpty h0
              then do
                  let pl = Slot
fp Slot -> Slot -> Slot
forall a. Monoid a => a -> a -> a
`mappend` (Int -> Slot
Slot Int
idx)
                  debug $ "empty, returning " ++ show pl
                  return $! SlotFindResponse 0 (_slot pl) (_slot pl)
              else do
                let !wrap' = Slot -> Int -> Bool
haveWrapped Slot
fp Int
idx
                if recordIsDeleted h0
                  then do
                      let !pl = Slot
fp Slot -> Slot -> Slot
forall a. Monoid a => a -> a -> a
`mappend` (Int -> Slot
Slot Int
idx)
                      debug $ "deleted, cont with pl=" ++ show pl
                      go pl (idx + 1) wrap'
                  else
                    if he == h0
                      then do
                        debug $ "found he == h0 == " ++ show h0
                        k' <- readArray keys idx
                        if k == k'
                          then do
                            debug $ "found at " ++ show idx
                            let !sl = Slot
fp Slot -> Slot -> Slot
forall a. Monoid a => a -> a -> a
`mappend` (Int -> Slot
Slot Int
idx)
                            return $! SlotFindResponse 1 (_slot sl) idx
                          else go fp (idx + 1) wrap'
                      else go fp (idx + 1) wrap'


------------------------------------------------------------------------------
{-# INLINE deleteFromSlot #-}
deleteFromSlot :: (HashTable_ s k v) -> Int -> ST s ()
deleteFromSlot :: forall s k v. HashTable_ s k v -> Int -> ST s ()
deleteFromSlot (HashTable Int
_ SizeRefs s
loadRef IntArray s
hashes MutableArray s k
keys MutableArray s v
values) Int
idx = do
    !he <- IntArray s -> Int -> ST s Elem
forall s. IntArray s -> Int -> ST s Elem
U.readArray IntArray s
hashes Int
idx
    when (recordIsFilled he) $ do
        bumpDelLoad loadRef 1
        bumpLoad loadRef (-1)
        U.writeArray hashes idx deletedMarker
        writeArray keys idx undefined
        writeArray values idx undefined


------------------------------------------------------------------------------
{-# INLINE insertIntoSlot #-}
insertIntoSlot :: (HashTable_ s k v) -> Int -> Elem -> k -> v -> ST s ()
insertIntoSlot :: forall s k v. HashTable_ s k v -> Int -> Elem -> k -> v -> ST s ()
insertIntoSlot (HashTable Int
_ SizeRefs s
loadRef IntArray s
hashes MutableArray s k
keys MutableArray s v
values) Int
idx Elem
he k
k v
v = do
    !heOld <- IntArray s -> Int -> ST s Elem
forall s. IntArray s -> Int -> ST s Elem
U.readArray IntArray s
hashes Int
idx
    let !heInt    = Elem -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Elem
heOld :: Int
        !delInt   = Elem -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Elem
deletedMarker :: Int
        !emptyInt = Elem -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Elem
emptyMarker :: Int
        !delBump  = Int -> Int -> Int
mask Int
heInt Int
delInt -- -1 if heInt == delInt,
                                      --  0  otherwise
        !mLoad    = Int -> Int -> Int
mask Int
heInt Int
delInt Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int -> Int -> Int
mask Int
heInt Int
emptyInt
        !loadBump = Int
mLoad Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
1 -- 1 if heInt == delInt || heInt == emptyInt,
                                -- 0 otherwise
    bumpDelLoad loadRef delBump
    bumpLoad loadRef loadBump
    U.writeArray hashes idx he
    writeArray keys idx k
    writeArray values idx v


-------------------------------------------------------------------------------
{-# INLINE bumpLoad #-}
bumpLoad :: (SizeRefs s) -> Int -> ST s ()
bumpLoad :: forall s. SizeRefs s -> Int -> ST s ()
bumpLoad SizeRefs s
ref Int
i = do
    !ld <- SizeRefs s -> ST s Int
forall s. SizeRefs s -> ST s Int
readLoad SizeRefs s
ref
    writeLoad ref $! ld + i


------------------------------------------------------------------------------
{-# INLINE bumpDelLoad #-}
bumpDelLoad :: (SizeRefs s) -> Int -> ST s ()
bumpDelLoad :: forall s. SizeRefs s -> Int -> ST s ()
bumpDelLoad SizeRefs s
ref Int
i = do
    !ld <- SizeRefs s -> ST s Int
forall s. SizeRefs s -> ST s Int
readDelLoad SizeRefs s
ref
    writeDelLoad ref $! ld + i


-----------------------------------------------------------------------------
maxLoad :: Double
maxLoad :: Double
maxLoad = Double
0.82


------------------------------------------------------------------------------
emptyMarker :: Elem
emptyMarker :: Elem
emptyMarker = Elem
0


------------------------------------------------------------------------------
deletedMarker :: Elem
deletedMarker :: Elem
deletedMarker = Elem
1


------------------------------------------------------------------------------
{-# INLINE trueInt #-}
trueInt :: Int -> Bool
trueInt :: Int -> Bool
trueInt (I# Int#
i#) = Int# -> Bool
forall a. Int# -> a
tagToEnum# Int#
i#


------------------------------------------------------------------------------
{-# INLINE recordIsEmpty #-}
recordIsEmpty :: Elem -> Bool
recordIsEmpty :: Elem -> Bool
recordIsEmpty = (Elem -> Elem -> Bool
forall a. Eq a => a -> a -> Bool
== Elem
emptyMarker)


------------------------------------------------------------------------------
{-# INLINE recordIsDeleted #-}
recordIsDeleted :: Elem -> Bool
recordIsDeleted :: Elem -> Bool
recordIsDeleted = (Elem -> Elem -> Bool
forall a. Eq a => a -> a -> Bool
== Elem
deletedMarker)


------------------------------------------------------------------------------
{-# INLINE recordIsFilled #-}
recordIsFilled :: Elem -> Bool
recordIsFilled :: Elem -> Bool
recordIsFilled !Elem
el = Int# -> Bool
forall a. Int# -> a
tagToEnum# Int#
isFilled#
  where
    !el# :: Int#
el# = Elem -> Int#
U.elemToInt# Elem
el
    !deletedMarker# :: Int#
deletedMarker# = Elem -> Int#
U.elemToInt# Elem
deletedMarker
    !emptyMarker# :: Int#
emptyMarker# = Elem -> Int#
U.elemToInt# Elem
emptyMarker
#if __GLASGOW_HASKELL__ >= 708
    !isFilled# :: Int#
isFilled# = (Int#
el# Int# -> Int# -> Int#
/=# Int#
deletedMarker#) Int# -> Int# -> Int#
`andI#` (Int#
el# Int# -> Int# -> Int#
/=# Int#
emptyMarker#)
#else
    !delOrEmpty# = mask# el# deletedMarker# `orI#` mask# el# emptyMarker#
    !isFilled# = 1# `andI#` notI# delOrEmpty#
#endif


------------------------------------------------------------------------------
{-# INLINE hash #-}
hash :: (Hashable k) => k -> Int
hash :: forall k. Hashable k => k -> Int
hash = k -> Int
forall k. Hashable k => k -> Int
H.hash


------------------------------------------------------------------------------
{-# INLINE hashToElem #-}
hashToElem :: Int -> Elem
hashToElem :: Int -> Elem
hashToElem !Int
h = Elem
out
  where
    !(I# Int#
lo#) = Int
h Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
U.elemMask

    !m# :: Word#
m#  = Int# -> Int# -> Word#
maskw# Int#
lo# Int#
0# Word# -> Word# -> Word#
`or#` Int# -> Int# -> Word#
maskw# Int#
lo# Int#
1#
    !nm# :: Word#
nm# = Word# -> Word#
not# Word#
m#

    !r# :: Word#
r#  = ((Int# -> Word#
int2Word# Int#
2#) Word# -> Word# -> Word#
`and#` Word#
m#) Word# -> Word# -> Word#
`or#` (Int# -> Word#
int2Word# Int#
lo# Word# -> Word# -> Word#
`and#` Word#
nm#)
    !out :: Elem
out = Word# -> Elem
U.primWordToElem Word#
r#


------------------------------------------------------------------------------
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
{-# INLINE newRef #-}

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
{-# INLINE writeRef #-}

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 readRef #-}


------------------------------------------------------------------------------
{-# INLINE debug #-}
debug :: String -> ST s ()
#ifdef DEBUG
debug s = unsafeIOToST (putStrLn s)
#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

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 = 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
    lookup' ht
  where
    lookup' :: HashTable_ s k v -> ST s (Maybe a)
lookup' (HashTable Int
sz SizeRefs s
_ IntArray s
hashes MutableArray s k
keys MutableArray s v
_values) = do
        let !b :: Int
b = Int -> Int -> Int
whichBucket Int
h Int
sz
        String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ String
"lookup h=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
h String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" sz=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" b=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
b
        Int -> Int -> Int -> ST s (Maybe a)
forall {a}. Num a => Int -> Int -> Int -> ST s (Maybe a)
go Int
b Int
0 Int
sz

      where
        !h :: Int
h  = k -> Int
forall k. Hashable k => k -> Int
hash k
k
        !he :: Elem
he = Int -> Elem
hashToElem Int
h

        go :: Int -> Int -> Int -> ST s (Maybe a)
go !Int
b !Int
start !Int
end = {-# SCC "lookupIndex/go" #-} do
            String -> ST s ()
forall s. String -> ST s ()
debug (String -> ST s ()) -> String -> ST s ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"lookupIndex/go: "
                           , Int -> String
forall a. Show a => a -> String
show Int
b
                           , String
"/"
                           , Int -> String
forall a. Show a => a -> String
show Int
start
                           , String
"/"
                           , Int -> String
forall a. Show a => a -> String
show Int
end
                           ]
            idx <- IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int
forall s. IntArray s -> Int -> Int -> Elem -> Elem -> ST s Int
forwardSearch2 IntArray s
hashes Int
b Int
end Elem
he Elem
emptyMarker
            debug $ "forwardSearch2 returned " ++ show idx
            if (idx < 0 || idx < start || idx >= end)
               then return Nothing
               else do
                 h0  <- U.readArray hashes idx
                 debug $ "h0 was " ++ show h0

                 if recordIsEmpty h0
                   then do
                       debug $ "record empty, returning Nothing"
                       return Nothing
                   else do
                     k' <- readArray keys idx
                     if k == k'
                       then do
                         debug $ "value found at " ++ show idx
                         return $! (Just $! fromIntegral idx)
                       else do
                         debug $ "value not found, recursing"
                         if idx < b
                           then go (idx + 1) (idx + 1) b
                           else go (idx + 1) start end
{-# INLINE lookupIndex #-}

nextByIndex :: HashTable s k v -> Word -> ST s (Maybe (Word, k, v))
nextByIndex :: forall s k v. HashTable s k v -> Word -> ST s (Maybe (Word, k, v))
nextByIndex HashTable s k v
htRef Word
i0 = 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 {a} {s} {k} {v}.
Num a =>
HashTable_ s k v -> ST s (Maybe (a, k, v))
work
  where
    work :: HashTable_ s k v -> ST s (Maybe (a, k, v))
work (HashTable Int
sz SizeRefs s
_ IntArray s
hashes MutableArray s k
keys MutableArray s v
values) = Int -> ST s (Maybe (a, k, v))
forall {a}. Num a => Int -> ST s (Maybe (a, k, v))
go (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
i0)
      where
        go :: Int -> ST s (Maybe (a, k, v))
go Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
sz = Maybe (a, k, v) -> ST s (Maybe (a, k, v))
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (a, k, v)
forall a. Maybe a
Nothing
             | Bool
otherwise = do
            h <- IntArray s -> Int -> ST s Elem
forall s. IntArray s -> Int -> ST s Elem
U.readArray IntArray s
hashes Int
i
            if recordIsEmpty h || recordIsDeleted h
              then go (i+1)
              else do
                k <- readArray keys i
                v <- readArray values i
                let !i' = Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
                return (Just (i', k, v))
{-# INLINE nextByIndex #-}