diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 61579da93e..12bf1baf2c 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -1002,6 +1002,28 @@ benchmark leios-db-bench time, vector, +benchmark leios-gc-bench + import: common-bench + type: exitcode-stdio-1.0 + hs-source-dirs: ouroboros-consensus/bench/leios-gc-bench + main-is: Main.hs + ghc-options: -with-rtsopts=-N4 + build-depends: + async, + base, + bytestring, + cardano-slotting, + contra-tracer, + direct-sqlite, + directory, + io-classes:si-timers, + optparse-applicative, + ouroboros-consensus, + temporary, + text, + time, + vector, + test-suite doctest import: common-test main-is: doctest.hs diff --git a/ouroboros-consensus/bench/leios-gc-bench/Main.hs b/ouroboros-consensus/bench/leios-gc-bench/Main.hs new file mode 100644 index 0000000000..3a693d84de --- /dev/null +++ b/ouroboros-consensus/bench/leios-gc-bench/Main.hs @@ -0,0 +1,554 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Benchmark for the sqlite backend of 'LeiosDemoDb' mark-as-immutable and +-- garbage collection. +-- +-- By default the benchmark populates a synthetic database with deterministic +-- data (as in @leios-db-bench@); given a @FIXTURE.db@ argument it runs +-- against a copy of that production 'leios.db' sqlite database file instead. +-- +-- Each cycle advances a GC frontier by @--slot-step@ slots (default 30); +-- then calls 'leiosDbMarkAsImmutable' and 'leiosDbGarbageCollect'. In +-- synthetic mode @--orphan-fraction@ of the EBs is never marked immutable, +-- so garbage collection evicts them. +-- +-- Reported per cycle, as one CSV row on stdout (everything else goes to +-- stderr). +-- +-- Usage: +-- +-- @ +-- cabal bench leios-gc-bench +-- cabal bench leios-gc-bench --benchmark-options='leios.db' +-- @ +module Main (main) where + +import Cardano.Slotting.Slot (SlotNo (..)) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (withAsync) +import Control.Exception (evaluate) +import Control.Monad (forM, forM_, forever, when) +import Control.Monad.Class.MonadTime.SI (diffTime, getMonotonicTime) +import Control.Tracer (Tracer (..), emit) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.List as List (foldl', intercalate) +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import Data.Time.Clock (DiffTime) +import qualified Data.Vector.Strict as V +import Data.Word (Word64) +import qualified Database.SQLite3 as SQL +import LeiosDemoDb + ( LeiosDbConnection (..) + , LeiosDbHandle (..) + , TraceLeiosDb (..) + , newLeiosDBSQLite + , sqlSampleLeiosDBStats + ) +import LeiosDemoTypes + ( BytesSize + , EbHash (..) + , LeiosEb (..) + , LeiosPoint (..) + , TxHash (..) + , leiosEbBytesSize + ) +import Options.Applicative hiding (action) +import System.Directory (copyFile) +import System.Exit (die) +import System.IO + ( BufferMode (LineBuffering) + , hPutStr + , hPutStrLn + , hSetBuffering + , stderr + , stdout + ) +import System.IO.Temp (withSystemTempDirectory) +import Text.Printf (printf) + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + opts <- execParser optsInfo + withSystemTempDirectory "leios-gc-bench" $ \tmpDir -> do + let benchDb = tmpDir <> "/bench.db" + (tracer, drain) <- mkCollectingTracer + -- get the series of (slot, ebHash) + (db, schedule) <- case optDbPath opts of + Just path -> do + hPutStrLn stderr $ "Copying the database " <> path <> " -> " <> benchDb + copyFile path benchDb + db <- newLeiosDBSQLite tracer benchDb + close =<< open db + schedule <- readEbSchedule benchDb + pure (db, schedule) + Nothing -> do + validateSyntheticOpts opts + hPutStrLn stderr $ + "Populating a synthetic database at " + <> benchDb + <> " (" + <> show (syntheticEbCount opts) + <> " EBs × " + <> show (optTxsPerEb opts) + <> " txs × " + <> show (optTxBytes opts) + <> " B, orphan fraction " + <> show (optOrphanFraction opts) + <> ")" + db <- newLeiosDBSQLite tracer benchDb + schedule <- populateDb opts db + pure (db, schedule) + (startSlot, endSlot) <- case schedule of + [] -> die "empty mark-as-immutable schedule (no volatile ebs, or --orphan-fraction 1)" + (s0, _) : rest -> pure (s0, maximum (map fst rest)) + let lastFrontier = startSlot + fromIntegral (optCycles opts) * optSlotStep opts + hPutStr stderr $ + unlines + [ "" + , "Volatile ebs window : slots " + <> show startSlot + <> ".." + <> show endSlot + <> " (" + <> show (length schedule) + <> " distinct EB hashes)" + , "Cycles : " + <> show (optCycles opts) + <> " × slot step " + <> show (optSlotStep opts) + <> " (GC frontier " + <> show (startSlot + optSlotStep opts) + <> ".." + <> show lastFrontier + <> ")" + , "" + ] + when (lastFrontier > endSlot) $ + hPutStrLn stderr $ + "NOTE: frontier passes the window top at cycle " + <> show ((endSlot - startSlot) `div` optSlotStep opts) + <> "; later cycles measure no-op GCs" + before <- sqlSampleLeiosDBStats benchDb + hPutStrLn stderr (renderStats "before" before) + latRef <- newIORef 0 + putStrLn csvHeader + cycleStats <- + withAsync mutator $ \_ -> + withAsync (tickProbe latRef) $ \_ -> + runCycles opts db drain latRef schedule startSlot + after <- sqlSampleLeiosDBStats benchDb + hPutStrLn stderr (renderStats "after " after) + hPutStr stderr (renderSummary cycleStats) + +-- * Options + +data Opts = Opts + { optDbPath :: Maybe FilePath + , optCycles :: Int + , optSlotStep :: Word64 + , optEbsPerSlot :: Int + , optTxsPerEb :: Int + , optTxBytes :: Int + , optOrphanFraction :: Double + } + +optsInfo :: ParserInfo Opts +optsInfo = + info + (optsParser <**> helper) + ( fullDesc + <> progDesc + "Benchmark LeiosDemoDb mark-as-immutable and garbage collection \ + \against a synthetic database (default) or a production leios.db \ + \fixture; per-cycle results are written to stdout as CSV" + ) + +optsParser :: Parser Opts +optsParser = + Opts + <$> optional + ( strArgument + ( metavar "FIXTURE.db" + <> help + "Production leios.db sqlite file (benchmarked on a temp \ + \copy); when omitted, a synthetic database is generated" + ) + ) + <*> option + auto + ( long "cycles" + <> metavar "N" + <> value 50 + <> showDefault + <> help "Number of GC cycles to run" + ) + <*> option + auto + ( long "slot-step" + <> metavar "N" + <> value 30 + <> showDefault + <> help "Slots the frontier advances per cycle" + ) + <*> option + auto + ( long "ebs-per-slot" + <> metavar "N" + <> value 1 + <> showDefault + <> help "Synthetic mode: EBs announced per slot" + ) + <*> option + auto + ( long "txs-per-eb" + <> metavar "N" + <> value 200 + <> showDefault + <> help "Synthetic mode: transactions per EB" + ) + <*> option + auto + ( long "tx-bytes" + <> metavar "N" + <> value 1536 + <> showDefault + <> help "Synthetic mode: bytes per transaction payload (min 32)" + ) + <*> option + auto + ( long "orphan-fraction" + <> metavar "F" + <> value 0.5 + <> showDefault + <> help + "Synthetic mode: fraction of EBs never marked immutable \ + \(evicted by GC instead)" + ) + +-- * Synthetic population + +validateSyntheticOpts :: Opts -> IO () +validateSyntheticOpts opts = do + when (optCycles opts < 1 || optSlotStep opts < 1 || optEbsPerSlot opts < 1 || optTxsPerEb opts < 1) $ + die "--cycles, --slot-step, --ebs-per-slot and --txs-per-eb must be at least 1" + when (optTxBytes opts < 32) $ + die "--tx-bytes must be at least 32 (a payload embeds the 32-byte tx hash)" + when (optOrphanFraction opts < 0 || optOrphanFraction opts > 1) $ + die "--orphan-fraction must be in [0, 1]" + +-- | EBs generated in synthetic mode: 'optEbsPerSlot' per slot over the slots +-- the GC frontier will sweep. +syntheticEbCount :: Opts -> Int +syntheticEbCount opts = + optCycles opts * fromIntegral (optSlotStep opts) * optEbsPerSlot opts + +-- | Insert deterministic volatile EBs (untimed) and return the +-- mark-as-immutable schedule, ascending in slot; orphaned EBs are inserted +-- but excluded from it, so GC evicts them. +populateDb :: Opts -> LeiosDbHandle IO -> IO [(Word64, BS.ByteString)] +populateDb opts db = do + conn <- open db + schedule <- forM [0 .. syntheticEbCount opts - 1] $ \ebIdx -> do + let slot = fromIntegral (ebIdx `div` optEbsPerSlot opts) :: Word64 + MkEbHash hashBytes = genEbHash ebIdx + point = MkLeiosPoint (SlotNo slot) (MkEbHash hashBytes) + eb = genEb opts ebIdx + txs = + [ (h, genTx opts h) + | txIdx <- [0 .. optTxsPerEb opts - 1] + , let h = genTxHash ebIdx txIdx + ] + leiosDbInsertEbPoint conn point (leiosEbBytesSize eb) + _ <- leiosDbInsertEbBody conn point eb + _ <- leiosDbInsertTxs conn txs + pure $ if orphaned ebIdx then Nothing else Just (slot, hashBytes) + close conn + pure (catMaybes schedule) + where + -- Bresenham-style even spread of the orphan fraction over the EB indices. + orphaned i = orphansBefore (i + 1) > orphansBefore i + orphansBefore i = floor (fromIntegral i * optOrphanFraction opts :: Double) :: Int + +-- * Deterministic data generation (as in leios-db-bench) + +-- | 'EbHash' from an index: \"ebHash:\" padded to 32 bytes with zeros. +genEbHash :: Int -> EbHash +genEbHash i = MkEbHash $ BS.take 32 (tag <> BS.replicate 32 0) + where + tag = BS8.pack ("ebHash:" <> show i) + +-- | 'LeiosEb' with 'optTxsPerEb' transactions of 'optTxBytes' each. +genEb :: Opts -> Int -> LeiosEb +genEb opts ebIdx = + MkLeiosEb $ + V.fromList + [ (genTxHash ebIdx txIdx, fromIntegral (optTxBytes opts) :: BytesSize) + | txIdx <- [0 .. optTxsPerEb opts - 1] + ] + +-- | 'TxHash' from an EB index + TX offset: \"txHash::\" padded +-- to 32 bytes with zeros. +-- +-- NOTE: This is taking an EB index as it always generates the worst case of +-- fully disjunct transaction closures between EBs. +genTxHash :: Int -> Int -> TxHash +genTxHash ebIdx txIdx = MkTxHash $ BS.take 32 (tag <> BS.replicate 32 0) + where + tag = BS8.pack ("txHash:" <> show ebIdx <> ":" <> show txIdx) + +-- | Generate a TX payload: the TX hash bytes padded with zeros to 'optTxBytes'. +genTx :: Opts -> TxHash -> BS.ByteString +genTx opts (MkTxHash h) = h <> BS.replicate (optTxBytes opts - BS.length h) 0 + +-- * Cycles + +-- | One benchmark cycle: what was measured while the frontier advanced once. +data CycleResult = CycleResult + { crFrontier :: !Word64 + , crMarkAsImmutableWall :: !DiffTime + , crMarkedAsImmutableHashes :: !Int + , crGcWall :: !DiffTime + , crStats :: !CycleStats + , crTickLat :: !DiffTime + } + +runCycles :: + Opts -> + LeiosDbHandle IO -> + IO [TraceLeiosDb] -> + IORef DiffTime -> + [(Word64, BS.ByteString)] -> + Word64 -> + IO [CycleResult] +runCycles opts db drain latRef schedule startSlot = do + remainingRef <- newIORef schedule + _ <- drain -- discard events from handle setup + _ <- atomicModifyIORef' latRef (\m -> (0, m)) + mapM (oneCycle remainingRef) [1 .. optCycles opts] + where + oneCycle remainingRef i = do + let frontier = startSlot + fromIntegral i * optSlotStep opts + remaining <- readIORef remainingRef + let (due, rest) = span (\(s, _) -> s < frontier) remaining + writeIORef remainingRef rest + (_, markAsImmutableWall) <- timed $ + forM_ due $ \(s, h) -> + leiosDbMarkAsImmutable db (MkLeiosPoint (SlotNo s) (MkEbHash h)) + let marked = length due + (_, gcWall) <- timed $ leiosDbGarbageCollect db (SlotNo frontier) + tickLat <- atomicModifyIORef' latRef (\m -> (0, m)) + stats <- List.foldl' addEvent emptyCycleStats <$> drain + let result = + CycleResult + { crFrontier = frontier + , crMarkAsImmutableWall = markAsImmutableWall + , crMarkedAsImmutableHashes = marked + , crGcWall = gcWall + , crStats = stats + , crTickLat = tickLat + } + putStrLn (renderCycle i result) + pure result + +-- * Event collection + +mkCollectingTracer :: IO (Tracer IO TraceLeiosDb, IO [TraceLeiosDb]) +mkCollectingTracer = do + ref <- newIORef [] + let tracer = Tracer $ emit $ \ev -> atomicModifyIORef' ref (\evs -> (ev : evs, ())) + drain = atomicModifyIORef' ref (\evs -> ([], reverse evs)) + pure (tracer, drain) + +data CycleStats = CycleStats + { csMarkedAsImmutable :: !(Int, Int, Int) + , csEvicted :: !(Int, Int, Int) + , csCollisions :: !Int + } + +emptyCycleStats :: CycleStats +emptyCycleStats = CycleStats (0, 0, 0) (0, 0, 0) 0 + +addEvent :: CycleStats -> TraceLeiosDb -> CycleStats +addEvent cs = \case + TraceLeiosDbCopiedToImmutable{copiedEbs, copiedEbTxs, copiedTxs} -> + cs{csMarkedAsImmutable = csMarkedAsImmutable cs `add3` (copiedEbs, copiedEbTxs, copiedTxs)} + TraceLeiosDbEvicted{evictedEbs, evictedEbTxs, evictedTxs} -> + cs{csEvicted = csEvicted cs `add3` (evictedEbs, evictedEbTxs, evictedTxs)} + TraceLeiosDbInsertCollision{} -> cs{csCollisions = csCollisions cs + 1} + _ -> cs + where + add3 (a, b, c) (x, y, z) = (a + x, b + y, c + z) + +-- * RTS health probe + +-- | Steady allocator, so minor heap GCs happen constantly (as on a real +-- node). Together with 'tickProbe' this reproduces the production failure +-- mode: an unsafe FFI call in the maintenance path blocks the RTS GC sync +-- and every thread — including the ticker — stalls for the statement's +-- duration. +-- +-- Must really allocate on every iteration: a fused non-allocating loop +-- (e.g. @sum [1 .. n]@ at -O1) never reaches a GC safe point and wedges the +-- process at the first GC sync. A fresh 'BS.ByteString' per iteration +-- cannot be fused away, and the 'threadDelay' keeps the allocation rate +-- bounded rather than saturating a core. +mutator :: IO () +mutator = forever $ do + _ <- evaluate (BS.length (BS.replicate 65_536 0)) + threadDelay 100 + +-- | Record the worst excess over a 1 ms sleep, i.e. how long the RTS +-- refused to schedule an always-runnable thread. +tickProbe :: IORef DiffTime -> IO () +tickProbe latRef = forever $ do + t0 <- getMonotonicTime + threadDelay 1_000 + t1 <- getMonotonicTime + let !excess = diffTime t1 t0 - 0.001 + atomicModifyIORef' latRef (\m -> (max m excess, ())) + +-- * Fixture inspection + +-- | Distinct volatile EB hashes with their newest announcement slot, ascending. +readEbSchedule :: FilePath -> IO [(Word64, BS.ByteString)] +readEbSchedule path = do + db <- SQL.open (T.pack path) + stmt <- + SQL.prepare + db + "SELECT MAX(ebSlot) AS s, ebHashBytes FROM ebs WHERE immutable = 0 GROUP BY ebHashBytes ORDER BY s" + let loop acc = + SQL.step stmt >>= \case + SQL.Row -> do + slot <- SQL.columnInt64 stmt 0 + h <- SQL.columnBlob stmt 1 + loop ((fromIntegral slot, h) : acc) + SQL.Done -> pure (reverse acc) + ebs <- loop [] + SQL.finalize stmt + SQL.close db + pure ebs + +-- * Rendering + +csvHeader :: String +csvHeader = + List.intercalate + "," + [ "cycle" + , "gcSlot" + , "markedEbs" + , "markedEbRows" + , "markedEbTxRows" + , "markedTxRows" + , "markAsImmutableSeconds" + , "evictedEbRows" + , "evictedEbTxRows" + , "evictedTxRows" + , "gcSeconds" + , "insertCollisions" + , "tickLatSeconds" + ] + +renderCycle :: Int -> CycleResult -> String +renderCycle + i + CycleResult + { crFrontier + , crMarkAsImmutableWall + , crMarkedAsImmutableHashes + , crGcWall + , crStats = cs + , crTickLat + } = + List.intercalate + "," + [ show i + , show crFrontier + , show crMarkedAsImmutableHashes + , show mEbs + , show mEbTxs + , show mTxs + , showSeconds crMarkAsImmutableWall + , show eEbs + , show eEbTxs + , show eTxs + , showSeconds crGcWall + , show (csCollisions cs) + , showSeconds crTickLat + ] + where + (mEbs, mEbTxs, mTxs) = csMarkedAsImmutable cs + (eEbs, eEbTxs, eTxs) = csEvicted cs + +renderStats :: String -> (TraceLeiosDb, TraceLeiosDb) -> String +renderStats label = \case + ( TraceLeiosDbVolatileStats{volatileEbs, volatileEbTxs, volatileTxs} + , TraceLeiosDbImmutableStats{immutableEbs, immutableEbTxs, immutableTxs} + ) -> + unwords + [ label <> ": volatile" + , "ebs=" <> show volatileEbs + , "ebTxs=" <> show volatileEbTxs + , "txs=" <> show volatileTxs + , "| immutable" + , "ebs=" <> show immutableEbs + , "ebTxs=" <> show immutableEbTxs + , "txs=" <> show immutableTxs + ] + other -> label <> ": unexpected stats events " <> show other + +renderSummary :: [CycleResult] -> String +renderSummary results = + unlines + [ "" + , "Totals over " <> show (length results) <> " cycles:" + , " marked as immutable ebs/ebTxs/txs = " + <> showT (sum3 (map (csMarkedAsImmutable . crStats) results)) + , " evicted ebs/ebTxs/txs = " <> showT (sum3 (map (csEvicted . crStats) results)) + , " insert collisions = " <> show (sum (map (csCollisions . crStats) results)) + , stat "mark as immutable " (map crMarkAsImmutableWall results) + , stat "gc " (map crGcWall results) + , stat "tick latency " (map crTickLat results) + ] + where + sum3 = List.foldl' (\(a, b, c) (x, y, z) -> (a + x, b + y, c + z)) (0, 0, 0) + showT (a, b, c) = show a <> "/" <> show b <> "/" <> show c + stat label ts = + " " + <> label + <> ": min=" + <> showTime (minimum ts) + <> " avg=" + <> showTime (sum ts / fromIntegral (length ts)) + <> " max=" + <> showTime (maximum ts) + +-- * Timing helpers (as in leios-db-bench) + +timed :: IO a -> IO (a, DiffTime) +timed action = do + t0 <- getMonotonicTime + !result <- action + t1 <- getMonotonicTime + pure (result, diffTime t1 t0) + +showSeconds :: DiffTime -> String +showSeconds t = printf "%.6f" (realToFrac t :: Double) + +showTime :: DiffTime -> String +showTime t + | t < 1e-6 = show (round (s * 1_000_000_000 :: Double) :: Int) <> " ns" + | t < 1e-3 = show (round (s * 1_000_000 :: Double) :: Int) <> " μs" + | t < 1 = show (round (s * 1_000 :: Double) :: Int) <> " ms" + | otherwise = show s <> " s" + where + s = realToFrac t :: Double diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb.hs index 6d77b3cd85..f400fdc11d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb.hs @@ -16,6 +16,7 @@ module LeiosDemoDb -- * SQLite implementation , newLeiosDBSQLiteFromEnv , newLeiosDBSQLite + , sqlSampleLeiosDBStats -- * SQL (re-exported for leiosdemo app) , sql_schema @@ -40,6 +41,7 @@ import LeiosDemoDb.InMemory import LeiosDemoDb.SQLite ( newLeiosDBSQLite , newLeiosDBSQLiteFromEnv + , sqlSampleLeiosDBStats , sql_insert_eb , sql_insert_ebBody , sql_insert_tx diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs index 6d043a9e7c..aaf362a530 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Common.hs @@ -41,38 +41,19 @@ data LeiosDbHandle m = LeiosDbHandle -- https://github.com/input-output-hk/ouroboros-leios/issues/983 for -- example motivation.) - -- TODO The two methods below are intentionally merely stubs for - -- now, but as part of implementing them, we should relocate them to - -- 'LeiosDbConnection'. - leiosDbGarbageCollect :: HasCallStack => SlotNo -> m () -- ^ Evict LeiosDb data that is no longer needed now that everything up to the -- given slot is immutable. The ChainDB drives this from its GC scheduler, - -- passing the same slot it uses to GC the VolatileDB\/PerasCertDB (see - -- @garbageCollectBlocks@); like those stores, the LeiosDb stays dumb about - -- /why/ -- it is handed a slot, nothing more (it never tracks the immutable - -- tip itself). + -- passing the same slot it uses to GC the VolatileDB (see @garbageCollectBlocks@); + , leiosDbMarkAsImmutable :: HasCallStack => LeiosPoint -> m () + -- ^ Mark the given EB as immutable. -- - -- Currently a no-op. When implemented it can stay purely slot-based: the EBs - -- the immutable chain still needs (for ledger replay of an immutable cert-RB, - -- or for serving peers) are preserved by 'leiosDbPromoteToImmutable' before - -- they would age out here, so eviction itself need not reason about which EB - -- data is still required. - , leiosDbPromoteToImmutable :: HasCallStack => LeiosPoint -> m () - -- ^ Promote the given EB's body and tx closure into immutable LeiosDb - -- storage, so they survive the slot-based 'leiosDbGarbageCollect' that will - -- later evict the volatile data. The ChainDB's copier (@copyToImmutableDB@) - -- drives this as it copies blocks to the ImmutableDB: for each cert-RB it - -- copies, it promotes the EB that cert-RB /certifies/ (the one its predecessor - -- announced). This is precise -- only EBs the immutable chain actually - -- references -- and gap-free: by the parking invariant a cert-RB is only - -- selected once its certified EB's closure is acquired, so an immutalised - -- cert-RB's closure is necessarily present (and complete). Promotion rides the - -- copy while eviction rides the later scheduled GC slot, so the data is always - -- promoted before it becomes eligible for eviction. + -- The ChainDB's copier (@copyToImmutableDB@) drives this as + -- it copies blocks to the ImmutableDB. -- - -- Currently a no-op -- the companion of 'leiosDbGarbageCollect': the immutable - -- storage it would promote into is not yet implemented. + -- Keys on the EB /hash/: all of the given EB's announcements are marked, not + -- just the announced point, because bodies and tx closures are shared across + -- an EB's announcement slots. } data LeiosEbNotification diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs index 0d1afc578d..baaeedd4f1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/InMemory.hs @@ -106,8 +106,8 @@ newLeiosDBInMemoryWith stateVar = do atomically (dupTChan notificationChan) , -- No-op for now; see 'leiosDbGarbageCollect'. leiosDbGarbageCollect = \_slotNo -> pure () - , -- No-op for now; see 'leiosDbPromoteToImmutable'. - leiosDbPromoteToImmutable = \_point -> pure () + , -- No-op for now; see 'leiosDbMarkAsImmutable'. + leiosDbMarkAsImmutable = \_point -> pure () , open = pure $ LeiosDbConnection diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs index ca39583f2e..9abdc01a4d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/SQLite.hs @@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -8,6 +9,7 @@ module LeiosDemoDb.SQLite ( newLeiosDBSQLiteFromEnv , newLeiosDBSQLite + , sqlSampleLeiosDBStats -- * SQL strings (re-exported for leiosdemo app) , sql_schema @@ -16,25 +18,27 @@ module LeiosDemoDb.SQLite , sql_insert_tx ) where -import Cardano.Prelude (forM_, traverse_, when) +import Cardano.Prelude (forM, forM_, traverse_, when) import Cardano.Slotting.Slot (SlotNo (..)) -import Control.Concurrent (threadDelay) +import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Class.MonadSTM.Strict ( StrictTChan , dupTChan , newBroadcastTChan , writeTChan ) -import Control.Exception (throwIO) -import Control.Monad (unless, void) +import Control.Exception (SomeException, throwIO) +import Control.Monad (forever, unless, void) import Control.Monad.Class.MonadThrow (generalBracket) import qualified Control.Monad.Class.MonadThrow as MonadThrow import Control.Tracer (Tracer, traceWith) +import qualified Data.Aeson as Aeson import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BSL +import Data.IORef (IORef, atomicModifyIORef', newIORef) import Data.Int (Int64) import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -64,8 +68,15 @@ import LeiosDemoTypes , leiosEbBodyItems , leiosEbBytesSize ) +import LeiosUtils.CallTrace + ( CallCtx + , CallName + , SomeJsonCallTrace (..) + , callTraceSameThread + , rootCallCtx + ) import Ouroboros.Consensus.Util.IOLike (atomically) -import System.Directory (doesFileExist) +import System.Directory (doesFileExist, getFileSize) import System.Environment (lookupEnv) import System.Exit (die) import System.Random (randomIO) @@ -90,19 +101,244 @@ newLeiosDBSQLiteFromEnv tracer = do newLeiosDBSQLite :: Tracer IO TraceLeiosDb -> FilePath -> IO (LeiosDbHandle IO) newLeiosDBSQLite tracer dbPath = do notificationChan <- atomically newBroadcastTChan + -- start a thread to sample the sizes of the volatile LeiosDB partition + startVolatileStatsSampler tracer dbPath + gcRootCtx <- rootCallCtx "leiosdb-gc" + copyRootCtx <- rootCallCtx "leiosdb-copy" + noGCYetDoneRef <- newIORef True -- True until the first GC of this handle pure $ LeiosDbHandle { subscribeEbNotifications = atomically (dupTChan notificationChan) - , -- No-op for now; see 'leiosDbGarbageCollect'. A real implementation - -- would open a transient connection and evict the no-longer-needed rows. - leiosDbGarbageCollect = \_slotNo -> pure () - , -- No-op for now; see 'leiosDbPromoteToImmutable'. A real implementation - -- would copy the EB's body and closure rows into immutable storage. - leiosDbPromoteToImmutable = \_point -> pure () + , leiosDbGarbageCollect = sqlGarbageCollect tracer gcRootCtx dbPath noGCYetDoneRef + , leiosDbMarkAsImmutable = sqlMarkAsImmutable tracer copyRootCtx dbPath , open = openSQLiteConnection tracer dbPath notificationChan } +-- | Implements 'leiosDbMarkAsImmutable': mark the EB's announcement row(s) as +-- immutable, in one database transaction. +sqlMarkAsImmutable :: + HasCallStack => + Tracer IO TraceLeiosDb -> CallCtx IO -> FilePath -> LeiosPoint -> IO () +sqlMarkAsImmutable tracer rootCtx dbPath point = do + let leiosDbCallTrace = traceWith tracer . TraceLeiosDbCall . SomeJsonCallTrace + (copiedEbs, copiedEbTxs, copiedTxs) <- + callTraceSameThread leiosDbCallTrace rootCtx "sqlMarkAsImmutable" (show point.pointEbHash) $ \_ctx -> + withMaintenanceConn dbPath $ \db -> + dbWithTransaction db $ do + -- TODO(geo2a): this is needed for statistics. Allow to turn it off to check if it affects performance + alreadyImmutable <- withStmt db sql_copy_is_immutable $ \stmt -> do + dbBindBlob stmt 1 ebHash + (/= 0) <$> readSingleInt64 stmt + -- here we actually mark the EB as immutable + execWithBlob db sql_copy_flag_immutable ebHash + -- get the number of EBs affected by the above + nEbs <- DB.changes db + -- TODO(geo2a): this is needed for statistics. Allow to turn it off to check if it affects performance + (nEbTxs, nTxs) <- + if alreadyImmutable || nEbs == 0 + then pure (0, 0) + else do + nEbTxs <- countWithBlob db sql_copy_count_ebTxs + nTxs <- countWithBlob db sql_copy_count_new_immutable_txs + pure (nEbTxs, nTxs) + -- Same transaction as the flag, so the counters commit atomically + -- with the row they count (see 'sql_copy_move_stats'). + -- TODO(geo2a): this is needed for statistics. Allow to turn it off to check if it affects performance + when (nEbs > 0 || nEbTxs > 0 || nTxs > 0) $ + execWithInt64x3 + db + sql_copy_move_stats + (fromIntegral nEbs, fromIntegral nEbTxs, fromIntegral nTxs) + pure (nEbs, nEbTxs, nTxs) + traceWith tracer TraceLeiosDbCopiedToImmutable{copiedEbs, copiedEbTxs, copiedTxs} + where + ebHash = point.pointEbHash.ebHashBytes + + countWithBlob :: DB.Database -> String -> IO Int + countWithBlob db sql = + withStmt db sql $ \stmt -> do + dbBindBlob stmt 1 ebHash + fromIntegral <$> readSingleInt64 stmt + + execWithBlob :: HasCallStack => DB.Database -> String -> ByteString -> IO () + execWithBlob db sql blob = + withStmt db sql $ \stmt -> do + dbBindBlob stmt 1 blob + dbStep1Safe stmt + +-- | Implements 'leiosDbGarbageCollect': evict every volatile EB all of whose +-- announcements are older than the given slot, then flush the WAL. +sqlGarbageCollect :: + HasCallStack => + Tracer IO TraceLeiosDb -> CallCtx IO -> FilePath -> IORef Bool -> SlotNo -> IO () +sqlGarbageCollect tracer rootCtx dbPath noGCYetDoneRef gcSlot = + gcSpan rootCtx "sqlGarbageCollect" (unSlotNo gcSlot) $ \gcCtx -> + withMaintenanceConn dbPath $ \db -> do + -- check if we're doing the first ever GC during this node's run + -- and flip the flag if so + -- TODO(geo2a): move this configuration out of the IORef. + firstGc <- atomicModifyIORef' noGCYetDoneRef (\b -> (False, b)) + hasWork <- gcSpan gcCtx "noopGuard" () $ \_ -> + withStmt db sql_gc_has_work $ \stmt -> do + dbBindInt64 stmt 1 slot + (/= 0) <$> readSingleInt64 stmt + when (hasWork || firstGc) $ do + (evictedEbs, evictedEbTxs, evictedTxs) <- + gcSpan gcCtx "evictionTransaction" () $ \txnCtx -> + dbWithTransaction db $ do + nTxsFromFirstGC <- + if firstGc + -- if the the first GC (for example, after a node restart), + -- run the expensive traversal + then gcSpan txnCtx "orphanTxsFullScan" () $ \_ -> + withStmt db sql_gc_orphan_txs_full_scan dbStep1Safe >> DB.changes db + else pure 0 + -- find txHashBytes that are only referenced by volatile EBs that are older + -- than the garbage collection slot and stage them for GC + gcSpan txnCtx "stageOrphanCandidates" () $ \_ -> + withStmt db sql_gc_stage_orphan_candidates $ \stmt -> do + dbBindInt64 stmt 1 slot + dbStep1Safe stmt + -- garbage collect rows of EbTxs + nEbTxs <- gcSpan txnCtx "evictEbTxs" () $ \_ -> + execWithInt64 db sql_gc_ebTxs slot >> DB.changes db + -- garbage collect EBs + nEbs <- gcSpan txnCtx "evictEbs" () $ \_ -> + execWithInt64 db sql_gc_ebs slot >> DB.changes db + -- finally, garbage collect txs that were staged before + -- + -- TODO(geo2a): can we GC txs based on the data we get from GCing EBs? + -- why is sql_gc_stage_orphan_candidates + sql_gc_orphan_txs is + -- faster than sql_gc_orphan_txs_full_scan? + nTxs <- gcSpan txnCtx "orphanTxs" () $ \_ -> + withStmt db sql_gc_orphan_txs dbStep1Safe >> DB.changes db + gcSpan txnCtx "clearCandidates" () $ \_ -> + withStmt db sql_gc_clear_candidates dbStep1Safe + let nTxsTotal = nTxs + nTxsFromFirstGC + when (nEbs > 0 || nEbTxs > 0 || nTxsTotal > 0) $ + execWithInt64x3 + db + sql_update_volatile_stats + ( negate (fromIntegral nEbs) + , negate (fromIntegral nEbTxs) + , negate (fromIntegral nTxsTotal) + ) + pure (nEbs, nEbTxs, nTxsTotal) + traceWith tracer TraceLeiosDbEvicted{evictedEbs, evictedEbTxs, evictedTxs} + gcSpan gcCtx "walCheckpoint" () $ \_ -> + dbExec db "PRAGMA wal_checkpoint(TRUNCATE);" + where + slot = fromIntegral (unSlotNo gcSlot) + + gcSpan :: + (Aeson.ToJSON arg, Aeson.ToJSON res) => + CallCtx IO -> CallName -> arg -> (CallCtx IO -> IO res) -> IO res + gcSpan = callTraceSameThread (traceWith tracer . TraceLeiosDbCall . SomeJsonCallTrace) + + execWithInt64 :: HasCallStack => DB.Database -> String -> Int64 -> IO () + execWithInt64 db sql n = + withStmt db sql $ \stmt -> do + dbBindInt64 stmt 1 n + dbStep1Safe stmt + +-- | Open a strictly read-only connection, for sampling DB statistics. +-- +-- Opening fails harmlessly if the database does not exist yet; the caller +-- swallows it and tries again on the next tick. +withReadOnlyConn :: HasCallStack => FilePath -> (DB.Database -> IO a) -> IO a +withReadOnlyConn dbPath = + MonadThrow.bracket open (void . DB.close) + where + open = do + db <- open2 (fromString dbPath) [SQLOpenReadOnly] SQLVFSDefault + -- Only mmap_size: journal_mode and page_size need write access. + dbExec db "pragma mmap_size = 268435500;" + pure db + +-- | LeiosDB volatile and immutable row counts plus the on-disk footprint. +-- +-- The counts come from the incrementally-maintained 'leiosDbStats' table. +sqlSampleLeiosDBStats :: + HasCallStack => FilePath -> IO (TraceLeiosDb, TraceLeiosDb) +sqlSampleLeiosDBStats dbPath = + withReadOnlyConn dbPath $ \db -> do + (volatileEbs, volatileEbTxs, volatileTxs) <- + withStmt db sql_read_volatile_stats $ \stmt -> + dbStepSafe stmt >>= \case + DB.Row -> + (,,) + <$> (fromIntegral <$> DB.columnInt64 stmt 0) + <*> (fromIntegral <$> DB.columnInt64 stmt 1) + <*> (fromIntegral <$> DB.columnInt64 stmt 2) + DB.Done -> error "sqlSampleLeiosDBStats: leiosDbStats row missing" + (immutableEbs, immutableEbTxs, immutableTxs) <- readImmutableStats db + pageCount <- pragmaInt64 db "page_count" + pageSize <- pragmaInt64 db "page_size" + walBytes <- fileSizeOr0 (dbPath <> "-wal") + pure + ( TraceLeiosDbVolatileStats + { volatileEbs + , volatileEbTxs + , volatileTxs + , dbFileBytes = fromIntegral pageCount * fromIntegral pageSize + , walBytes + } + , TraceLeiosDbImmutableStats + { immutableEbs + , immutableEbTxs + , immutableTxs + } + ) + where + pragmaInt64 :: HasCallStack => DB.Database -> String -> IO Int64 + pragmaInt64 db name = withStmt db ("PRAGMA " <> name) readSingleInt64 + + fileSizeOr0 :: FilePath -> IO Integer + fileSizeOr0 path = do + exists <- doesFileExist path + if exists then getFileSize path else pure 0 + +-- | Fork a thread that runs 'sqlSampleLeiosDBStats' and traces +-- 'TraceLeiosDbVolatileStats' and 'TraceLeiosDbImmutableStats' every 10 +-- seconds. +startVolatileStatsSampler :: + HasCallStack => Tracer IO TraceLeiosDb -> FilePath -> IO () +startVolatileStatsSampler tracer dbPath = + void $ forkIO $ forever $ do + -- wait one sample window to side-step contention with starting the LeiosDB + threadDelay tenSeconds + -- swallow the exception here, it's OK to miss one stats sample, and the next + -- one will open a fresh connection. + MonadThrow.handle (\(_ :: SomeException) -> pure ()) $ do + (volatileStats, immutableStats) <- sqlSampleLeiosDBStats dbPath + traceWith tracer volatileStats + traceWith tracer immutableStats + where + tenSeconds = 10_000_000 + +-- | Immutable-partition row counts, as @(ebs, ebTxs, txs)@. +-- +-- This reads the one-row 'leiosDbStats' running totals that the certification +-- transaction maintains ('sql_copy_move_stats'). +readImmutableStats :: HasCallStack => DB.Database -> IO (Int, Int, Int) +readImmutableStats db = + withStmt db sql_read_immutable_stats $ \stmt -> + dbStep stmt >>= \case + DB.Row -> + (,,) + <$> (fromIntegral <$> DB.columnInt64 stmt 0) + <*> (fromIntegral <$> DB.columnInt64 stmt 1) + <*> (fromIntegral <$> DB.columnInt64 stmt 2) + DB.Done -> error "readImmutableStats: immutableStats row missing" + +-- | Step a statement that yields exactly one integer column. +readSingleInt64 :: HasCallStack => DB.Statement -> IO Int64 +readSingleInt64 stmt = + dbStep stmt >>= \case + DB.Row -> DB.columnInt64 stmt 0 + DB.Done -> error "readSingleInt64: expected a row, got Done" + -- * Connection management -- | Every prepared statement the connection needs, prepared once at open @@ -133,6 +369,7 @@ data Stmts = Stmts , stFilterMissingTxs :: !DB.Statement , stLookupEbClosure :: !DB.Statement , stScanCompleteEbsSince :: !DB.Statement + , stUpdateVolatileStats :: !DB.Statement } data Conn = Conn @@ -158,6 +395,7 @@ prepareStmts db = do stFilterMissingTxs <- dbPrepare db (fromString sql_filter_missing_txs_json) stLookupEbClosure <- dbPrepare db (fromString sql_lookup_eb_closure) stScanCompleteEbsSince <- dbPrepare db (fromString sql_scan_complete_ebs_since) + stUpdateVolatileStats <- dbPrepare db (fromString sql_update_volatile_stats) pure Stmts{..} -- | Finalise every statement in 'Stmts'. Called from 'close' immediately @@ -179,6 +417,7 @@ finalizeStmts Stmts{..} = do dbFinalize stFilterMissingTxs dbFinalize stLookupEbClosure dbFinalize stScanCompleteEbsSince + dbFinalize stUpdateVolatileStats -- | Run an action on a pre-prepared statement and always @sqlite3_reset@ -- it afterwards, regardless of outcome. Reset uses raw 'DB.reset' (no @@ -188,22 +427,27 @@ useStmt :: DB.Statement -> IO a -> IO a useStmt stmt action = action `MonadThrow.finally` (void $ DB.reset stmt) +-- | Fold deltas into the volatile counters of 'leiosDbStats' via the +-- connection's prepared 'sql_update_volatile_stats'. +-- +-- TODO(geo2a): refactor the tuple into a dedicated data type +bumpVolatileStats :: Conn -> (Int64, Int64, Int64) -> IO () +bumpVolatileStats conn (dEbs, dEbTxs, dTxs) = + unless (dEbs == 0 && dEbTxs == 0 && dTxs == 0) $ useStmt stmt $ do + dbBindInt64 stmt 1 dEbs + dbBindInt64 stmt 2 dEbTxs + dbBindInt64 stmt 3 dTxs + dbStep1 stmt + where + Conn{connStmts = Stmts{stUpdateVolatileStats = stmt}} = conn + openSQLiteConnection :: Tracer IO TraceLeiosDb -> FilePath -> StrictTChan IO LeiosEbNotification -> IO (LeiosDbConnection IO) openSQLiteConnection tracer dbPath notificationChan = do - shouldInitSchema <- not <$> doesFileExist dbPath - db <- open2 (fromString dbPath) [SQLOpenReadWrite, SQLOpenCreate] SQLVFSDefault - traverse_ (dbExec db) $ - [ "pragma journal_mode = WAL;" - , "pragma synchronous = normal;" - , "pragma page_size = 32768;" - , "pragma mmap_size = 268435500;" - ] - when shouldInitSchema $ - dbExec db (fromString sql_schema) + db <- openRawConnection dbPath stmts <- prepareStmts db let conn = Conn{connDb = db, connStmts = stmts} notify = atomically . writeTChan notificationChan @@ -222,6 +466,42 @@ openSQLiteConnection tracer dbPath notificationChan = do , leiosDbLookupEbClosure = sqlLookupEbClosure conn } +-- | Open an SQLite connection, setting the shared PRAGMAs plus the idempotent 'sql_schema'. +openRawConnection :: HasCallStack => FilePath -> IO DB.Database +openRawConnection dbPath = do + db <- open2 (fromString dbPath) [SQLOpenReadWrite, SQLOpenCreate] SQLVFSDefault + traverse_ (dbExec db) $ + [ "pragma journal_mode = WAL;" + , "pragma synchronous = normal;" + , "pragma page_size = 32768;" + , "pragma mmap_size = 268435500;" + ] + -- we run the DDL unconditionally as it is idempotent + dbExec db (fromString sql_schema) + pure db + +-- | Open a short-lived connection for maintenance operations +-- ('leiosDbMarkAsImmutable', 'leiosDbGarbageCollect') and close it on unwind +withMaintenanceConn :: HasCallStack => FilePath -> (DB.Database -> IO a) -> IO a +withMaintenanceConn dbPath = + MonadThrow.bracket (openRawConnection dbPath) (void . DB.close) + +-- | Prepare a statement, run an action on it, and finalise it on unwind +withStmt :: HasCallStack => DB.Database -> String -> (DB.Statement -> IO a) -> IO a +withStmt db sql = + MonadThrow.bracket (dbPrepare db (fromString sql)) dbFinalize + +-- | Run a maintenance statement that takes three INTEGER parameters and +-- returns no rows. +execWithInt64x3 :: + HasCallStack => DB.Database -> String -> (Int64, Int64, Int64) -> IO () +execWithInt64x3 db sql (n1, n2, n3) = + withStmt db sql $ \stmt -> do + dbBindInt64 stmt 1 n1 + dbBindInt64 stmt 2 n2 + dbBindInt64 stmt 3 n3 + dbStep1Safe stmt + -- * Top-level implementations sqlScanEbPoints :: Conn -> IO [(SlotNo, EbHash)] @@ -274,6 +554,8 @@ sqlInsertEbPoint conn point ebBytesSize = dbBindBlob stmt 2 point.pointEbHash.ebHashBytes dbBindInt64 stmt 3 (fromIntegral ebBytesSize) dbStep1 stmt + inserted <- DB.changes db + bumpVolatileStats conn (fromIntegral inserted, 0, 0) where Conn{connDb = db, connStmts = Stmts{stInsertEbPoint = stmt}} = conn @@ -290,7 +572,7 @@ sqlInsertEbBody tracer conn notify point eb = do when (null items) $ error "leiosDbInsertEbBody: empty EB body (programmer error)" completedNow <- dbWithTransaction db $ do - forM_ items $ \(txOffset, txHash, txBytesSize) -> useStmt stInsertEbTxsRow $ do + insertedNewRows <- forM items $ \(txOffset, txHash, txBytesSize) -> useStmt stInsertEbTxsRow $ do dbBindBlob stInsertEbTxsRow 1 point.pointEbHash.ebHashBytes dbBindInt64 stInsertEbTxsRow 2 (fromIntegral txOffset) dbBindBlob stInsertEbTxsRow 3 (let MkTxHash bytes = txHash in bytes) @@ -300,6 +582,8 @@ sqlInsertEbBody tracer conn notify point eb = do "ebTxs" (show point.pointEbHash <> "@" <> show txOffset) stInsertEbTxsRow + let nOfNewRows = length (filter id insertedNewRows) + bumpVolatileStats conn (0, fromIntegral nOfNewRows, 0) -- Initialize missingTxCount and read the resulting value via -- @RETURNING missingTxCount@. Only /this/ point's row can have -- transitioned to 0 as a consequence of the insert above. @@ -329,19 +613,16 @@ sqlInsertEbBody tracer conn notify point eb = do , stMarkPointNotified } = connStmts --- | Read a single-column @Int64@ from a statement that uses a --- @RETURNING@ clause on a PK-scoped @UPDATE@ (i.e. produces exactly one --- row followed by 'DB.Done'). Any other shape is a programmer error. -readReturningInt64 :: DB.Statement -> IO Int64 -readReturningInt64 stmt = - dbStep stmt >>= \case - DB.Done -> - error "readReturningInt64: expected one row from RETURNING, got Done" - DB.Row -> do - n <- DB.columnInt64 stmt 0 - dbStep stmt >>= \case - DB.Done -> pure n - DB.Row -> error "readReturningInt64: expected exactly one row from RETURNING" + readReturningInt64 :: DB.Statement -> IO Int64 + readReturningInt64 stmt = + dbStep stmt >>= \case + DB.Done -> + error "readReturningInt64: expected one row from RETURNING, got Done" + DB.Row -> do + n <- DB.columnInt64 stmt 0 + dbStep stmt >>= \case + DB.Done -> pure n + DB.Row -> error "readReturningInt64: expected exactly one row from RETURNING" sqlInsertTxs :: Tracer IO TraceLeiosDb -> @@ -359,7 +640,7 @@ sqlInsertTxs _tracer conn notify txs = do -- 'dbStepInsert' still handles the rare race where a concurrent -- writer inserted the same hash between the filter above and the -- INSERT below. - forM_ (novel missing) $ \(txHash, txBytes) -> do + insertedRows <- forM (novel missing) $ \(txHash, txBytes) -> do let txBytesSize = fromIntegral $ BS.length txBytes txHashBytes = let MkTxHash bytes = txHash in bytes inserted <- useStmt stInsertTx $ do @@ -370,6 +651,9 @@ sqlInsertTxs _tracer conn notify txs = do when inserted $ useStmt stDecrMissingCount $ do dbBindBlob stDecrMissingCount 1 txHashBytes dbStep1 stDecrMissingCount + pure inserted + let nOfNewRows = length (filter id insertedRows) + bumpVolatileStats conn (0, 0, fromIntegral nOfNewRows) -- Find newly-complete EBs (missingTxCount reached 0) completed <- useStmt stFindCompleteEbs $ do let loop acc = @@ -503,40 +787,89 @@ sqlLookupEbClosure conn ebHash = -- * SQL strings --- | Schema for the Leios database. +-- | Schema for the Leios database +-- +-- - 'ebs' holds one row per announced @(slot, hash)@. @immutable = 1@ marks +-- every announcement of an EB the immutable chain references; +-- - 'ebTxs' and 'txs' hold the bodies and tx bytes, keyed by EB hash. +-- - 'leiosDbStats' holds the statistics on volatile and immutable EBs and transiting. sql_schema :: String sql_schema = unlines - [ "CREATE TABLE ebs (" + [ "CREATE TABLE IF NOT EXISTS ebs (" , " ebSlot INTEGER NOT NULL," , " ebHashBytes BLOB NOT NULL," , " ebBytesSize INTEGER NOT NULL," , -- NULL = body not downloaded, >0 = txs missing, 0 = just completed, <0 = notified " missingTxCount INTEGER," + , -- 1 = the immutable chain references this EB + " immutable INTEGER NOT NULL DEFAULT 0," , " PRIMARY KEY (ebSlot, ebHashBytes)" , ");" - , "CREATE INDEX idx_ebs_ebHashBytes ON ebs(ebHashBytes);" - , "CREATE TABLE ebTxs (" + , "CREATE INDEX IF NOT EXISTS idx_ebs_ebHashBytes ON ebs(ebHashBytes);" + , -- Index on the volatile EBs only + "CREATE INDEX IF NOT EXISTS idx_ebs_volatile_slot ON ebs(ebSlot) WHERE immutable = 0;" + , "CREATE TABLE IF NOT EXISTS ebTxs (" , " ebHashBytes BLOB NOT NULL," , " txOffset INTEGER NOT NULL," , " txHashBytes BLOB NOT NULL," , " txBytesSize INTEGER NOT NULL," , " PRIMARY KEY (ebHashBytes, txOffset)" , ");" - , "CREATE INDEX idx_ebTxs_txHashBytes ON ebTxs(txHashBytes);" - , "CREATE TABLE txs (" + , "CREATE INDEX IF NOT EXISTS idx_ebTxs_txHashBytes ON ebTxs(txHashBytes);" + , "CREATE TABLE IF NOT EXISTS txs (" , " txHashBytes BLOB NOT NULL PRIMARY KEY," , " txBytes BLOB NOT NULL," , " txBytesSize INTEGER NOT NULL" , ");" + , -- Running per-partition row counts, maintained for observability. + "CREATE TABLE IF NOT EXISTS leiosDbStats (" + , " id INTEGER PRIMARY KEY CHECK (id = 0)," + , " volatileEbs INTEGER NOT NULL," + , " volatileEbTxs INTEGER NOT NULL," + , " volatileTxs INTEGER NOT NULL," + , " immutableEbs INTEGER NOT NULL," + , " immutableEbTxs INTEGER NOT NULL," + , " immutableTxs INTEGER NOT NULL" + , ");" + , -- TODO(geo2a): why exactly is this needed? Initialize the stats with the existing data on node restart? + "INSERT INTO leiosDbStats (id, volatileEbs, volatileEbTxs, volatileTxs, immutableEbs, immutableEbTxs, immutableTxs)" + , "SELECT 0," + , " (SELECT COUNT(*) FROM ebs WHERE immutable = 0)," + , " (SELECT COUNT(*) FROM ebTxs e WHERE NOT EXISTS" + , " (SELECT 1 FROM ebs b WHERE b.ebHashBytes = e.ebHashBytes AND b.immutable = 1))," + , " (SELECT COUNT(*) FROM txs t WHERE NOT EXISTS" + , " (SELECT 1 FROM ebTxs e JOIN ebs b ON b.ebHashBytes = e.ebHashBytes AND b.immutable = 1" + , " WHERE e.txHashBytes = t.txHashBytes))," + , " (SELECT COUNT(*) FROM ebs WHERE immutable = 1)," + , " (SELECT COUNT(*) FROM ebTxs e WHERE EXISTS" + , " (SELECT 1 FROM ebs b WHERE b.ebHashBytes = e.ebHashBytes AND b.immutable = 1))," + , " (SELECT COUNT(*) FROM txs t WHERE EXISTS" + , " (SELECT 1 FROM ebTxs e JOIN ebs b ON b.ebHashBytes = e.ebHashBytes AND b.immutable = 1" + , " WHERE e.txHashBytes = t.txHashBytes))" + , "WHERE NOT EXISTS (SELECT 1 FROM leiosDbStats WHERE id = 0);" + , -- Garbage collection candidates. + "CREATE TABLE IF NOT EXISTS gcTxCandidates (" + , " txHashBytes BLOB NOT NULL PRIMARY KEY" + , ");" ] +-- | The 'ebTxs' rows of one EB hash. @?1@ is the ebHash blob. +sql_eb_txs :: String +sql_eb_txs = + "SELECT txOffset, txHashBytes, txBytesSize FROM ebTxs\n\ + \WHERE ebHashBytes = ?1\n" + +-- | A tx's bytes. Yields NULL when the tx is absent. +sql_tx_bytes :: String -> String +sql_tx_bytes txHashExpr = + "(SELECT txBytes FROM txs WHERE txHashBytes = " <> txHashExpr <> ")" + +-- | All EB announcements +-- TODO(geo2a): do we really need all of them, or only volatile ones? sql_scan_ebs :: String sql_scan_ebs = - "SELECT ebSlot, ebHashBytes\n\ - \FROM ebs\n\ - \ORDER BY ebSlot ASC\n\ - \" + "SELECT ebSlot, ebHashBytes FROM ebs ORDER BY ebSlot ASC\n" -- | For 'sqlScanCompleteEbPointsSince' -- @@ -548,6 +881,8 @@ sql_scan_ebs = -- (its recent row never got a body insert, so its @missingTxCount@ is still -- NULL), leaving its cert-RB parked forever. Hence: keep a hash that has -- /any/ complete row and /any/ row at @ebSlot >= ?@. +-- +-- TODO(geo2a): do we really need all of them, or only volatile ones? sql_scan_complete_ebs_since :: String sql_scan_complete_ebs_since = "SELECT MAX(ebSlot), ebHashBytes FROM ebs\n\ @@ -563,10 +898,10 @@ sql_insert_eb = sql_lookup_ebBodies :: String sql_lookup_ebBodies = - "SELECT txHashBytes, txBytesSize FROM ebTxs\n\ - \WHERE ebHashBytes = ?\n\ - \ORDER BY txOffset ASC\n\ - \" + "SELECT txHashBytes, txBytesSize FROM (\n" + <> sql_eb_txs + <> ")\n\ + \ORDER BY txOffset ASC\n" sql_insert_ebBody :: String sql_insert_ebBody = @@ -595,23 +930,24 @@ sql_filter_missing_txs_json = \WHERE NOT EXISTS (SELECT 1 FROM txs t WHERE t.txHashBytes = unhex(je.value))\n\ \" --- | Find EBs that are now complete (missingTxCount reached 0). +-- | Find all volatile EBs that are now complete (missingTxCount reached 0). sql_find_complete_ebs :: String sql_find_complete_ebs = - "SELECT ebHashBytes, ebSlot FROM ebs WHERE missingTxCount = 0" + "SELECT ebHashBytes, ebSlot FROM ebs WHERE immutable = 0 AND missingTxCount = 0" --- | Mark complete EBs as notified so they are not found again by +-- | Mark complete volatile EBs as notified so they are not found again by -- 'sql_find_complete_ebs'. Uses -1 as a sentinel for "already notified". sql_mark_notified_ebs :: String sql_mark_notified_ebs = - "UPDATE ebs SET missingTxCount = -1 WHERE missingTxCount = 0" + "UPDATE ebs SET missingTxCount = -1 WHERE immutable = 0 AND missingTxCount = 0" --- | Decrement missingTxCount for all EBs referencing the given txHash. +-- | Decrement missingTxCount for all volatile EBs referencing the given txHash. -- Parameter 1: txHashBytes sql_decrement_missing_tx_count :: String sql_decrement_missing_tx_count = "UPDATE ebs SET missingTxCount = missingTxCount - 1\n\ - \WHERE ebHashBytes IN (SELECT ebHashBytes FROM ebTxs WHERE txHashBytes = ?)\n\ + \WHERE immutable = 0\n\ + \ AND ebHashBytes IN (SELECT ebHashBytes FROM ebTxs WHERE txHashBytes = ?)\n\ \" -- | Initialize missingTxCount after EB body is inserted, returning the @@ -626,8 +962,8 @@ sql_init_missing_tx_count :: String sql_init_missing_tx_count = "UPDATE ebs SET missingTxCount = (\n\ \ SELECT COUNT(*) FROM ebTxs e\n\ - \ LEFT JOIN txs t ON e.txHashBytes = t.txHashBytes\n\ - \ WHERE e.ebHashBytes = ? AND t.txHashBytes IS NULL\n\ + \ WHERE e.ebHashBytes = ?\n\ + \ AND NOT EXISTS (SELECT 1 FROM txs t WHERE t.txHashBytes = e.txHashBytes)\n\ \) WHERE ebHashBytes = ? AND ebSlot = ?\n\ \RETURNING missingTxCount\n\ \" @@ -643,26 +979,153 @@ sql_mark_point_notified = -- | Batch retrieve of tx bytes for a batch of @(ebHash, offset)@ points. -- @?1@ is the ebHash blob (all offsets belong to the same EB); @?2@ is a --- JSON int array of offsets. The join uses ebTxs' PK --- @(ebHashBytes, txOffset)@, so index lookups still fire. +-- JSON int array of offsets. +-- +-- The per-hash filter lives inside 'sql_eb_txs', so the join reads as if it +-- were on @txOffset@ alone. It still costs one index seek per offset via the +-- full @(ebHashBytes, txOffset)@ PK. sql_retrieve_from_ebTxs_json :: String sql_retrieve_from_ebTxs_json = - "SELECT je.value, e.txHashBytes, t.txBytes\n\ - \FROM json_each(?2) je\n\ - \JOIN ebTxs e ON e.ebHashBytes = ?1 AND e.txOffset = je.value\n\ - \LEFT JOIN txs t ON e.txHashBytes = t.txHashBytes\n\ - \ORDER BY je.value ASC\n\ - \" + "SELECT je.value, e.txHashBytes,\n " + <> sql_tx_bytes "e.txHashBytes" + <> "\nFROM json_each(?2) je\n\ + \JOIN (\n" + <> sql_eb_txs + <> ") e ON e.txOffset = je.value\n\ + \ORDER BY je.value ASC\n\ + \" sql_lookup_eb_closure :: String sql_lookup_eb_closure = - unlines - [ "SELECT ebTx.txHashBytes, tx.txBytes" - , "FROM ebTxs as ebTx" - , "LEFT JOIN txs as tx ON ebTx.txHashBytes = tx.txHashBytes" - , "WHERE ebTx.ebHashBytes = ?" - , "ORDER BY ebTx.txOffset ASC" - ] + "SELECT ebTx.txHashBytes,\n " + <> sql_tx_bytes "ebTx.txHashBytes" + <> "\nFROM (\n" + <> sql_eb_txs + <> ") AS ebTx\n\ + \ORDER BY ebTx.txOffset ASC\n\ + \" + +-- ** Marking an EB as immutable + +-- | Whether the EB hash (parameter 1) already has an immutable announcement. +sql_copy_is_immutable :: String +sql_copy_is_immutable = + "SELECT EXISTS (SELECT 1 FROM ebs WHERE ebHashBytes = ?1 AND immutable = 1)\n" + +-- | Mark an EB as immutable +-- TODO(geo2a): do we need to check 'immutable = 0'? Probably we could skip that. +sql_copy_flag_immutable :: String +sql_copy_flag_immutable = + "UPDATE ebs SET immutable = 1 WHERE ebHashBytes = ? AND immutable = 0\n" + +sql_copy_count_ebTxs :: String +sql_copy_count_ebTxs = + "SELECT COUNT(*) FROM ebTxs WHERE ebHashBytes = ?1\n" + +-- | How many of the certified EB's txs become immutable /now/: txs referenced +-- by this EB and by no other already-immutable EB. +sql_copy_count_new_immutable_txs :: String +sql_copy_count_new_immutable_txs = + "SELECT COUNT(DISTINCT e.txHashBytes) FROM ebTxs e\n\ + \WHERE e.ebHashBytes = ?1\n\ + \ AND NOT EXISTS\n\ + \ (SELECT 1 FROM ebTxs e2\n\ + \ JOIN ebs b ON b.ebHashBytes = e2.ebHashBytes AND b.immutable = 1\n\ + \ WHERE e2.txHashBytes = e.txHashBytes AND e2.ebHashBytes <> ?1)\n" + +-- | Move this EBs row counts from the volatile side of +-- 'leiosDbStats' to the immutable side. +-- TODO(geo2a): this is getting a little too complicated. Consider simplifying the stats. +sql_copy_move_stats :: String +sql_copy_move_stats = + "UPDATE leiosDbStats SET\n\ + \ volatileEbs = volatileEbs - ?1, immutableEbs = immutableEbs + ?1,\n\ + \ volatileEbTxs = volatileEbTxs - ?2, immutableEbTxs = immutableEbTxs + ?2,\n\ + \ volatileTxs = volatileTxs - ?3, immutableTxs = immutableTxs + ?3\n\ + \WHERE id = 0\n" + +-- | Fold deltas into the volatile counters of +-- 'leiosDbStats'. +sql_update_volatile_stats :: String +sql_update_volatile_stats = + "UPDATE leiosDbStats SET\n\ + \ volatileEbs = volatileEbs + ?1,\n\ + \ volatileEbTxs = volatileEbTxs + ?2,\n\ + \ volatileTxs = volatileTxs + ?3\n\ + \WHERE id = 0\n" + +-- | Read the running immutable-partition counts. +sql_read_immutable_stats :: String +sql_read_immutable_stats = + "SELECT immutableEbs, immutableEbTxs, immutableTxs FROM leiosDbStats WHERE id = 0\n" + +-- | Read the running volatile-partition counts. +sql_read_volatile_stats :: String +sql_read_volatile_stats = + "SELECT volatileEbs, volatileEbTxs, volatileTxs FROM leiosDbStats WHERE id = 0\n" + +-- ** Garbage collection of the volatile partition + +-- | Whether a GC at slot @?1@ would evict anything. +sql_gc_has_work :: String +sql_gc_has_work = + "SELECT EXISTS (SELECT 1 FROM ebs WHERE immutable = 0 AND ebSlot < ?1)\n\ + \" + +-- | The evictable EB hashes: every announcement is volatile and older than +-- the GC slot @?1@. +sql_gc_stale_hashes :: String +sql_gc_stale_hashes = + "SELECT DISTINCT cand.ebHashBytes FROM ebs cand\n\ + \ WHERE cand.immutable = 0 AND cand.ebSlot < ?1\n\ + \ AND NOT EXISTS\n\ + \ (SELECT 1 FROM ebs\n\ + \ WHERE ebs.ebHashBytes = cand.ebHashBytes\n\ + \ AND (ebs.immutable = 1 OR ebs.ebSlot >= ?1))\n" + +-- | Stage the txs of the stale EB hashes as orphan candidates. @?1@ is the GC +-- slot. +sql_gc_stage_orphan_candidates :: String +sql_gc_stage_orphan_candidates = + "INSERT OR IGNORE INTO gcTxCandidates (txHashBytes)\n\ + \ SELECT DISTINCT txHashBytes FROM ebTxs WHERE ebHashBytes IN\n\ + \ (" + <> sql_gc_stale_hashes + <> ")\n" + +-- | Evict the body rows of the stale EB hashes. @?1@ is the GC slot. +sql_gc_ebTxs :: String +sql_gc_ebTxs = + "DELETE FROM ebTxs WHERE ebHashBytes IN\n\ + \ (" + <> sql_gc_stale_hashes + <> ")\n" + +-- | Evict volatile announcements older than the GC slot @?1@. +sql_gc_ebs :: String +sql_gc_ebs = "DELETE FROM ebs WHERE immutable = 0 AND ebSlot < ?\n" + +-- | Reap staged candidate txs that no EB references any more. +sql_gc_orphan_txs :: String +sql_gc_orphan_txs = + "DELETE FROM txs WHERE txHashBytes IN\n\ + \ (SELECT txHashBytes FROM gcTxCandidates)\n\ + \ AND NOT EXISTS\n\ + \ (SELECT 1 FROM ebTxs WHERE ebTxs.txHashBytes = txs.txHashBytes)\n\ + \" + +-- | Full-scan variant of 'sql_gc_orphan_txs', run once per handle on the +-- first GC: reaps orphans the candidate scheme cannot see (e.g. from before +-- 'gcTxCandidates' existed). +sql_gc_orphan_txs_full_scan :: String +sql_gc_orphan_txs_full_scan = + "DELETE FROM txs WHERE NOT EXISTS\n\ + \ (SELECT 1 FROM ebTxs WHERE ebTxs.txHashBytes = txs.txHashBytes)\n\ + \" + +-- | Drop all staged candidates. +sql_gc_clear_candidates :: String +sql_gc_clear_candidates = "DELETE FROM gcTxCandidates\n" -- * Low-level terminating SQLite functions @@ -706,6 +1169,20 @@ dbStep stmt = withDieStmt stmt $ DB.stepNoCB stmt dbStep1 :: HasCallStack => DB.Statement -> IO () dbStep1 stmt = withDieDoneStmt stmt $ DB.stepNoCB stmt +-- | 'dbStep' through the safe FFI binding of @sqlite3_step@ ('DB.step' +-- rather than 'DB.stepNoCB'). +-- +-- Safe FFI calls carry significantly more overhead, but run in a separate +-- GHC RTS capability, meaning they do not block the capability that started them. +-- +-- Use for long-running FFI calls where the faster unsafe FFI does not win much. +dbStepSafe :: HasCallStack => DB.Statement -> IO DB.StepResult +dbStepSafe stmt = withDieStmt stmt $ DB.step stmt + +-- | 'dbStep1' through the safe FFI binding; see 'dbStepSafe'. +dbStep1Safe :: HasCallStack => DB.Statement -> IO () +dbStep1Safe stmt = withDieDoneStmt stmt $ DB.step stmt + -- | Like 'dbStep1' but returns 'True' on success and 'False' on constraint -- violation (duplicate key). Other errors are thrown as usual. dbStepInsert :: HasCallStack => DB.Statement -> IO Bool @@ -732,7 +1209,8 @@ dbStepInsert stmt = -- | Step an INSERT statement, absorbing UNIQUE/PRIMARY KEY violations and -- emitting a 'TraceLeiosDbInsertCollision' for each one. The caller supplies a --- table label and a key description for the trace. +-- table label and a key description for the trace. Returns whether the row +-- was actually inserted. -- -- After a constraint error, sqlite3_reset reports the same error code; the -- normal 'dbReset' would re-throw it, so we use raw 'DB.reset' and discard the @@ -744,12 +1222,13 @@ dbStepInsertOrTrace :: String -> String -> DB.Statement -> - IO () + IO Bool dbStepInsertOrTrace tracer table key stmt = do - novel <- dbStepInsert stmt + isNew <- dbStepInsert stmt _ <- DB.reset stmt - unless novel $ + unless isNew $ traceWith tracer (TraceLeiosDbInsertCollision table key) + pure isNew -- ** Error "handling" diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Trace.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Trace.hs index ae399ed925..b5421a9de1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Trace.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoDb/Trace.hs @@ -1,8 +1,44 @@ +-- TODO(geo2a): Claude really likes partial fields. Consider getting rid of them in the final production version. +{-# OPTIONS_GHC -Wno-partial-fields #-} + module LeiosDemoDb.Trace (TraceLeiosDb (..)) where +import LeiosUtils.CallTrace (SomeJsonCallTrace) + data TraceLeiosDb = -- | A UNIQUE/PRIMARY KEY constraint was violated by an INSERT, the -- offending row was silently ignored. Fields: table name, then a -- human-readable description of the colliding key. TraceLeiosDbInsertCollision String String + | -- | Size of the volatile LeiosDB partition and its on-disk footprint, sampled on a + -- timer independent of any chain activity. + TraceLeiosDbVolatileStats + { volatileEbs :: !Int + , volatileEbTxs :: !Int + , volatileTxs :: !Int + , dbFileBytes :: !Integer + , walBytes :: !Integer + } + | -- | Size of the immutable LeiosDB partition, sampled on the same timer as + -- 'TraceLeiosDbVolatileStats'. The counts are maintained incrementally by + -- 'LeiosDbHandle.leiosDbMarkAsImmutable'. + TraceLeiosDbImmutableStats + { immutableEbs :: !Int + , immutableEbTxs :: !Int + , immutableTxs :: !Int + } + | -- | Rows moved into the immutable partition by 'LeiosDbHandle.leiosDbMarkAsImmutable'. + TraceLeiosDbCopiedToImmutable + { copiedEbs :: !Int + , copiedEbTxs :: !Int + , copiedTxs :: !Int + } + | -- | Rows evicted by 'LeiosDbHandle.leiosDbGarbageCollect'. + TraceLeiosDbEvicted + { evictedEbs :: !Int + , evictedEbTxs :: !Int + , evictedTxs :: !Int + } + | -- | A trace event for LeiosUtils.CallTrace spans + TraceLeiosDbCall !SomeJsonCallTrace deriving Show diff --git a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs index b1d6ec49e4..28e00156f5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/LeiosDemoTypes.hs @@ -102,6 +102,7 @@ import LeiosDemoOnlyTestFetch (LeiosFetch, Message (..)) import qualified LeiosDemoOnlyTestFetch as LeiosFetch import LeiosDemoOnlyTestNotify (LeiosNotify, Message (..)) import qualified LeiosDemoOnlyTestNotify as LeiosNotify +import LeiosUtils.CallTrace (SomeJsonCallTrace (..), callTraceToObject) import NoThunks.Class (OnlyCheckWhnfNamed (..)) import qualified Numeric import Ouroboros.Consensus.Ledger.Basics (EmptyMK, LedgerState) @@ -1065,6 +1066,46 @@ traceLeiosKernelToObject = \case , "table" .= table , "key" .= key ] + TraceLeiosDb + TraceLeiosDbVolatileStats{volatileEbs, volatileEbTxs, volatileTxs, dbFileBytes, walBytes} -> + mconcat + [ "kind" .= Aeson.String "LeiosDbVolatileStats" + , "volatileEbs" .= volatileEbs + , "volatileEbTxs" .= volatileEbTxs + , "volatileTxs" .= volatileTxs + , "dbFileBytes" .= dbFileBytes + , "walBytes" .= walBytes + ] + TraceLeiosDb + TraceLeiosDbImmutableStats + { immutableEbs + , immutableEbTxs + , immutableTxs + } -> + mconcat + [ "kind" .= Aeson.String "LeiosDbImmutableStats" + , "immutableEbs" .= immutableEbs + , "immutableEbTxs" .= immutableEbTxs + , "immutableTxs" .= immutableTxs + ] + TraceLeiosDb TraceLeiosDbCopiedToImmutable{copiedEbs, copiedEbTxs, copiedTxs} -> + mconcat + [ "kind" .= Aeson.String "LeiosDbCopiedToImmutable" + , "copiedEbs" .= copiedEbs + , "copiedEbTxs" .= copiedEbTxs + , "copiedTxs" .= copiedTxs + ] + TraceLeiosDb TraceLeiosDbEvicted{evictedEbs, evictedEbTxs, evictedTxs} -> + mconcat + [ "kind" .= Aeson.String "LeiosDbEvicted" + , "evictedEbs" .= evictedEbs + , "evictedEbTxs" .= evictedEbTxs + , "evictedTxs" .= evictedTxs + ] + -- The object carries @"kind": "Call"@ (from 'callTraceToObject'), matching + -- the forge loop's call traces, so one dashboard query shape covers both. + TraceLeiosDb (TraceLeiosDbCall (SomeJsonCallTrace ct)) -> + callTraceToObject ct TraceLeiosCertifiedAndAnnounced slotNo rbHash -> mconcat [ "kind" .= Aeson.String "LeiosCertifiedAndAnnounced" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index 143499bc4a..ed075849ee 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -61,7 +61,7 @@ import GHC.Stack (HasCallStack) import LeiosDemoDb.Common ( LeiosEbNotification (..) , leiosDbGarbageCollect - , leiosDbPromoteToImmutable + , leiosDbMarkAsImmutable , subscribeEbNotifications ) import LeiosDemoTypes (LeiosPoint, pointEbHash) @@ -240,9 +240,9 @@ copyToImmutableDB cdb@CDB{..} = withWriteAccess cdbImmutableDBLock $ \() -> do -- slot-scheduled VolatileDB-side GC can evict its body and closure. By the -- parking invariant a cert-RB is only selected once its certified EB's -- closure is acquired, so an immutalised cert-RB's closure is necessarily - -- present (and complete) now. See 'leiosDbPromoteToImmutable'. + -- present (and complete) now. See 'leiosDbMarkAsImmutable'. getBI <- atomically $ VolatileDB.getBlockInfo cdbVolatileDB - forM_ (certifiedEb getBI hash) $ leiosDbPromoteToImmutable cdbLeiosDb + forM_ (certifiedEb getBI hash) $ leiosDbMarkAsImmutable cdbLeiosDb -- TODO the invariant of 'cdbChain' is shortly violated between -- these two lines: the tip was updated on the line above, but the -- anchor point is only updated on the line below. @@ -482,9 +482,6 @@ garbageCollectBlocks CDB{..} slotNo = do atomically $ do modifyTVar cdbInvalid $ fmap $ Map.filter ((>= slotNo) . invalidBlockSlotNo) PerasCertDB.garbageCollect cdbPerasCertDB slotNo - -- Evict LeiosDb EB bodies and closures no longer needed now that everything - -- up to 'slotNo' is immutable. Driven by the same scheduled slot as the other - -- stores; currently a no-op (see 'leiosDbGarbageCollect'). leiosDbGarbageCollect cdbLeiosDb slotNo traceWith cdbTracer $ TraceGCEvent $ PerformedGC slotNo diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 649a337dcd..7676f9f0a3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -402,8 +402,8 @@ data ChainDbEnv m blk = CDB -- 'leiosDbScanCompleteEbClosuresNotOlderThanSlot'; -- * grow 'cdbAcquiredLeiosEbs' from closure-completion notifications -- ('subscribeEbNotifications'), in @leiosAcquiredEbsRunner@; - -- * promote a copied cert-RB's certified EB into immutable storage - -- ('leiosDbPromoteToImmutable'), in @copyToImmutableDB@; + -- * mark a just-copied cert-RB's certified EB as immutable + -- ('leiosDbMarkAsImmutable'), in @copyToImmutableDB@; -- * garbage-collect volatile LeiosDb data as the immutable tip advances -- ('leiosDbGarbageCollect'), in @garbageCollectBlocks@. }