Skip to content

Commit 7af3e4d

Browse files
jasagredojasagredo
committed
Make forkers more observable
1 parent fe2513c commit 7af3e4d

File tree

6 files changed

+126
-93
lines changed

6 files changed

+126
-93
lines changed

‎ouroboros-consensus/changelog.d/20251124_165014_javier.sagredo_tracing_forkers.md‎

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
<!--
2+
A new scriv changelog fragment.
3+
4+
Uncomment the section that is right (remove the HTML comment wrapper).
5+
For top level release notes, leave all the headers commented out.
6+
-->
7+
8+
### Patch
9+
10+
- Make forker tracers more informative, with enclosing times.
11+
12+
<!--
13+
### Non-Breaking
14+
15+
- A bullet item for the Non-Breaking category.
16+
17+
-->
18+
<!--
19+
### Breaking
20+
21+
- A bullet item for the Breaking category.
22+
23+
-->

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Forker.hs‎

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -39,6 +39,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Forker
3939
-- ** Tracing
4040
, TraceForkerEvent (..)
4141
, TraceForkerEventWithKey (..)
42+
, ForkerWasCommitted (..)
4243

4344
-- * Validation
4445
, AnnLedgerError (..)
@@ -81,6 +82,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol
8182
import Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache
8283
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.BlockCache as BlockCache
8384
import Ouroboros.Consensus.Util.CallStack
85+
import Ouroboros.Consensus.Util.Enclose
8486
import Ouroboros.Consensus.Util.IOLike
8587

8688
{-------------------------------------------------------------------------------
@@ -663,14 +665,14 @@ data TraceForkerEventWithKey
663665

664666
data TraceForkerEvent
665667
= ForkerOpen
666-
| ForkerCloseUncommitted
667-
| ForkerCloseCommitted
668-
| ForkerReadTablesStart
669-
| ForkerReadTablesEnd
670-
| ForkerRangeReadTablesStart
671-
| ForkerRangeReadTablesEnd
668+
| ForkerReadTables EnclosingTimed
669+
| ForkerRangeReadTables EnclosingTimed
672670
| ForkerReadStatistics
673-
| ForkerPushStart
674-
| ForkerPushEnd
675-
| DanglingForkerClosed
671+
| ForkerPush EnclosingTimed
672+
| ForkerClose ForkerWasCommitted
676673
deriving (Show, Eq)
674+
675+
data ForkerWasCommitted
676+
= ForkerWasCommitted
677+
| ForkerWasUncommitted
678+
deriving (Eq, Show)

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -852,13 +852,15 @@ newForker h ldbEnv (rk, releaseVar) rr dblog =
852852
dblogVar <- newTVarIO dblog
853853
forkerKey <- atomically $ stateTVar (ldbNextForkerKey ldbEnv) $ \r -> (r, r + 1)
854854
forkerMVar <- newMVar $ Left (ldbLock ldbEnv, ldbBackingStore ldbEnv, rr)
855+
forkerCommitted <- newTVarIO False
855856
let forkerEnv =
856857
ForkerEnv
857858
{ foeBackingStoreValueHandle = forkerMVar
858859
, foeChangelog = dblogVar
859860
, foeSwitchVar = ldbChangelog ldbEnv
860861
, foeTracer =
861862
LedgerDBForkerEvent . TraceForkerEventWithKey forkerKey >$< ldbTracer ldbEnv
863+
, foeWasCommitted = forkerCommitted
862864
}
863865
atomically $ do
864866
-- Note that we add the forkerEnv to the 'ldbForkers' so that an exception
@@ -921,5 +923,7 @@ implForkerClose (LDBHandle varState) forkerKey env = do
921923
(\m -> Map.updateLookupWithKey (\_ _ -> Nothing) forkerKey m)
922924
case frk of
923925
Nothing -> pure ()
924-
Just e -> traceWith (foeTracer e) DanglingForkerClosed
926+
Just e -> do
927+
wc <- readTVarIO (foeWasCommitted e)
928+
traceWith (foeTracer e) (ForkerClose $ if wc then ForkerWasCommitted else ForkerWasUncommitted)
925929
closeForkerEnv env

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Forker.hs‎

Lines changed: 47 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V1.Forker
2323
import qualified Control.Monad as Monad
2424
import Control.ResourceRegistry
2525
import Control.Tracer
26+
import Data.Functor.Contravariant ((>$<))
2627
import qualified Data.Map.Strict as Map
2728
import Data.Semigroup
2829
import qualified Data.Set as Set
@@ -43,6 +44,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq
4344
)
4445
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DiffSeq as DS
4546
import Ouroboros.Consensus.Storage.LedgerDB.V1.Lock
47+
import Ouroboros.Consensus.Util.Enclose
4648
import Ouroboros.Consensus.Util.IOLike
4749
import qualified Ouroboros.Network.AnchoredSeq as AS
4850

