Revert "STM-based chain selection algo for mining"

This reverts commit d6cd8e8.

chainweb.cabal

@@ -382,7 +382,6 @@ library
         , pem >=0.2
         , primitive >= 0.7.1.0
         , random >= 1.2
-        , random-shuffle >= 0.0.4
         , rosetta >= 1.0
         , safe-exceptions >= 0.1
         , scheduler >= 1.4

src/Chainweb/Cut/Create.hs

@@ -138,7 +138,7 @@ instance HasChainwebVersion CutExtension where
 -- | Witness that a cut can be extended for the given chain by trying to
 -- assemble the adjacent hashes for a new work header.
 --
--- Generally, adjacent validation uses the graph of the parent header. This
+-- Generally, adajacent validation uses the graph of the parent header. This
 -- ensures that during a graph transition the current header and all
 -- dependencies use the same graph and the inductive validation step works
 -- without special cases. Genesis headers don't require validation, because they
@@ -213,13 +213,13 @@ getCutExtension c cid = do
     tryAdj b
 
         -- When the block is behind, we can move ahead
-        | _blockHeight b == targetHeight = Just (_blockParent b)
+        | _blockHeight b == targetHeight = Just $! _blockParent b
 
         -- if the block is ahead it's blocked
         | _blockHeight b + 1 == parentHeight = Nothing -- chain is blocked
 
         -- If this is not a graph transition cut we can move ahead
-        | _blockHeight b == parentHeight = Just (_blockHash b)
+        | _blockHeight b == parentHeight = Just $! _blockHash b
 
         -- The cut is invalid
         | _blockHeight b > targetHeight = error $ T.unpack

src/Chainweb/Miner/Coordinator.hs

@@ -6,7 +6,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -42,20 +41,16 @@ module Chainweb.Miner.Coordinator
 , publish
 ) where
 
-import Control.Applicative
-import Control.Exception
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async
-import Control.Concurrent.STM (atomically, retry)
+import Control.Concurrent.STM (atomically)
 import Control.Concurrent.STM.TVar
 import Control.DeepSeq (NFData)
 import Control.Lens (makeLenses, over, view)
 import Control.Monad
-import Control.Monad.Catch(throwM)
+import Control.Monad.Catch
 
 import Data.Aeson (ToJSON)
+import Data.Bool (bool)
 import qualified Data.ByteString as BS
-import Data.Functor
 import qualified Data.HashMap.Strict as HM
 import Data.IORef
 import qualified Data.Map.Strict as M
@@ -66,8 +61,6 @@ import GHC.Generics (Generic)
 import GHC.Stack
 
 import System.LogLevel (LogLevel(..))
-import System.Random
-import System.Random.Shuffle
 
 -- internal modules
 
@@ -83,11 +76,13 @@ import Chainweb.Logging.Miner
 import Chainweb.Miner.Config
 import Chainweb.Miner.Pact (Miner(..), MinerId(..), minerId)
 import Chainweb.Payload
+import Chainweb.Sync.WebBlockHeaderStore
 import Chainweb.Time (Micros(..), Time(..), getCurrentTimeIntegral)
 import Chainweb.Utils hiding (check)
 import Chainweb.Version
+import Chainweb.Version.Utils
 import Chainweb.WebBlockHeaderDB
-
+import Chainweb.WebPactExecutionService
 
 import Data.LogMessage (JsonLog(..), LogFunction)
 
@@ -169,59 +164,68 @@ newtype PrevTime = PrevTime BlockCreationTime
 
 data ChainChoice = Anything | TriedLast !ChainId | Suggestion !ChainId
 
