Skip to content

Commit 73106af

Browse files
jorisdraljorisdral
authored
Merge pull request #598 from IntersectMBO/jdral/union-credit-debt
Public API: add union debt/credits types and related functions
2 parents ec24627 + 636f233 commit 73106af

File tree

8 files changed

+203
-23
lines changed

8 files changed

+203
-23
lines changed

‎prototypes/ScheduledMerges.hs‎

Lines changed: 40 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -67,7 +67,9 @@ module ScheduledMerges (
6767
NominalDebt(..),
6868
Run,
6969
runSize,
70+
UnionCredits (..),
7071
supplyCreditsMergingTree,
72+
UnionDebt(..),
7173
remainingDebtMergingTree,
7274
mergek,
7375
mergeBatchSize,
@@ -840,25 +842,51 @@ unions lsms = do
840842
c <- newSTRef 0
841843
return (LSMHandle c lsmr)
842844

843-
-- | An upper bound on the number of merging steps that need to be performed
844-
-- until the delayed work of performing a 'union' is completed. This debt can
845-
-- be paid off using 'supplyUnionCredits'. This includes the cost for existing
846-
-- merges that were part of the union's input tables.
847-
remainingUnionDebt :: LSM s -> ST s Debt
845+
-- | The /current/ upper bound on the number of 'UnionCredits' that have to be
846+
-- supplied before a 'union' is completed.
847+
--
848+
-- The union debt is the number of merging steps that need to be performed /at
849+
-- most/ until the delayed work of performing a 'union' is completed. This
850+
-- includes the cost of completing merges that were part of the union's input
851+
-- tables.
852+
newtype UnionDebt = UnionDebt Debt
853+
deriving stock (Show, Eq, Ord)
854+
deriving newtype Num
855+
856+
-- | Return the current union debt. This debt can be reduced until it is paid
857+
-- off using 'supplyUnionCredits'.
858+
remainingUnionDebt :: LSM s -> ST s UnionDebt
848859
remainingUnionDebt (LSMHandle _ lsmr) = do
849860
LSMContent _ _ ul <- readSTRef lsmr
850-
case ul of
861+
UnionDebt <$> case ul of
851862
NoUnion -> return 0
852863
Union tree d -> checkedUnionDebt tree d
853864

854-
-- | Supplying credits leads to union merging work being performed in batches.
855-
-- This reduces the debt returned by 'remainingUnionDebt'.
856-
supplyUnionCredits :: LSM s -> Credit -> ST s Credit
857-
supplyUnionCredits (LSMHandle scr lsmr) credits
858-
| credits <= 0 = return 0
865+
-- | Credits are used to pay off 'UnionDebt', completing a 'union' in the
866+
-- process.
867+
--
868+
-- A union credit corresponds to a single merging step being performed.
869+
newtype UnionCredits = UnionCredits Credit
870+
deriving stock (Show, Eq, Ord)
871+
deriving newtype Num
872+
873+
-- | Supply union credits to reduce union debt.
874+
--
875+
-- Supplying union credits leads to union merging work being performed in
876+
-- batches. This reduces the union debt returned by 'remainingUnionDebt'. Union
877+
-- debt will be reduced by /at least/ the number of supplied union credits. It
878+
-- is therefore advisable to query 'remainingUnionDebt' every once in a while to
879+
-- see what the current debt is.
880+
--
881+
-- This function returns any surplus of union credits as /leftover/ credits when
882+
-- a union has finished. In particular, if the returned number of credits is
883+
-- non-negative, then the union is finished.
884+
supplyUnionCredits :: LSM s -> UnionCredits -> ST s UnionCredits
885+
supplyUnionCredits (LSMHandle scr lsmr) (UnionCredits credits)
886+
| credits <= 0 = return (UnionCredits 0)
859887
| otherwise = do
860888
content@(LSMContent _ _ ul) <- readSTRef lsmr
861-
case ul of
889+
UnionCredits <$> case ul of
862890
NoUnion ->
863891
return credits
864892
Union tree debtRef -> do

‎prototypes/ScheduledMergesTest.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -184,14 +184,14 @@ prop_union kopss = length (filter (not . null) kopss) > 1 QC.==>
184184
ts <- traverse (mkTable tr) kopss
185185
t <- LSM.unions ts
186186

187-
debt <- LSM.remainingUnionDebt t
188-
_ <- LSM.supplyUnionCredits t debt
187+
debt@(UnionDebt x) <- LSM.remainingUnionDebt t
188+
_ <- LSM.supplyUnionCredits t (UnionCredits x)
189189
debt' <- LSM.remainingUnionDebt t
190190

191191
rep <- dumpRepresentation t
192192
return $ QC.counterexample (show (debt, debt')) $ QC.conjoin
193-
[ debt =/= 0
194-
, debt' === 0
193+
[ debt =/= UnionDebt 0
194+
, debt' === UnionDebt 0
195195
, hasUnionWith isCompleted rep
196196
]
197197
where

‎prototypes/ScheduledMergesTestQLS.hs‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,7 @@
11
{-# LANGUAGE TypeFamilies #-}
22

3+
{-# OPTIONS_GHC -Wno-orphans #-}
4+
35
module ScheduledMergesTestQLS (tests) where
46

57
import Control.Monad.ST
@@ -73,7 +75,7 @@ modelMupsert :: ModelLSM -> Key -> Value -> ModelOp ()
7375
modelLookup :: ModelLSM -> Key -> ModelOp (LookupResult Value Blob)
7476
modelDuplicate :: ModelLSM -> ModelOp ModelLSM
7577
modelUnions :: [ModelLSM] -> ModelOp ModelLSM
76-
modelSupplyUnion :: ModelLSM -> NonNegative Credit -> ModelOp ()
78+
modelSupplyUnion :: ModelLSM -> NonNegative UnionCredits -> ModelOp ()
7779
modelDump :: ModelLSM -> ModelOp (Map Key (Value, Maybe Blob))
7880

7981
modelNew Model {mlsms} =
@@ -150,7 +152,7 @@ instance StateModel (Lockstep Model) where
150152
-> Action (Lockstep Model) (LSM RealWorld)
151153

152154
ASupplyUnion :: ModelVar Model (LSM RealWorld)
153-
-> NonNegative Credit
155+
-> NonNegative UnionCredits
154156
-> Action (Lockstep Model) ()
155157

156158
ADump :: ModelVar Model (LSM RealWorld)
@@ -318,6 +320,7 @@ instance InLockstep Model where
318320

319321
shrinkWithVars _ctx _model _action = []
320322

323+
deriving newtype instance Arbitrary UnionCredits
321324

322325
instance RunLockstep Model IO where
323326
observeReal _ action result =

‎src/Database/LSMTree.hs‎

Lines changed: 22 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -83,6 +83,10 @@ module Database.LSMTree (
8383
-- * Table union
8484
, union
8585
, unions
86+
, UnionDebt (..)
87+
, remainingUnionDebt
88+
, UnionCredits (..)
89+
, supplyUnionCredits
8690

8791
-- * Serialisation
8892
, SerialiseKey
@@ -112,8 +116,8 @@ import Data.Typeable (Proxy (..), Typeable, eqT, type (:~:) (Refl))
112116
import qualified Data.Vector as V
113117
import Database.LSMTree.Common (BlobRef (BlobRef), IOLike, Range (..),
114118
SerialiseKey, SerialiseValue, Session, SnapshotName,
115-
closeSession, deleteSnapshot, listSnapshots, openSession,
116-
withSession)
119+
UnionCredits (..), UnionDebt (..), closeSession,
120+
deleteSnapshot, listSnapshots, openSession, withSession)
117121
import qualified Database.LSMTree.Common as Common
118122
import qualified Database.LSMTree.Internal as Internal
119123
import qualified Database.LSMTree.Internal.BlobRef as Internal
@@ -552,6 +556,22 @@ unions (t :| ts) =
552556
| Just Refl <- eqT @h @h' = pure t'
553557
| otherwise = throwIO (Internal.ErrUnionsTableTypeMismatch 0 i)
554558

559+
{-# SPECIALISE remainingUnionDebt :: Table IO k v b -> IO UnionDebt #-}
560+
remainingUnionDebt :: IOLike m => Table m k v b -> m UnionDebt
561+
remainingUnionDebt (Internal.Table' t) =
562+
(\(Internal.UnionDebt x) -> UnionDebt x) <$>
563+
Internal.remainingUnionDebt t
564+
565+
{-# SPECIALISE supplyUnionCredits :: Table IO k v b -> UnionCredits -> IO UnionCredits #-}
566+
supplyUnionCredits ::
567+
IOLike m
568+
=> Table m k v b
569+
-> UnionCredits
570+
-> m UnionCredits
571+
supplyUnionCredits (Internal.Table' t) (UnionCredits credits) =
572+
(\(Internal.UnionCredits x) -> UnionCredits x) <$>
573+
Internal.supplyUnionCredits t (Internal.UnionCredits credits)
574+
555575
{-------------------------------------------------------------------------------
556576
Monoidal value resolution
557577
-------------------------------------------------------------------------------}

‎src/Database/LSMTree/Common.hs‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -43,6 +43,9 @@ module Database.LSMTree.Common (
4343
, Internal.TableConfigOverride
4444
, Internal.configNoOverride
4545
, Internal.configOverrideDiskCachePolicy
46+
-- * Unions
47+
, UnionDebt (..)
48+
, UnionCredits (..)
4649
) where
4750

4851
import Control.Concurrent.Class.MonadMVar.Strict
@@ -259,3 +262,24 @@ data BlobRef m b where
259262

260263
instance Show (BlobRef m b) where
261264
showsPrec d (BlobRef b) = showsPrec d b
265+
266+
{-------------------------------------------------------------------------------
267+
Unions
268+
-------------------------------------------------------------------------------}
269+
270+
-- | The /current/ upper bound on the number of 'UnionCredits' that have to be
271+
-- supplied before a @union@ is completed.
272+
--
273+
-- The union debt is the number of merging steps that need to be performed /at
274+
-- most/ until the delayed work of performing a @union@ is completed. This
275+
-- includes the cost of completing merges that were part of the union's input
276+
-- tables.
277+
newtype UnionDebt = UnionDebt Int
278+
deriving stock (Show, Eq)
279+
280+
-- | Credits are used to pay off 'UnionDebt', completing a @union@ in the
281+
-- process.
282+
--
283+
-- A union credit corresponds to a single merging step being performed.
284+
newtype UnionCredits = UnionCredits Int
285+
deriving stock (Show, Eq)

‎src/Database/LSMTree/Internal.hs‎

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -68,6 +68,10 @@ module Database.LSMTree.Internal (
6868
, duplicate
6969
-- * Table union
7070
, unions
71+
, UnionDebt (..)
72+
, remainingUnionDebt
73+
, UnionCredits (..)
74+
, supplyUnionCredits
7175
) where
7276

7377
import Codec.CBOR.Read
@@ -275,6 +279,9 @@ data TableTrace =
275279
| TraceSnapshot SnapshotName
276280
-- Duplicate
277281
| TraceDuplicate
282+
-- Unions
283+
| TraceRemainingUnionDebt
284+
| TraceSupplyUnionCredits UnionCredits
278285
deriving stock Show
279286

280287
data CursorTrace =
@@ -1535,3 +1542,34 @@ matchSessions = \(t :| ts) ->
15351542
else pure (Left i)
15361543

15371544
withSessionRoot t k = withOpenSession (tableSession t) $ k . sessionRoot
1545+
1546+
{-------------------------------------------------------------------------------
1547+
Table union: debt and credit
1548+
-------------------------------------------------------------------------------}
1549+
1550+
-- | See 'Database.LSMTree.Normal.UnionDebt'.
1551+
newtype UnionDebt = UnionDebt Int
1552+
deriving newtype (Show, Eq)
1553+
1554+
{-# SPECIALISE remainingUnionDebt :: Table IO h -> IO UnionDebt #-}
1555+
-- | See 'Database.LSMTree.Normal.remainingUnionDebt'.
1556+
remainingUnionDebt :: (MonadSTM m, MonadThrow m) => Table m h -> m UnionDebt
1557+
remainingUnionDebt t = do
1558+
traceWith (tableTracer t) TraceRemainingUnionDebt
1559+
withOpenTable t $ \tEnv -> do
1560+
RW.withReadAccess (tableContent tEnv) $ \_tableContent -> do
1561+
error "remainingUnionDebt: not yet implemented"
1562+
1563+
-- | See 'Database.LSMTree.Normal.UnionCredits'.
1564+
newtype UnionCredits = UnionCredits Int
1565+
deriving newtype (Show, Eq)
1566+
1567+
{-# SPECIALISE supplyUnionCredits :: Table IO h -> UnionCredits -> IO UnionCredits #-}
1568+
-- | See 'Database.LSMTree.Normal.supplyUnionCredits'.
1569+
supplyUnionCredits :: (MonadSTM m, MonadCatch m) => Table m h -> UnionCredits -> m UnionCredits
1570+
supplyUnionCredits t credits = do
1571+
traceWith (tableTracer t) $ TraceSupplyUnionCredits credits
1572+
withOpenTable t $ \tEnv -> do
1573+
-- TODO: should this be acquiring read or write access?
1574+
RW.withWriteAccess (tableContent tEnv) $ \_tableContent -> do
1575+
error "supplyUnionCredits: not yet implemented"

‎src/Database/LSMTree/Monoidal.hs‎

Lines changed: 35 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -100,6 +100,10 @@ module Database.LSMTree.Monoidal (
100100
-- * Table union
101101
, union
102102
, unions
103+
, UnionDebt (..)
104+
, remainingUnionDebt
105+
, UnionCredits (..)
106+
, supplyUnionCredits
103107

104108
-- * Concurrency
105109
-- $concurrency
@@ -132,7 +136,8 @@ import Data.Proxy (Proxy (Proxy))
132136
import Data.Typeable (Typeable, eqT, type (:~:) (Refl))
133137
import qualified Data.Vector as V
134138
import Database.LSMTree.Common (IOLike, Range (..), SerialiseKey,
135-
SerialiseValue (..), Session, SnapshotName, closeSession,
139+
SerialiseValue (..), Session, SnapshotName,
140+
UnionCredits (..), UnionDebt (..), closeSession,
136141
deleteSnapshot, listSnapshots, openSession, withSession)
137142
import qualified Database.LSMTree.Common as Common
138143
import qualified Database.LSMTree.Internal as Internal
@@ -700,6 +705,35 @@ unions (t :| ts) =
700705
| Just Refl <- eqT @h @h' = pure t'
701706
| otherwise = throwIO (Internal.ErrUnionsTableTypeMismatch 0 i)
702707

708+
{-# SPECIALISE remainingUnionDebt :: Table IO k v -> IO UnionDebt #-}
709+
-- | Return the current union debt. This debt can be reduced until it is paid
710+
-- off using @supplyUnionCredits@.
711+
remainingUnionDebt :: IOLike m => Table m k v -> m UnionDebt
712+
remainingUnionDebt (Internal.MonoidalTable t) =
713+
(\(Internal.UnionDebt x) -> UnionDebt x) <$>
714+
Internal.remainingUnionDebt t
715+
716+
{-# SPECIALISE supplyUnionCredits :: Table IO k v -> UnionCredits -> IO UnionCredits #-}
717+
-- | Supply union credits to reduce union debt.
718+
--
719+
-- Supplying union credits leads to union merging work being performed in
720+
-- batches. This reduces the union debt returned by @remainingUnionDebt@. Union
721+
-- debt will be reduced by /at least/ the number of supplied union credits. It
722+
-- is therefore advisable to query @remainingUnionDebt@ every once in a while to
723+
-- see what the current debt is.
724+
--
725+
-- This function returns any surplus of union credits as /leftover/ credits when
726+
-- a union has finished. In particular, if the returned number of credits is
727+
-- non-negative, then the union is finished.
728+
supplyUnionCredits ::
729+
IOLike m
730+
=> Table m k v
731+
-> UnionCredits
732+
-> m UnionCredits
733+
supplyUnionCredits (Internal.MonoidalTable t) (UnionCredits credits) =
734+
(\(Internal.UnionCredits x) -> UnionCredits x) <$>
735+
Internal.supplyUnionCredits t (Internal.UnionCredits credits)
736+
703737
{-------------------------------------------------------------------------------
704738
Monoidal value resolution
705739
-------------------------------------------------------------------------------}

‎src/Database/LSMTree/Normal.hs‎

Lines changed: 35 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -101,6 +101,10 @@ module Database.LSMTree.Normal (
101101
-- * Table union
102102
, union
103103
, unions
104+
, UnionDebt (..)
105+
, remainingUnionDebt
106+
, UnionCredits (..)
107+
, supplyUnionCredits
104108

105109
-- * Concurrency #concurrency#
106110
-- $concurrency
@@ -123,8 +127,8 @@ import Data.Typeable (Typeable, eqT, type (:~:) (Refl))
123127
import qualified Data.Vector as V
124128
import Database.LSMTree.Common (BlobRef (BlobRef), IOLike, Range (..),
125129
SerialiseKey, SerialiseValue, Session, SnapshotName,
126-
closeSession, deleteSnapshot, listSnapshots, openSession,
127-
withSession)
130+
UnionCredits (..), UnionDebt (..), closeSession,
131+
deleteSnapshot, listSnapshots, openSession, withSession)
128132
import qualified Database.LSMTree.Common as Common
129133
import qualified Database.LSMTree.Internal as Internal
130134
import qualified Database.LSMTree.Internal.BlobRef as Internal
@@ -820,3 +824,32 @@ unions (t :| ts) =
820824
checkTableType _ i (Internal.NormalTable (t' :: Internal.Table m h'))
821825
| Just Refl <- eqT @h @h' = pure t'
822826
| otherwise = throwIO (Internal.ErrUnionsTableTypeMismatch 0 i)
827+
828+
{-# SPECIALISE remainingUnionDebt :: Table IO k v b -> IO UnionDebt #-}
829+
-- | Return the current union debt. This debt can be reduced until it is paid
830+
-- off using @supplyUnionCredits@.
831+
remainingUnionDebt :: IOLike m => Table m k v b -> m UnionDebt
832+
remainingUnionDebt (Internal.NormalTable t) =
833+
(\(Internal.UnionDebt x) -> UnionDebt x) <$>
834+
Internal.remainingUnionDebt t
835+
836+
{-# SPECIALISE supplyUnionCredits :: Table IO k v b -> UnionCredits -> IO UnionCredits #-}
837+
-- | Supply union credits to reduce union debt.
838+
--
839+
-- Supplying union credits leads to union merging work being performed in
840+
-- batches. This reduces the union debt returned by @remainingUnionDebt@. Union
841+
-- debt will be reduced by /at least/ the number of supplied union credits. It
842+
-- is therefore advisable to query @remainingUnionDebt@ every once in a while to
843+
-- see what the current debt is.
844+
--
845+
-- This function returns any surplus of union credits as /leftover/ credits when
846+
-- a union has finished. In particular, if the returned number of credits is
847+
-- non-negative, then the union is finished.
848+
supplyUnionCredits ::
849+
IOLike m
850+
=> Table m k v b
851+
-> UnionCredits
852+
-> m UnionCredits
853+
supplyUnionCredits (Internal.NormalTable t) (UnionCredits credits) =
854+
(\(Internal.UnionCredits x) -> UnionCredits x) <$>
855+
Internal.supplyUnionCredits t (Internal.UnionCredits credits)

0 commit comments

Comments
 (0)