Merge pull request #623 from IntersectMBO/jdral/ordinary-index-nothunks

Run `Class`-based and `StateMachine` tests using both index types

Author: jorisdral

bench/micro/Bench/Database/LSMTree/Internal/Index.hs

@@ -112,8 +112,8 @@ searchBenchmarkable index = whnf $ foldl' (\ _ key -> rnf (search key index)) ()
 -- ** Incremental construction
 
 -- | Constructs append operations to be used in index construction.
-incrementalConstructionAppends
-    :: Int      -- ^ Number of keys used in the construction
+incrementalConstructionAppends ::
+       Int      -- ^ Number of keys used in the construction
     -> [Append] -- ^ Constructed append operations
 incrementalConstructionAppends = appendsForIndexCompact
 

src-extras/Database/LSMTree/Extras/NoThunks.hs

@@ -461,9 +461,31 @@ deriving anyclass instance Typeable s
   GrowingVector
 -------------------------------------------------------------------------------}
 
-deriving stock instance Generic (GrowingVector s a)
-deriving anyclass instance (Typeable s, Typeable a, NoThunks a)
-                        => NoThunks (GrowingVector s a)
+instance (NoThunks a, Typeable s, Typeable a) => NoThunks (GrowingVector s a) where
+  showTypeOf (p :: Proxy (GrowingVector s a)) = show $ typeRep p
+  wNoThunks ctx
+    (GrowingVector (a :: STRef s (VM.MVector s a)) (b :: PrimVar s Int))
+    = allNoThunks [
+          noThunks ctx b
+          -- Check that the STRef is in WHNF
+        , noThunks ctx $ OnlyCheckWhnf a
+          -- Check that the MVector is in WHNF
+        , do
+            mvec <- unsafeSTToIO $ readSTRef a
+            noThunks ctx' $ OnlyCheckWhnf mvec
+          -- Check that the vector elements contain no thunks. The vector
+          -- contains undefined elements after the first @n@ elements
+        , do
+            n <- unsafeSTToIO $ readPrimVar b
+            mvec <- unsafeSTToIO $ readSTRef a
+            allNoThunks [
+                unsafeSTToIO (VM.read mvec i) >>= \x -> noThunks ctx'' x
+              | i <- [0..n-1]
+              ]
+        ]
+    where
+      ctx' = showTypeOf (Proxy @(STRef s (VM.MVector s a))) : ctx
+      ctx'' = showTypeOf (Proxy @(VM.MVector s a)) : ctx'
 
 {-------------------------------------------------------------------------------
   Baler
@@ -663,15 +685,21 @@ instance (NoThunks a, Typeable s, Typeable a) => NoThunks (MutableHeap s a) wher
     (MH (a :: PrimVar s Int) (b :: SmallMutableArray s a))
     = allNoThunks [
           noThunks ctx a
-          -- the small array may contain bogus/undefined placeholder values
-          -- after the first @n@ elements in the heap
-        , noThunks ctx $! do
+          -- Check that the array is in WHNF
+        , noThunks ctx (OnlyCheckWhnf b)
+          -- Check that the array elements contain no thunks. The small array
+          -- may contain undefined placeholder values after the first @n@
+          -- elements in the array. The very first element of the array can also
+          -- be undefined.
+        , do
             n <- unsafeSTToIO (readPrimVar a)
             allNoThunks [
-                unsafeSTToIO (readSmallArray b i) >>= \x -> noThunks ctx x
-              | i <- [0..n-1]
+                unsafeSTToIO (readSmallArray b i) >>= \x -> noThunks ctx' x
+              | i <- [1..n-1]
               ]
         ]
+    where
+      ctx' = showTypeOf (Proxy @(SmallMutableArray s a)) : ctx
 
 {-------------------------------------------------------------------------------
   IOLike

src/Database/LSMTree/Internal/Index.hs

@@ -154,8 +154,8 @@ fromSBS Ordinary input = second OrdinaryIndex <$> Ordinary.fromSBS input
     Incremental index construction is only guaranteed to work correctly when the
     supplied key ranges do not overlap and are given in ascending order.
 -}
-data IndexAcc s = CompactIndexAcc  (IndexCompactAcc  s)
-                | OrdinaryIndexAcc (IndexOrdinaryAcc s)
+data IndexAcc s = CompactIndexAcc  !(IndexCompactAcc  s)
+                | OrdinaryIndexAcc !(IndexOrdinaryAcc s)
 
 -- | Create a new index accumulator, using a default configuration.
 newWithDefaults :: IndexType -> ST s (IndexAcc s)

src/Database/LSMTree/Internal/Index/Ordinary.hs

@@ -80,7 +80,17 @@ toLastKeys (IndexOrdinary lastKeys) = lastKeys
     type-agnostic version]('Database.LSMTree.Internal.Index.search').
 -}
 search :: SerialisedKey -> IndexOrdinary -> PageSpan