--- -- | Construct a new `BlockHeader` to mine on.
--- --
--- newWork
---     :: LogFunction
---     -> ChainChoice
---     -> Miner
---     -> WebBlockHeaderDb
---         -- ^ this is used to lookup parent headers that are not in the cut
---         -- itself.
---     -> PactExecutionService
---     -> TVar PrimedWork
---     -> CutDb tbl
---     -> IO (Maybe (T2 WorkHeader PayloadData))
--- newWork logFun choice eminer@(Miner mid _) hdb pact tpw cdb = do
-
---     -- Randomly pick a chain to mine on, unless the caller specified a specific
---     -- one.
---     --
-
---     cid <- findReadyChainId mid tpw
---     PrimedWork pw <- readTVarIO tpw
-
---     cid <- chainChoice c choice pw
---     logFun @T.Text Debug $ "newWork: picked chain " <> sshow cid
---     let mr = T2
---             <$> join (HM.lookup mid pw >>= HM.lookup cid)
---             <*> getCutExtension c cid
-
---     case mr of
---         Nothing -> do
---             logFun @T.Text Debug $ "newWork: chain " <> sshow cid <> " not mineable"
---             newWork logFun (TriedLast cid) eminer hdb pact tpw c
---         Just (T2 (payload, primedParentHash) extension)
---             | primedParentHash == _blockHash (_parentHeader (_cutExtensionParent extension)) -> do
---                 let !phash = _payloadDataPayloadHash payload
---                 !wh <- newWorkHeader hdb extension phash
---                 pure $ Just $ T2 wh payload
---             | otherwise -> do
-
---                 -- The cut is too old or the primed work is outdated. Probably
---                 -- the former because it the mining coordination background job
---                 -- is updating the primed work cache regularly. We could try
---                 -- another chain, but it's safer to just return 'Nothing' here
---                 -- and retry with an updated cut.
---                 --
---                 let !extensionParent = _parentHeader (_cutExtensionParent extension)
---                 logFun @T.Text Info
---                     $ "newWork: chain " <> sshow cid <> " not mineable because of parent header mismatch"
---                     <> ". Primed parent hash: " <> toText primedParentHash
---                     <> ". Extension parent: " <> toText (_blockHash extensionParent)
---                     <> ". Extension height: " <> sshow (_blockHeight extensionParent)
-
---                 return Nothing
+-- | Construct a new `BlockHeader` to mine on.
+--
+newWork
+    :: LogFunction
+    -> ChainChoice
+    -> Miner
+    -> WebBlockHeaderDb
+        -- ^ this is used to lookup parent headers that are not in the cut
+        -- itself.
+    -> PactExecutionService
+    -> TVar PrimedWork
+    -> Cut
+    -> IO (Maybe (T2 WorkHeader PayloadData))
+newWork logFun choice eminer@(Miner mid _) hdb pact tpw c = do
+
+    -- Randomly pick a chain to mine on, unless the caller specified a specific
+    -- one.
+    --
+    cid <- chainChoice c choice
+    logFun @T.Text Debug $ "newWork: picked chain " <> sshow cid
+
+    PrimedWork pw <- readTVarIO tpw
+    let mr = T2
+            <$> join (HM.lookup mid pw >>= HM.lookup cid)
+            <*> getCutExtension c cid
+
+    case mr of
+        Nothing -> do
+            logFun @T.Text Debug $ "newWork: chain " <> sshow cid <> " not mineable"
+            newWork logFun (TriedLast cid) eminer hdb pact tpw c
+        Just (T2 (payload, primedParentHash) extension)
+            | primedParentHash == _blockHash (_parentHeader (_cutExtensionParent extension)) -> do
+                let !phash = _payloadDataPayloadHash payload
+                !wh <- newWorkHeader hdb extension phash
+                pure $ Just $ T2 wh payload
+            | otherwise -> do
+
+                -- The cut is too old or the primed work is outdated. Probably
+                -- the former because it the mining coordination background job
+                -- is updating the primed work cache regularly. We could try
+                -- another chain, but it's safer to just return 'Nothing' here
+                -- and retry with an updated cut.
+                --
+                let !extensionParent = _parentHeader (_cutExtensionParent extension)
+                logFun @T.Text Info
+                    $ "newWork: chain " <> sshow cid <> " not mineable because of parent header mismatch"
+                    <> ". Primed parent hash: " <> toText primedParentHash
+                    <> ". Extension parent: " <> toText (_blockHash extensionParent)
+                    <> ". Extension height: " <> sshow (_blockHeight extensionParent)
+
+                return Nothing
+
+chainChoice :: Cut -> ChainChoice -> IO ChainId
+chainChoice c choice = case choice of
+    Anything -> randomChainIdAt c (minChainHeight c)
+    Suggestion cid -> pure cid
+    TriedLast cid -> loop cid
+  where
+    loop :: ChainId -> IO ChainId
+    loop cid = do
+        new <- randomChainIdAt c (minChainHeight c)
+        bool (pure new) (loop cid) $ new == cid
 
 -- | Accepts a "solved" `BlockHeader` from some external source (e.g. a remote
 -- mining client), attempts to reassociate it with the current best `Cut`, and
