{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.HashTable.ST.Swiss
  ( Table (..)
  , new
  , newSized
  , insert'
  , insert
  , lookup'
  , lookup
  , delete'
  , delete
  , foldM
  , mapM_
  , analyze
  , getSize
  , mutateST
  , mutate
  ) where

import           Control.Monad        (forM_, void, when)
import qualified Control.Monad        as M
import           Control.Monad.ST     (RealWorld, ST)
import           Data.Bits
import           Data.Hashable
import           Data.Primitive
import           Data.Primitive.Array as A
import           Data.Primitive.Ptr   as PP
import           Data.STRef
import           Data.Word
import           Foreign.C.Types
import           GHC.Generics         (Generic)
import           GHC.IO               (ioToST)
import           Prelude              hiding (lookup, mapM_)

-- todo: try foreign import prim
foreign import ccall unsafe "_elm_cmp_vec" cElmCmpVec :: Word8 -> Ptr Word8 -> Word32
foreign import ccall unsafe "_load_movemask" cLoadMovemask :: Ptr Word8 -> Word32
foreign import ccall unsafe "ffs" cFfs :: Word32 -> CInt
foreign import ccall unsafe "_elm_add_movemask" cElmAddMovemask :: Word8 -> Ptr Word8 -> Word32

newtype Table s k v = T (STRef s (Table_ s k v))
  deriving ((forall x. Table s k v -> Rep (Table s k v) x)
-> (forall x. Rep (Table s k v) x -> Table s k v)
-> Generic (Table s k v)
forall x. Rep (Table s k v) x -> Table s k v
forall x. Table s k v -> Rep (Table s k v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s k v x. Rep (Table s k v) x -> Table s k v
forall s k v x. Table s k v -> Rep (Table s k v) x
$cto :: forall s k v x. Rep (Table s k v) x -> Table s k v
$cfrom :: forall s k v x. Table s k v -> Rep (Table s k v) x
Generic)

-- todo: distibute STRef
data Table_ s k v = Table
 { Table_ s k v -> MutableArray s (k, v)
elems ::  {-# UNPACK #-} !(MutableArray s (k, v))
 , Table_ s k v -> MutablePrimArray s Word8
ctrl  ::  {-# UNPACK #-} !(MutablePrimArray s Word8)
 , Table_ s k v -> Int
size  ::  {-# UNPACK #-} !Int
 , Table_ s k v -> Int
mask  ::  {-# UNPACK #-} !Int
 , Table_ s k v -> STRef s Int
used  ::  {-# UNPACK #-} !(STRef s Int)
 } deriving ((forall x. Table_ s k v -> Rep (Table_ s k v) x)
-> (forall x. Rep (Table_ s k v) x -> Table_ s k v)
-> Generic (Table_ s k v)
forall x. Rep (Table_ s k v) x -> Table_ s k v
forall x. Table_ s k v -> Rep (Table_ s k v) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s k v x. Rep (Table_ s k v) x -> Table_ s k v
forall s k v x. Table_ s k v -> Rep (Table_ s k v) x
$cto :: forall s k v x. Rep (Table_ s k v) x -> Table_ s k v
$cfrom :: forall s k v x. Table_ s k v -> Rep (Table_ s k v) x
Generic)

new :: ST s (Table s k v)
new :: ST s (Table s k v)
new = Int -> ST s (Table s k v)
forall s k v. Int -> ST s (Table s k v)
newSized Int
16

empty :: Word8
empty :: Word8
empty = Word8
128

deleted :: Word8
deleted :: Word8
deleted = Word8
254

newSized :: Int -> ST s (Table s k v)
newSized :: Int -> ST s (Table s k v)
newSized Int
n = do
  Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
n Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ [Char] -> ST s ()
forall a. HasCallStack => [Char] -> a
error [Char]
"size should be power of 2"
  MutableArray s (k, v)
es <- Int -> (k, v) -> ST s (MutableArray (PrimState (ST s)) (k, v))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (MutableArray (PrimState m) a)
A.newArray Int
n ([Char] -> (k, v)
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible")
  MutablePrimArray s Word8
c <- Int -> ST s (MutablePrimArray (PrimState (ST s)) Word8)
forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPinnedPrimArray (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32)
  MutablePrimArray (PrimState (ST s)) Word8
-> Int -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m ()
setPrimArray MutablePrimArray s Word8
MutablePrimArray (PrimState (ST s)) Word8
c Int
0 Int
n Word8
empty
  MutablePrimArray (PrimState (ST s)) Word8
-> Int -> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> Int -> a -> m ()
setPrimArray MutablePrimArray s Word8
MutablePrimArray (PrimState (ST s)) Word8
c Int
n Int
32 Word8
deleted
  STRef s Int
u <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
0
  let t :: Table_ s k v
t = MutableArray s (k, v)
-> MutablePrimArray s Word8
-> Int
-> Int
-> STRef s Int
-> Table_ s k v
forall s k v.
MutableArray s (k, v)
-> MutablePrimArray s Word8
-> Int
-> Int
-> STRef s Int
-> Table_ s k v
Table MutableArray s (k, v)
es MutablePrimArray s Word8
c (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) STRef s Int
u
  Table_ s k v -> ST s (Table s k v)
forall s k v. Table_ s k v -> ST s (Table s k v)
newRef Table_ s k v
t

newRef :: Table_ s k v -> ST s (Table s k v)
newRef :: Table_ s k v -> ST s (Table s k v)
newRef = (STRef s (Table_ s k v) -> Table s k v)
-> ST s (STRef s (Table_ s k v)) -> ST s (Table s k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap STRef s (Table_ s k v) -> Table s k v
forall s k v. STRef s (Table_ s k v) -> Table s k v
T (ST s (STRef s (Table_ s k v)) -> ST s (Table s k v))
-> (Table_ s k v -> ST s (STRef s (Table_ s k v)))
-> Table_ s k v
-> ST s (Table s k v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table_ s k v -> ST s (STRef s (Table_ s k v))
forall a s. a -> ST s (STRef s a)
newSTRef
{-# INLINE newRef #-}

readRef :: Table s k v -> ST s (Table_ s k v)
readRef :: Table s k v -> ST s (Table_ s k v)
readRef (T STRef s (Table_ s k v)
ref) = STRef s (Table_ s k v) -> ST s (Table_ s k v)
forall s a. STRef s a -> ST s a
readSTRef STRef s (Table_ s k v)
ref
{-# INLINE readRef #-}

writeRef :: Table s k v -> Table_ s k v -> ST s ()
writeRef :: Table s k v -> Table_ s k v -> ST s ()
writeRef (T STRef s (Table_ s k v)
ref) = STRef s (Table_ s k v) -> Table_ s k v -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Table_ s k v)
ref
{-# INLINE writeRef #-}

insert' :: (Hashable k, Eq k) => (k -> Int) -> Table s k v -> k -> v -> ST s ()
insert' :: (k -> Int) -> Table s k v -> k -> v -> ST s ()
insert' k -> Int
h Table s k v
m k
k v
v = do
  (k -> Int)
-> Table s k v -> k -> (Maybe v -> ST s (Maybe v, ())) -> ST s ()
forall k s v a.
(Eq k, Hashable k) =>
(k -> Int)
-> Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST' k -> Int
h Table s k v
m k
k (ST s (Maybe v, ()) -> Maybe v -> ST s (Maybe v, ())
forall a b. a -> b -> a
const (ST s (Maybe v, ()) -> Maybe v -> ST s (Maybe v, ()))
-> ST s (Maybe v, ()) -> Maybe v -> ST s (Maybe v, ())
forall a b. (a -> b) -> a -> b
$ (Maybe v, ()) -> ST s (Maybe v, ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (v -> Maybe v
forall a. a -> Maybe a
Just v
v, ()))
{-# INLINE insert' #-}

rawInsert :: (Hashable k, Eq k) => Int -> Table s k v -> k -> v -> ST s ()
rawInsert :: Int -> Table s k v -> k -> v -> ST s ()
rawInsert !Int
h1' Table s k v
ref !k
k !v
v = do
  m :: Table_ s k v
m@Table{Int
STRef s Int
MutablePrimArray s Word8
MutableArray s (k, v)
used :: STRef s Int
mask :: Int
size :: Int
ctrl :: MutablePrimArray s Word8
elems :: MutableArray s (k, v)
used :: forall s k v. Table_ s k v -> STRef s Int
mask :: forall s k v. Table_ s k v -> Int
size :: forall s k v. Table_ s k v -> Int
ctrl :: forall s k v. Table_ s k v -> MutablePrimArray s Word8
elems :: forall s k v. Table_ s k v -> MutableArray s (k, v)
..} <- Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
ref
  (Int -> ST s (Maybe ())) -> Int -> Int -> ST s ()
forall (m :: * -> *) b.
Monad m =>
(Int -> m (Maybe b)) -> Int -> Int -> m b
iterateCtrlIdx (Ptr Word8
-> Int
-> MutableArray (PrimState (ST s)) (k, v)
-> MutablePrimArray (PrimState (ST s)) Word8
-> Int
-> ST s (Maybe ())
forall (m :: * -> *).
PrimMonad m =>
Ptr Word8
-> Int
-> MutableArray (PrimState m) (k, v)
-> MutablePrimArray (PrimState m) Word8
-> Int
-> m (Maybe ())
f (MutablePrimArray s Word8 -> Ptr Word8
forall s a. MutablePrimArray s a -> Ptr a
mutablePrimArrayContents MutablePrimArray s Word8
ctrl) Int
size MutableArray s (k, v)
MutableArray (PrimState (ST s)) (k, v)
elems MutablePrimArray s Word8
MutablePrimArray (PrimState (ST s)) Word8
ctrl) Int
size (Int
mask Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
h1')
  STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef' STRef s Int
used (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  Table_ s k v -> ST s Bool
forall k s v. Hashable k => Table_ s k v -> ST s Bool
checkOverflow Table_ s k v
m ST s Bool -> (Bool -> ST s ()) -> ST s ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
x -> Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
x (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ Table s k v -> ST s ()
forall k s v. (Hashable k, Eq k) => Table s k v -> ST s ()
grow Table s k v
ref
  () -> ST s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    f :: Ptr Word8
-> Int
-> MutableArray (PrimState m) (k, v)
-> MutablePrimArray (PrimState m) Word8
-> Int
-> m (Maybe ())
f !Ptr Word8
ptr !Int
size !MutableArray (PrimState m) (k, v)
elems !MutablePrimArray (PrimState m) Word8
ctrl !Int
idx = do
      let !pc :: Ptr Word8
pc = Ptr Word8 -> Int -> Ptr Word8
forall a. Prim a => Ptr a -> Int -> Ptr a
PP.advancePtr Ptr Word8
ptr Int
idx
      let !mask :: Word32
mask = Ptr Word8 -> Word32
cLoadMovemask Ptr Word8
pc
      let !offset :: CInt
offset = Word32 -> CInt
cFfs Word32
mask CInt -> CInt -> CInt
forall a. Num a => a -> a -> a
- CInt
1
      let !idx' :: Int
idx' = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
offset
      if CInt
offset CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
>= CInt
0 Bool -> Bool -> Bool
&& Int
idx' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
size then do
        MutableArray (PrimState m) (k, v) -> Int -> (k, v) -> m ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray MutableArray (PrimState m) (k, v)
elems Int
idx' (k
k, v
v)
        MutablePrimArray (PrimState m) Word8 -> Int -> Word8 -> m ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray (PrimState m) Word8
ctrl Int
idx' (Int -> Word8
h2 Int
h1')
        Maybe () -> m (Maybe ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe () -> m (Maybe ())) -> Maybe () -> m (Maybe ())
forall a b. (a -> b) -> a -> b
$ () -> Maybe ()
forall a. a -> Maybe a
Just ()
        else Maybe () -> m (Maybe ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ()
forall a. Maybe a
Nothing
    {-# INLINE f #-}
{-# INLINE rawInsert #-}

lookup' :: forall k s a. (Hashable k, Eq k) => (k -> Int) -> Table s k a -> k -> ST s (Maybe a)
lookup' :: (k -> Int) -> Table s k a -> k -> ST s (Maybe a)
lookup' k -> Int
h !Table s k a
r !k
k = ((a, Int) -> a) -> Maybe (a, Int) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, Int) -> a
forall a b. (a, b) -> a
fst (Maybe (a, Int) -> Maybe a)
-> ST s (Maybe (a, Int)) -> ST s (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Table s k a -> k -> ST s (Maybe (a, Int))
forall k s a.
(Hashable k, Eq k) =>
Int -> Table s k a -> k -> ST s (Maybe (a, Int))
lookup'' ((k -> Int) -> k -> Int
forall k. Hashable k => (k -> Int) -> k -> Int
h1 k -> Int
h k
k) Table s k a
r k
k
{-# INLINE lookup' #-}

lookup'' :: forall k s a. (Hashable k, Eq k) => Int -> Table s k a -> k -> ST s (Maybe (a, Int))
lookup'' :: Int -> Table s k a -> k -> ST s (Maybe (a, Int))
lookup'' !Int
h1' Table s k a
ref !k
k = do
  Table{Int
STRef s Int
MutablePrimArray s Word8
MutableArray s (k, a)
used :: STRef s Int
mask :: Int
size :: Int
ctrl :: MutablePrimArray s Word8
elems :: MutableArray s (k, a)
used :: forall s k v. Table_ s k v -> STRef s Int
mask :: forall s k v. Table_ s k v -> Int
size :: forall s k v. Table_ s k v -> Int
ctrl :: forall s k v. Table_ s k v -> MutablePrimArray s Word8
elems :: forall s k v. Table_ s k v -> MutableArray s (k, v)
..} <- Table s k a -> ST s (Table_ s k a)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k a
ref
  let !idx :: Int
idx = Int
mask Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
h1'
  (Int -> ST s (Maybe (Maybe (a, Int))))
-> Int -> Int -> ST s (Maybe (a, Int))
forall (m :: * -> *) b.
Monad m =>
(Int -> m (Maybe b)) -> Int -> Int -> m b
iterateCtrlIdx (Ptr Word8
-> MutableArray (PrimState (ST s)) (k, a)
-> Int
-> ST s (Maybe (Maybe (a, Int)))
forall (m :: * -> *) a.
PrimMonad m =>
Ptr Word8
-> MutableArray (PrimState m) (k, a)
-> Int
-> m (Maybe (Maybe (a, Int)))
lookCtrlAt (MutablePrimArray s Word8 -> Ptr Word8
forall s a. MutablePrimArray s a -> Ptr a
mutablePrimArrayContents MutablePrimArray s Word8
ctrl) MutableArray s (k, a)
MutableArray (PrimState (ST s)) (k, a)
elems) Int
size Int
idx
  where
    !h2' :: Word8
h2' = Int -> Word8
h2 Int
h1'
    lookBitmask :: MutableArray (PrimState m) (k, a)
-> Int -> Int -> m (Maybe (a, Int))
lookBitmask MutableArray (PrimState m) (k, a)
es Int
idx Int
bidx = do
      let idx' :: Int
idx' = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bidx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      (!k
k', a
v) <- MutableArray (PrimState m) (k, a) -> Int -> m (k, a)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray (PrimState m) (k, a)
es Int
idx'
      Maybe (a, Int) -> m (Maybe (a, Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Int) -> m (Maybe (a, Int)))
-> Maybe (a, Int) -> m (Maybe (a, Int))
forall a b. (a -> b) -> a -> b
$ if k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k' -- todo: opt(hashも保持？)
             then (a, Int) -> Maybe (a, Int)
forall a. a -> Maybe a
Just (a
v, Int
idx')
             else Maybe (a, Int)
forall a. Maybe a
Nothing
    {-# INLINE lookBitmask #-}
    lookCtrlAt :: Ptr Word8
-> MutableArray (PrimState m) (k, a)
-> Int
-> m (Maybe (Maybe (a, Int)))
lookCtrlAt !Ptr Word8
ptr !MutableArray (PrimState m) (k, a)
es !Int
idx = do
        let pc :: Ptr Word8
pc = Ptr Word8 -> Int -> Ptr Word8
forall a. Prim a => Ptr a -> Int -> Ptr a
PP.advancePtr Ptr Word8
ptr Int
idx
        let !mask :: Word32
mask = Word8 -> Ptr Word8 -> Word32
cElmCmpVec Word8
h2' Ptr Word8
pc
        Maybe (a, Int)
x <- (Int -> m (Maybe (a, Int))) -> Word32 -> m (Maybe (a, Int))
forall (m :: * -> *) a.
Monad m =>
(Int -> m (Maybe a)) -> Word32 -> m (Maybe a)
iterateBitmaskSet (MutableArray (PrimState m) (k, a)
-> Int -> Int -> m (Maybe (a, Int))
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) (k, a)
-> Int -> Int -> m (Maybe (a, Int))
lookBitmask MutableArray (PrimState m) (k, a)
es Int
idx) Word32
mask
        case Maybe (a, Int)
x of
          Maybe (a, Int)
Nothing
            | Word8 -> Ptr Word8 -> Word32
cElmCmpVec Word8
128 Ptr Word8
pc Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 -> Maybe (Maybe (a, Int)) -> m (Maybe (Maybe (a, Int)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Int) -> Maybe (Maybe (a, Int))
forall a. a -> Maybe a
Just Maybe (a, Int)
forall a. Maybe a
Nothing) -- found empty -- unlikely
            | Bool
otherwise -> Maybe (Maybe (a, Int)) -> m (Maybe (Maybe (a, Int)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe (a, Int))
forall a. Maybe a
Nothing
          Maybe (a, Int)
_       -> Maybe (Maybe (a, Int)) -> m (Maybe (Maybe (a, Int)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (a, Int) -> Maybe (Maybe (a, Int))
forall a. a -> Maybe a
Just Maybe (a, Int)
x)
    {-# INLINE lookCtrlAt #-}
{-# INLINE lookup'' #-}

iterateCtrlIdx :: Monad m => (Int -> m (Maybe b)) -> Int -> Int -> m b
iterateCtrlIdx :: (Int -> m (Maybe b)) -> Int -> Int -> m b
iterateCtrlIdx Int -> m (Maybe b)
f !Int
s !Int
offset = Int -> m b
go Int
offset
  where
    go :: Int -> m b
go !Int
idx = do
      Int -> m (Maybe b)
f Int
idx m (Maybe b) -> (Maybe b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe b
Nothing ->
          let !next :: Int
next = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32
          in if Int
next Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
s then Int -> m b
go Int
0 else Int -> m b
go Int
next
        Just b
x -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
{-# INLINE iterateCtrlIdx #-}

listBitmaskSet :: Word32 -> [CInt]
listBitmaskSet :: Word32 -> [CInt]
listBitmaskSet = (Word32 -> CInt) -> [Word32] -> [CInt]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> CInt
cFfs ([Word32] -> [CInt]) -> (Word32 -> [Word32]) -> Word32 -> [CInt]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> Word32) -> Word32 -> [Word32]
forall a. (a -> a) -> a -> [a]
iterate (\Word32
x -> Word32
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. (Word32
x Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
1))
{-# INLINE listBitmaskSet #-}

iterateBitmaskSet :: Monad m => (Int -> m (Maybe a)) -> Word32 -> m (Maybe a)
iterateBitmaskSet :: (Int -> m (Maybe a)) -> Word32 -> m (Maybe a)
iterateBitmaskSet  Int -> m (Maybe a)
f !Word32
mask = do
  let bitidxs :: [CInt]
bitidxs = Word32 -> [CInt]
listBitmaskSet Word32
mask
  [CInt] -> m (Maybe a)
forall a. Integral a => [a] -> m (Maybe a)
go [CInt]
bitidxs
  where
    go :: [a] -> m (Maybe a)
go (a
bidx:[a]
bidxs)
      | a
bidx a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 = do
          Int -> m (Maybe a)
f (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
bidx) m (Maybe a) -> (Maybe a -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe a
Nothing -> [a] -> m (Maybe a)
go [a]
bidxs
            Maybe a
x       -> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
x
      | Bool
otherwise = Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    go [a]
_ = Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    {-# INLINE go #-}
{-# INLINE iterateBitmaskSet #-}

h1 :: Hashable k => (k -> Int) -> k -> Int
h1 :: (k -> Int) -> k -> Int
h1 = (k -> Int) -> k -> Int
forall a b. (a -> b) -> a -> b
($)
{-# INLINE h1 #-}

h2 :: Int -> Word8
h2 :: Int -> Word8
h2 Int
x = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Int
x Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
127
{-# INLINE h2 #-}

-- delete :: (PrimMonad m, Hashable k, Eq k) => k -> Table (PrimState m) k v -> m ()
delete :: (Hashable k, Eq k) => Table s k v -> k -> ST s ()
delete :: Table s k v -> k -> ST s ()
delete = (k -> Int) -> Table s k v -> k -> ST s ()
forall k s v.
(Hashable k, Eq k) =>
(k -> Int) -> Table s k v -> k -> ST s ()
delete' k -> Int
forall a. Hashable a => a -> Int
hash

-- delete' :: (PrimMonad m, Hashable k, Eq k) => (k -> Int) -> k -> Table (PrimState m) k v -> m ()
delete' :: (Hashable k, Eq k) => (k -> Int) -> Table s k v -> k -> ST s ()
delete' :: (k -> Int) -> Table s k v -> k -> ST s ()
delete' k -> Int
hash' Table s k v
ref k
k = do
  Table_ s k v
m <- Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
ref
  let s :: Int
s = Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ s k v
m
  let h1' :: Int
h1' = (k -> Int) -> k -> Int
forall k. Hashable k => (k -> Int) -> k -> Int
h1 k -> Int
hash' k
k
      h2' :: Word8
h2' = Int -> Word8
h2 Int
h1'
  let idx :: Int
idx = (Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
h1'
  let es :: MutableArray s (k, v)
es = Table_ s k v -> MutableArray s (k, v)
forall s k v. Table_ s k v -> MutableArray s (k, v)
elems Table_ s k v
m
  let ct :: MutablePrimArray s Word8
ct = Table_ s k v -> MutablePrimArray s Word8
forall s k v. Table_ s k v -> MutablePrimArray s Word8
ctrl Table_ s k v
m
  let f'' :: Int -> ST s (Maybe (Maybe Int))
f'' Int
offset = do
        let pc :: Ptr Word8
pc = Ptr Word8 -> Int -> Ptr Word8
forall a. Prim a => Ptr a -> Int -> Ptr a
PP.advancePtr (MutablePrimArray s Word8 -> Ptr Word8
forall s a. MutablePrimArray s a -> Ptr a
mutablePrimArrayContents MutablePrimArray s Word8
ct) Int
offset
        let mask :: Word32
mask = Word8 -> Ptr Word8 -> Word32
cElmCmpVec Word8
h2' Ptr Word8
pc
        (Int -> ST s (Maybe Int)) -> Word32 -> ST s (Maybe Int)
forall (m :: * -> *) a.
Monad m =>
(Int -> m (Maybe a)) -> Word32 -> m (Maybe a)
iterateBitmaskSet (MutableArray (PrimState (ST s)) (k, v)
-> Int -> Int -> ST s (Maybe Int)
forall (m :: * -> *) b.
PrimMonad m =>
MutableArray (PrimState m) (k, b) -> Int -> Int -> m (Maybe Int)
readBM MutableArray s (k, v)
MutableArray (PrimState (ST s)) (k, v)
es Int
offset) Word32
mask ST s (Maybe Int)
-> (Maybe Int -> ST s (Maybe (Maybe Int)))
-> ST s (Maybe (Maybe Int))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe Int
Nothing
            | Word8 -> Ptr Word8 -> Word32
cElmCmpVec Word8
128 Ptr Word8
pc Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 -> Maybe (Maybe Int) -> ST s (Maybe (Maybe Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> Maybe (Maybe Int)
forall a. a -> Maybe a
Just Maybe Int
forall a. Maybe a
Nothing)
            | Bool
otherwise -> Maybe (Maybe Int) -> ST s (Maybe (Maybe Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe Int)
forall a. Maybe a
Nothing
          Maybe Int
x       -> Maybe (Maybe Int) -> ST s (Maybe (Maybe Int))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> Maybe (Maybe Int)
forall a. a -> Maybe a
Just Maybe Int
x)
  Maybe Int
idx' <- (Int -> ST s (Maybe (Maybe Int))) -> Int -> Int -> ST s (Maybe Int)
forall (m :: * -> *) b.
Monad m =>
(Int -> m (Maybe b)) -> Int -> Int -> m b
iterateCtrlIdx Int -> ST s (Maybe (Maybe Int))
f'' Int
s Int
idx
  Maybe Int -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
idx' ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ Table_ s k v -> Int -> ST s ()
forall s k v. Table_ s k v -> Int -> ST s ()
deleteIdx Table_ s k v
m
  where
    readBM :: MutableArray (PrimState m) (k, b) -> Int -> Int -> m (Maybe Int)
readBM MutableArray (PrimState m) (k, b)
es Int
offset Int
bidx = do
      let idx' :: Int
idx' = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bidx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      (k
k', b
_) <- MutableArray (PrimState m) (k, b) -> Int -> m (k, b)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray (PrimState m) (k, b)
es Int
idx'
      Maybe Int -> m (Maybe Int)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Int -> m (Maybe Int)) -> Maybe Int -> m (Maybe Int)
forall a b. (a -> b) -> a -> b
$ if k
k k -> k -> Bool
forall a. Eq a => a -> a -> Bool
== k
k'
             then Int -> Maybe Int
forall a. a -> Maybe a
Just Int
idx'
             else Maybe Int
forall a. Maybe a
Nothing

deleteIdx :: Table_ s k v
          -> Int
          -> ST s ()
deleteIdx :: Table_ s k v -> Int -> ST s ()
deleteIdx Table_ s k v
m Int
idx = do
  MutablePrimArray (PrimState (ST s)) Word8
-> Int -> Word8 -> ST s ()
forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray (Table_ s k v -> MutablePrimArray s Word8
forall s k v. Table_ s k v -> MutablePrimArray s Word8
ctrl Table_ s k v
m) Int
idx Word8
254
  STRef s Int -> (Int -> Int) -> ST s ()
forall s a. STRef s a -> (a -> a) -> ST s ()
modifySTRef (Table_ s k v -> STRef s Int
forall s k v. Table_ s k v -> STRef s Int
used Table_ s k v
m) (\Int
x -> Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- insert :: (PrimMonad m, Hashable k) => k -> v -> Table (PrimState m) k v -> m ()
insert :: (Hashable k, Eq k) => Table s k v -> k -> v -> ST s ()
insert :: Table s k v -> k -> v -> ST s ()
insert = (k -> Int) -> Table s k v -> k -> v -> ST s ()
forall k s v.
(Hashable k, Eq k) =>
(k -> Int) -> Table s k v -> k -> v -> ST s ()
insert' k -> Int
forall a. Hashable a => a -> Int
hash

-- lookup :: (PrimMonad m, Hashable k, Show k, Eq k)
--   => k -> Table (PrimState m) k v -> m (Maybe v)
lookup :: (Hashable k, Eq k) => Table s k a -> k -> ST s (Maybe a)
lookup :: Table s k a -> k -> ST s (Maybe a)
lookup = (k -> Int) -> Table s k a -> k -> ST s (Maybe a)
forall k s a.
(Hashable k, Eq k) =>
(k -> Int) -> Table s k a -> k -> ST s (Maybe a)
lookup' k -> Int
forall a. Hashable a => a -> Int
hash
{-# INLINE lookup #-}

checkOverflow ::
  (Hashable k) => Table_ s k v -> ST s Bool
checkOverflow :: Table_ s k v -> ST s Bool
checkOverflow Table_ s k v
t = do
  Int
u <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef (Table_ s k v -> STRef s Int
forall s k v. Table_ s k v -> STRef s Int
used Table_ s k v
t)
  Bool -> ST s Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ s k v
t) Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
maxLoad
{-# INLINE checkOverflow #-}

maxLoad :: Double
maxLoad :: Double
maxLoad = Double
0.8

grow :: (Hashable k, Eq k) => Table s k v -> ST s ()
grow :: Table s k v -> ST s ()
grow Table s k v
ref = do
  Table_ s k v
t <- Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
ref
  let size' :: Int
size' = Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ s k v
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
  Table s k v
t' <- Int -> ST s (Table s k v)
forall s k v. Int -> ST s (Table s k v)
newSized Int
size'
  ((k, v) -> ST s ()) -> Table s k v -> ST s ()
forall k v s a. ((k, v) -> ST s a) -> Table s k v -> ST s ()
mapM_ (Table s k v -> (k, v) -> ST s ()
forall k s v.
(Hashable k, Eq k) =>
Table s k v -> (k, v) -> ST s ()
f Table s k v
t') Table s k v
ref
  Table s k v -> Table_ s k v -> ST s ()
forall s k v. Table s k v -> Table_ s k v -> ST s ()
writeRef Table s k v
ref (Table_ s k v -> ST s ()) -> ST s (Table_ s k v) -> ST s ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
t'
  () -> ST s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    f :: Table s k v -> (k, v) -> ST s ()
f Table s k v
t (!k
k, !v
v) = Int -> Table s k v -> k -> v -> ST s ()
forall k s v.
(Hashable k, Eq k) =>
Int -> Table s k v -> k -> v -> ST s ()
rawInsert (k -> Int
forall a. Hashable a => a -> Int
hash k
k) Table s k v
t k
k v
v

mapM_ :: ((k, v) -> ST s a) -> Table s k v -> ST s ()
mapM_ :: ((k, v) -> ST s a) -> Table s k v -> ST s ()
mapM_ (k, v) -> ST s a
f Table s k v
ref = do
  Table_ s k v
t <- Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
ref
  let idx :: Int
idx = Int
0
  ST s (Maybe Any) -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s (Maybe Any) -> ST s ()) -> ST s (Maybe Any) -> ST s ()
forall a b. (a -> b) -> a -> b
$ (Int -> ST s (Maybe (Maybe Any))) -> Int -> Int -> ST s (Maybe Any)
forall (m :: * -> *) b.
Monad m =>
(Int -> m (Maybe b)) -> Int -> Int -> m b
iterateCtrlIdx (Ptr Word8 -> Table_ s k v -> Int -> ST s (Maybe (Maybe Any))
forall a.
Ptr Word8 -> Table_ s k v -> Int -> ST s (Maybe (Maybe a))
h (MutablePrimArray s Word8 -> Ptr Word8
forall s a. MutablePrimArray s a -> Ptr a
mutablePrimArrayContents (Table_ s k v -> MutablePrimArray s Word8
forall s k v. Table_ s k v -> MutablePrimArray s Word8
ctrl Table_ s k v
t)) Table_ s k v
t) (Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ s k v
t) Int
idx
  where
    g :: MutableArray s (k, v) -> Int -> Int -> ST s (Maybe a)
g MutableArray s (k, v)
elms !Int
idx !Int
bidx = do
      let idx' :: Int
idx' = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bidx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      !(k, v)
e <- MutableArray (PrimState (ST s)) (k, v) -> Int -> ST s (k, v)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray MutableArray s (k, v)
MutableArray (PrimState (ST s)) (k, v)
elms Int
idx'
      ST s a -> ST s ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ST s a -> ST s ()) -> ST s a -> ST s ()
forall a b. (a -> b) -> a -> b
$ (k, v) -> ST s a
f (k, v)
e
      Maybe a -> ST s (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    h :: Ptr Word8 -> Table_ s k v -> Int -> ST s (Maybe (Maybe a))
h Ptr Word8
ptr Table_ s k v
t !Int
idx = do
      let pc :: Ptr Word8
pc = Ptr Word8 -> Int -> Ptr Word8
forall a. Prim a => Ptr a -> Int -> Ptr a
PP.advancePtr Ptr Word8
ptr Int
idx
      let mask :: Word32
mask = Word8 -> Ptr Word8 -> Word32
cElmAddMovemask Word8
128 Ptr Word8
pc
      Maybe (Maybe a)
r <- (Int -> ST s (Maybe (Maybe a))) -> Word32 -> ST s (Maybe (Maybe a))
forall (m :: * -> *) a.
Monad m =>
(Int -> m (Maybe a)) -> Word32 -> m (Maybe a)
iterateBitmaskSet (MutableArray s (k, v) -> Int -> Int -> ST s (Maybe (Maybe a))
forall a. MutableArray s (k, v) -> Int -> Int -> ST s (Maybe a)
g (Table_ s k v -> MutableArray s (k, v)
forall s k v. Table_ s k v -> MutableArray s (k, v)
elems Table_ s k v
t) Int
idx) Word32
mask
      if Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ s k v
t then Maybe (Maybe a) -> ST s (Maybe (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing) else Maybe (Maybe a) -> ST s (Maybe (Maybe a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Maybe a)
r

foldM :: (a -> (k,v) -> ST s a) -> a -> Table s k v -> ST s a
foldM :: (a -> (k, v) -> ST s a) -> a -> Table s k v -> ST s a
foldM a -> (k, v) -> ST s a
f a
seed0 Table s k v
ref = do
  Table_ s k v
t <- Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
ref
  (a -> Table_ s k v -> Int -> [Int] -> ST s a)
-> a -> Table_ s k v -> Int -> ST s a
forall a s k v.
(a -> Table_ s k v -> Int -> [Int] -> ST s a)
-> a -> Table_ s k v -> Int -> ST s a
foldCtrlM a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
seed0 Table_ s k v
t Int
0
  where
    g :: a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
acc Table_ s k v
t Int
idx (Int
bidx:[Int]
xs)
      | Int
bidx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc
      | Bool
otherwise = do
          let idx' :: Int
idx' = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bidx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          (k, v)
e <- MutableArray (PrimState (ST s)) (k, v) -> Int -> ST s (k, v)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray (Table_ s k v -> MutableArray s (k, v)
forall s k v. Table_ s k v -> MutableArray s (k, v)
elems Table_ s k v
t) Int
idx'
          a
acc' <- a -> (k, v) -> ST s a
f a
acc (k, v)
e
          a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
acc' Table_ s k v
t Int
idx [Int]
xs
    g a
_ Table_ s k v
_ Int
_ [Int]
_ = [Char] -> ST s a
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"

foldCtrlM :: (a -> Table_ s k v -> Int -> [Int] -> ST s a) -> a -> Table_ s k v -> Int -> ST s a
foldCtrlM :: (a -> Table_ s k v -> Int -> [Int] -> ST s a)
-> a -> Table_ s k v -> Int -> ST s a
foldCtrlM a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
acc Table_ s k v
t Int
idx = do
  let pc :: Ptr Word8
pc = Ptr Word8 -> Int -> Ptr Word8
forall a. Prim a => Ptr a -> Int -> Ptr a
PP.advancePtr (MutablePrimArray s Word8 -> Ptr Word8
forall s a. MutablePrimArray s a -> Ptr a
mutablePrimArrayContents (Table_ s k v -> MutablePrimArray s Word8
forall s k v. Table_ s k v -> MutablePrimArray s Word8
ctrl Table_ s k v
t)) Int
idx
  let mask :: Word32
mask = Word8 -> Ptr Word8 -> Word32
cElmAddMovemask Word8
128 Ptr Word8
pc
  a
acc' <- a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
acc Table_ s k v
t Int
idx ((CInt -> Int) -> [CInt] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([CInt] -> [Int]) -> [CInt] -> [Int]
forall a b. (a -> b) -> a -> b
$ Word32 -> [CInt]
listBitmaskSet Word32
mask)
  if Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ s k v
t then a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc' else (a -> Table_ s k v -> Int -> [Int] -> ST s a)
-> a -> Table_ s k v -> Int -> ST s a
forall a s k v.
(a -> Table_ s k v -> Int -> [Int] -> ST s a)
-> a -> Table_ s k v -> Int -> ST s a
foldCtrlM a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
acc' Table_ s k v
t (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
32)

_foldM :: (a -> (k,v) -> Int -> ST s a) -> a -> Table s k v -> ST s a
_foldM :: (a -> (k, v) -> Int -> ST s a) -> a -> Table s k v -> ST s a
_foldM a -> (k, v) -> Int -> ST s a
f a
seed0 Table s k v
ref = do
  Table_ s k v
t <- Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
ref
  (a -> Table_ s k v -> Int -> [Int] -> ST s a)
-> a -> Table_ s k v -> Int -> ST s a
forall a s k v.
(a -> Table_ s k v -> Int -> [Int] -> ST s a)
-> a -> Table_ s k v -> Int -> ST s a
foldCtrlM a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
seed0 Table_ s k v
t Int
0
  where
    g :: a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
acc Table_ s k v
t Int
idx (Int
bidx:[Int]
xs)
      | Int
bidx Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
acc
      | Bool
otherwise = do
          let idx' :: Int
idx' = Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
bidx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          (k, v)
e <- MutableArray (PrimState (ST s)) (k, v) -> Int -> ST s (k, v)
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> m a
readArray (Table_ s k v -> MutableArray s (k, v)
forall s k v. Table_ s k v -> MutableArray s (k, v)
elems Table_ s k v
t) Int
idx'
          a
acc' <- a -> (k, v) -> Int -> ST s a
f a
acc (k, v)
e Int
idx'
          a -> Table_ s k v -> Int -> [Int] -> ST s a
g a
acc' Table_ s k v
t Int
idx [Int]
xs
    g a
_ Table_ s k v
_ Int
_ [Int]
_ = [Char] -> ST s a
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible"

analyze :: (Hashable k, Show k) => (Table RealWorld k v -> ST RealWorld ())
analyze :: Table RealWorld k v -> ST RealWorld ()
analyze Table RealWorld k v
ref = do
  Table_ RealWorld k v
t <- Table RealWorld k v -> ST RealWorld (Table_ RealWorld k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table RealWorld k v
ref
  [((k, Int, Int), Int)]
cs <- ([((k, Int, Int), Int)]
 -> (k, v) -> Int -> ST RealWorld [((k, Int, Int), Int)])
-> [((k, Int, Int), Int)]
-> Table RealWorld k v
-> ST RealWorld [((k, Int, Int), Int)]
forall a k v s.
(a -> (k, v) -> Int -> ST s a) -> a -> Table s k v -> ST s a
_foldM (Table_ RealWorld k v
-> [((k, Int, Int), Int)]
-> (k, v)
-> Int
-> ST RealWorld [((k, Int, Int), Int)]
forall (f :: * -> *) a s k v b.
(Applicative f, Hashable a) =>
Table_ s k v
-> [((a, Int, Int), Int)]
-> (a, b)
-> Int
-> f [((a, Int, Int), Int)]
f Table_ RealWorld k v
t) [] Table RealWorld k v
ref
  Int
u <- STRef RealWorld Int -> ST RealWorld Int
forall s a. STRef s a -> ST s a
readSTRef (Table_ RealWorld k v -> STRef RealWorld Int
forall s k v. Table_ s k v -> STRef s Int
used Table_ RealWorld k v
t)
  IO () -> ST RealWorld ()
forall a. IO a -> ST RealWorld a
ioToST (IO () -> ST RealWorld ()) -> IO () -> ST RealWorld ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"size: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show (Table_ RealWorld k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ RealWorld k v
t)
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"used: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
u
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Double -> [Char]
forall a. Show a => a -> [Char]
show (Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
u Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Table_ RealWorld k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ RealWorld k v
t) :: Double)
    [Char] -> IO ()
forall a. Show a => a -> IO ()
print ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"max diff: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ((((k, Int, Int), Int) -> Int) -> [((k, Int, Int), Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((k, Int, Int), Int) -> Int
forall a b. (a, b) -> b
snd [((k, Int, Int), Int)]
cs))
    [Char] -> IO ()
forall a. Show a => a -> IO ()
print ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"sum diff: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((((k, Int, Int), Int) -> Int) -> [((k, Int, Int), Int)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((k, Int, Int), Int) -> Int
forall a b. (a, b) -> b
snd [((k, Int, Int), Int)]
cs))
    (((k, Int, Int), Int) -> IO ()) -> [((k, Int, Int), Int)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
M.mapM_ ((k, Int, Int), Int) -> IO ()
forall a. Show a => a -> IO ()
print [((k, Int, Int), Int)]
cs
  where
    f :: Table_ s k v
-> [((a, Int, Int), Int)]
-> (a, b)
-> Int
-> f [((a, Int, Int), Int)]
f Table_ s k v
t [((a, Int, Int), Int)]
acc (a
k, b
_) Int
idx = do
      let nidx :: Int
nidx = (Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ s k v
t Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. a -> Int
forall a. Hashable a => a -> Int
hash a
k
      let d :: Int
d = if Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nidx Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nidx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size Table_ s k v
t else Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
nidx
      [((a, Int, Int), Int)] -> f [((a, Int, Int), Int)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([((a, Int, Int), Int)] -> f [((a, Int, Int), Int)])
-> [((a, Int, Int), Int)] -> f [((a, Int, Int), Int)]
forall a b. (a -> b) -> a -> b
$ ((a
k, Int
nidx, Int
idx), Int
d)((a, Int, Int), Int)
-> [((a, Int, Int), Int)] -> [((a, Int, Int), Int)]
forall a. a -> [a] -> [a]
:[((a, Int, Int), Int)]
acc

mutateST' :: (Eq k, Hashable k)
         => (k -> Int) -> Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST' :: (k -> Int)
-> Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST' k -> Int
h Table s k v
ref k
k Maybe v -> ST s (Maybe v, a)
f = do
  let !h1' :: Int
h1' = (k -> Int) -> k -> Int
forall k. Hashable k => (k -> Int) -> k -> Int
h1 k -> Int
h k
k
  Int -> Table s k v -> k -> ST s (Maybe (v, Int))
forall k s a.
(Hashable k, Eq k) =>
Int -> Table s k a -> k -> ST s (Maybe (a, Int))
lookup'' Int
h1' Table s k v
ref k
k ST s (Maybe (v, Int)) -> (Maybe (v, Int) -> ST s a) -> ST s a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (v
v, Int
idx) ->
      Maybe v -> ST s (Maybe v, a)
f (v -> Maybe v
forall a. a -> Maybe a
Just v
v) ST s (Maybe v, a) -> ((Maybe v, a) -> ST s a) -> ST s a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Just v
v', a
a) -> do -- update
        Table_ s k v
t <- Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
ref
        MutableArray (PrimState (ST s)) (k, v) -> Int -> (k, v) -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MutableArray (PrimState m) a -> Int -> a -> m ()
writeArray (Table_ s k v -> MutableArray s (k, v)
forall s k v. Table_ s k v -> MutableArray s (k, v)
elems Table_ s k v
t) Int
idx (k
k, v
v') ST s () -> ST s a -> ST s a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      (Maybe v
Nothing, a
a) -> do--delete
        Table_ s k v
t <- Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef Table s k v
ref
        Table_ s k v -> Int -> ST s ()
forall s k v. Table_ s k v -> Int -> ST s ()
deleteIdx Table_ s k v
t Int
idx ST s () -> ST s a -> ST s a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
    Maybe (v, Int)
Nothing ->
      Maybe v -> ST s (Maybe v, a)
f Maybe v
forall a. Maybe a
Nothing ST s (Maybe v, a) -> ((Maybe v, a) -> ST s a) -> ST s a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (Just v
v', a
a) -> -- insert
        Int -> Table s k v -> k -> v -> ST s ()
forall k s v.
(Hashable k, Eq k) =>
Int -> Table s k v -> k -> v -> ST s ()
rawInsert Int
h1' Table s k v
ref k
k v
v' ST s () -> ST s a -> ST s a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      (Maybe v
Nothing, a
a) -> a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
{-# INLINE mutateST' #-}

mutateST :: (Eq k, Hashable k)
         => Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST :: Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST = (k -> Int)
-> Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
forall k s v a.
(Eq k, Hashable k) =>
(k -> Int)
-> Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST' k -> Int
forall a. Hashable a => a -> Int
hash
{-# INLINE mutateST #-}

mutate :: (Eq k, Hashable k) =>
  Table s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
mutate :: Table s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a
mutate Table s k v
ref !k
k !Maybe v -> (Maybe v, a)
f = Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
forall k s v a.
(Eq k, Hashable k) =>
Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a
mutateST Table s k v
ref 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 #-}

{-
試したい
　右端で競合が発生した際に0に戻るのではなく、
　予備領域を使い、予備領域が埋まったら拡張する。
  -> unlikelyすぎて効果うすそう
-- make Data.HashTable.Class instance?
  -> 両方に依存したインターフェス揃えるようlibrary作れば良い
-}

getSize :: Table s k v -> ST s Int
getSize :: Table s k v -> ST s Int
getSize  = (Table_ s k v -> Int) -> ST s (Table_ s k v) -> ST s Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Table_ s k v -> Int
forall s k v. Table_ s k v -> Int
size (ST s (Table_ s k v) -> ST s Int)
-> (Table s k v -> ST s (Table_ s k v)) -> Table s k v -> ST s Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Table s k v -> ST s (Table_ s k v)
forall s k v. Table s k v -> ST s (Table_ s k v)
readRef