Lift the 8-byte key restriction for the compact index

jorisdral · jorisdral · commit 32be3054080e · 2025-06-03T11:33:30.000+02:00
Now that `topBits64` is fully safe, remove the 8-byte key constraint when using
the compact index. Instead, the config option for the index type includes a hint
not to use the compact index if their keys are too small, because that will lead
to bad performance.
diff --git a/bench/micro/Bench/Database/LSMTree/Internal/Index.hs b/bench/micro/Bench/Database/LSMTree/Internal/Index.hs
@@ -11,15 +11,13 @@ import           Criterion.Main (Benchmark, Benchmarkable, bench, bgroup, env,
 import           Data.List (foldl')
                  -- foldl' is included in the Prelude from base 4.20 onwards
 #endif
-import           Database.LSMTree.Extras.Generators (getKeyForIndexCompact,
-                     mkPages, toAppends)
+import           Database.LSMTree.Extras.Generators (mkPages, toAppends)
                      -- also for @Arbitrary@ instantiation of @SerialisedKey@
 import           Database.LSMTree.Extras.Index (Append, append)
 import           Database.LSMTree.Internal.Index (Index,
                      IndexType (Compact, Ordinary), newWithDefaults, search,
                      unsafeEnd)
-import           Database.LSMTree.Internal.Serialise
-                     (SerialisedKey (SerialisedKey))
+import           Database.LSMTree.Internal.Serialise (SerialisedKey)
 import           Test.QuickCheck (choose, vector)
 import           Test.QuickCheck.Gen (Gen (MkGen))
 import           Test.QuickCheck.Random (mkQCGen)
@@ -61,8 +59,7 @@ generated (MkGen exec) = exec (mkQCGen 411) 30
 keysForIndexCompact :: Int             -- ^ Number of keys
                     -> [SerialisedKey] -- ^ Constructed keys
 keysForIndexCompact = vector                                        >>>
-                      generated                                     >>>
-                      map (getKeyForIndexCompact >>> SerialisedKey)
+                      generated
 
 {-|
     Constructs append operations whose serialised keys conform to the key size
diff --git a/src-extras/Database/LSMTree/Extras/Generators.hs b/src-extras/Database/LSMTree/Extras/Generators.hs
@@ -33,8 +33,6 @@ module Database.LSMTree.Extras.Generators (
   , genRawBytesSized
   , packRawBytesPinnedOrUnpinned
   , LargeRawBytes (..)
-  , isKeyForIndexCompact
-  , KeyForIndexCompact (..)
   , BiasedKey (..)
     -- * helpers
   , shrinkVec
@@ -510,28 +508,6 @@ instance Arbitrary LargeRawBytes where
 
 deriving newtype instance SerialiseValue LargeRawBytes
 
--- Serialised keys for the compact index must be at least 8 bytes long.
-
-genKeyForIndexCompact :: Gen RawBytes
-genKeyForIndexCompact =
-    genRawBytesN =<< QC.sized (\s -> QC.chooseInt (8, s + 8))
-
-isKeyForIndexCompact :: RawBytes -> Bool
-isKeyForIndexCompact rb = RB.size rb >= 8
-
-newtype KeyForIndexCompact =
-    KeyForIndexCompact { getKeyForIndexCompact :: RawBytes }
-  deriving stock (Eq, Ord, Show)
-
-instance Arbitrary KeyForIndexCompact where
-  arbitrary =
-      KeyForIndexCompact <$> genKeyForIndexCompact
-  shrink (KeyForIndexCompact rawBytes) =
-      [KeyForIndexCompact rawBytes' | rawBytes' <- shrink rawBytes,
-                                      isKeyForIndexCompact rawBytes']
-
-deriving newtype instance SerialiseKey KeyForIndexCompact
-
 -- we try to make collisions and close keys more likely (very crudely)
 arbitraryBiasedKey :: (RawBytes -> k) -> Gen RawBytes -> Gen k
 arbitraryBiasedKey fromRB genUnbiased = fromRB <$> frequency
diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs
@@ -140,7 +140,6 @@ module Database.LSMTree (
   serialiseKeyIdentity,
   serialiseKeyIdentityUpToSlicing,
   serialiseKeyPreservesOrdering,
-  serialiseKeyMinimalSize,
   serialiseValueIdentity,
   serialiseValueIdentityUpToSlicing,
   packSlice,
@@ -216,7 +215,7 @@ import           Database.LSMTree.Internal.Config
                      DiskCachePolicy (..), FencePointerIndexType (..),
                      LevelNo (..), MergePolicy (..), MergeSchedule (..),
                      SizeRatio (..), TableConfig (..), WriteBufferAlloc (..),
-                     defaultTableConfig, serialiseKeyMinimalSize)
+                     defaultTableConfig)
 import           Database.LSMTree.Internal.Config.Override
                      (OverrideDiskCachePolicy (..))
 import           Database.LSMTree.Internal.Entry (NumEntries (..))
diff --git a/src/Database/LSMTree/Internal/Config.hs b/src/Database/LSMTree/Internal/Config.hs
@@ -20,7 +20,6 @@ module Database.LSMTree.Internal.Config (
     -- * Fence pointer index
   , FencePointerIndexType (..)
   , indexTypeForRun
-  , serialiseKeyMinimalSize
     -- * Disk cache policy
   , DiskCachePolicy (..)
   , diskCachePolicyForLevel
@@ -32,11 +31,9 @@ import           Control.DeepSeq (NFData (..))
 import           Database.LSMTree.Internal.Index (IndexType)
 import qualified Database.LSMTree.Internal.Index as Index
                      (IndexType (Compact, Ordinary))
-import qualified Database.LSMTree.Internal.RawBytes as RB
 import           Database.LSMTree.Internal.Run (RunDataCaching (..))
 import           Database.LSMTree.Internal.RunAcc (RunBloomFilterAlloc (..))
 import           Database.LSMTree.Internal.RunBuilder (RunParams (..))
-import           Database.LSMTree.Internal.Serialise.Class (SerialiseKey (..))
 
 newtype LevelNo = LevelNo Int
   deriving stock (Show, Eq, Ord)
@@ -303,12 +300,7 @@ data FencePointerIndexType =
   | {- |
     Compact indexes are designed  for the case where the keys in the database are uniformly distributed, e.g., when the keys are hashes.
 
-    When using a compact index, the 'Database.LSMTree.Internal.Serialise.Class.serialiseKey' function must satisfy the following additional law:
-
-    [Minimal size]
-      @'Database.LSMTree.Internal.RawBytes.size' ('Database.LSMTree.Internal.Serialise.Class.serialiseKey' x) >= 8@
-
-    Use 'serialiseKeyMinimalSize' to test this law.
+    When using a compact index, the 'Database.LSMTree.Internal.Serialise.Class.serialiseKey' function must ideally produce more than 8 bytes
     -}
     CompactIndex
   deriving stock (Eq, Show)
@@ -321,10 +313,6 @@ indexTypeForRun :: FencePointerIndexType -> IndexType
 indexTypeForRun CompactIndex  = Index.Compact
 indexTypeForRun OrdinaryIndex = Index.Ordinary
 
--- | Test the __Minimal size__ law for the 'CompactIndex' option.
-serialiseKeyMinimalSize :: SerialiseKey k => k -> Bool
-serialiseKeyMinimalSize x = RB.size (serialiseKey x) >= 8
-
 {-------------------------------------------------------------------------------
   Disk cache policy
 -------------------------------------------------------------------------------}
diff --git a/src/Database/LSMTree/Simple.hs b/src/Database/LSMTree/Simple.hs
@@ -132,7 +132,6 @@ module Database.LSMTree.Simple (
     serialiseKeyIdentity,
     serialiseKeyIdentityUpToSlicing,
     serialiseKeyPreservesOrdering,
-    serialiseKeyMinimalSize,
     serialiseValueIdentity,
     serialiseValueIdentityUpToSlicing,
     packSlice,
@@ -178,9 +177,8 @@ import           Database.LSMTree (BloomFilterAlloc, CursorClosedError (..),
                      TableTooLargeError (..), UnionCredits (..), UnionDebt (..),
                      WriteBufferAlloc, isValidSnapshotName, packSlice,
                      serialiseKeyIdentity, serialiseKeyIdentityUpToSlicing,
-                     serialiseKeyMinimalSize, serialiseKeyPreservesOrdering,
-                     serialiseValueIdentity, serialiseValueIdentityUpToSlicing,
-                     toSnapshotName)
+                     serialiseKeyPreservesOrdering, serialiseValueIdentity,
+                     serialiseValueIdentityUpToSlicing, toSnapshotName)
 import qualified Database.LSMTree as LSMT
 import           Prelude hiding (lookup, take, takeWhile)
 
diff --git a/test/Test/Database/LSMTree/Generators.hs b/test/Test/Database/LSMTree/Generators.hs
@@ -63,9 +63,6 @@ tests = testGroup "Test.Database.LSMTree.Generators" [
         prop_arbitraryAndShrinkPreserveInvariant
           (\(LargeRawBytes rb) -> labelRawBytes rb)
           (deepseqInvariant @LargeRawBytes)
-    , testGroup "KeyForIndexCompact" $
-        prop_arbitraryAndShrinkPreserveInvariant noTags $
-          isKeyForIndexCompact . getKeyForIndexCompact
     , testGroup "BiasedKey" $
           prop_arbitraryAndShrinkPreserveInvariant
             (labelTestKOps @BiasedKey)
diff --git a/test/Test/Database/LSMTree/Internal/Index/Compact.hs b/test/Test/Database/LSMTree/Internal/Index/Compact.hs
@@ -28,7 +28,7 @@ import           Data.Word
 import           Database.LSMTree.Extras
 import           Database.LSMTree.Extras.Generators (ChunkSize (..),
                      LogicalPageSummaries, LogicalPageSummary (..), Pages (..),
-                     genRawBytes, isKeyForIndexCompact, labelPages, toAppends)
+                     genRawBytes, labelPages, toAppends)
 import           Database.LSMTree.Extras.Index (Append (..), appendToCompact)
 import           Database.LSMTree.Internal.BitMath
 import           Database.LSMTree.Internal.Chunk as Chunk (toByteString)
@@ -54,9 +54,7 @@ import           Text.Printf (printf)
 
 tests :: TestTree
 tests = testGroup "Test.Database.LSMTree.Internal.Index.Compact" [
-    testGroup "TestKey" $
-      prop_arbitraryAndShrinkPreserveInvariant @TestKey noTags isTestKey
-  , testProperty "prop_distribution @TestKey" $
+    testProperty "prop_distribution @TestKey" $
       prop_distribution @TestKey
   , testProperty "prop_searchMinMaxKeysAfterConstruction" $
       prop_searchMinMaxKeysAfterConstruction @TestKey 100
@@ -173,15 +171,12 @@ instance Arbitrary TestKey where
   -- Shrink keys extensively: most failures will occur in small counterexamples,
   -- so we don't have to limit the number of shrinks as much.
   shrink (TestKey bytes) = [
-        TestKey bytes'
+        testkey'
       | let RawBytes vec = bytes
       , vec' <- VP.fromList <$> shrink (VP.toList vec)
-      , let bytes' = RawBytes vec'
-      , isKeyForIndexCompact bytes'
+      , let testkey' = TestKey $ RawBytes vec'
       ]
 
-isTestKey :: TestKey -> Bool
-isTestKey (TestKey bytes) = isKeyForIndexCompact bytes
 
 {-------------------------------------------------------------------------------
   Properties
diff --git a/test/Test/Database/LSMTree/Internal/Lookup.hs b/test/Test/Database/LSMTree/Internal/Lookup.hs
@@ -60,7 +60,7 @@ import qualified Database.LSMTree.Internal.Run as Run
 import           Database.LSMTree.Internal.RunAcc as Run
 import           Database.LSMTree.Internal.RunBuilder
                      (RunDataCaching (CacheRunData), RunParams (RunParams))
-import           Database.LSMTree.Internal.Serialise
+import           Database.LSMTree.Internal.Serialise as Serialise
 import           Database.LSMTree.Internal.Serialise.Class
 import           Database.LSMTree.Internal.UniqCounter
 import qualified Database.LSMTree.Internal.WriteBuffer as WB
@@ -563,14 +563,10 @@ liftShrink3InMemLookupData shrinkKey shrinkValue shrinkBlob InMemLookupData{ run
       shrinkEntry = liftShrink2 shrinkValue shrinkBlob
 
 genSerialisedKey :: Gen SerialisedKey
-genSerialisedKey = frequency [
-      (9, arbitrary `suchThat` (\k -> sizeofKey k >= 8))
-    , (1, do x <- getSmall <$> arbitrary
-             pure $ SerialisedKey (RB.pack [0,0,0,0,0,0,0, x]))
-    ]
+genSerialisedKey = Serialise.serialiseKey <$> arbitraryBoundedIntegral @Word64
 
 shrinkSerialisedKey :: SerialisedKey -> [SerialisedKey]
-shrinkSerialisedKey k = [k' | k' <- shrink k, sizeofKey k' >= 8]
+shrinkSerialisedKey k = Serialise.serialiseKey <$> shrink (Serialise.deserialiseKey k :: Word64)
 
 genSerialisedValue :: Gen SerialisedValue
 genSerialisedValue = frequency [ (50, arbitrary), (1, genLongValue) ]
diff --git a/test/Test/Database/LSMTree/Internal/RunAcc.hs b/test/Test/Database/LSMTree/Internal/RunAcc.hs
@@ -140,8 +140,7 @@ fromProtoValue (Proto.Value bs) = SerialisedValue . RB.fromShortByteString $ SBS
 fromProtoBlobRef :: Proto.BlobRef -> BlobSpan
 fromProtoBlobRef (Proto.BlobRef x y) = BlobSpan x y
 
--- | Wrapper around 'PageLogical' that generates nearly-full pages, and
--- keys that are always large enough (>= 8 bytes) for the compact index.
+-- | Wrapper around 'PageLogical' that generates nearly-full pages.
 newtype PageLogical' = PageLogical' { getPrototypeKOps :: [(Proto.Key, Proto.Operation)] }
   deriving stock Show
 
@@ -150,7 +149,7 @@ getRealKOps = fmap fromProtoKOp . getPrototypeKOps
 
 instance Arbitrary PageLogical' where
   arbitrary = PageLogical' <$>
-      Proto.genPageContentFits Proto.DiskPage4k (Proto.MinKeySize 8)
+      Proto.genPageContentFits Proto.DiskPage4k Proto.noMinKeySize
   shrink (PageLogical' page) =
       [ PageLogical' page' | page' <- shrink page ]
 
diff --git a/test/Test/Database/LSMTree/StateMachine.hs b/test/Test/Database/LSMTree/StateMachine.hs
@@ -92,12 +92,12 @@ import qualified Database.LSMTree as R
 import           Database.LSMTree.Class (Entry (..), LookupResult (..))
 import qualified Database.LSMTree.Class as Class
 import           Database.LSMTree.Extras (showPowersOf)
-import           Database.LSMTree.Extras.Generators (KeyForIndexCompact)
+import           Database.LSMTree.Extras.Generators ()
 import           Database.LSMTree.Extras.NoThunks (propNoThunks)
 import qualified Database.LSMTree.Internal.Config as R
                      (TableConfig (TableConfig))
 import           Database.LSMTree.Internal.Serialise (SerialisedBlob,
-                     SerialisedValue)
+                     SerialisedKey, SerialisedValue)
 import qualified Database.LSMTree.Internal.Types as R.Types
 import qualified Database.LSMTree.Internal.Unsafe as R.Unsafe
 import qualified Database.LSMTree.Model.IO as ModelIO
@@ -567,7 +567,7 @@ handleFsError = Model.ErrFsError . displayException
   Key and value types
 -------------------------------------------------------------------------------}
 
-newtype Key = Key KeyForIndexCompact
+newtype Key = Key SerialisedKey
   deriving stock (Show, Eq, Ord)
   deriving newtype (Arbitrary, R.SerialiseKey)
 