@@ -72,6 +74,7 @@ data ForkerEnv m l blk = ForkerEnv
7274
-- flushed, but 'forkerCommit' will take care of this.
7375
, foeTracer :: !(Tracer m TraceForkerEvent)
7476
-- ^ Config
77+
, foeWasCommitted :: !(StrictTVar m Bool)
7578
}
7679
deriving Generic
7780

@@ -132,53 +135,50 @@ implForkerReadTables ::
132135
ForkerEnv m l blk ->
133136
LedgerTables l KeysMK ->
134137
m (LedgerTables l ValuesMK)
135-
implForkerReadTables env ks = do
136-
traceWith (foeTracer env) ForkerReadTablesStart
137-
chlog <- readTVarIO (foeChangelog env)
138-
bsvh <- getValueHandle env
139-
unfwd <- readKeySetsWith bsvh (changelogLastFlushedState chlog) ks
140-
case forwardTableKeySets chlog unfwd of
141-
Left _err -> error "impossible!"
142-
Right vs -> do
143-
traceWith (foeTracer env) ForkerReadTablesEnd
144-
pure vs
138+
implForkerReadTables env ks =
139+
encloseTimedWith (ForkerReadTables >$< foeTracer env) $ do
140+
chlog <- readTVarIO (foeChangelog env)
141+
bsvh <- getValueHandle env
142+
unfwd <- readKeySetsWith bsvh (changelogLastFlushedState chlog) ks
143+
case forwardTableKeySets chlog unfwd of
144+
Left _err -> error "impossible!"
145+
Right vs -> pure vs
145146

146147
implForkerRangeReadTables ::
147148
(IOLike m, GetTip l, HasLedgerTables l) =>
148149
QueryBatchSize ->
149150
ForkerEnv m l blk ->
150151
RangeQueryPrevious l ->
151152
m (LedgerTables l ValuesMK, Maybe (TxIn l))
152-
implForkerRangeReadTables qbs env rq0 = do
153-
traceWith (foeTracer env) ForkerRangeReadTablesStart
154-
ldb <- readTVarIO $ foeChangelog env
155-
let
156-
-- Get the differences without the keys that are greater or equal
157-
-- than the maximum previously seen key.
158-
diffs =
159-
maybe
160-
id
161-
(ltliftA2 doDropLTE)
162-
(BackingStore.rqPrev rq)
163-
$ ltmap prj
164-
$ changelogDiffs ldb
165-
-- (1) Ensure that we never delete everything read from disk (ie if
166-
-- our result is non-empty then it contains something read from
167-
-- disk, as we only get an empty result if we reached the end of
168-
-- the table).
169-
--
170-
-- (2) Also, read one additional key, which we will not include in
171-
-- the result but need in order to know which in-memory
172-
-- insertions to include.
173-
maxDeletes = ltcollapse $ ltmap (K2 . numDeletesDiffMK) diffs
174-
nrequested = 1 + max (BackingStore.rqCount rq) (1 + maxDeletes)
153+
implForkerRangeReadTables qbs env rq0 =
154+
encloseTimedWith (ForkerRangeReadTables >$< foeTracer env) $ do
155+
ldb <- readTVarIO $ foeChangelog env
156+
let
157+
-- Get the differences without the keys that are greater or equal
158+
-- than the maximum previously seen key.
159+
diffs =
160+
maybe
161+
id
162+
(ltliftA2 doDropLTE)
163+
(BackingStore.rqPrev rq)
164+
$ ltmap prj
165+
$ changelogDiffs ldb
166+
-- (1) Ensure that we never delete everything read from disk (ie if
167+
-- our result is non-empty then it contains something read from
168+
-- disk, as we only get an empty result if we reached the end of
169+
-- the table).
170+
--
171+
-- (2) Also, read one additional key, which we will not include in
172+
-- the result but need in order to know which in-memory
173+
-- insertions to include.
174+
maxDeletes = ltcollapse $ ltmap (K2 . numDeletesDiffMK) diffs
175+
nrequested = 1 + max (BackingStore.rqCount rq) (1 + maxDeletes)
175176

