db-analyser: draft --benchmark-ledger-ops

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Analysis.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE LambdaCase          #-}
 {-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE PatternSynonyms     #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections       #-}
@@ -22,16 +23,22 @@ import           Data.List (intercalate)
 import qualified Data.Map.Strict as Map
 import           Data.Word (Word16, Word64)
 import qualified Debug.Trace as Debug
+import qualified GHC.Stats as GC
 import           NoThunks.Class (noThunks)
+import qualified System.IO as IO
 
+import qualified Cardano.Slotting.Slot as Slotting
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
+import           Ouroboros.Consensus.Forecast (forecastFor)
 import           Ouroboros.Consensus.HeaderValidation (HasAnnTip (..),
-                     HeaderState (..), annTipPoint)
+                     HeaderState (..), annTipPoint, tickHeaderState,
+                     validateHeader)
 import           Ouroboros.Consensus.Ledger.Abstract (LedgerCfg, LedgerConfig,
-                     applyChainTick, tickThenApplyLedgerResult, tickThenReapply)
+                     applyBlockLedgerResult, applyChainTick,
+                     tickThenApplyLedgerResult, tickThenReapply)
 import           Ouroboros.Consensus.Ledger.Basics (LedgerResult (..),
-                     LedgerState)
+                     LedgerState, getTipSlot)
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.SupportsMempool
                      (LedgerSupportsMempool)
@@ -44,6 +51,7 @@ import qualified Ouroboros.Consensus.Mempool.TxSeq as MP
 import           Ouroboros.Consensus.Storage.Common (BlockComponent (..),
                      StreamFrom (..))
 import           Ouroboros.Consensus.Storage.FS.API (SomeHasFS (..))
+import           Ouroboros.Consensus.Util.Condense (condense)
 import qualified Ouroboros.Consensus.Util.IOLike as IOLike
 import           Ouroboros.Consensus.Util.ResourceRegistry
 
@@ -76,6 +84,7 @@ data AnalysisName =
   | CountBlocks
   | CheckNoThunksEvery Word64
   | TraceLedgerProcessing
+  | BenchmarkLedgerOps
   | ReproMempoolAndForge Int
   deriving Show
 
@@ -111,6 +120,7 @@ runAnalysis analysisName env@(AnalysisEnv { tracer }) = do
     go CountBlocks                 = countBlocks env
     go (CheckNoThunksEvery nBks)   = checkNoThunksEvery nBks env
     go TraceLedgerProcessing       = traceLedgerProcessing env
+    go BenchmarkLedgerOps          = benchmarkLedgerOps env
     go (ReproMempoolAndForge nBks) = reproMempoolForge nBks env
 
 type Analysis blk = AnalysisEnv IO blk -> IO (Maybe AnalysisResult)
@@ -450,6 +460,123 @@ traceLedgerProcessing
       mapM_ Debug.traceMarkerIO traces
       return $ newLedger
 