@@ -294,83 +298,43 @@ work
     -> Maybe ChainId
     -> Miner
     -> IO WorkHeader
-work mr _mcid m = do
-    T2 wh pd <-
-        withAsync (logDelays 0) $ \_ -> findWork
+work mr mcid m = do
+    T2 wh pd <- newWorkForCut
     now <- getCurrentTimeIntegral
     atomically
         . modifyTVar' (_coordState mr)
         . over miningState
         . M.insert (_payloadDataPayloadHash pd)
         $ T3 m pd now
-    pure wh
+    return wh
   where
+    -- There is no strict synchronization between the primed work cache and the
+    -- new work selection. There is a chance that work selection picks a primed
+    -- work that is out of sync with the current cut. In that case we just try
+    -- again with a new cut. In case the cut was good but the primed work was
+    -- outdated, chances are that in the next attempt we pick a different chain
+    -- with update work or that the primed work cache caught up in the meantime.
+    --
+    newWorkForCut = do
+        c' <- _cut cdb
+        newWork logf choice m hdb pact (_coordPrimedWork mr) c' >>= \case
+            Nothing -> newWorkForCut
+            Just x -> return x
 
     logf :: LogFunction
     logf = logFunction $ _coordLogger mr
 
     hdb :: WebBlockHeaderDb
     hdb = view cutDbWebBlockHeaderDb cdb
 
+    choice :: ChainChoice
+    choice = maybe Anything Suggestion mcid
+
     cdb :: CutDb tbl
     cdb = _coordCutDb mr
 
-    -- here we log the case that the work loop has stalled. we don't
-    -- write to anything here that the miner reads, to avoid stalling
-    -- it ourselves.
-    logDelays :: Int -> IO ()
-    logDelays n = do
-        threadDelay 1_000_000
-        let !n' = n + 1
-        PrimedWork primedWork <- readTVarIO (_coordPrimedWork mr)
-        logf @T.Text Warn $ "findWork: stalled for " <> sshow n' <> "s"
-        logf @T.Text Info $ case HM.lookup (view minerId m) primedWork of
-            Nothing ->
-                 "findWork: no primed work for miner key" <> sshow m
-            Just mpw
-                | HM.null mpw ->
-                    "findWork: no chains have primed work"
-                | otherwise ->
-                    "findWork: all chains with primed work may be stalled, possible stalled chains: " <> sshow (HM.keys mpw)
-
-        logDelays (n + 1)
-
-    -- Here we come up with a block to mine. We find a random unblocked chain
-    -- on which we have run a payload. We do this in an STM transaction so that
-    -- we can automatically re-check when the primed work or current cut
-    -- change.
-    findWork :: IO (T2 WorkHeader PayloadData)
-    findWork = do
-        -- we grab the generator state here because we can't do it in the following
-        -- transaction.
-        gen <- newStdGen
-        (cid, cutExtension, payloadData) <- atomically $ do
-            -- the first condition making a chain eligible to mine is having a
-            -- payload. we wait until at least one chain has a payload, which
-            -- is prepared by 'primeWork' executing a Pact newBlock request.
-            PrimedWork primedWork <- readTVar (_coordPrimedWork mr)
-            minerPrimedWork <- maybe retry pure $ HM.lookup (view minerId m) primedWork
-            let minerPrimedWorkList = [ (cid, p) | (cid, Just p) <- HM.toList minerPrimedWork ]
-            guard (not $ null minerPrimedWorkList)
-            -- we shuffle the chains into a new order that changes each time we
-            -- fetch work, to avoid privileging any particular chains first.
-            let shuffledMinerPrimedWork = shuffle' minerPrimedWorkList (length minerPrimedWorkList) gen
-            -- the second condition is that we have a valid cut extension for one
-            -- of those headers, i.e. all of its adjacent headers are present in
-            -- the current cut.
-            c <- _cutStm cdb
-            asum $ shuffledMinerPrimedWork <&> \(cid, (payloadData, primedParentHash)) -> do
-                -- check that we have a valid cut extension for this chain
-                cutExtension <- maybe retry pure $ getCutExtension c cid
-                -- check that the latest cut and primedWork agree on what
-                -- the latest header on this chain is, the parent of the
-                -- block we want to mine. if this is not true, the cut is
-                -- probably too old.
-                guard (primedParentHash == _blockHash (_parentHeader (_cutExtensionParent cutExtension)))
-                pure (cid, cutExtension, payloadData)
-        logf @T.Text Debug $ "findWork: picked chain " <> sshow cid
-        wh <- newWorkHeader hdb cutExtension (_payloadDataPayloadHash payloadData)
-        pure $ T2 wh payloadData
+    pact :: PactExecutionService
+    pact = _webPactExecutionService $ view cutDbPactService cdb
 
 data NoAsscociatedPayload = NoAsscociatedPayload
     deriving (Show, Eq)

