Skip to content
Permalink
Browse files

Address Duncan's comments

  • Loading branch information...
mrBliss committed Jul 11, 2019
1 parent c59f156 commit c716e0dfb931ea2f519bf7370d5a7362fa1ab0a6
@@ -375,6 +375,32 @@ special case.
have to be careful to use `preferCandidate` rather than `compareCandidates` as
appropriate.

### Concurrency

Multiple blocks might be added concurrently, and since this operation is not
atomic, as it involves writing a block to disk and reading headers from disk,
we explore the possible interleavings.

The three main steps are:

1. Add a block
2. Compute candidates and perform chain selection which might result in a
candidate that is preferred over the current chain.
3. Try to install the candidate as the new chain.

We want that all possible interleavings will result in installing the most
preferable candidate as the new chain. We will reason that this is the case
(for two concurrent threads).

If either of the two computations (step 2) is done with
knowledge of both blocks (after step 1), then the computation with knowledge
of only one block can't possibly construct a candidate that is preferred over
the candidate produced by the other computation.

For this not to be true, both computations would have to be done with only
knowledge of their own block (step 1). This is impossible, as the execution of
step 1 is serialised, so at least one thread must see both blocks.

## Short volatile fragment

Nothing above relies in any way on the length of the current fragment, but
@@ -39,7 +39,11 @@ import Control.Monad.Class.MonadTimer

import Control.Tracer

import Ouroboros.Network.Block (blockNo)
import Ouroboros.Network.Chain (genesisBlockNo)

import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Protocol.Abstract

import Ouroboros.Storage.ChainDB.API

@@ -107,11 +111,20 @@ openDBInternal args launchBgTasks = do
(Args.cdbNodeConfig args)
varInvalid

let chain = ChainSel.clChain chainAndLedger
ledger = ChainSel.clLedger chainAndLedger
-- Get the actual BlockNo of the tip of the ImmutableDB. Note that this
-- might not end up being the \"immutable\" block(no), because the current
-- chain computed from the VolatileDB could be longer than @k@.
immDbBlockNo <- maybe genesisBlockNo blockNo <$> ImmDB.getBlockAtTip immDB

let chain = ChainSel.clChain chainAndLedger
ledger = ChainSel.clLedger chainAndLedger
cfg = Args.cdbNodeConfig args
secParam = protocolSecurityParam cfg
immBlockNo = ChainSel.getImmBlockNo secParam chain immDbBlockNo

atomically $ LgrDB.setCurrent lgrDB ledger
varChain <- atomically $ newTVar chain
varImmBlockNo <- atomically $ newTVar immBlockNo
varIterators <- atomically $ newTVar Map.empty
varReaders <- atomically $ newTVar Map.empty
varNextIteratorId <- atomically $ newTVar $ IteratorId 0
@@ -123,9 +136,10 @@ openDBInternal args launchBgTasks = do
, cdbVolDB = volDB
, cdbLgrDB = lgrDB
, cdbChain = varChain
, cdbImmBlockNo = varImmBlockNo
, cdbIterators = varIterators
, cdbReaders = varReaders
, cdbNodeConfig = Args.cdbNodeConfig args
, cdbNodeConfig = cfg
, cdbInvalid = varInvalid
, cdbNextIteratorId = varNextIteratorId
, cdbNextReaderId = varNextReaderId
@@ -26,8 +26,12 @@ module Ouroboros.Storage.ChainDB.Impl.Background
, updateLedgerSnapshotsRunner
) where

import Control.Exception (assert)
import Control.Monad (forM_, forever)
import Data.Maybe (fromMaybe)
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import GHC.Stack (HasCallStack)

import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
@@ -111,6 +115,7 @@ copyToImmDB
, OuroborosTag (BlockProtocol blk)
, HasHeader blk
, HasHeader (Header blk)
, HasCallStack
)
=> ChainDbEnv m blk
-> m SlotNo
@@ -120,11 +125,15 @@ copyToImmDB CDB{..} = withCopyLock $ do
let nbToCopy = max 0 (AF.length curChain - fromIntegral k)
toCopy :: [Point blk]
toCopy = map headerPoint
$ take nbToCopy
$ AF.toOldestFirst curChain
$ AF.toOldestFirst
$ AF.takeOldest nbToCopy curChain
return toCopy

if null toCopy
-- This can't happen in practice, as we're only called when the fragment
-- is longer than @k@. However, in the tests, we will be calling this
-- function manually, which means it might be called when there are no
-- blocks to copy.
then trace NoBlocksToCopyToImmDB
else forM_ toCopy $ \pt -> do
let hash = case pointHash pt of
@@ -133,18 +142,16 @@ copyToImmDB CDB{..} = withCopyLock $ do
GenesisHash -> error "genesis block on current chain"
-- This call is cheap
slotNoAtImmDBTip <- ImmDB.getSlotNoAtTip cdbImmDB
if pointSlot pt > slotNoAtImmDBTip
then do
blk <- VolDB.getKnownBlock cdbVolDB hash
-- We're the only one modifying the ImmutableDB, so the tip cannot
-- have changed since we last checked it.
ImmDB.appendBlock cdbImmDB blk
-- 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.
atomically $ removeFromChain pt
trace $ CopiedBlockToImmDB pt
else error "block to copy was older than the ImmutableDB's tip"
assert (pointSlot pt > slotNoAtImmDBTip) $ return ()
blk <- VolDB.getKnownBlock cdbVolDB hash
-- We're the only one modifying the ImmutableDB, so the tip cannot
-- have changed since we last checked it.
ImmDB.appendBlock cdbImmDB blk
-- 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.
atomically $ removeFromChain pt
trace $ CopiedBlockToImmDB pt

-- Get the /possibly/ updated tip of the ImmDB
ImmDB.getSlotNoAtTip cdbImmDB
@@ -168,11 +175,15 @@ copyToImmDB CDB{..} = withCopyLock $ do
-- happen if the precondition was satisfied.
_ -> error "header to remove not on the current chain"

withCopyLock :: forall a. m a -> m a
withCopyLock :: forall a. HasCallStack => m a -> m a
withCopyLock = bracket_
(atomically $ takeTMVar cdbCopyLock)
(fmap mustBeUnlocked $ atomically $ tryTakeTMVar cdbCopyLock)
(atomically $ putTMVar cdbCopyLock ())

mustBeUnlocked :: forall b. HasCallStack => Maybe b -> b
mustBeUnlocked = fromMaybe
$ error "copyToImmDB running concurrently with itself"

-- | Watches the current chain for changes. Whenever the chain is longer than
-- @k@, then the headers older than @k@ are copied from the VolatileDB to the
-- ImmutableDB (with 'copyToImmDB'). Afterwards, a garbage collection of the
@@ -225,7 +236,9 @@ garbageCollect
-> m ()
garbageCollect CDB{..} slotNo = do
VolDB.garbageCollect cdbVolDB slotNo
atomically $ LgrDB.garbageCollectPrevApplied cdbLgrDB slotNo
atomically $ do
LgrDB.garbageCollectPrevApplied cdbLgrDB slotNo
modifyTVar' cdbInvalid $ Set.filter ((<= slotNo) . pointSlot)
traceWith cdbTracer $ TraceGCEvent $ PerformedGC slotNo

{-------------------------------------------------------------------------------

0 comments on commit c716e0d

Please sign in to comment.
You can’t perform that action at this time.