From 587e2e7ace0779be77d8517a54e56894916dc097 Mon Sep 17 00:00:00 2001
From: nakaji_dayo <>
Date: Tue, 23 Feb 2021 10:17:00 +0100
Subject: version 0.1.0.3


diff --git a/README.md b/README.md
index 7c7e051..bd77aa8 100755
--- a/README.md
+++ b/README.md
@@ -5,9 +5,12 @@
 ## links
 
 - [Hackage](https://hackage.haskell.org/package/swisstable-0.1.0.1)
+- [Instance definition of Data.HashTable.Class](https://github.com/nakaji-dayo/hs-swisstable-hashtables-class)
 
 ## Benchmark snapshot
 
+### time
+
 15564c4
 ```
 benchmarking lookup(seq)/small/SwissTable
@@ -46,3 +49,14 @@ time                 1.315 ms   (1.311 ms .. 1.319 ms)
 mean                 1.321 ms   (1.319 ms .. 1.322 ms)
 std dev              5.360 μs   (4.111 μs .. 6.704 μs)
 ```
+
+### space
+
+8557655
+```
+Case                                    Allocated  GCs
+Swiss.insert                          362,035,256  314
+Data.HashTable.ST.Basic.insert        192,201,784  108
+Swiss.insert sized                    162,891,112  140
+Data.HashTable.ST.Basic.insert sized  152,675,336   94
+```
diff --git a/bench/Main.hs b/bench/Main.hs
index 4ca27dc..79a0542 100644
--- a/bench/Main.hs
+++ b/bench/Main.hs
@@ -2,7 +2,6 @@
 module Main where
 
 import           Control.DeepSeq
-import           Control.DeepSeq         (NFData)
 import           Control.Monad
 import           Criterion
 import           Criterion.Main
diff --git a/space/Main.hs b/space/Main.hs
new file mode 100644
index 0000000..4e98ece
--- /dev/null
+++ b/space/Main.hs
@@ -0,0 +1,26 @@
+module Main where
+
+import           Control.DeepSeq
+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           Weigh
+
+ssize = 1000000
+
+main =
+  mainWith $ do
+    io "Swiss.insert" (testInsert new insert) ssize
+    io "Data.HashTable.ST.Basic.insert" (testInsert (H.new :: IO (H.BasicHashTable Int Int)) H.insert) ssize
+    io "Swiss.insert sized" (testInsert (newSized (2^21)) insert) ssize
+    io "Data.HashTable.ST.Basic.insert sized" (testInsert (H.newSized (2^21) :: IO (H.BasicHashTable Int Int)) H.insert) ssize
+
+testInsert new insert size = do
+  t <- new
+  mapM_ (\x -> insert t x x) ([1..size] :: [Int])
+  pure t
+
+instance NFData (Data.HashTable.ST.Basic.HashTable s k v) where
+  rnf x = seq x ()
+instance NFData (S.Table s k v)
diff --git a/src/Data/HashTable/ST/Swiss.hs b/src/Data/HashTable/ST/Swiss.hs
index 46d32dc..b085a0b 100644
--- a/src/Data/HashTable/ST/Swiss.hs
+++ b/src/Data/HashTable/ST/Swiss.hs
@@ -98,6 +98,7 @@ rawInsert !h1' ref !k !v = do
   iterateCtrlIdx (f (mutablePrimArrayContents ctrl) size elems ctrl) size (mask .&. h1')
   modifySTRef' used (+ 1)
   checkOverflow m >>= \x -> when x $ grow ref
+  pure ()
   where
     f !ptr !size !elems !ctrl !idx = do
       let !pc = PP.advancePtr ptr idx
@@ -158,7 +159,7 @@ 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
+iterateBitmaskSet  f !mask = do
   let bitidxs = listBitmaskSet mask
   go bitidxs
   where
@@ -248,23 +249,23 @@ grow ref = do
   writeRef ref =<< readRef t'
   pure ()
   where
-    f t (k, v) = insert t k v
+    f t (!k, !v) = rawInsert (hash k) 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
+  void $ iterateCtrlIdx (h (mutablePrimArrayContents (ctrl t)) t) (size t) idx
   where
-    g t idx bidx = do
+    g elms !idx !bidx = do
       let idx' = idx + bidx - 1
-      e <- readArray (elems t) idx'
+      !e <- readArray elms idx'
       void $ f e
       pure Nothing
-    h t idx = do
-      let pc = PP.advancePtr (mutablePrimArrayContents (ctrl t)) idx
+    h ptr t !idx = do
+      let pc = PP.advancePtr ptr idx
       let mask = cElmAddMovemask 128 pc
-      r <- iterateBitmaskSet (g t idx) mask
+      r <- iterateBitmaskSet (g (elems 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
@@ -323,14 +324,15 @@ analyze ref = do
 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
+      (Just v', a) -> do -- update
+        t <- readRef ref
         writeArray (elems t) idx (k, v') >> pure a
-      (Nothing, a) -> --delete
+      (Nothing, a) -> do--delete
+        t <- readRef ref
         deleteIdx t idx >> pure a
     Nothing ->
       f Nothing >>= \case
diff --git a/swisstable.cabal b/swisstable.cabal
index c85fc46..5599c1b 100644
--- a/swisstable.cabal
+++ b/swisstable.cabal
@@ -4,10 +4,10 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 5fef574e1937b884f6bad8ceedf9e2b80334d6db31ecd33f899c1aab7643f6c5
+-- hash: 3ef14fa03a61f138cc4f0c33f762ab65d32e97c4397ce2e3af5c587e8b506ecb
 
 name:           swisstable
-version:        0.1.0.2
+version:        0.1.0.3
 synopsis:       SwissTable hash map
 description:    Please see the README on GitHub at <https://github.com/nakaji-dayo/hs-swisstable#readme>
 category:       Data
@@ -43,7 +43,7 @@ library
   build-depends:
       base >=4.7 && <5
     , hashable
-    , primitive
+    , primitive >=0.7.1.0
     , vector
   default-language: Haskell2010
 
@@ -51,7 +51,7 @@ test-suite swisstable-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
-      Test.Basic
+      Test.Data.HashTable.ST.Swiss
       Paths_swisstable
   hs-source-dirs:
       test
@@ -60,7 +60,7 @@ test-suite swisstable-test
       QuickCheck
     , base >=4.7 && <5
     , hashable
-    , primitive
+    , primitive >=0.7.1.0
     , swisstable
     , tasty
     , tasty-discover
@@ -83,7 +83,26 @@ benchmark swisstable-bench
     , deepseq
     , hashable
     , hashtables
-    , primitive
+    , primitive >=0.7.1.0
     , swisstable
     , vector
   default-language: Haskell2010
+
+benchmark swisstable-space
+  type: exitcode-stdio-1.0
+  main-is: Main.hs
+  other-modules:
+      Paths_swisstable
+  hs-source-dirs:
+      space
+  ghc-options: -O2
+  build-depends:
+      base >=4.7 && <5
+    , deepseq
+    , hashable
+    , hashtables
+    , primitive >=0.7.1.0
+    , swisstable
+    , vector
+    , weigh
+  default-language: Haskell2010
diff --git a/test/Test/Basic.hs b/test/Test/Basic.hs
deleted file mode 100644
index 2caec6d..0000000
--- a/test/Test/Basic.hs
+++ /dev/null
@@ -1,132 +0,0 @@
-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
diff --git a/test/Test/Data/HashTable/ST/Swiss.hs b/test/Test/Data/HashTable/ST/Swiss.hs
new file mode 100644
index 0000000..65dfe34
--- /dev/null
+++ b/test/Test/Data/HashTable/ST/Swiss.hs
@@ -0,0 +1,133 @@
+module Test.Data.HashTable.ST.Swiss 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.List                (sort)
+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 = replicate 5 "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
+  sort "ABC" @=? sort 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
-- 
cgit v0.10.2