src/Chainweb/Pact/PactService/ExecBlock.hs

@@ -626,5 +626,5 @@ toPayloadWithOutputs mi ts =
         blockOuts = snd $ newBlockOutputs cb transOuts
 
         blockPL = blockPayload blockTrans blockOuts
-        plData = mkPayloadData blockTrans blockPL
+        plData = payloadData blockTrans blockPL
      in payloadWithOutputs plData cb transOuts

src/Chainweb/Payload.hs

@@ -93,7 +93,7 @@ module Chainweb.Payload
 -- * API Payload Data
 , PayloadData
 , PayloadData_(..)
-, mkPayloadData
+, payloadData
 , newPayloadData
 , PayloadDataCas
 , verifyPayloadData
@@ -968,8 +968,8 @@ instance IsCasValue (PayloadData_ a) where
     casKey = _payloadDataPayloadHash
     {-# INLINE casKey #-}
 
-mkPayloadData :: BlockTransactions_ a -> BlockPayload_ a -> PayloadData_ a
-mkPayloadData txs payload = PayloadData
+payloadData :: BlockTransactions_ a -> BlockPayload_ a -> PayloadData_ a
+payloadData txs payload = PayloadData
     { _payloadDataTransactions = _blockTransactions txs
     , _payloadDataMiner = _blockMinerData txs
     , _payloadDataPayloadHash = _blockPayloadPayloadHash payload
@@ -982,7 +982,7 @@ newPayloadData
     => BlockTransactions_ a
     -> BlockOutputs_ a
     -> PayloadData_ a
-newPayloadData txs outputs = mkPayloadData txs $ blockPayload txs outputs
+newPayloadData txs outputs = payloadData txs $ blockPayload txs outputs
 
 type PayloadDataCas tbl = Cas tbl PayloadData
 

src/Chainweb/Payload/RestAPI/Server.hs

@@ -84,7 +84,7 @@ payloadHandler db k = run >>= \case
         txs <- MaybeT $ liftIO $ tableLookup
             (_transactionDbBlockTransactions $ _transactionDb db)
             (_blockPayloadTransactionsHash payload)
-        return $ mkPayloadData txs payload
+        return $ payloadData txs payload
 
 -- -------------------------------------------------------------------------- --
 -- POST Payload Batch Handler
@@ -98,7 +98,7 @@ payloadBatchHandler
 payloadBatchHandler batchLimit db ks = liftIO $ do
     payloads <- catMaybes
         <$> tableLookupBatch payloadsDb (take (int batchLimit) ks)
-    txs <- zipWith (\a b -> mkPayloadData <$> a <*> pure b)
+    txs <- zipWith (\a b -> payloadData <$> a <*> pure b)
         <$> tableLookupBatch txsDb (_blockPayloadTransactionsHash <$> payloads)
         <*> pure payloads
     return $ catMaybes txs