packages feed

swisstable (empty) → 0.1.0.1

raw patch · 11 files changed

+813/−0 lines, 11 filesdep +QuickCheckdep +basedep +criterionsetup-changed

Dependencies added: QuickCheck, base, criterion, deepseq, hashable, hashtables, primitive, swisstable, tasty, tasty-discover, tasty-hunit, vector

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for swisstable++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,42 @@+# swisstable++:warning: Currently, This library works on processors that support `AVX2` .++15564c4+```+benchmarking lookup(seq)/small/SwissTable+time                 218.0 μs   (217.3 μs .. 218.6 μs)+                     1.000 R²   (0.999 R² .. 1.000 R²)+mean                 218.5 μs   (218.2 μs .. 218.8 μs)+std dev              1.074 μs   (903.7 ns .. 1.357 μs)++benchmarking lookup(seq)/small/BasicHashTable+time                 277.8 μs   (277.5 μs .. 278.1 μs)+                     1.000 R²   (1.000 R² .. 1.000 R²)+mean                 277.6 μs   (277.0 μs .. 277.9 μs)+std dev              1.479 μs   (906.2 ns .. 2.655 μs)++benchmarking lookup(rand)/small/SwissTable+time                 386.7 μs   (384.2 μs .. 390.1 μs)+                     1.000 R²   (1.000 R² .. 1.000 R²)+mean                 394.0 μs   (392.4 μs .. 395.4 μs)+std dev              5.017 μs   (4.124 μs .. 6.518 μs)++benchmarking lookup(rand)/small/BasicHashTable+time                 484.9 μs   (483.8 μs .. 485.8 μs)+                     1.000 R²   (1.000 R² .. 1.000 R²)+mean                 484.7 μs   (484.2 μs .. 485.2 μs)+std dev              1.557 μs   (1.294 μs .. 1.956 μs)++benchmarking insert(seq)/sized/small/SwissTable+time                 1.271 ms   (1.265 ms .. 1.278 ms)+                     1.000 R²   (1.000 R² .. 1.000 R²)+mean                 1.245 ms   (1.238 ms .. 1.252 ms)+std dev              24.58 μs   (20.19 μs .. 29.61 μs)++benchmarking insert(seq)/sized/small/BasicHashTable+time                 1.315 ms   (1.311 ms .. 1.319 ms)+                     1.000 R²   (1.000 R² .. 1.000 R²)+mean                 1.321 ms   (1.319 ms .. 1.322 ms)+std dev              5.360 μs   (4.111 μs .. 6.704 μs)+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE BangPatterns    #-}+module Main where++import           Control.DeepSeq+import           Control.DeepSeq         (NFData)+import           Control.Monad+import           Criterion+import           Criterion.Main+import qualified Data.HashTable.IO       as H+import           Data.HashTable.IO.Swiss hiding (fildM, mapM_)+import qualified Data.HashTable.ST.Basic+import qualified Data.HashTable.ST.Swiss as S+import           Data.Maybe+import           Prelude                 hiding (lookup)+import           Test.QuickCheck         (Gen, generate, vector)++smallKeys :: [Int]+smallKeys = [1..10000]++initSmall new insert = do+  t <- new+  mapM_ (\x -> insert t x x) smallKeys+  pure $! t+++benchSmall name new insert lookup =+  env (initSmall new insert) $ \t -> bench name $ whnfIO $ do+  mapM_ (lookup t) smallKeys+++genSmallRand = generate (vector 10000 :: Gen [Int])++initSmallRand new insert ks = do+  t <- new+  mapM_ (\x -> insert t x x) ks+  pure (ks, t)++benchSmallRand name new insert lookup ks =+  env (initSmallRand new insert ks) $ \ ~(ks, t) -> bench name $ whnfIO $ do+  mapM_ (lookup t) ks++insertSmallSeq name new insert =+  bench name $ whnfIO $ initSmall new insert++main =+  defaultMain+    [ bgroup+        "lookup(seq)"+        [ bgroup+            "small"+            [ benchSmall "SwissTable" new insert lookup+            , benchSmall "BasicHashTable" (H.new :: IO (H.BasicHashTable Int Int)) H.insert H.lookup+            ]+        ]+    , bgroup+      "lookup(rand)"+      [ env genSmallRand $ \k -> bgroup+      "small"+        [ benchSmallRand "SwissTable" new insert lookup k+        , benchSmallRand "BasicHashTable" (H.new :: IO (H.BasicHashTable Int Int)) H.insert H.lookup k+        ]+      ]+    , bgroup+        "insert(seq)"+        [ bgroup "sized"+          [ bgroup+            "small"+            [ insertSmallSeq "SwissTable" (newSized (2^16)) insert+            , insertSmallSeq "BasicHashTable" (H.newSized (2^16) :: IO (H.BasicHashTable Int Int)) H.insert+            ]+          ]+        ]+    ]++instance NFData (Data.HashTable.ST.Basic.HashTable s k v) where+  rnf x = seq x ()+instance NFData (S.Table s k v)
+ csrc/simd.c view
@@ -0,0 +1,21 @@+#include <stdio.h>+#include <immintrin.h>+#include <x86intrin.h>+#include <strings.h>++int _elm_cmp_vec(char elem, char *src){+  __m256i _list = _mm256_loadu_si256((__m256i*)src);+  __m256i _lookup = _mm256_set1_epi8(elem);+  return _mm256_movemask_epi8(_mm256_cmpeq_epi8(_list, _lookup));+}++int _load_movemask(char *src) {+  return _mm256_movemask_epi8(_mm256_loadu_si256((__m256i*)src));+}+++int _elm_add_movemask(char elem, char *src){+  __m256i _list = _mm256_loadu_si256((__m256i*)src);+  __m256i _lookup = _mm256_set1_epi8(elem);+  return _mm256_movemask_epi8(_mm256_xor_si256(_list, _lookup));+}
+ src/Data/HashTable/IO/Swiss.hs view
@@ -0,0 +1,55 @@+module Data.HashTable.IO.Swiss where++import           Control.Monad.ST+import           Data.HashTable.ST.Swiss              as H+import Data.Hashable (Hashable)++new :: IO (Table RealWorld k v)+new = stToIO H.new+{-# INLINE new #-}++newSized :: (Int -> IO (Table RealWorld k v))+newSized = stToIO . H.newSized+{-# INLINE newSized #-}++insert :: (Hashable k, Eq k) => Table RealWorld k v -> k -> v -> IO ()+insert t k = stToIO . H.insert t k+{-# INLINE insert #-}++insert' :: (Hashable k, Eq k) => (k -> Int) -> Table RealWorld k v -> k -> v -> IO ()+insert' h t k = stToIO . H.insert' h t k+{-# INLINE insert' #-}++lookup :: ((Hashable k, Show k, Eq k) => Table RealWorld k a -> k -> IO (Maybe a))+lookup t = stToIO . H.lookup t+{-# INLINE lookup #-}++lookup' :: ((Hashable k, Show k, Eq k) => (k -> Int)+                  -> Table RealWorld k a -> k -> IO (Maybe a))+lookup' h t = stToIO . H.lookup' h t+{-# INLINE lookup' #-}++delete :: ((Hashable k, Show k, Eq k) => Table RealWorld k v -> k -> IO ())+delete t = stToIO . H.delete t+{-# INLINE delete #-}+++getSize :: Table RealWorld k v -> IO Int+getSize  = stToIO . H.getSize+{-# INLINE getSize #-}++mutateST :: (Eq k, Hashable k)+         => Table RealWorld k v -> k -> (Maybe v -> ST RealWorld (Maybe v, a)) -> IO a+mutateST t k = stToIO . H.mutateST t k+{-# INLINE mutateST #-}++mutate :: (Eq k, Hashable k)+         => Table RealWorld k v -> k -> (Maybe v -> (Maybe v, a)) -> IO a+mutate t k = stToIO . H.mutate t k+{-# INLINE mutate #-}++mapM_ :: ((k, v) -> ST RealWorld a) -> Table RealWorld k v -> IO ()+mapM_ f = stToIO . H.mapM_ f++foldM :: (a -> (k,v) -> ST RealWorld a) -> a -> Table RealWorld k v -> IO a+foldM f i = stToIO . H.foldM f i
+ src/Data/HashTable/ST/Swiss.hs view
@@ -0,0 +1,362 @@+{-# 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 (Generic)++-- todo: distibute STRef+data Table_ s k v = Table+ { elems ::  {-# UNPACK #-} !(MutableArray s (k, v))+ , ctrl  ::  {-# UNPACK #-} !(MutablePrimArray s Word8)+ , size  ::  {-# UNPACK #-} !Int+ , mask  ::  {-# UNPACK #-} !Int+ , used  ::  {-# UNPACK #-} !(STRef s Int)+ } deriving (Generic)++new :: ST s (Table s k v)+new = newSized 16++empty :: Word8+empty = 128++deleted :: Word8+deleted = 254++newSized :: Int -> ST s (Table s k v)+newSized n = do+  when (n .&. (n - 1) /= 0) $ error "size should be power of 2"+  es <- A.newArray n (error "impossible")+  c <- newPinnedPrimArray (n + 32)+  setPrimArray c 0 n empty+  setPrimArray c n 32 deleted+  u <- newSTRef 0+  let t = Table es c (fromIntegral n) (fromIntegral n - 1) u+  newRef t++newRef :: Table_ s k v -> ST s (Table s k v)+newRef = fmap T . newSTRef+{-# INLINE newRef #-}++readRef :: Table s k v -> ST s (Table_ s k v)+readRef (T ref) = readSTRef ref+{-# INLINE readRef #-}++writeRef :: Table s k v -> Table_ s k v -> ST s ()+writeRef (T ref) = writeSTRef ref+{-# INLINE writeRef #-}++insert' :: (Hashable k, Eq k) => (k -> Int) -> Table s k v -> k -> v -> ST s ()+insert' h m k v = do+  mutateST' h m k (const $ pure (Just v, ()))+{-# INLINE insert' #-}++rawInsert :: (Hashable k, Eq k) => Int -> Table s k v -> k -> v -> ST s ()+rawInsert !h1' ref !k !v = do+  m@Table{..} <- readRef ref+  iterateCtrlIdx (f (mutablePrimArrayContents ctrl) size elems ctrl) size (mask .&. h1')+  modifySTRef' used (+ 1)+  checkOverflow m >>= \x -> when x $ grow ref+  where+    f !ptr !size !elems !ctrl !idx = do+      let !pc = PP.advancePtr ptr idx+      let !mask = cLoadMovemask pc+      let !offset = cFfs mask - 1+      let !idx' = idx + fromIntegral offset+      if offset >= 0 && idx' < size then do+        writeArray elems idx' (k, v)+        writePrimArray ctrl idx' (h2 h1')+        pure $ Just ()+        else pure 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' h !r !k = fmap fst <$> lookup'' (h1 h k) r k+{-# INLINE lookup' #-}++lookup'' :: forall k s a. (Hashable k, Eq k) => Int -> Table s k a -> k -> ST s (Maybe (a, Int))+lookup'' !h1' ref !k = do+  Table{..} <- readRef ref+  let !idx = mask .&. h1'+  iterateCtrlIdx (lookCtrlAt (mutablePrimArrayContents ctrl) elems) size idx+  where+    !h2' = h2 h1'+    lookBitmask es idx bidx = do+      let idx' = idx + bidx - 1+      (!k', v) <- readArray es idx'+      pure $ if k == k' -- todo: opt(hashも保持？)+             then Just (v, idx')+             else Nothing+    {-# INLINE lookBitmask #-}+    lookCtrlAt !ptr !es !idx = do+        let pc = PP.advancePtr ptr idx+        let !mask = cElmCmpVec h2' pc+        x <- iterateBitmaskSet (lookBitmask es idx) mask+        case x of+          Nothing+            | cElmCmpVec 128 pc /= 0 -> pure (Just Nothing) -- found empty -- unlikely+            | otherwise -> pure Nothing+          _       -> pure (Just x)+    {-# INLINE lookCtrlAt #-}+{-# INLINE lookup'' #-}++iterateCtrlIdx :: Monad m => (Int -> m (Maybe b)) -> Int -> Int -> m b+iterateCtrlIdx f !s !offset = go offset+  where+    go !idx = do+      f idx >>= \case+        Nothing ->+          let !next = idx + 32+          in if next > s then go 0 else go next+        Just x -> pure x+{-# INLINE iterateCtrlIdx #-}++listBitmaskSet :: Word32 -> [CInt]+listBitmaskSet = map cFfs . iterate (\x -> x .&. (x - 1))+{-# INLINE listBitmaskSet #-}++iterateBitmaskSet :: Monad m => (Int -> m (Maybe a)) -> Word32 -> m (Maybe a)+iterateBitmaskSet  !f !mask = do+  let bitidxs = listBitmaskSet mask+  go bitidxs+  where+    go (bidx:bidxs)+      | bidx /= 0 = do+          f (fromIntegral bidx) >>= \case+            Nothing -> go bidxs+            x       -> pure x+      | otherwise = pure Nothing+    go _ = pure Nothing+    {-# INLINE go #-}+{-# INLINE iterateBitmaskSet #-}++h1 :: Hashable k => (k -> Int) -> k -> Int+h1 = ($)+{-# INLINE h1 #-}++h2 :: Int -> Word8+h2 x = fromIntegral $ x .&. 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 = delete' 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' hash' ref k = do+  m <- readRef ref+  let s = size m+  let h1' = h1 hash' k+      h2' = h2 h1'+  let idx = (s - 1) .&. h1'+  let es = elems m+  let ct = ctrl m+  let f'' offset = do+        let pc = PP.advancePtr (mutablePrimArrayContents ct) offset+        let mask = cElmCmpVec h2' pc+        iterateBitmaskSet (readBM es offset) mask >>= \case+          Nothing+            | cElmCmpVec 128 pc /= 0 -> pure (Just Nothing)+            | otherwise -> pure Nothing+          x       -> pure (Just x)+  idx' <- iterateCtrlIdx f'' s idx+  forM_ idx' $ deleteIdx m+  where+    readBM es offset bidx = do+      let idx' = offset + bidx - 1+      (k', _) <- readArray es idx'+      pure $ if k == k'+             then Just idx'+             else Nothing++deleteIdx :: Table_ s k v+          -> Int+          -> ST s ()+deleteIdx m idx = do+  writePrimArray (ctrl m) idx 254+  modifySTRef (used m) (\x -> x - 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 = insert' 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 = lookup' hash+{-# INLINE lookup #-}++checkOverflow ::+  (Hashable k) => Table_ s k v -> ST s Bool+checkOverflow t = do+  u <- readSTRef (used t)+  pure $ fromIntegral u / fromIntegral (size t) > maxLoad+{-# INLINE checkOverflow #-}++maxLoad :: Double+maxLoad = 0.8++grow :: (Hashable k, Eq k) => Table s k v -> ST s ()+grow ref = do+  t <- readRef ref+  let size' = size t * 2+  t' <- newSized size'+  mapM_ (f t') ref+  writeRef ref =<< readRef t'+  pure ()+  where+    f t (k, v) = insert t k v++mapM_ :: ((k, v) -> ST s a) -> Table s k v -> ST s ()+mapM_ f ref = do+  t <- readRef ref+  let idx = 0+  void $ iterateCtrlIdx (h t) (size t) idx+  where+    g t idx bidx = do+      let idx' = idx + bidx - 1+      e <- readArray (elems t) idx'+      void $ f e+      pure Nothing+    h t idx = do+      let pc = PP.advancePtr (mutablePrimArrayContents (ctrl t)) idx+      let mask = cElmAddMovemask 128 pc+      r <- iterateBitmaskSet (g t idx) mask+      if idx + 32 > size t then pure (Just Nothing) else pure r++foldM :: (a -> (k,v) -> ST s a) -> a -> Table s k v -> ST s a+foldM f seed0 ref = do+  t <- readRef ref+  foldCtrlM g seed0 t 0+  where+    g acc t idx (bidx:xs)+      | bidx == 0 = pure acc+      | otherwise = do+          let idx' = idx + bidx - 1+          e <- readArray (elems t) idx'+          acc' <- f acc e+          g acc' t idx xs+    g _ _ _ _ = error "impossible"++foldCtrlM :: (a -> Table_ s k v -> Int -> [Int] -> ST s a) -> a -> Table_ s k v -> Int -> ST s a+foldCtrlM g acc t idx = do+  let pc = PP.advancePtr (mutablePrimArrayContents (ctrl t)) idx+  let mask = cElmAddMovemask 128 pc+  acc' <- g acc t idx (map fromIntegral $ listBitmaskSet mask)+  if idx + 32 > size t then pure acc' else foldCtrlM g acc' t (idx + 32)++_foldM :: (a -> (k,v) -> Int -> ST s a) -> a -> Table s k v -> ST s a+_foldM f seed0 ref = do+  t <- readRef ref+  foldCtrlM g seed0 t 0+  where+    g acc t idx (bidx:xs)+      | bidx == 0 = pure acc+      | otherwise = do+          let idx' = idx + bidx - 1+          e <- readArray (elems t) idx'+          acc' <- f acc e idx'+          g acc' t idx xs+    g _ _ _ _ = error "impossible"++analyze :: (Hashable k, Show k) => (Table RealWorld k v -> ST RealWorld ())+analyze ref = do+  t <- readRef ref+  cs <- _foldM (f t) [] ref+  u <- readSTRef (used t)+  ioToST $ do+    putStrLn $ "size: " <> show (size t)+    putStrLn $ "used: " <> show u+    putStrLn $ "  " <> show (fromIntegral u / fromIntegral (size t) :: Double)+    print $ "max diff: " <> show (maximum (fmap snd cs))+    print $ "sum diff: " <> show (sum (fmap snd cs))+    M.mapM_ print cs+  where+    f t acc (k, _) idx = do+      let nidx = (size t - 1) .&. hash k+      let d = if idx - nidx < 0 then idx - nidx + size t else idx - nidx+      pure $ ((k, nidx, idx), d):acc++mutateST' :: (Eq k, Hashable k)+         => (k -> Int) -> Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a+mutateST' h ref k f = do+  t <- readRef ref+  let !h1' = h1 h k+  lookup'' h1' ref k >>= \case+    Just (v, idx) ->+      f (Just v) >>= \case+      (Just v', a) -> -- update+        writeArray (elems t) idx (k, v') >> pure a+      (Nothing, a) -> --delete+        deleteIdx t idx >> pure a+    Nothing ->+      f Nothing >>= \case+      (Just v', a) -> -- insert+        rawInsert h1' ref k v' >> pure a+      (Nothing, a) -> pure a+{-# INLINE mutateST' #-}++mutateST :: (Eq k, Hashable k)+         => Table s k v -> k -> (Maybe v -> ST s (Maybe v, a)) -> ST s a+mutateST = mutateST' hash+{-# INLINE mutateST #-}++mutate :: (Eq k, Hashable k) =>+  Table s k v -> k -> (Maybe v -> (Maybe v, a)) -> ST s a+mutate ref !k !f = mutateST ref k (pure . f)+{-# INLINE mutate #-}++{-+試したい+　右端で競合が発生した際に0に戻るのではなく、+　予備領域を使い、予備領域が埋まったら拡張する。+  -> unlikelyすぎて効果うすそう+-- make Data.HashTable.Class instance?+  -> 両方に依存したインターフェス揃えるようlibrary作れば良い+-}++getSize :: Table s k v -> ST s Int+getSize  = fmap size . readRef
+ swisstable.cabal view
@@ -0,0 +1,88 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 2f9c118c109be85a1779a0713e0192b5bb52fcc83774f4555b155cc5e188a863++name:           swisstable+version:        0.1.0.1+synopsis:       Google's SwissTable hash map+description:    Please see the README on GitHub at <https://github.com/nakaji-dayo/hs-swisstable#readme>+category:       Data+homepage:       https://github.com/nakaji-dayo/hs-swisstable#readme+bug-reports:    https://github.com/nakaji-dayo/hs-swisstable/issues+author:         Daishi Nakajima+maintainer:     nakaji.dayo@gmail.com+copyright:      2021 Daishi Nakajima+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md+    csrc/simd.c++source-repository head+  type: git+  location: https://github.com/nakaji-dayo/hs-swisstable++library+  exposed-modules:+      Data.HashTable.IO.Swiss+      Data.HashTable.ST.Swiss+  other-modules:+      Paths_swisstable+  hs-source-dirs:+      src+  ghc-options: -O2 -Wall+  cc-options: -mavx2+  c-sources:+      csrc/simd.c+  build-depends:+      base >=4.7 && <5+    , hashable+    , primitive+    , vector+  default-language: Haskell2010++executable swisstable-bench+  main-is: Main.hs+  other-modules:+      Paths_swisstable+  hs-source-dirs:+      bench+  ghc-options: -O2+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , criterion+    , deepseq+    , hashable+    , hashtables+    , primitive+    , swisstable+    , vector+  default-language: Haskell2010++test-suite swisstable-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Test.Basic+      Paths_swisstable+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , base >=4.7 && <5+    , hashable+    , primitive+    , swisstable+    , tasty+    , tasty-discover+    , tasty-hunit+    , vector+  default-language: Haskell2010
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+ test/Test/Basic.hs view
@@ -0,0 +1,132 @@+module Test.Basic where++import           Prelude                  hiding (lookup)++import           Control.Monad+import           Data.HashTable.IO.Swiss  hiding (foldM, mapM_)+import qualified Data.HashTable.IO.Swiss  as S+import           Test.Tasty+import           Test.Tasty.HUnit++import           Control.Monad.ST         (stToIO)+import           Data.Primitive.Array     as A+import           Data.Primitive.PrimArray+import           Test.QuickCheck          (Gen, generate, vector)+++unit_insertAndLookup :: IO ()+unit_insertAndLookup = do+  let ks = ["A", "Z", "C", "Y", "E", "X", "G", "W"]+  ref <- new+  mapM_ (\k -> insert ref k k) ks+  forM_ ks $ \k -> do+    h <- lookup ref k+    Just k @=? h++unit_insertAndLookup_rand :: IO ()+unit_insertAndLookup_rand = do+  ks <- generate (vector 1000 :: Gen [Int])+  ref <- new+  mapM_ (\k -> insert ref k k) ks+  forM_ ks $ \k -> do+    h <- lookup ref k+    Just k @=? h++unit_insert_conflict :: IO ()+unit_insert_conflict = do+  let ks = ["head", "Z", "C", "last"]+  t <- newSized 8+  mapM_ (\x -> insert' h t x x) ks+  forM_ ks $ \k -> do+    h <- lookup' h t k+    Just k @=? h+ where+   h = const 0++unit_insert_right_overflow :: IO ()+unit_insert_right_overflow = do+  let ks = ["head", "Z", "C", "last"]+  t <- newSized 8+  mapM_ (\x -> insert' h t x x) ks+  forM_ ks $ \k -> do+    h <- lookup' h t k+    Just k @=? h+ where+   h = const 7++-- 一旦deleteでごまかす+-- vのswapできるようにすべき+unit_update :: IO ()+unit_update = do+  let ks = take 5 $ repeat "A"+  t <- newSized 4+  mapM_ (\x -> insert t x x) ks+  s <- getSize t+  4 @=? s++unit_lookup_nothing_conflict :: IO ()+unit_lookup_nothing_conflict = do+  let ks = ["A", "B", "C", "D"]+  t <- new+  mapM_ (\x -> insert' h t x x) ks+  h <- lookup' h t "X"+  h @=? Nothing+ where+   h = const 7++unit_lookup_nothing :: IO ()+unit_lookup_nothing = do+  let ks = ["A", "B", "C", "D"]+  t <- new+  mapM_ (\x -> insert t x x) ks+  h <- lookup t "X"+  h @=? Nothing++unit_grow_rehash :: IO ()+unit_grow_rehash = do+  let ks = ["A","Z", "C", "Y", "E", "X", "G", "W", "ab", "cd", "ef", "gh", "xx"]+  t <- newSized 8+  mapM_ (\k -> insert t k k) ks+  forM_ ks $ \k -> do+    h <- lookup t k+    Just k @=? h++unit_grow_rehash2 :: IO ()+unit_grow_rehash2 = do+  let ks = [0..99::Int]+  t <- newSized 8+  mapM_ (\k -> insert t k k) ks+  forM_ ks $ \k -> do+    h <- lookup t k+    Just k @=? h++unit_delete :: IO ()+unit_delete = do+  let ks = ["A","B", "C"]+  t <- new+  mapM_ (\k -> insert t k k) ks+  delete t "B"+  h <- lookup t "B"+  h @=? Nothing+  h <- lookup t "C"+  h @=? Just "C"++unit_foldM :: IO ()+unit_foldM = do+  let ks = ["A","B", "C"]+  t <- new+  mapM_ (\k -> insert t k k) ks+  x <- S.foldM (\acc (k, _) -> pure (acc ++ k)) "" t+  "ABC" @=? x++unit_mutate :: IO ()+unit_mutate = do+  let ks = ["A","B", "C"]+  t <- new+  mapM_ (\k -> insert t k k) ks+  mutate t "A" (\(Just v) -> (Just (v ++ "!"), ()))+  mutate t "B" (const (Nothing, ()))+  a <- lookup t "A"+  Just "A!" @=? a+  a <- lookup t "B"+  Nothing @=? a