176-
let st = changelogLastFlushedState ldb
177-
bsvh <- getValueHandle env
178-
(values, mx) <- BackingStore.bsvhRangeRead bsvh st (rq{BackingStore.rqCount = nrequested})
179-
traceWith (foeTracer env) ForkerRangeReadTablesEnd
180-
let res = ltliftA2 (doFixupReadResult nrequested) diffs values
181-
pure (res, mx)
177+
let st = changelogLastFlushedState ldb
178+
bsvh <- getValueHandle env
179+
(values, mx) <- BackingStore.bsvhRangeRead bsvh st (rq{BackingStore.rqCount = nrequested})
180+
let res = ltliftA2 (doFixupReadResult nrequested) diffs values
181+
pure (res, mx)
182182
where
183183
rq = BackingStore.RangeQuery rq1 (fromIntegral $ defaultQueryBatchSize qbs)
184184

@@ -309,17 +309,16 @@ implForkerReadStatistics env = do
309309
}
310310

311311
implForkerPush ::
312-
(MonadSTM m, GetTip l, HasLedgerTables l) =>
312+
(IOLike m, GetTip l, HasLedgerTables l) =>
313313
ForkerEnv m l blk ->
314314
l DiffMK ->
315315
m ()
316-
implForkerPush env newState = do
317-
traceWith (foeTracer env) ForkerPushStart
318-
atomically $ do
319-
chlog <- readTVar (foeChangelog env)
320-
let chlog' = extend newState chlog
321-
writeTVar (foeChangelog env) chlog'
322-
traceWith (foeTracer env) ForkerPushEnd
316+
implForkerPush env newState =
317+
encloseTimedWith (ForkerPush >$< foeTracer env) $ do
318+
atomically $ do
319+
chlog <- readTVar (foeChangelog env)
320+
let chlog' = extend newState chlog
321+
writeTVar (foeChangelog env) chlog'
323322

324323
implForkerCommit ::
325324
(MonadSTM m, GetTip l, StandardHash l, HasLedgerTables l) =>
@@ -350,6 +349,7 @@ implForkerCommit env = do
350349
, changelogDiffs =
351350
ltliftA2 (doPrune s) (changelogDiffs orig) (changelogDiffs dblog)
352351
}
352+
Monad.void $ swapTVar (foeWasCommitted env) True
353353
where
354354
-- Prune the diffs from the forker's log that have already been flushed to
355355
-- disk

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -734,7 +734,9 @@ implForkerClose (LDBHandle varState) forkerKey forkerEnv = do
734734