-search key (IndexOrdinary lastKeys) = assert (pageCount > 0) result where
+search key (IndexOrdinary lastKeys)
+  -- TODO: ideally, we could assert that an index is never empty, but
+  -- unfortunately we can not currently do this. Runs (and thefeore indexes)
+  -- /can/ be empty if they were created by a last-level merge where all input
+  -- entries were deletes. Other parts of the @lsm-tree@ code won't fail as long
+  -- as we return @PageSpan 0 0@ when we search an empty ordinary index. The
+  -- ideal fix would be to remove empty runs from the levels entirely, but this
+  -- requires more involved changes to the merge schedule and until then we'll
+  -- just hack the @pageCount <= 0@ case in.
+  | pageCount <= 0 = PageSpan (PageNo 0) (PageNo 0)
+  | otherwise = assert (pageCount > 0) result where
 
     protoStart :: Int
     !protoStart = binarySearchL lastKeys key
@@ -224,7 +234,7 @@ fromSBS shortByteString@(SBS unliftedByteArray)
                           = Primitive.splitAt firstSize postFirstSizeBytes
 
                       first :: SerialisedKey
-                      first = SerialisedKey' (Primitive.force firstBytes)
+                      !first = SerialisedKey' (Primitive.force firstBytes)
 
                   others <- lastKeys othersBytes
                   return (first : others)

src/Database/LSMTree/Internal/Vector/Growing.hs

@@ -70,7 +70,7 @@ append (GrowingVector bufferRef lengthRef) count val
           length <- readPrimVar lengthRef
           makeRoom
           buffer' <- readSTRef bufferRef
