voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

fixing-cpu-burning-and-further-optimizations

This commit is contained in:
Dmitry Zuikov 2023-09-21 08:09:46 +03:00
parent 21b951aaf9
commit bd2c0e0367
1 changed files with 57 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
examples/refchan-qblf/app/RefChanQBLFMain.hs
View File

@ -241,10 +241,22 @@ instance (ForConsensus m) => IsQBLF ConsensusQBLF (App m) where
let sk = view peerSignSk creds let sk = view peerSignSk creds
let pk = view peerSignPk creds let pk = view peerSignPk creds
-- let block = serialise (HashSet.toList $ HashSet.fromList txs) -- основная проблема в том, что мы пересортировываем весь state
-- однако, если считать его уже отсортированным, то, может быть,
-- все будет не так уж плохо.
-- так-то мы можем вообще его на диске держать
root <- if List.null txs then do
pure h0
else do
hashes <- liftIO $ mapM (putBlock sto . serialise) txs <&> catMaybes hashes <- liftIO $ mapM (putBlock sto . serialise) txs <&> catMaybes
current <- readLog (getBlock sto) h0
let new = HashSet.fromList ( current <> fmap HashRef hashes )
let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList new)
-- пробуем разослать бандлы с транзакциями -- пробуем разослать бандлы с транзакциями
runMaybeT do runMaybeT do
ref <- MaybeT $ createBundle sto (fmap HashRef hashes) ref <- MaybeT $ createBundle sto (fmap HashRef hashes)
@ -252,19 +264,6 @@ instance (ForConsensus m) => IsQBLF ConsensusQBLF (App m) where
r <- MaybeT $ liftIO $ putBlock sto (serialise refval) r <- MaybeT $ liftIO $ putBlock sto (serialise refval)
lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r))) lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r)))
current <- readLog (getBlock sto) h0
-- основная проблема в том, что мы пересортировываем весь state
-- однако, если считать его уже отсортированным, то, может быть,
-- все будет не так уж плохо.
-- так-то мы можем вообще его на диске держать
let new = HashSet.fromList ( current <> fmap HashRef hashes )
let pt = toPTree (MaxSize 256) (MaxNum 256) (HashSet.toList new)
root <- if List.null hashes then do
pure h0
else do
r <- makeMerkle 0 pt $ \(hx,_,bs) -> do r <- makeMerkle 0 pt $ \(hx,_,bs) -> do
th <- liftIO (enqueueBlock sto bs) th <- liftIO (enqueueBlock sto bs)
debug $ "WRITE TX" <+> pretty hx debug $ "WRITE TX" <+> pretty hx
@ -320,9 +319,14 @@ instance (ForConsensus m) => IsQBLF ConsensusQBLF (App m) where
sto <- asks mySto sto <- asks mySto
let readFn = liftIO . getBlock sto let readFn = liftIO . getBlock sto
tx0 <- readLog readFn (fromDAppState s0) <&> HashSet.fromList
tx1 <- mapM (readLog readFn) (fmap fromDAppState s1) <&> mconcat tx1 <- mapM (readLog readFn) (fmap fromDAppState s1) <&> mconcat
tx0 <- readLog readFn (fromDAppState s0) <&> HashSet.fromList
let txNew = HashSet.fromList tx1 `HashSet.difference` tx0
if List.null txNew then do
pure s0
else do
debug $ "READ TXS" <+> pretty s1 <+> pretty (length tx1) debug $ "READ TXS" <+> pretty s1 <+> pretty (length tx1)
r <- forM tx1 $ \t -> runMaybeT do r <- forM tx1 $ \t -> runMaybeT do
@ -478,7 +482,7 @@ fetchMissed env s = do
when here do when here do
liftIO $ Cache.delete cache href liftIO $ Cache.delete cache href
unless (here && not wip) do unless (here || wip) do
debug $ "We might be need to fetch" <+> pretty s debug $ "We might be need to fetch" <+> pretty s
liftIO $ Cache.insert cache href () liftIO $ Cache.insert cache href ()
request @UNIX tube (ActionRequest @UNIX chan (RefChanFetch (fromDAppState s))) request @UNIX tube (ActionRequest @UNIX chan (RefChanFetch (fromDAppState s)))