Tidying

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

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)

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,24 +124,24 @@ 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{..}
 
 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,31 +159,43 @@ 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
 
   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 ()

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

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