Merge pull request #437 from IntersectMBO/jdral/cleanups

Cleanups related to write buffer updates and value resolution in the core library.

Author: dcoutts

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

@@ -1,12 +1,13 @@
 module Bench.Database.LSMTree.Internal.WriteBuffer (benchmarks) where
 
-import           Control.DeepSeq (NFData (..))
+import           Control.DeepSeq (NFData (..), rwhnf)
+import           Control.Exception (assert)
 import           Criterion.Main (Benchmark, bench, bgroup)
 import qualified Criterion.Main as Cr
 import           Data.Bifunctor (first)
 import qualified Data.Foldable as Fold
 import qualified Data.List as List
-import           Data.Maybe (fromMaybe)
+import           Data.Maybe (fromMaybe, isJust, isNothing)
 import           Data.Word (Word64)
 import           Database.LSMTree.Extras.Orphans ()
 import           Database.LSMTree.Extras.Random (frequency, randomByteStringR)
@@ -16,9 +17,6 @@ import           Database.LSMTree.Internal.Entry
 import           Database.LSMTree.Internal.Serialise
 import           Database.LSMTree.Internal.WriteBuffer (WriteBuffer)
 import qualified Database.LSMTree.Internal.WriteBuffer as WB
-import qualified Database.LSMTree.Monoidal as Monoidal
-import qualified Database.LSMTree.Normal as Normal
-import           GHC.Generics
 import           System.Random (StdGen, mkStdGen, uniform)
 
 benchmarks :: Benchmark
@@ -110,19 +108,13 @@ benchWriteBuffer conf@Config{name} =
         ]
 
 insert :: InputKOps -> WriteBuffer
-insert (NormalInputs kops) =
-    Fold.foldl' (\wb (k, e) -> WB.addEntryNormal k e wb) WB.empty kops
-insert (MonoidalInputs kops mappendVal) =
-    Fold.foldl' (\wb (k, e) -> WB.addEntryMonoidal mappendVal k e wb) WB.empty kops
-
-data InputKOps
-  = NormalInputs
-      ![(SerialisedKey, Normal.Update SerialisedValue BlobSpan)]
-  | MonoidalInputs
-      ![(SerialisedKey, Monoidal.Update SerialisedValue)]
-      !Mappend
-  deriving stock Generic
-  deriving anyclass NFData
+insert (InputKOps kops mappendVal) =
+    Fold.foldl' (\wb (k, e) -> WB.addEntry mappendVal k e wb) WB.empty kops
+
+data InputKOps = InputKOps [(SerialisedKey, Entry SerialisedValue BlobSpan)] Mappend
+
+instance NFData InputKOps where
+  rnf (InputKOps kops mappendVal) = rnf kops `seq` rwhnf mappendVal
 
 type Mappend = SerialisedValue -> SerialisedValue -> SerialisedValue
 