735735
case frk of
736736
Nothing -> pure ()
737-
Just e -> traceWith (foeTracer e) DanglingForkerClosed
737+
Just e -> do
738+
wc <- readTVarIO (foeWasCommitted e)
739+
traceWith (foeTracer e) (ForkerClose $ if wc then ForkerWasCommitted else ForkerWasUncommitted)
738740

739741
closeForkerEnv forkerEnv
740742

@@ -757,6 +759,7 @@ newForker h ldbEnv rr (rk, st) = do
757759
traceWith tr ForkerOpen
758760
lseqVar <- newTVarIO . LedgerSeq . AS.Empty $ st
759761
foeCleanup <- newTVarIO $ pure ()
762+
forkerCommitted <- newTVarIO False
760763
let forkerEnv =
761764
ForkerEnv
762765
{ foeLedgerSeq = lseqVar
@@ -768,6 +771,7 @@ newForker h ldbEnv rr (rk, st) = do
768771
, foeCleanup
769772
, foeLedgerDbLock = ldbOpenHandlesLock ldbEnv
770773
, foeLedgerDbToClose = ldbToClose ldbEnv
774+
, foeWasCommitted = forkerCommitted
771775
}
772776
atomically $ modifyTVar (ldbForkers ldbEnv) $ Map.insert forkerKey forkerEnv
773777
pure $

‎ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs‎

Lines changed: 35 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.V2.Forker
2222
import Control.RAWLock (RAWLock)
2323
import Control.ResourceRegistry
2424
import Control.Tracer
25+
import Data.Functor.Contravariant ((>$<))
2526
import Data.Maybe (fromMaybe)
2627
import GHC.Generics
2728
import NoThunks.Class
@@ -35,6 +36,7 @@ import Ouroboros.Consensus.Storage.LedgerDB.Forker
3536
import Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq
3637
import Ouroboros.Consensus.Util (whenJust)
3738
import Ouroboros.Consensus.Util.CallStack
39+
import Ouroboros.Consensus.Util.Enclose
3840
import Ouroboros.Consensus.Util.IOLike
3941
import Ouroboros.Consensus.Util.NormalForm.StrictTVar ()
4042
import qualified Ouroboros.Network.AnchoredSeq as AS
@@ -66,6 +68,7 @@ data ForkerEnv m l blk = ForkerEnv
6668
-- LedgerDB and release the discarded ones.
6769
, foeLedgerDbLock :: !(RAWLock m ())
6870
-- ^ 'ldbOpenHandlesLock'.
71+
, foeWasCommitted :: !(StrictTVar m Bool)
6972
}
7073
deriving Generic
7174

@@ -79,36 +82,32 @@ deriving instance
7982
NoThunks (ForkerEnv m l blk)
8083

8184
implForkerReadTables ::
82-
(MonadSTM m, GetTip l) =>
85+
(IOLike m, GetTip l) =>
8386
ForkerEnv m l blk ->
8487
LedgerTables l KeysMK ->
8588
m (LedgerTables l ValuesMK)
86-
implForkerReadTables env ks = do
87-
traceWith (foeTracer env) ForkerReadTablesStart
88-
lseq <- readTVarIO (foeLedgerSeq env)
89-
let stateRef = currentHandle lseq
90-
tbs <- read (tables stateRef) (state stateRef) ks
91-
traceWith (foeTracer env) ForkerReadTablesEnd
92-
pure tbs
89+
implForkerReadTables env ks =
90+
encloseTimedWith (ForkerReadTables >$< foeTracer env) $ do
91+
lseq <- readTVarIO (foeLedgerSeq env)
92+
let stateRef = currentHandle lseq
93+
read (tables stateRef) (state stateRef) ks
9394

