Merge pull request #66 from gregorycollins/fix/mutate

Fix #55 (mutate is broken when growing the table)

.gitignore

@@ -19,3 +19,4 @@ test/.hpc
 test/.hpc/**
 test/dist
 test/dist/**
+.ghc*

changelog.md

@@ -1,5 +1,10 @@
 # Hashtables changelog
 
+## 1.2.4.0
+
+Fix a [correctness bug](https://github.com/gregorycollins/hashtables/issues/55)
+with cuckoo hash tables and the new `mutate` function introduced in 1.2.3.0.
+
 ## 1.2.3.4
 
 Fix build with GHC 8.8.

hashtables.cabal

@@ -1,6 +1,6 @@
 Cabal-Version: 2.2
 Name:                hashtables
-Version:             1.2.3.4
+Version:             1.2.4.0
 Synopsis:            Mutable hash tables in the ST monad
 Homepage:            http://github.com/gregorycollins/hashtables
 License:             BSD-3-Clause
@@ -214,6 +214,64 @@ Library
   else
     ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
 
+test-suite testsuite
+  hs-source-dirs:    src test/suite
+  main-is:           TestSuite.hs
+  type: exitcode-stdio-1.0
+
+  if flag(sse42) && !flag(portable)
+    cc-options:  -DUSE_SSE_4_2 -msse4.2
+    cpp-options: -DUSE_SSE_4_2
+    C-sources:   cbits/sse-42.c
+
+  if !flag(portable) && !flag(sse42)
+    C-sources:       cbits/default.c
+
+  if !flag(portable)
+    C-sources:       cbits/common.c
+
+  ghc-prof-options:  -prof -auto-all
+
+  if flag(portable) || !flag(unsafe-tricks)
+    ghc-options: -fhpc
+
+  if flag(portable)
+    cpp-options: -DNO_C_SEARCH -DPORTABLE
+
+  if !flag(portable) && flag(unsafe-tricks) && impl(ghc)
+    cpp-options: -DUNSAFETRICKS
+    build-depends: ghc-prim
+
+  if flag(debug)
+    cpp-options: -DDEBUG
+
+  if flag(bounds-checking)
+    cpp-options: -DBOUNDS_CHECKING
+
+  Build-depends:     base                       >= 4     && <5,
+                     hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,
+                     mwc-random                 >= 0.8   && <0.14,
+                     primitive,
+                     QuickCheck                 >= 2.3.0.2,
+                     HUnit                      >= 1.2   && <2,
+                     test-framework             >= 0.3.1 && <0.9,
+                     test-framework-quickcheck2 >= 0.2.6 && <0.4,
+                     test-framework-hunit       >= 0.2.6 && <3,
+                     vector                     >= 0.7
+
+  cpp-options: -DTESTSUITE
+
+  if impl(ghc >= 7)
+    ghc-options: -rtsopts
+
+  if impl(ghc >= 6.12.0)
+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
+                 -fno-warn-unused-do-bind -threaded
+  else
+    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -threaded
+
+
+
 source-repository head
   type:     git
   location: https://github.com/gregorycollins/hashtables.git

src/Data/HashTable/ST/Cuckoo.hs

@@ -486,8 +486,8 @@ mutate' ht@(HashTable sz _ hashes keys values _) !k !f = do
               else do
                 result <- cuckooOrFail ht h1 h2 b1 b2 k v
                 maybe (return ht)
-                      (\(_k', _v') -> do
-                          newHt <- grow ht k v
+                      (\(k', v') -> do
+                          newHt <- grow ht k' v'
                           return newHt)
                       result
 {-# INLINE mutate' #-}

test/hashtables-test.cabal

@@ -32,62 +32,6 @@ Flag portable
   Default: False
 
 
-Executable testsuite
-  hs-source-dirs:    ../src suite
-  main-is:           TestSuite.hs
-
-  if flag(sse42) && !flag(portable)
-    cc-options:  -DUSE_SSE_4_2 -msse4.2
-    cpp-options: -DUSE_SSE_4_2
-    C-sources:   ../cbits/sse-42.c
-
-  if !flag(portable) && !flag(sse42)
-    C-sources:       ../cbits/default.c
-
-  if !flag(portable)
-    C-sources:       ../cbits/common.c
-
-  ghc-prof-options:  -prof -auto-all
-
-  if flag(portable) || !flag(unsafe-tricks)
-    ghc-options: -fhpc
-
-  if flag(portable)
-    cpp-options: -DNO_C_SEARCH -DPORTABLE
-
-  if !flag(portable) && flag(unsafe-tricks) && impl(ghc)
-    cpp-options: -DUNSAFETRICKS
-    build-depends: ghc-prim
-
-  if flag(debug)
-    cpp-options: -DDEBUG
-
-  if flag(bounds-checking)
-    cpp-options: -DBOUNDS_CHECKING
-
-  Build-depends:     base                       >= 4     && <5,
-                     hashable >= 1.1 && <1.2 || >= 1.2.1 && <1.3,
-                     mwc-random                 >= 0.8   && <0.14,
-                     primitive,
-                     QuickCheck                 >= 2.3.0.2,
-                     HUnit                      >= 1.2   && <2,
-                     test-framework             >= 0.3.1 && <0.9,
-                     test-framework-quickcheck2 >= 0.2.6 && <0.4,
-                     test-framework-hunit       >= 0.2.6 && <3,
-                     vector                     >= 0.7
-
-  cpp-options: -DTESTSUITE
-
-  if impl(ghc >= 7)
-    ghc-options: -rtsopts
-
-  if impl(ghc >= 6.12.0)
-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
-                 -fno-warn-unused-do-bind -threaded
-  else
-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -threaded
-
-
 Executable compute-overhead
   hs-source-dirs:    ../src suite compute-overhead
   main-is:           ComputeOverhead.hs

test/suite/Data/HashTable/Test/Common.hs

@@ -26,11 +26,13 @@ import           System.Timeout
 import           Test.Framework
 import           Test.Framework.Providers.HUnit
 import           Test.Framework.Providers.QuickCheck2
-import           Test.HUnit                           (assertFailure)
+import           Test.HUnit                           (assertEqual,
+                                                       assertFailure)
 import           Test.QuickCheck                      (arbitrary, choose,
                                                        sample')
-import           Test.QuickCheck.Monadic              (PropertyM, assert, pre,
-                                                       forAllM, monadicIO, run)
+import           Test.QuickCheck.Monadic              (PropertyM, assert,
+                                                       forAllM, monadicIO, pre,
+                                                       run)
 ------------------------------------------------------------------------------
 import qualified Data.HashTable.Class                 as C
 import           Data.HashTable.Internal.Utils        (unsafeIOToST)
@@ -104,6 +106,7 @@ tests prefix dummyArg = testGroup prefix $ map f ts
          , SomeTest testNastyFullLookup
          , SomeTest testForwardSearch3
          , SomeTest testMutate
+         , SomeTest testMutateGrow
          ]
 
 
@@ -323,6 +326,19 @@ testMutate prefix dummyArg = testProperty (prefix ++ "/mutate") $
         assertEq "mutate inserts correctly folded list value" s out2
         forceType dummyArg ht
 
+testMutateGrow :: HashTest
+testMutateGrow prefix dummyArg = testCase (prefix ++ "/mutateGrow") go
+  where
+    go = do
+        tbl <- new
+        forceType tbl dummyArg
+        timeout_ 3000000 $ do
+            let inputs = [0..128 :: Int]
+            Monad.mapM_ (mutIns tbl) inputs
+            l <- sort <$> toList tbl
+            let expected = map (\i -> (i, i)) inputs
+            assertEqual "mutate-grow" expected l
+    mutIns tbl i = mutate tbl i (const (Just i, ()))
 
 ------------------------------------------------------------------------------
 data Action = Lookup Int
@@ -489,7 +505,7 @@ initializeRNG = run $ withSystemRandom (return :: GenIO -> IO GenIO)
 dedupe :: (Ord k, Ord v, Eq k) => [(k,v)] -> [(k,v)]
 dedupe l = go0 $ sort l
   where
-    go0 [] = []
+    go0 []     = []
     go0 (x:xs) = go id x xs
 
     go !dl !lastOne [] = (dl . (lastOne:)) []