diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 7d35dfd91a..d37094d48c 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -30,7 +30,7 @@ import qualified Cardano.Slotting.Slot as Slotting import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.FileWriting as F import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.SlotDataPoint as DP import Cardano.Tools.DBAnalyser.CSV (computeAndWriteLine, - writeHeaderLine) + writeHeaderLine, writeLine) import Cardano.Tools.DBAnalyser.HasAnalysis (HasAnalysis) import qualified Cardano.Tools.DBAnalyser.HasAnalysis as HasAnalysis import Cardano.Tools.DBAnalyser.Types @@ -45,6 +45,7 @@ import qualified Data.Map.Strict as Map import Data.Singletons import Data.Word (Word16, Word32, Word64) import qualified Debug.Trace as Debug +import GHC.Profiling import qualified GHC.Stats as GC import NoThunks.Class (noThunks) import Ouroboros.Consensus.Block @@ -75,6 +76,7 @@ import qualified Ouroboros.Consensus.Util.IOLike as IOLike import Ouroboros.Network.Protocol.LocalStateQuery.Type import Ouroboros.Network.SizeInBytes import qualified System.IO as IO +import qualified Text.Builder as Builder {------------------------------------------------------------------------------- Run the requested analysis @@ -825,7 +827,10 @@ reproMempoolForge numBlks env = do ) nullTracer - void $ processAll db registry GetBlock startFrom limit Nothing (process howManyBlocks mempool) + hdl <- IO.openFile "readd-txs.csv" IO.WriteMode + writeLine hdl "\t" ["txid", "dur", "mut", "gc"] + void $ processAll db registry GetBlock startFrom limit Nothing (process howManyBlocks hdl mempool) + IO.hFlush hdl pure Nothing where AnalysisEnv { @@ -834,7 +839,6 @@ reproMempoolForge numBlks env = do , db , registry , limit - , tracer } = env lCfg :: LedgerConfig blk @@ -855,14 +859,16 @@ reproMempoolForge numBlks env = do process :: ReproMempoolForgeHowManyBlks + -> IO.Handle -> Mempool.Mempool IO blk -> Maybe blk -> blk -> IO (Maybe blk) - process howManyBlocks mempool mbBlk blk' = (\() -> Just blk') <$> do + process howManyBlocks hdl mempool mbBlk blk' = (\() -> Just blk') <$> do + let txs = LedgerSupportsMempool.extractTxs blk' -- add this block's transactions to the mempool do - results <- Mempool.addTxs mempool $ LedgerSupportsMempool.extractTxs blk' + results <- Mempool.addTxs mempool txs let rejs = [ (LedgerSupportsMempool.txId tx, rej) | rej@(Mempool.MempoolTxRejected tx _) <- results @@ -877,42 +883,33 @@ reproMempoolForge numBlks env = do , "Consider trying again with `--repro-mempool-and-forge 1`." ] + Foldable.for_ txs $ \tx -> do + let isInteresting = show (LedgerSupportsMempool.txId tx) `elem` intTxs + where + intTxs = + [ "HardForkGenTxId {getHardForkGenTxId = S (S (S (S (S (S (Z (WrapGenTxId {unwrapGenTxId = txid: TxId {unTxId = SafeHash \"0dc72224c84ed853231c6a7790e9d4ac4e31dc13824779dedb59330e8b177804\"}})))))))}" + , "HardForkGenTxId {getHardForkGenTxId = S (S (S (S (S (S (Z (WrapGenTxId {unwrapGenTxId = txid: TxId {unTxId = SafeHash \"681db1ffb477e9a52adafd8ce643eb01a6bceb5abc7ae4a503d76936c54feea0\"}})))))))}" + ] + when isInteresting startProfTimer + (res, dur, mut, gc) <- timed $ Mempool.addTx mempool Mempool.AddTxForRemotePeer tx + when isInteresting stopProfTimer + case res of + Mempool.MempoolTxRejected {} -> pure () + Mempool.MempoolTxAdded {} -> fail "unexpected success" + + writeLine hdl "\t" + [ Builder.string $ show $ LedgerSupportsMempool.txId tx + , Builder.decimal $ round @_ @Int $ dur * 1000000 + , Builder.decimal $ mut + , Builder.decimal gc + ] + let scrutinee = case howManyBlocks of ReproMempoolForgeOneBlk -> Just blk' ReproMempoolForgeTwoBlks -> mbBlk case scrutinee of Nothing -> pure () Just blk -> do - LedgerDB.withPrivateTipForker ledgerDB $ \forker -> do - st <- IOLike.atomically $ LedgerDB.forkerGetLedgerState forker - - -- time the suspected slow parts of the forge thread that created - -- this block - -- - -- Primary caveat: that thread's mempool may have had more transactions in it. - let slot = blockSlot blk - (ticked, durTick, mutTick, gcTick) <- timed $ IOLike.evaluate $ - applyChainTick lCfg slot (ledgerState st) - ((), durSnap, mutSnap, gcSnap) <- timed $ do - snap <- Mempool.getSnapshotFor mempool slot ticked $ - fmap castLedgerTables . LedgerDB.forkerReadTables forker . castLedgerTables - - pure $ length (Mempool.snapshotTxs snap) `seq` Mempool.snapshotStateHash snap `seq` () - - let sizes = HasAnalysis.blockTxSizes blk - traceWith tracer $ - BlockMempoolAndForgeRepro - (blockNo blk) - slot - (length sizes) - (sum sizes) - durTick - mutTick - gcTick - durSnap - mutSnap - gcSnap - -- advance the ledger state to include this block -- -- TODO We could inline/reuse parts of the IsLedger ExtLedgerState diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index 6ddfc97a33..3a2379de9b 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -35,6 +35,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB import qualified Ouroboros.Consensus.Storage.LedgerDB.V1 as LedgerDB.V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB.V1 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB as LMDB +import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as LedgerDB.V2 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB.V2 import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike @@ -68,8 +69,17 @@ openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs=LedgerDB.Led emptyStream genesisPoint pure (ledgerDB, intLedgerDB) -openLedgerDB LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs=LedgerDB.LedgerDbFlavorArgsV2{}} = - error "not defined for v2, use v1 instead for now!" +openLedgerDB lgrDbArgs@LedgerDB.LedgerDbArgs{LedgerDB.lgrFlavorArgs=LedgerDB.LedgerDbFlavorArgsV2 args} = do + (ledgerDB, _, intLedgerDB) <- + LedgerDB.openDBInternal + lgrDbArgs + (LedgerDB.V2.mkInitDb + lgrDbArgs + args + (\_ -> error "no replay")) + emptyStream + genesisPoint + pure (ledgerDB, intLedgerDB) emptyStream :: Applicative m => ImmutableDB.StreamAPI m blk a emptyStream = ImmutableDB.StreamAPI $ \_ k -> k $ Right $ pure ImmutableDB.NoMoreItems diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs index 6e8ba8eb6c..34819df713 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs @@ -38,8 +38,8 @@ import Control.Monad.Trans.Except (runExcept) import Control.Tracer import qualified Data.Foldable as Foldable import qualified Data.List.NonEmpty as NE -import Data.Set (Set) -import qualified Data.Set as Set +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Typeable import GHC.Generics (Generic) import Ouroboros.Consensus.Block @@ -80,7 +80,7 @@ data InternalState blk = IS { -- 'MempoolSnapshot' (see 'snapshotHasTx'). -- -- This should always be in-sync with the transactions in 'isTxs'. - , isTxIds :: !(Set (GenTxId blk)) + , isTxIds :: !(Map (GenTxId blk) (Validated (GenTx blk))) -- | The cached ledger state after applying the transactions in the -- Mempool against the chain's ledger state. New transactions will be @@ -150,7 +150,7 @@ initInternalState :: -> InternalState blk initInternalState capacityOverride lastTicketNo cfg slot st = IS { isTxs = TxSeq.Empty - , isTxIds = Set.empty + , isTxIds = Map.empty , isLedgerState = st , isTip = castPoint $ getTip st , isSlotNo = slot @@ -279,17 +279,25 @@ validateNewTransaction , InternalState blk ) validateNewTransaction cfg wti tx txsz st is = - case runExcept (applyTx cfg wti isSlotNo tx st) of + case runExcept res of Left err -> ( Left err, is ) Right (st', vtx) -> ( Right vtx , is { isTxs = isTxs :> TxTicket vtx nextTicketNo txsz - , isTxIds = Set.insert (txId tx) isTxIds + , isTxIds = Map.insert (txId tx) vtx isTxIds , isLedgerState = prependDiffs isLedgerState st' , isLastTicketNo = nextTicketNo } ) where + res = case Map.lookup (txId tx) isTxIds of + Nothing -> applyTx cfg wti isSlotNo tx st + Just vtx -> do + _ <- reapplyTx cfg isSlotNo vtx st + -- that must have failed, since every tx must consume at least one + -- input and this one is necessarily a double-spend + pure $ error "unreachable" + IS { isTxs , isTxIds @@ -333,7 +341,7 @@ revalidateTxsFor capacityOverride cfg slot st values lastTicketNo txTickets = in RevalidateTxsResult (IS { isTxs = TxSeq.fromList $ map unwrap val - , isTxIds = Set.fromList $ map (txId . txForgetValidated . fst) val + , isTxIds = Map.fromList $ map (\(vtx, _) -> (txId $ txForgetValidated vtx, vtx)) val , isLedgerState = trackingToDiffs st' , isTip = castPoint $ getTip st , isSlotNo = slot @@ -394,7 +402,7 @@ snapshotFromIS is = MempoolSnapshot { implSnapshotHasTx :: InternalState blk -> GenTxId blk -> Bool - implSnapshotHasTx IS{isTxIds} = flip Set.member isTxIds + implSnapshotHasTx IS{isTxIds} = flip Map.member isTxIds implSnapshotGetMempoolSize :: InternalState blk -> MempoolSize