9495
implForkerRangeReadTables ::
95-
(MonadSTM m, GetTip l, HasLedgerTables l) =>
96+
(IOLike m, GetTip l, HasLedgerTables l) =>
9697
QueryBatchSize ->
9798
ForkerEnv m l blk ->
9899
RangeQueryPrevious l ->
99100
m (LedgerTables l ValuesMK, Maybe (TxIn l))
100-
implForkerRangeReadTables qbs env rq0 = do
101-
traceWith (foeTracer env) ForkerRangeReadTablesStart
102-
ldb <- readTVarIO $ foeLedgerSeq env
103-
let n = fromIntegral $ defaultQueryBatchSize qbs
104-
stateRef = currentHandle ldb
105-
case rq0 of
106-
NoPreviousQuery -> readRange (tables stateRef) (state stateRef) (Nothing, n)
107-
PreviousQueryWasFinal -> pure (LedgerTables emptyMK, Nothing)
108-
PreviousQueryWasUpTo k -> do
109-
tbs <- readRange (tables stateRef) (state stateRef) (Just k, n)
110-
traceWith (foeTracer env) ForkerRangeReadTablesEnd
111-
pure tbs
101+
implForkerRangeReadTables qbs env rq0 =
102+
encloseTimedWith (ForkerRangeReadTables >$< foeTracer env) $ do
103+
ldb <- readTVarIO $ foeLedgerSeq env
104+
let n = fromIntegral $ defaultQueryBatchSize qbs
105+
stateRef = currentHandle ldb
106+
case rq0 of
107+
NoPreviousQuery -> readRange (tables stateRef) (state stateRef) (Nothing, n)
108+
PreviousQueryWasFinal -> pure (LedgerTables emptyMK, Nothing)
109+
PreviousQueryWasUpTo k ->
110+
readRange (tables stateRef) (state stateRef) (Just k, n)
112111

113112
implForkerGetLedgerState ::
114113
(MonadSTM m, GetTip l) =>
@@ -129,24 +128,23 @@ implForkerPush ::
129128
ForkerEnv m l blk ->
130129
l DiffMK ->
131130
m ()
132-
implForkerPush env newState = do
133-
traceWith (foeTracer env) ForkerPushStart
134-
lseq <- readTVarIO (foeLedgerSeq env)
131+
implForkerPush env newState =
132+
encloseTimedWith (ForkerPush >$< foeTracer env) $ do
133+
lseq <- readTVarIO (foeLedgerSeq env)
135134

136-
let st0 = current lseq
137-
st = forgetLedgerTables newState
135+
let st0 = current lseq
136+
st = forgetLedgerTables newState
138137

139-
bracketOnError
140-
(duplicate (tables $ currentHandle lseq) (foeResourceRegistry env))
141-
(release . fst)
142-
( \(_, newtbs) -> do
143-
pushDiffs newtbs st0 newState
138+
bracketOnError
139+
(duplicate (tables $ currentHandle lseq) (foeResourceRegistry env))
140+
(release . fst)
141+
( \(_, newtbs) -> do
142+
pushDiffs newtbs st0 newState
144143

145-
let lseq' = extend (StateRef st newtbs) lseq
144+
let lseq' = extend (StateRef st newtbs) lseq
146145

147-
traceWith (foeTracer env) ForkerPushEnd
148-
atomically $ writeTVar (foeLedgerSeq env) lseq'
149-
)
146+
atomically $ writeTVar (foeLedgerSeq env) lseq'
147+
)
150148

151149
implForkerCommit ::
152150
(IOLike m, GetTip l, StandardHash l) =>
@@ -183,6 +181,7 @@ implForkerCommit env = do
183181
)
184182
whenJust ldbToClose (modifyTVar foeLedgerDbToClose . (:))
185183
writeTVar foeCleanup transfer
184+
writeTVar foeWasCommitted True
186185
where
187186
ForkerEnv
188187
{ foeLedgerSeq
@@ -191,6 +190,7 @@ implForkerCommit env = do
191190
, foeLedgerDbRegistry
192191
, foeCleanup
193192
, foeLedgerDbToClose
193+
, foeWasCommitted
194194
} = env
195195

196196
theImpossible =

0 commit comments

Comments
 (0)