diff --git a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/Main.hs b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/Main.hs index 35dfce6dec4..78396ede038 100644 --- a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/Main.hs +++ b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/Main.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE TypeFamilies #-} @@ -31,14 +32,11 @@ import GHC.Clock (getMonotonicTimeNSec) import qualified Options.Applicative as O import qualified Control.Monad.State.Strict as Strict import Control.Monad.IO.Class (liftIO) +import Control.Tracer import TxIn.Types import TxIn.GenesisUTxO import qualified TxIn.UTxODb as UTxODb -import qualified UTxODb.InMemory as UTxODb -import qualified UTxODb.Pipeline as UTxODb -import qualified UTxODb.Snapshots as UTxODb -import qualified UTxODb.Haskey.Db as UTxODb main :: IO () main = do @@ -59,19 +57,32 @@ chooseAnalysis = do case whichAnalysis commandLine of InMemSim -> pure inMemSim MeasureAge -> pure measureAge - DbInMemSim -> pure utxodbInMemSim - DbHaskeySim -> pure $ utxodbHaskeySim (haskeyBackend commandLine) + DbInMemSim -> pure $ UTxODb.utxodbInMemSim tracer + DbHaskeySim -> do + hb <- case haskeyBackend commandLine of + Nothing -> error "No haskey backend" + Just x -> x + pure $ UTxODb.utxodbHaskeySim hb tracer where opts = O.info (commandLineParser O.<**> O.helper) $ O.fullDesc <> O.progDesc "Analyse a txin delta timeline file" <> O.header "txin-delta-timeline-analyser - a tool for empirical UTxO HD design" + tracer :: Tracer IO UTxODb.TraceUTxODb + tracer = go `contramap` stdoutTracer where + go UTxODb.TBlock{..} =show (rBlockNumber tbRow) + <> "\t" <> show (rSlotNumber tbRow) + <> "\t" <> show tbTime_ms + <> "\t" <> show tbCreated + <> "\t" <> show tbConsumed + <> "\t" <> show tbSize + go x = show x data AnalysisName = InMemSim | MeasureAge - | DbInMemSim - | DbHaskeySim + | DbInMemSim -- Use DiskDb interface, implemented with a TVar + | DbHaskeySim -- Use Haskey implementation of DiskDb interface deriving (Bounded, Enum, Show) @@ -417,39 +428,6 @@ measureAge = pure $ AgeMeasures utxo' histo' -{- UTxODb interface - --} - -utxodbInMemSim :: [Row] -> IO () -utxodbInMemSim rows = do - let init_seq_no = UTxODb.SeqNo (-2) - db <- UTxODb.initTVarDb init_seq_no - - init_ls <- UTxODb.addTxIns db genesisUTxO (UTxODb.SeqNo (-1)) $ UTxODb.initLedgerState init_seq_no - flip Strict.execStateT init_ls $ for_ (filterRowsForEBBs rows) $ \r -> do - ls0 <- Strict.get - ls <- liftIO (UTxODb.addRow db r (UTxODb.injectTables UTxODb.emptyTables ls0)) - Strict.put ls - pure () - -utxodbHaskeySim :: Maybe (IO UTxODb.HaskeyBackend) -> [Row] -> IO () -utxodbHaskeySim mb_hb rows = do - hb <- fromMaybe (error "No Haskey Backend") mb_hb - - let init_seq_no = UTxODb.SeqNo (-2) - db <- UTxODb.openHaskeyDb init_seq_no hb - init_ls <- UTxODb.addTxIns db genesisUTxO (UTxODb.SeqNo (-1)) $ UTxODb.initLedgerState init_seq_no - let - get_keys r = let - keyset = UTxODb.consumed . UTxODb.keysForRow $ r - in UTxODb.OnDiskLedgerState { UTxODb.od_utxo = UTxODb.TableKeySet keyset } - UTxODb.runPipeline db init_ls 10 (filterRowsForEBBs rows) get_keys UTxODb.rowOp - -- flip Strict.execStateT init_ls $ for_ (filterRowsForEBBs rows) $ \r -> do - -- ls0 <- Strict.get - -- ls <- liftIO (UTxODb.addRow db r (UTxODb.injectTables UTxODb.emptyTables ls0)) - -- Strict.put ls - pure () {------------------------------------------------------------------------------- TODO more simulations/statistics etc diff --git a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/Types.hs b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/Types.hs index 311cb8d1b78..baac678c774 100644 --- a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/Types.hs +++ b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/Types.hs @@ -14,20 +14,11 @@ import GHC.Generics (Generic()) import Data.Binary (Binary()) import Data.Foldable(toList) -import qualified Data.BTree.Primitives.Value as Haskey(Value(..)) -import qualified Data.BTree.Primitives.Key as Haskey(Key(..)) - data TxIn = TxIn !ShortByteString !Word32 -- index deriving (Eq, Ord, Show, Generic) instance Binary TxIn -instance Haskey.Value TxIn where - fixedSize _ = Nothing -- TODO is it fixed size? we can be more efficient if it is - -instance Haskey.Key TxIn - - data TxOutputIds = TxOutputIds !ShortByteString !Word32 -- count deriving (Eq, Ord, Show) diff --git a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/UTxODb.hs b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/UTxODb.hs index 26f89b95bd3..4977293e0b7 100644 --- a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/UTxODb.hs +++ b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/TxIn/UTxODb.hs @@ -1,21 +1,31 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE NumericUnderscores #-} {-# language DataKinds #-} {-# language ScopedTypeVariables #-} -module TxIn.UTxODb where +module TxIn.UTxODb + ( module TxIn.UTxODb + , module X + ) where -import Data.Set (Set) +import UTxODb.Haskey.Db as X(HaskeyBackend, haskeyBackendParser) + +import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Vector as V import qualified Data.Text.Short as TextShort import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Data.ByteString.Short as Short -import Control.Monad.Catch +import Control.Monad.Catch +import Data.Binary (Binary()) +import Data.Maybe import qualified Control.Monad.State.Strict as Strict import Data.Kind @@ -26,10 +36,24 @@ import Data.Functor import Control.Monad (foldM, unless) import Data.Int -import TxIn.Types(Row(..), TxIn(..), outputTxIns) +import TxIn.Types (Row(..), TxIn(..), outputTxIns, filterRowsForEBBs ) +import TxIn.GenesisUTxO import qualified UTxODb.Snapshots as Db + import qualified UTxODb.Haskey.Tree as HaskeyDb +import qualified UTxODb.InMemory as Db +import qualified UTxODb.Pipeline as Db +import qualified UTxODb.Haskey.Db as Db + +import qualified Data.BTree.Primitives.Value as Haskey(Value(..)) +import qualified Data.BTree.Primitives.Key as Haskey(Key(..)) +import Data.Foldable +import Control.Monad.IO.Class +import Control.Tracer +import GHC.Clock (getMonotonicTimeNSec) +import Data.Word + -- writeDb :: dbhandle -- -> [Either (TableDiffs state) (TableSnapshots state)] -- -> SeqNo state -- ^ The old sequence number, as a sanity check @@ -43,16 +67,27 @@ import qualified UTxODb.Haskey.Tree as HaskeyDb -- , rConsumed :: {-# UNPACK #-} !(V.Vector TxIn) -- , rCreated :: {-# UNPACK #-} !(V.Vector TxOutputIds) -- } + + +newtype UTxODbTxIn = UTxODbTxIn TxIn + deriving newtype (Eq, Ord, Show, Binary) + +instance Haskey.Value UTxODbTxIn where + fixedSize _ = Nothing -- TODO is it fixed size? we can be more efficient if it is + +instance Haskey.Key UTxODbTxIn + data LedgerState table = LedgerState - { utxo :: !(table Db.TableTypeRW TxIn Bool) + { utxo :: !(table Db.TableTypeRW UTxODbTxIn Bool) , seq_no :: !Int64 + , size :: !Int } instance Db.HasSeqNo LedgerState where stateSeqNo LedgerState{seq_no} = coerce seq_no initLedgerState :: Db.SeqNo LedgerState -> LedgerState Db.EmptyTable -initLedgerState sn = LedgerState { seq_no = coerce sn, utxo = Db.EmptyTable } +initLedgerState sn = LedgerState { seq_no = coerce sn, utxo = Db.EmptyTable, size = 0 } instance Db.HasTables LedgerState where type StateTableKeyConstraint LedgerState = All @@ -73,7 +108,7 @@ instance Db.HasOnlyTables (Db.Tables LedgerState) where traverse2Tables f x y = OnDiskLedgerState <$> f Db.TableTagRW (od_utxo x) (od_utxo y) instance Db.HasOnDiskTables LedgerState where - newtype Tables LedgerState table = OnDiskLedgerState { od_utxo :: table Db.TableTypeRW TxIn Bool } + newtype Tables LedgerState table = OnDiskLedgerState { od_utxo :: table Db.TableTypeRW UTxODbTxIn Bool } projectTables LedgerState {utxo} = OnDiskLedgerState {od_utxo = utxo} injectTables OnDiskLedgerState{od_utxo} ls@LedgerState {} = ls { utxo = od_utxo } @@ -89,15 +124,15 @@ newtype LedgerRulesException = LedgerRulesException String instance Exception LedgerRulesException data RowTxIns = RowTxIns - { created :: Set TxIn - , consumed :: Set TxIn + { created :: Set UTxODbTxIn + , consumed :: Set UTxODbTxIn } deriving stock (Show) keysForRow :: Row -> RowTxIns keysForRow row = let - consumed0 = Set.fromList $ V.toList $ rConsumed row - created0 = Set.fromList $ concatMap outputTxIns $ V.toList $ rCreated row + consumed0 = Set.fromList $ coerce $ V.toList $ rConsumed row + created0 = Set.fromList $ coerce $ concatMap outputTxIns $ V.toList $ rCreated row created = Set.difference created0 consumed0 consumed = Set.difference consumed0 created0 in RowTxIns{..} @@ -105,8 +140,8 @@ keysForRow row = let ledgerRules :: (MonadThrow m, Db.MappingW (table Db.TableTypeRW), Db.MappingR (table Db.TableTypeRW)) => Row -> LedgerState table -> m (LedgerState table) ledgerRules r ls@LedgerState{utxo = utxo0, seq_no = old_seq_no} = do let RowTxIns{created, consumed} = keysForRow r - sho1 (TxIn h i) = TextShort.toString (encodeBase64 h) <> "@" <> show i - sho2 (TxIn h i) = Char8.unpack (Char8.fromStrict (Short.fromShort (encodeBase16' h))) <> "@" <> show i + sho1 (UTxODbTxIn (TxIn h i)) = TextShort.toString (encodeBase64 h) <> "@" <> show i + sho2 (UTxODbTxIn (TxIn h i)) = Char8.unpack (Char8.fromStrict (Short.fromShort (encodeBase16' h))) <> "@" <> show i (utxo1, missing) <- let go utxo txin = case Db.lookup txin utxo of @@ -124,13 +159,19 @@ ledgerRules r ls@LedgerState{utxo = utxo0, seq_no = old_seq_no} = do in throwM $ LedgerRulesException message let new_seq_no = fromIntegral $ rSlotNumber r - new_ls = ls { utxo = utxo2, seq_no = new_seq_no} + new_ls = ls { utxo = utxo2, seq_no = new_seq_no, size = size ls + length created - length consumed } unless (old_seq_no < new_seq_no) $ throwM $ LedgerRulesException $ unwords ["nonmonotonic slot no:", show old_seq_no, ">", show new_seq_no] pure new_ls -addTxIns :: Db.DiskDb dbhandle LedgerState => dbhandle -> Set TxIn -> Db.SeqNo state -> LedgerState Db.EmptyTable -> IO (LedgerState Db.EmptyTable) -addTxIns handle txins new_seq_no ls0 = do +addTxIns :: Db.DiskDb dbhandle LedgerState + => dbhandle + -> Set TxIn + -> Db.SeqNo state + -> LedgerState Db.EmptyTable + -> IO (LedgerState Db.EmptyTable) +addTxIns handle txins0 new_seq_no ls0 = do + let txins = Set.mapMonotonic coerce txins0 let keyset = OnDiskLedgerState { od_utxo = Db.AnnTable (Db.TableKeySet txins) ()} tracking_tables <- Db.annotatedReadsetToTrackingTables <$> Db.readDb handle keyset @@ -138,17 +179,23 @@ addTxIns handle txins new_seq_no ls0 = do ls1 <- let init_ls = Db.injectTables tracking_tables ls0 go !ls txin = case Db.lookup txin (utxo ls ) of - Nothing -> pure $ ls { utxo = Db.insert txin True (utxo ls) } + Nothing -> do + pure $ ls { utxo = Db.insert txin True (utxo ls) } Just _ -> throwM $ LedgerRulesException $ "addTxIns: duplicate txin:" <> show txin - in (\x -> x { seq_no = coerce new_seq_no }) <$> foldM go init_ls txins + in (\x -> x { seq_no = coerce new_seq_no, size = length txins }) <$> foldM go init_ls txins let table_diffs = Db.projectTables . Db.trackingTablesToTableDiffs $ ls1 Db.writeDb handle [Left table_diffs] (Db.stateSeqNo ls0) (Db.stateSeqNo ls1) - putStrLn $ "addTxIns: " <> show (length txins) pure $ Db.injectTables Db.emptyTables ls1 -- addRow :: forall dbhandle. Db.DiskDb dbhandle LedgerState => dbhandle -> Row -> IO () -addRow :: Db.DiskDb dbhandle LedgerState => dbhandle -> Row -> LedgerState Db.EmptyTable -> IO (LedgerState Db.EmptyTable) -addRow handle r ls0 = do +addRow :: Db.DiskDb dbhandle LedgerState + => dbhandle + -> Tracer IO TraceUTxODb + -> Word64 -- ^ report time relative to this + -> Row + -> LedgerState Db.EmptyTable + -> IO (LedgerState Db.EmptyTable) +addRow handle tracer t0 r ls0 = do let RowTxIns {created, consumed} = keysForRow r keyset :: Db.AnnTableKeySets LedgerState () keyset = OnDiskLedgerState { od_utxo = Db.AnnTable (Db.TableKeySet consumed) ()} @@ -159,11 +206,9 @@ addRow handle r ls0 = do ls1 <- ledgerRules r ls let table_diffs = Db.projectTables . Db.trackingTablesToTableDiffs $ ls1 Db.writeDb handle [Left table_diffs] (Db.stateSeqNo ls0) (Db.stateSeqNo ls1) - putStrLn $ show (rBlockNumber r) - <> "\t" <> show (rSlotNumber r) - <> "\t" <> show (Set.size consumed) - <> "\t" <> show (Set.size created) + now <- getMonotonicTimeNSec + traceWith tracer $ TBlock ((now - t0) `div` 1_000_000) r (length created) (length consumed) (size ls1) pure $ Db.injectTables Db.emptyTables ls1 @@ -174,3 +219,55 @@ rowOp r ls0 = let Just x -> x table_diffs = Db.trackingTablesToTableDiffs ls1 in table_diffs + +utxodbInMemSim :: Tracer IO TraceUTxODb -> [Row] -> IO () +utxodbInMemSim tracer rows = do + let init_seq_no = Db.SeqNo (-2) + db <- Db.initTVarDb init_seq_no + + init_ls <- addTxIns db genesisUTxO (Db.SeqNo (-1)) $ initLedgerState init_seq_no + t0 <- getMonotonicTimeNSec + flip Strict.execStateT init_ls $ for_ (filterRowsForEBBs rows) $ \r -> do + ls0 <- Strict.get + ls <- liftIO (addRow db tracer t0 r (Db.injectTables Db.emptyTables ls0)) + Strict.put ls + pure () + +data TracePipeline + deriving stock (Show) +data TraceUTxODb + = TPipeline TracePipeline + | TBlock + { tbTime_ms :: !Word64 + , tbRow :: !Row + , tbCreated :: Int + , tbConsumed :: Int + , tbSize :: Int + } + deriving stock (Show) + +utxodbHaskeySim :: Db.HaskeyBackend + -> Tracer IO TraceUTxODb + -> [Row] + -> IO () +utxodbHaskeySim hb tracer rows = do + let init_seq_no = Db.SeqNo (-2) + db <- Db.openHaskeyDb init_seq_no hb + init_ls <- addTxIns db genesisUTxO (Db.SeqNo (-1)) $ initLedgerState init_seq_no + + t0 <- getMonotonicTimeNSec + flip Strict.execStateT init_ls $ for_ (filterRowsForEBBs rows) $ \r -> do + ls0 <- Strict.get + ls <- liftIO (addRow db tracer t0 r (Db.injectTables Db.emptyTables ls0)) + Strict.put ls + -- TODO this is a pipelined implementation + -- let + -- get_keys r = let + -- keyset = consumed . keysForRow $ r + -- in OnDiskLedgerState { od_utxo = Db.TableKeySet . Set.mapMonotonic coerce $ keyset } + -- Db.runPipeline db init_ls 10 (filterRowsForEBBs rows) get_keys rowOp + -- flip Strict.execStateT init_ls $ for_ (filterRowsForEBBs rows) $ \r -> do + -- ls0 <- Strict.get + -- ls <- liftIO (UTxODb.addRow db r (UTxODb.injectTables UTxODb.emptyTables ls0)) + -- Strict.put ls + pure () diff --git a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/UTxODb/Haskey/Db.hs b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/UTxODb/Haskey/Db.hs index 80223ade03f..599773250f8 100644 --- a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/UTxODb/Haskey/Db.hs +++ b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/UTxODb/Haskey/Db.hs @@ -53,6 +53,7 @@ import UTxODb.Haskey.Tree import Control.Concurrent.MVar import Data.Functor import Data.Monoid +import Database.Haskey.Store.InMemory (newEmptyMemoryStore) data HaskeySideTable state = HaskeySideTable { seqId :: !(SeqNo state) @@ -283,7 +284,7 @@ haskeyBackendParser = haskeyParamsParser <&> \HaskeyParams{..} -> do , filename = haskeyFile } else do - memFiles <- newEmptyMVar + memFiles <- newEmptyMemoryStore pure HBMemory { memConfig = Haskey.MemoryStoreConfig { Haskey.memoryStoreConfigPageSize = maybe (Haskey.memoryStoreConfigPageSize Haskey.defMemoryStoreConfig) fromIntegral haskeyPageSize diff --git a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/txin-delta-timeline-analyser.cabal b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/txin-delta-timeline-analyser.cabal index 558953b66bc..e304e37f1d3 100644 --- a/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/txin-delta-timeline-analyser.cabal +++ b/ouroboros-consensus-cardano/tools/txin-delta-timeline-analyser/txin-delta-timeline-analyser.cabal @@ -39,7 +39,8 @@ library mtl, haskey-btree, haskey, - async + async, + contra-tracer executable txin hs-source-dirs: app