Expose a method for retrieving UTxO set size from the ChainDB

We test this by:
* Extending the BackingStore model-based tests for `bsStat`
* Extending the OnDisk tests for `getCurrentLedgerTableSize`

cabal.project

@@ -93,7 +93,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: febddc58683186232db5fa376de65c58973f9686
+  tag: ff9982e22d6c8e5a3af4bd3e87794a3b27e91afa
   subdir:
    libs/cardano-ledger-binary
   --sha256: 0q6c2f4ld5l85153q8xrm2qc64k8p0y66j6adcl8bga31yd0pl16

ouroboros-consensus/ouroboros-consensus.cabal

@@ -53,6 +53,7 @@ common common-bench
     -Wredundant-constraints -Wmissing-export-lists -Wunused-packages
     -Wno-unticked-promoted-constructors -rtsopts -with-rtsopts=-A32m
     -threaded
+
   -- We use this option to avoid skewed results due to changes in cache-line
   -- alignment. See
   -- https://github.com/Bodigrim/tasty-bench#comparison-against-baseline

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables.hs

@@ -1,15 +1,17 @@
-{-# LANGUAGE DataKinds                #-}
-{-# LANGUAGE DefaultSignatures        #-}
-{-# LANGUAGE DeriveAnyClass           #-}
-{-# LANGUAGE DeriveGeneric            #-}
-{-# LANGUAGE DerivingStrategies       #-}
-{-# LANGUAGE FlexibleContexts         #-}
-{-# LANGUAGE GADTs                    #-}
-{-# LANGUAGE QuantifiedConstraints    #-}
-{-# LANGUAGE Rank2Types               #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE TypeFamilies             #-}
-{-# LANGUAGE UndecidableInstances     #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE QuantifiedConstraints      #-}
+{-# LANGUAGE Rank2Types                 #-}
+{-# LANGUAGE StandaloneKindSignatures   #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
 
 -- | See @'LedgerTables'@
 module Ouroboros.Consensus.Ledger.Tables (
@@ -26,6 +28,7 @@ module Ouroboros.Consensus.Ledger.Tables (
     -- ** Concrete definitions
   , Canonical (..)
   , CodecMK (..)
+  , ConstMK (..)
   , DiffMK (..)
   , EmptyMK (..)
   , KeysMK (..)
@@ -422,7 +425,7 @@ newtype KeysMK     k v = KeysMK      (Set k)
   deriving stock (Generic, Eq, Show)
   deriving anyclass NoThunks
 
-newtype SeqDiffMK  k v = SeqDiffMK   (DiffSeq k v)
+newtype SeqDiffMK  k v = SeqDiffMK { getSeqDiffMK :: DiffSeq k v }
   deriving stock (Generic, Eq, Show)
   deriving anyclass NoThunks
 
@@ -489,6 +492,12 @@ instance Ord k => Monoid (KeysMK k v) where
 instance Functor (DiffMK k) where
   fmap f (DiffMK d) = DiffMK $ fmap f d
 
+newtype ConstMK a k v = ConstMK { getConstMK :: a }
+  deriving stock (Generic, Eq, Show, Functor)
+  deriving newtype (Semigroup, Monoid)
+  deriving anyclass NoThunks
+  deriving anyclass IsMapKind
+
 {-------------------------------------------------------------------------------
   Serialization Codecs
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables/DiffSeq.hs

@@ -71,12 +71,15 @@ module Ouroboros.Consensus.Ledger.Tables.DiffSeq (
   , SlotNoUB (..)
     -- * Short-hands for type-class constraints
   , SM
-    -- * API: derived functions
-  , append
+    -- * Queries
   , cumulativeDiff
+  , length
+  , numDeletes
+  , numInserts
+    -- * Construction
+  , append
   , empty
   , extend
-  , length
     -- * Slots
   , maxSlot
   , minSlot
@@ -93,13 +96,15 @@ import qualified Control.Exception as Exn
 import           Data.Bifunctor (Bifunctor (bimap))
 import           Data.FingerTree.RootMeasured.Strict hiding (split)
 import qualified Data.FingerTree.RootMeasured.Strict as RMFT (splitSized)
-import           Data.Map.Diff.Strict as MapDiff
+import           Data.Map.Diff.Strict (Diff)
+import qualified Data.Map.Diff.Strict as Diff
 import           Data.Maybe.Strict
 import           Data.Monoid (Sum (..))
 import           Data.Semigroup (Max (..), Min (..))
 import           Data.Semigroup.Cancellative
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks)
+import           Ouroboros.Consensus.Util.Orphans ()
 import           Prelude hiding (length, splitAt)
 
 {-------------------------------------------------------------------------------
@@ -125,9 +130,13 @@ newtype DiffSeq k v =
 -- cancellative monoid.
 data RootMeasure k v = RootMeasure {
     -- | Cumulative length
-    rmLength :: {-# UNPACK #-} !Length
+    rmLength     :: {-# UNPACK #-} !Length
     -- | Cumulative diff
-  , rmDiff   :: !(Diff k v)
+  , rmDiff       :: !(Diff k v)
+    -- | Cumulative number of inserts
+  , rmNumInserts :: !(Sum Int)
+    -- | Cumulative number of deletes
+  , rmNumDeletes :: !(Sum Int)
   }
   deriving stock (Generic, Show, Eq, Functor)
   deriving anyclass (NoThunks)
@@ -190,22 +199,25 @@ noSlotBoundsIntersect (SlotNoUB sl1) (SlotNoLB sl2) = sl1 <= sl2
 -------------------------------------------------------------------------------}
 
 instance (Ord k, Eq v) => RootMeasured (RootMeasure k v) (Element k v) where
-  measureRoot (Element _ d) = RootMeasure 1 d
+  measureRoot (Element _ d) =
+      RootMeasure 1 d (Sum $ Diff.numInserts d) (Sum $ Diff.numDeletes d)
 
 instance (Ord k, Eq v) => Semigroup (RootMeasure k v) where
-  RootMeasure len1 d1 <> RootMeasure len2 d2 =
-      RootMeasure (len1 <> len2) (d1 <> d2)
+  RootMeasure len1 d1 n1 m1 <> RootMeasure len2 d2 n2 m2 =
+      RootMeasure (len1 <> len2) (d1 <> d2) (n1 <> n2) (m1 <> m2)
 
 instance (Ord k, Eq v) => Monoid (RootMeasure k v) where
-  mempty = RootMeasure mempty mempty
+  mempty = RootMeasure mempty mempty mempty mempty
 
 instance (Ord k, Eq v) => LeftReductive (RootMeasure k v) where
-  stripPrefix (RootMeasure len1 d1) (RootMeasure len2 d2) =
+  stripPrefix (RootMeasure len1 d1 n1 m1) (RootMeasure len2 d2 n2 m2) =
       RootMeasure <$> stripPrefix len1 len2 <*> stripPrefix d1 d2
+                  <*> stripPrefix n1 n2     <*> stripPrefix m1 m2
 
 instance (Ord k, Eq v) => RightReductive (RootMeasure k v) where
-  stripSuffix (RootMeasure len1 d1) (RootMeasure len2 d2) =
+  stripSuffix (RootMeasure len1 d1 n1 m1) (RootMeasure len2 d2 n2 m2) =
       RootMeasure <$> stripSuffix len1 len2 <*> stripSuffix d1 d2
+                  <*> stripSuffix n1 n2     <*> stripSuffix m1 m2
 
 instance (Ord k, Eq v) => LeftCancellative (RootMeasure k v)
 instance (Ord k, Eq v) => RightCancellative (RootMeasure k v)
@@ -251,6 +263,16 @@ length ::
   => DiffSeq k v -> Int
 length (UnsafeDiffSeq ft) = unLength . rmLength $ measureRoot ft
 
+numInserts ::
+     SM k v
+  => DiffSeq k v -> Sum Int
+numInserts (UnsafeDiffSeq ft) = rmNumInserts $ measureRoot ft
+
+numDeletes ::
+     SM k v
+  => DiffSeq k v -> Sum Int
+numDeletes (UnsafeDiffSeq ft) = rmNumInserts $ measureRoot ft
+
 {-------------------------------------------------------------------------------
   Construction
 -------------------------------------------------------------------------------}
@@ -315,7 +337,8 @@ split ::
   => (InternalMeasure k v -> Bool)
   -> DiffSeq k v
   -> (DiffSeq k v, DiffSeq k v)
-split p (UnsafeDiffSeq ft) = bimap UnsafeDiffSeq UnsafeDiffSeq $ RMFT.splitSized p ft
+split p (UnsafeDiffSeq ft) = bimap UnsafeDiffSeq UnsafeDiffSeq $
+    RMFT.splitSized p ft
 
 splitAt ::
      SM k v

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs

@@ -1,16 +1,27 @@
 {-# LANGUAGE DataKinds   #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE GADTs       #-}
 {-# LANGUAGE RankNTypes  #-}
 
-module Ouroboros.Consensus.Storage.LedgerDB.API (LedgerDB (..)) where
+module Ouroboros.Consensus.Storage.LedgerDB.API (
+    LedgerDB (..)
+  , LedgerDBView2 (..)
+  , fromLDB
+  ) where
 
 import           Control.Concurrent.Class.MonadSTM.Strict
+import           Data.Monoid (Sum (..))
 import           Data.Set (Set)
+import           Data.SOP (K (K))
 import           Data.Word
 import           NoThunks.Class
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.Ledger.Abstract (getTipSlot)
 import           Ouroboros.Consensus.Ledger.Extended
+import           Ouroboros.Consensus.Ledger.SupportsProtocol
+                     (LedgerSupportsProtocol)
 import           Ouroboros.Consensus.Ledger.Tables
+import           Ouroboros.Consensus.Ledger.Tables.DiffSeq
 import           Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
 import           Ouroboros.Consensus.Storage.LedgerDB.BackingStore
 import           Ouroboros.Consensus.Storage.LedgerDB.Config
@@ -82,3 +93,48 @@ data LedgerDB m blk = LedgerDB {
          -- ^ How many blocks have been processed since the last snapshot.
       -> m SnapCounters
   } deriving NoThunks via OnlyCheckWhnfNamed "LedgerDB" (LedgerDB m blk)
+
+{-------------------------------------------------------------------------------
+  LedgerDBView2
+-------------------------------------------------------------------------------}
+
+-- TODO: cleanup
+
+newtype LedgerDBView2 m blk = LedgerDBView2 {
+    ldbStat :: m Statistics
+  }
+
+fromLDB ::
+     (Monad m, LedgerSupportsProtocol blk)
+  => LedgerDBView m b blk -> LedgerDBView2 m blk
+fromLDB ldb = case ldb of
+      StaticLeft (lbsvh, dblog) -> mkIt lbsvh dblog
+      StaticRight x -> case x of
+        Left e               -> error (show e)
+        Right (lbsvh, dblog) -> mkIt lbsvh dblog
+  where
+    mkIt lbsvh dblog = LedgerDBView2 {
+        ldbStat = mkLdbStat lbsvh dblog
+      }
+
+    mkLdbStat lbsvh dblog = do
+        Statistics{sequenceNumber = seqNo', numEntries = n} <- bsvhStat vh
+        if seqNo /= seqNo' then
+          error $ show (seqNo, seqNo')
+        else
+          pure $ Statistics {
+              sequenceNumber = getTipSlot $ K dblog
+            , numEntries = n + nInserts - nDeletes
+            }
+      where
+        LedgerBackingStoreValueHandle _ vh = lbsvh
+
+        diffs = changelogDiffs dblog
+        seqNo = getTipSlot $ changelogLastFlushedState dblog
+
+        nInserts = getSum
+                $ foldLedgerTables (numInserts . getSeqDiffMK)
+                  diffs
+        nDeletes = getSum
+                $ foldLedgerTables (numDeletes . getSeqDiffMK)
+                  diffs

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/BackingStore.hs

@@ -22,6 +22,8 @@ module Ouroboros.Consensus.Storage.LedgerDB.BackingStore (
   , RangeQuery (..)
   , bsRead
   , withBsValueHandle
+    -- * Statistics
+  , Statistics (..)
     -- * Ledger DB wrappers
   , LedgerBackingStore (..)
   , LedgerBackingStore'
@@ -95,6 +97,8 @@ data BackingStoreValueHandle m keys values = BackingStoreValueHandle {
     -- Absent keys will merely not be present in the result instead of causing a
     -- failure or an exception.
   , bsvhRead      :: !(keys -> m values)
+    -- | Retrieve statistics
+  , bsvhStat      :: !(m Statistics)
   }
 
 castBackingStoreValueHandle ::
@@ -105,16 +109,18 @@ castBackingStoreValueHandle ::
   -> BackingStoreValueHandle m keys' values'
 castBackingStoreValueHandle f g bsvh =
   BackingStoreValueHandle {
-    bsvhClose
+      bsvhClose
     , bsvhRangeRead = \(RangeQuery prev count) ->
         fmap f . bsvhRangeRead $  RangeQuery (fmap g prev) count
     , bsvhRead = fmap f . bsvhRead . g
+    , bsvhStat
     }
   where
     BackingStoreValueHandle {
         bsvhClose
       , bsvhRangeRead
       , bsvhRead
+      , bsvhStat
       } = bsvh
 
 data RangeQuery keys = RangeQuery {
@@ -163,6 +169,19 @@ withBsValueHandle store kont =
       (bsvhClose . snd)
       (uncurry kont)
 
+{-------------------------------------------------------------------------------
+  Statistics
+-------------------------------------------------------------------------------}
+
+-- | Statistics that can be gather from a backing store value handle.
+data Statistics = Statistics {
+    -- | The last slot number for which key-value pairs were written.
+    sequenceNumber :: !(WithOrigin SlotNo)
+    -- | The total number of key-value pair entries that are stored.
+  , numEntries     :: !Int
+  }
+  deriving stock (Show, Eq)
+
 {-------------------------------------------------------------------------------
   Ledger DB wrappers
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/BackingStore/InMemory.hs

@@ -78,12 +78,13 @@ newTVarBackingStoreInitialiser ::
   -> (keys -> values -> values)
   -> (RangeQuery keys -> values -> values)
   -> (values -> diff -> values)
+  -> (values -> Int)
   -> (values -> CBOR.Encoding)
   -> (forall s. CBOR.Decoder s values)
   -> SomeHasFS m
   -> InitFrom values
   -> m (BackingStore m keys values diff)
-newTVarBackingStoreInitialiser tracer lookup_ rangeRead_ forwardValues_ enc dec (SomeHasFS fs0) initialization = do
+newTVarBackingStoreInitialiser tracer lookup_ rangeRead_ forwardValues_ count_ enc dec (SomeHasFS fs0) initialization = do
     traceWith tracer TVarTraceOpening
     ref <- do
       (slot, values) <- case initialization of
@@ -144,6 +145,10 @@ newTVarBackingStoreInitialiser tracer lookup_ rangeRead_ forwardValues_ enc dec
                     guardClosed ref
                     guardHandleClosed refHandleClosed
                     pure $ lookup_ keys values
+                , bsvhStat = atomically $ do
+                    guardClosed ref
+                    guardHandleClosed refHandleClosed
+                    pure $ Statistics slot (count_ values)
                 }
       , bsWrite    = \slot2 diff -> do
          slot1 <- atomically $ do

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/BackingStore/Init.hs

@@ -16,6 +16,7 @@ import           Control.Tracer
 import           Data.Functor.Contravariant
 import qualified Data.Map.Diff.Strict as Diff
 import qualified Data.Map.Strict as Map
+import           Data.Monoid (Sum (..))
 import qualified Data.Set as Set
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.Tables
@@ -83,6 +84,7 @@ newBackingStoreInitialiser trcr bss =
             zipLedgerTables (rangeRead_  (rqCount rq)) keys values
       )
       (zipLedgerTables applyDiff_)
+      (getSum . foldLedgerTables count_)
       valuesMKEncoder
       valuesMKDecoder
   where
@@ -120,6 +122,9 @@ newBackingStoreInitialiser trcr bss =
     applyDiff_ (ValuesMK values) (DiffMK diff) =
       ValuesMK (Diff.applyDiff values diff)
 
+    count_ :: ValuesMK k v -> Sum Int
+    count_ (ValuesMK values) = Sum $ Map.size values
+
 -- | The backing store selector
 data BackingStoreSelector m where
   LMDBBackingStore     :: MonadIO m => !LMDB.LMDBLimits -> BackingStoreSelector m