@@ -187,22 +179,16 @@ configUTxO = defaultConfig {
 envInputKOps :: Config -> InputKOps
 envInputKOps config = do
     let kops = randomKOps config (mkStdGen 17)
-     in case mappendVal config of
-          Nothing -> NormalInputs (fmap (fmap expectNormal) kops)
-          Just f  -> MonoidalInputs (fmap (fmap expectMonoidal) kops) f
-  where
-    expectNormal e = fromMaybe (error ("invalid normal update: " <> show e))
-                       (entryToUpdateNormal e)
-    expectMonoidal e = fromMaybe (error ("invalid monoidal update: " <> show e))
-                       (entryToUpdateMonoidal e)
+     in InputKOps kops (fromMaybe const (mappendVal config))
 
 -- | Generate keys and entries to insert into the write buffer.
 -- They are already serialised to exclude the cost from the benchmark.
 randomKOps ::
      Config
   -> StdGen -- ^ RNG
   -> [SerialisedKOp]
-randomKOps Config {..} = take nentries . List.unfoldr (Just . randomKOp)
+randomKOps Config {..} = take nentries . List.unfoldr (Just . randomKOp) .
+    assert (if fmupserts > 0 then isJust mappendVal else isNothing mappendVal)
   where
     randomKOp :: Rnd SerialisedKOp
     randomKOp g = let (!k, !g')  = randomKey g

lsm-tree.cabal

@@ -135,8 +135,6 @@ library
     Database.LSMTree.Internal.Lookup
     Database.LSMTree.Internal.Merge
     Database.LSMTree.Internal.MergeSchedule
-    Database.LSMTree.Internal.Monoidal
-    Database.LSMTree.Internal.Normal
     Database.LSMTree.Internal.PageAcc
     Database.LSMTree.Internal.PageAcc1
     Database.LSMTree.Internal.Paths

src/Database/LSMTree/Internal/Entry.hs

@@ -5,27 +5,14 @@ module Database.LSMTree.Internal.Entry (
   , onBlobRef
   , NumEntries (..)
   , unNumEntries
-    -- * Injections/projections
-  , updateToEntryNormal
-  , updateToEntryMonoidal
-  , entryToUpdateNormal
-  , entryToUpdateMonoidal
     -- * Value resolution/merging
   , combine
   , combineMaybe
-  , combinesMonoidal
-  , combinesNormal
-  , resolveEntriesNormal
-  , resolveEntriesMonoidal
   ) where
 
 import           Control.DeepSeq (NFData (..))
 import           Data.Bifoldable (Bifoldable (..))
 import           Data.Bifunctor (Bifunctor (..))
-import           Data.List.NonEmpty (NonEmpty)
-import qualified Data.List.NonEmpty as NE
-import qualified Database.LSMTree.Internal.Monoidal as Monoidal
-import qualified Database.LSMTree.Internal.Normal as Normal
 
 data Entry v blobref
     = Insert !v
@@ -89,40 +76,14 @@ newtype NumEntries = NumEntries Int
 unNumEntries :: NumEntries -> Int
 unNumEntries (NumEntries x) = x
 
-{-------------------------------------------------------------------------------
-  Injections/projections
--------------------------------------------------------------------------------}
-
-updateToEntryNormal :: Normal.Update v blob -> Entry v blob
-updateToEntryNormal = \case
-    Normal.Insert v Nothing  -> Insert v
-    Normal.Insert v (Just b) -> InsertWithBlob v b
-    Normal.Delete            -> Delete
-
-entryToUpdateNormal :: Entry v blob -> Maybe (Normal.Update v blob)
-entryToUpdateNormal = \case
-    Insert v           -> Just (Normal.Insert v Nothing)
-    InsertWithBlob v b -> Just (Normal.Insert v (Just b))
-    Mupdate _          -> Nothing
-    Delete             -> Just Normal.Delete
-
-updateToEntryMonoidal :: Monoidal.Update v -> Entry v blob
-updateToEntryMonoidal = \case
-    Monoidal.Insert v  -> Insert v
-    Monoidal.Mupsert v -> Mupdate v
-    Monoidal.Delete    -> Delete
-
-entryToUpdateMonoidal :: Entry v blob -> Maybe (Monoidal.Update v)
-entryToUpdateMonoidal = \case
-    Insert v           -> Just (Monoidal.Insert v)
-    InsertWithBlob _ _ -> Nothing
-    Mupdate v          -> Just (Monoidal.Mupsert v)
-    Delete             -> Just Monoidal.Delete
-
 {-------------------------------------------------------------------------------
   Value resolution/merging
 -------------------------------------------------------------------------------}
 
+-- | As long as values are a semigroup, an Entry is too
+instance Semigroup v => Semigroup (Entry v blob) where
+  e1 <> e2 = combine (<>) e1 e2
+
 -- | Given a value-merge function, combine entries
 combine :: (v -> v -> v) -> Entry v blobref -> Entry v blobref -> Entry v blobref
 combine _ e@Delete            _                       = e
@@ -137,24 +98,3 @@ combineMaybe :: (v -> v -> v) -> Maybe (Entry v blobref) -> Maybe (Entry v blobr
 combineMaybe _ e1 Nothing          = e1
 combineMaybe _ Nothing e2          = e2
 combineMaybe f (Just e1) (Just e2) = Just $! combine f e1 e2
-
-combinesMonoidal :: (v -> v -> v) -> NonEmpty (Entry v blob) -> Entry v blob
-combinesMonoidal f = foldr1 (combine f) -- short-circuit fold
-
-combinesNormal :: NonEmpty (Entry v blob) -> Entry v blob
-combinesNormal = NE.head
-
--- | Returns 'Nothing' if the combined entries can not be mapped to an
--- 'Normal.Update'.
-resolveEntriesNormal ::
-     NonEmpty (Entry v blob)
-  -> Maybe (Normal.Update v blob)
-resolveEntriesNormal es = entryToUpdateNormal (combinesNormal es)
-
--- | Returns 'Nothing' if the combined entries can not be mapped to an
--- 'Monoidal.Update'.
-resolveEntriesMonoidal ::
-     (v -> v -> v)
-  -> NonEmpty (Entry v blob)
-  -> Maybe (Monoidal.Update v)
-resolveEntriesMonoidal f es = entryToUpdateMonoidal (combinesMonoidal f es)

src/Database/LSMTree/Internal/Monoidal.hs

@@ -2,25 +2,6 @@
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 
 -- | The in-memory LSM level 0.
---
--- === TODO
---
--- This is temporary module header documentation. The module will be
--- fleshed out more as we implement bits of it.
---
--- Related work packages: 5
---
--- This module includes in-memory parts parts for, amongst others,
---
--- * Incremental construction
---
--- * Updates (inserts, deletes, mupserts)
---
--- * Queries (lookups, range lookups)
---
--- The above list is a sketch. Functionality may move around, and the list is
--- not exhaustive.
---
 module Database.LSMTree.Internal.WriteBuffer (
     WriteBuffer,
     empty,
@@ -29,10 +10,7 @@ module Database.LSMTree.Internal.WriteBuffer (
     toMap,
     fromList,
     toList,
-    addEntries,
     addEntry,
-    addEntryMonoidal,
-    addEntryNormal,
     null,
     lookups,
     lookup,
@@ -46,8 +24,6 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Vector as V
 import           Database.LSMTree.Internal.BlobRef (BlobSpan)
 import           Database.LSMTree.Internal.Entry
-import qualified Database.LSMTree.Internal.Monoidal as Monoidal
-import qualified Database.LSMTree.Internal.Normal as Normal
 import           Database.LSMTree.Internal.Range (Range (..))
 import           Database.LSMTree.Internal.Serialise
 import qualified Database.LSMTree.Internal.Vector as V
@@ -94,13 +70,6 @@ toList (WB m) = Map.assocs m
   Updates
 -------------------------------------------------------------------------------}
 
-addEntries ::
-     (SerialisedValue -> SerialisedValue -> SerialisedValue) -- ^ merge function
-  -> V.Vector (SerialisedKey, Entry SerialisedValue BlobSpan)
-  -> WriteBuffer
-  -> WriteBuffer
-addEntries f es wb = V.foldl' (flip (uncurry (addEntry f))) wb es
-
 addEntry ::
      (SerialisedValue -> SerialisedValue -> SerialisedValue) -- ^ merge function
   -> SerialisedKey
@@ -110,21 +79,6 @@ addEntry ::
 addEntry f k e (WB wb) =
     WB (Map.insertWith (combine f) k e wb)
 
-addEntryMonoidal ::
-     (SerialisedValue -> SerialisedValue -> SerialisedValue) -- ^ merge function
-  -> SerialisedKey
-  -> Monoidal.Update SerialisedValue
-  -> WriteBuffer
-  -> WriteBuffer
-addEntryMonoidal f k = addEntry f k . updateToEntryMonoidal
-
-addEntryNormal ::
-     SerialisedKey
-  -> Normal.Update SerialisedValue BlobSpan
-  -> WriteBuffer
-  -> WriteBuffer
-addEntryNormal k = addEntry const k . updateToEntryNormal
-
 {-------------------------------------------------------------------------------
   Querying
 -------------------------------------------------------------------------------}