+{-------------------------------------------------------------------------------
+  Analysis: maintain a ledger state and time the five major ledger calculations
+  for each block
+-------------------------------------------------------------------------------}
+
+data St blk = St {- !IOLike.Time -} !GC.RTSStats !(ExtLedgerState blk)
+
+infixl :&
+pattern (:&) :: a -> b -> (a, b)
+pattern x :& y = (x, y)
+{-# COMPLETE (:&) #-}
+
+benchmarkLedgerOps ::
+  forall blk.
+     ( HasAnalysis blk
+     , LedgerSupportsProtocol blk
+     )
+  => Analysis blk
+benchmarkLedgerOps
+  (AnalysisEnv {db, registry, initLedger, cfg, limit}) = do
+    IO.hSetBuffering IO.stdout (IO.BlockBuffering $ Just $ 4*1024*1024)   -- useful?
+    putStrLn $ unwords $ reverse $ "...era-specific stats" : theHeadings
+
+    rtsStats <- GC.getRTSStats
+    let st0 = St rtsStats initLedger
+
+    void $ processAll db registry GetBlock initLedger limit st0 process
+  where
+    ccfg = topLevelConfigProtocol cfg
+    lcfg = topLevelConfigLedger   cfg
+
+    _showTimeDiff t' t = show $ fromEnum (t' `IOLike.diffTime` t) `div` 1000000
+
+    -- nanoseconds from RTS
+    showNsDiff t' t = show $ (t' - t) `div` 1000
+
+    (theHeadings, theCells) =
+        let infixl `o`
+            (headings, acc) `o` heading =
+              ( heading : headings
+              , \(ts, t') ->
+                  let (cells, t) = acc ts
+--                  in (showTimeDiff t' t : cells, t')
+                  in (showNsDiff t' t : cells, t')
+              )
+            acc0 (                                 rp :& slotGap :& both :& mut :& gc :& majGcCount, t') =
+                ( reverse [condense (realPointSlot rp),  slotGap,   both,   mut,   gc,   majGcCount]
+                , t'
+                )
+        in
+        (reverse [                              "slot", "slotGap", "both", "mut", "gc", "majGcCount"], acc0)
+          `o` "forecast"
+          `o` "headerTick"
+          `o` "headerApply"
+          `o` "blockTick"
+          `o` "blockApply"
+
+    slotCount :: SlotNo -> WithOrigin SlotNo -> String
+    slotCount (SlotNo i) = show . \case
+        Slotting.Origin        -> i
+        Slotting.At (SlotNo j) -> i - j
+
+    process :: St blk -> blk -> IO (St blk)
+    process (St prevRtsStats extLdgrSt) blk = do
+        let slot = blockSlot      blk
+            rp   = blockRealPoint blk
+
+        t0 <- GC.mutator_elapsed_ns <$> GC.getRTSStats
+
+        -- forecast the LedgerView
+        let forecaster = ledgerViewForecastAt lcfg (ledgerState extLdgrSt)
+        !tickedLedgerView <- case runExcept $ forecastFor forecaster slot of
+            Left err -> fail $ "benchmark doesn't support headers beyond the forecast limit: " <> show rp <> " " <> show err
+            Right !x -> pure x
+
+        t1 <- GC.mutator_elapsed_ns <$> GC.getRTSStats
+
+        -- tick the HeaderState
+        let !tickedHeaderState = tickHeaderState ccfg tickedLedgerView slot (headerState extLdgrSt)
+
+        t2 <- GC.mutator_elapsed_ns <$> GC.getRTSStats
+
+        -- apply the header
+        !headerState' <- case runExcept $ validateHeader cfg tickedLedgerView (getHeader blk) tickedHeaderState of
+            Left err -> fail $ "benchmark doesn't support invalid headers: " <> show rp <> " " <> show err
+            Right x -> pure x
+
+        t3 <- GC.mutator_elapsed_ns <$> GC.getRTSStats
+
+        -- tick the ledger state
+        let !tickedLdgrSt = applyChainTick lcfg slot (ledgerState extLdgrSt)
+
+        t4 <- GC.mutator_elapsed_ns <$> GC.getRTSStats
+
+        -- apply the block
+        !ldgrSt' <- case runExcept (lrResult <$> applyBlockLedgerResult lcfg blk tickedLdgrSt) of
+            Left err -> fail $ "benchmark doesn't support invalid blocks: " <> show rp <> " " <> show err
+            Right x -> pure x
+
+        rtsStats5 <- GC.getRTSStats
+        let t5 = GC.mutator_elapsed_ns rtsStats5
+
+        putStrLn
+          $ unwords
+          $ reverse (fst $ theCells $
+                           rp
+                        :& (slot `slotCount` getTipSlot extLdgrSt)
+                        :& showNsDiff (GC.elapsed_ns rtsStats5) (GC.elapsed_ns prevRtsStats)
+                        :& showNsDiff t5 (GC.mutator_elapsed_ns prevRtsStats)
+                        :& showNsDiff (GC.gc_elapsed_ns rtsStats5) (GC.gc_elapsed_ns prevRtsStats)
+                        :& show (GC.major_gcs rtsStats5 - GC.major_gcs prevRtsStats)
+                        :& t0 :& t1 :& t2 :& t3 :& t4 :& t5
+                    )
+            ++ HasAnalysis.blockStats blk
+
+        pure $ St rtsStats5 $ ExtLedgerState ldgrSt' headerState'
+
 {-------------------------------------------------------------------------------
   Analysis: reforge the blocks, via the mempool
 -------------------------------------------------------------------------------}

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Block/Byron.hs

@@ -39,6 +39,7 @@ instance HasAnalysis ByronBlock where
     blockTxSizes = aBlockOrBoundary (const []) blockTxSizesByron
     knownEBBs = const Byron.knownEBBs
     emitTraces _ = []
+    blockStats blk = [show $ length $ blockTxSizes blk, show $ sum $ blockTxSizes blk]
 
 instance HasProtocolInfo ByronBlock where
     data Args ByronBlock =

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Block/Cardano.hs

@@ -33,13 +33,16 @@ import           Data.Word (Word16)
 import           System.Directory (makeAbsolute)
 import           System.FilePath (takeDirectory, (</>))
 
+import qualified Block.Byron as BlockByron
+import           Block.Shelley ()
 import           Cardano.Binary (Raw)
 import qualified Cardano.Chain.Genesis as Byron.Genesis
 import qualified Cardano.Chain.Update as Byron.Update
 import           Cardano.Crypto (RequiresNetworkMagic (..))
 import qualified Cardano.Crypto as Crypto
 import qualified Cardano.Crypto.Hash.Class as CryptoClass
 import qualified Cardano.Ledger.Alonzo.Genesis as SL (AlonzoGenesis)
+import qualified Cardano.Ledger.Alonzo.Tx (ValidatedTx (..))
 import           Cardano.Ledger.Crypto
 import qualified Cardano.Ledger.Era as Core
 
@@ -72,7 +75,6 @@ import qualified Cardano.Tools.DBAnalyser.Block.Byron as BlockByron
 import           Cardano.Tools.DBAnalyser.Block.Shelley ()
 import           Cardano.Tools.DBAnalyser.HasAnalysis
 
-
 analyseBlock ::
      (forall blk. HasAnalysis blk => blk -> a)
   -> CardanoBlock StandardCrypto -> a
@@ -261,6 +263,8 @@ instance (HasAnnTip (CardanoBlock StandardCrypto), GetPrevHash (CardanoBlock Sta
 
   emitTraces = analyseWithLedgerState emitTraces
 
+  blockStats = analyseBlock blockStats
+
 type CardanoBlockArgs = Args (CardanoBlock StandardCrypto)
 
 mkCardanoProtocolInfo ::

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Block/Shelley.hs

@@ -15,18 +15,30 @@ module Cardano.Tools.DBAnalyser.Block.Shelley (
   ) where
 
 import qualified Data.Aeson as Aeson
-import           Data.Foldable (toList)
+import           Data.Foldable (asum, foldl', toList)
 import qualified Data.Map.Strict as Map
-import           Data.Maybe (catMaybes)
+import           Data.Maybe (catMaybes, maybeToList)
 import           Data.Maybe.Strict
+import           Data.Sequence.Strict (StrictSeq)
+import           Data.Word (Word64)
+import           GHC.Records (HasField, getField)
 import           Lens.Micro ((^.))
 import           Lens.Micro.Extras (view)
+import           Options.Applicative
 
 import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Era as CL
 import qualified Cardano.Ledger.Shelley.API as SL
 import qualified Cardano.Ledger.Shelley.RewardUpdate as SL
 
+import           Cardano.Ledger.Allegra (AllegraEra)
+import           Cardano.Ledger.Alonzo (AlonzoEra)
+import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
+import qualified Cardano.Ledger.Alonzo.Tx as Alonzo
+import           Cardano.Ledger.Babbage (BabbageEra)
+import           Cardano.Ledger.Mary (MaryEra)
+import           Cardano.Ledger.Shelley (ShelleyEra)
+
 import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
 import           Ouroboros.Consensus.Node.ProtocolInfo
 
@@ -46,7 +58,10 @@ import           Ouroboros.Consensus.Shelley.Node (Nonce (..),
 import           Cardano.Tools.DBAnalyser.HasAnalysis
 
 -- | Usable for each Shelley-based era
-instance ShelleyCompatible proto era => HasAnalysis (ShelleyBlock proto era) where
+instance ( ShelleyCompatible proto era
+         , PerEraAnalysis era
+         , HasField "outputs" (Core.TxBody era) (StrictSeq (Core.TxOut era))
+         ) => HasAnalysis (ShelleyBlock proto era) where
 
   countTxOutputs blk = case Shelley.shelleyBlockRaw blk of
       SL.Block _ body -> sum $ fmap countOutputs (CL.fromTxSeq @era body)
@@ -78,6 +93,43 @@ instance ShelleyCompatible proto era => HasAnalysis (ShelleyBlock proto era) whe
         (_, _) -> Nothing
     ]
 
+  blockStats blk =
+      [ show $ length $ blockTxSizes blk
+      , show $ sum $ blockTxSizes blk
+      ]
+      ++
+      [ show $ foldl' (\acc tx -> acc + f tx) 0 txs
+      | f <- maybeToList txExUnitsSteps
+      ]
+    where
+      txs :: StrictSeq (Core.Tx era)
+      txs = case Shelley.shelleyBlockRaw blk of
+        SL.Block _ body -> CL.fromTxSeq @era body
+
+-----
+
+class PerEraAnalysis era where
+    txExUnitsSteps :: Maybe (Core.Tx era -> Word64)
+
+instance PerEraAnalysis (ShelleyEra c) where txExUnitsSteps = Nothing
+instance PerEraAnalysis (AllegraEra c) where txExUnitsSteps = Nothing
+instance PerEraAnalysis (MaryEra    c) where txExUnitsSteps = Nothing
+
+instance ( HasField "wits" (Core.Tx (AlonzoEra c)) (Core.Witnesses (AlonzoEra c))
+         )
+      => PerEraAnalysis (AlonzoEra c) where
+    txExUnitsSteps = Just $ \tx ->
+        let (Alonzo.ExUnits _mem steps) = Alonzo.totExUnits tx
+        in toEnum $ fromEnum steps
+
+instance ( HasField "wits" (Core.Tx (BabbageEra c)) (Core.Witnesses (BabbageEra c))
+         )
+      => PerEraAnalysis (BabbageEra c) where
+    txExUnitsSteps = Just $ \tx ->
+        let (Alonzo.ExUnits _mem steps) = Alonzo.totExUnits tx
+        in toEnum $ fromEnum steps
+
+-----
 
 -- | Shelley-era specific
 instance HasProtocolInfo (ShelleyBlock (TPraos StandardCrypto) StandardShelley) where

ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/HasAnalysis.hs

@@ -1,4 +1,6 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies     #-}
+
 module Cardano.Tools.DBAnalyser.HasAnalysis (
     HasAnalysis (..)
   , HasProtocolInfo (..)
@@ -13,6 +15,7 @@ import           Ouroboros.Consensus.HeaderValidation (HasAnnTip (..))
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Storage.Serialisation (SizeInBytes)
+import           Ouroboros.Consensus.Util.Condense (Condense)
 
 {-------------------------------------------------------------------------------
   HasAnalysis
@@ -24,7 +27,7 @@ data WithLedgerState blk = WithLedgerState
   , wlsStateAfter  :: LedgerState blk
   }
 
-class (HasAnnTip blk, GetPrevHash blk) => HasAnalysis blk where
+class (HasAnnTip blk, GetPrevHash blk, Condense (HeaderHash blk)) => HasAnalysis blk where
 
   countTxOutputs :: blk -> Int
   blockTxSizes   :: blk -> [SizeInBytes]
@@ -33,6 +36,8 @@ class (HasAnnTip blk, GetPrevHash blk) => HasAnalysis blk where
   -- | Emit trace markers at points in processing.
   emitTraces     :: WithLedgerState blk -> [String]
 
+  blockStats     :: blk -> [String]
+
 class HasProtocolInfo blk where
   data Args blk
   mkProtocolInfo :: Args blk -> IO (ProtocolInfo IO blk)