-          Mutable.set (Mutable.slice length count buffer') val
+          Mutable.set (Mutable.slice length count buffer') $! val
     where
 
     makeRoom :: ST s ()

test/Test/Database/LSMTree/Class.hs

@@ -24,6 +24,7 @@ import           Database.LSMTree.Common (mkSnapshotName)
 import           Database.LSMTree.Extras.Generators ()
 import qualified Database.LSMTree.Model.IO as ModelIO
 import qualified System.FS.API as FS
+import           Test.Database.LSMTree.StateMachine ()
 import           Test.QuickCheck.Monadic (monadicIO, monitor, run)
 import           Test.Tasty (TestName, TestTree, testGroup)
 import qualified Test.Tasty.QuickCheck as QC
@@ -36,19 +37,17 @@ tests = testGroup "Test.Database.LSMTree.Class"
     , testGroup "Real"  $ zipWith ($) (props tbl2) expectFailures2
     ]
   where
-    tbl1 :: Proxy ModelIO.Table
-    tbl1 = Setup {
-          testTableConfig = ModelIO.TableConfig
+    tbl1 :: RunSetup ModelIO.Table IO
+    tbl1 = RunSetup $ \conf -> Setup {
+          testTableConfig = conf
         , testWithSessionArgs = \action -> action ModelIO.NoSessionArgs
         }
 
     expectFailures1 = repeat False
 
-    tbl2 :: Proxy R.Table
-    tbl2 = Setup {
-          testTableConfig = R.defaultTableConfig {
-              R.confWriteBufferAlloc = R.AllocNumEntries (R.NumEntries 3)
-            }
+    tbl2 :: RunSetup R.Table IO
+    tbl2 = RunSetup $ \conf -> Setup {
+          testTableConfig = conf
         , testWithSessionArgs = \action ->
             FS.withTempIOHasBlockIO "R" $ \hfs hbio ->
               action (SessionArgs hfs hbio (FS.mkFsPath []))
@@ -83,33 +82,33 @@ tests = testGroup "Test.Database.LSMTree.Class"
       , True  -- merge
       ] ++ repeat False
 
-    props tbl =
-      [ testProperty' "lookup-insert" $ prop_lookupInsert tbl
-      , testProperty' "lookup-insert-else" $ prop_lookupInsertElse tbl
-      , testProperty' "lookup-insert-blob" $ prop_lookupInsertBlob tbl
-      , testProperty' "lookup-delete" $ prop_lookupDelete tbl
-      , testProperty' "lookup-delete-else" $ prop_lookupDeleteElse tbl
-      , testProperty' "insert-insert" $ prop_insertInsert tbl
-      , testProperty' "insert-insert-blob" $ prop_insertInsertBlob tbl
-      , testProperty' "insert-commutes" $ prop_insertCommutes tbl
-      , testProperty' "insert-commutes-blob" $ prop_insertCommutesBlob tbl
-      , testProperty' "invalidated-blob-references" $ prop_updatesMayInvalidateBlobRefs tbl
-      , testProperty' "dup-insert-insert" $ prop_dupInsertInsert tbl
-      , testProperty' "dup-insert-comm" $ prop_dupInsertCommutes tbl
-      , testProperty' "dup-nochanges" $ prop_dupNoChanges tbl
-      , testProperty' "lookupRange-like-lookups" $ prop_lookupRangeLikeLookups tbl
-      , testProperty' "lookupRange-insert" $ prop_insertLookupRange tbl
-      , testProperty' "readCursor-sorted" $ prop_readCursorSorted tbl
-      , testProperty' "readCursor-num-results" $ prop_readCursorNumResults tbl
-      , testProperty' "readCursor-insert" $ prop_readCursorInsert tbl
-      , testProperty' "readCursor-delete" $ prop_readCursorDelete tbl
-      , testProperty' "readCursor-delete-else" $ prop_readCursorDeleteElse tbl
-      , testProperty' "readCursor-stable-view" $ prop_readCursorStableView tbl
-      , testProperty' "readCursor-offset" $ prop_readCursorOffset tbl
-      , testProperty' "snapshot-nochanges" $ prop_snapshotNoChanges tbl
-      , testProperty' "snapshot-nochanges2" $ prop_snapshotNoChanges2 tbl
-      , testProperty' "lookup-mupsert" $ prop_lookupUpdate tbl
-      , testProperty' "union" $ prop_union tbl
+    props RunSetup {..} =
+      [ testProperty' "lookup-insert" $ prop_lookupInsert . runSetup
+      , testProperty' "lookup-insert-else" $ prop_lookupInsertElse . runSetup
+      , testProperty' "lookup-insert-blob" $ prop_lookupInsertBlob . runSetup
+      , testProperty' "lookup-delete" $ prop_lookupDelete . runSetup
+      , testProperty' "lookup-delete-else" $ prop_lookupDeleteElse . runSetup
+      , testProperty' "insert-insert" $ prop_insertInsert . runSetup
+      , testProperty' "insert-insert-blob" $ prop_insertInsertBlob . runSetup
+      , testProperty' "insert-commutes" $ prop_insertCommutes . runSetup
+      , testProperty' "insert-commutes-blob" $ prop_insertCommutesBlob . runSetup
+      , testProperty' "invalidated-blob-references" $ prop_updatesMayInvalidateBlobRefs . runSetup
+      , testProperty' "dup-insert-insert" $ prop_dupInsertInsert . runSetup
+      , testProperty' "dup-insert-comm" $ prop_dupInsertCommutes . runSetup
+      , testProperty' "dup-nochanges" $ prop_dupNoChanges . runSetup
+      , testProperty' "lookupRange-like-lookups" $ prop_lookupRangeLikeLookups . runSetup
+      , testProperty' "lookupRange-insert" $ prop_insertLookupRange . runSetup
+      , testProperty' "readCursor-sorted" $ prop_readCursorSorted . runSetup
+      , testProperty' "readCursor-num-results" $ prop_readCursorNumResults . runSetup
+      , testProperty' "readCursor-insert" $ prop_readCursorInsert . runSetup
+      , testProperty' "readCursor-delete" $ prop_readCursorDelete . runSetup
+      , testProperty' "readCursor-delete-else" $ prop_readCursorDeleteElse . runSetup
+      , testProperty' "readCursor-stable-view" $ prop_readCursorStableView . runSetup
+      , testProperty' "readCursor-offset" $ prop_readCursorOffset . runSetup
+      , testProperty' "snapshot-nochanges" $ prop_snapshotNoChanges . runSetup
+      , testProperty' "snapshot-nochanges2" $ prop_snapshotNoChanges2 . runSetup
+      , testProperty' "lookup-mupsert" $ prop_lookupUpdate . runSetup
+      , testProperty' "union" $ prop_union . runSetup
       ]
 
 testProperty' :: forall a. Testable a => TestName -> a -> Bool -> TestTree
@@ -138,6 +137,10 @@ label = SnapshotLabel "Word64 ByteString ByteString"
 
 type Proxy h = Setup h IO
 
+newtype RunSetup h m = RunSetup {
+    runSetup :: TableConfig h -> Setup h m
+  }
+
 data Setup h m = Setup {
     testTableConfig     :: TableConfig h
   , testWithSessionArgs :: forall a. (SessionArgs (Session h) m -> m a) -> m a

test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs

@@ -55,8 +55,8 @@ handleOutputFiles :: TestTree -> TestTree
 handleOutputFiles = Tasty.localOption Au.OnPass
 
 -- | Internally, the function will infer the correct filepath names.
-snapshotCodecTest
-  :: String -- ^ Name of the test
+snapshotCodecTest ::
+     String -- ^ Name of the test
   -> SnapshotMetaData -- ^ Data to be serialized
   -> TestTree
 snapshotCodecTest name datum =

test/Test/Database/LSMTree/StateMachine.hs

@@ -223,22 +223,25 @@ instance Arbitrary R.TableConfig where
         , (4, pure R.Incremental)
         ]
     confWriteBufferAlloc <- QC.arbitrary
+    confFencePointerIndex <- QC.arbitrary
     pure $ R.TableConfig {
         R.confMergePolicy       = R.MergePolicyLazyLevelling
       , R.confSizeRatio         = R.Four
       , confWriteBufferAlloc
       , R.confBloomFilterAlloc  = R.AllocFixed 10
-      , R.confFencePointerIndex = R.CompactIndex
+      , confFencePointerIndex
       , R.confDiskCachePolicy   = R.DiskCacheNone
       , confMergeSchedule
       }
 
   shrink R.TableConfig{..} =
       [ R.TableConfig {
             confWriteBufferAlloc = confWriteBufferAlloc'
+          , confFencePointerIndex = confFencePointerIndex'
           , ..
           }
-      | confWriteBufferAlloc' <- QC.shrink confWriteBufferAlloc
+      | ( confWriteBufferAlloc', confFencePointerIndex')
+          <- QC.shrink (confWriteBufferAlloc, confFencePointerIndex)
       ]
 
 -- TODO: the current generator is suboptimal, and should be improved. There are
@@ -273,6 +276,13 @@ instance Arbitrary R.WriteBufferAlloc where
       | QC.Positive x' <- QC.shrink (QC.Positive x)
       ]
 
+deriving stock instance Enum R.FencePointerIndex
+deriving stock instance Bounded R.FencePointerIndex
+instance Arbitrary R.FencePointerIndex where
+  arbitrary = QC.arbitraryBoundedEnum
+  shrink R.OrdinaryIndex = []
+  shrink R.CompactIndex  = [R.OrdinaryIndex]
+
 propLockstep_RealImpl_RealFS_IO ::
      Tracer IO R.LSMTreeTrace
   -> Actions (Lockstep (ModelState R.Table))