Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

memoize some cut properties in the cut record #2086

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
+145 −84
Open

memoize some cut properties in the cut record #2086

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
307629d
memoize some cut properties in the cut record
larskuhtz Dec 23, 2024
19b2c0d
Apply suggestions from code review
larskuhtz Jan 3, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
189 changes: 117 additions & 72 deletions src/Chainweb/Cut.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -40,12 +40,21 @@ module Chainweb.Cut
( Cut
, cutToTextShort
, cutDiffToTextShort
, _cutHeaders
, cutHeaders
, _cutMap
, cutMap
, _cutHeight
, cutHeight
, _cutWeight
, cutWeight
, _cutMinHeight
, cutMinHeight
, _cutMaxHeight
, cutMaxHeight
, _cutIsTransition
, cutIsTransition

, _cutAdjPairs
, cutAdjPairs
, cutAdjs
Expand All @@ -56,10 +65,6 @@ module Chainweb.Cut
, limitCutHeaders
, unsafeMkCut
, chainHeights
, meanChainHeight
, maxChainHeight
, minChainHeight
, isTransitionCut

-- * Exceptions
, CutException(..)
Expand Down Expand Up @@ -170,28 +175,88 @@ import Control.Monad.State.Strict
-- function, both of which are not exported from this module.
--
data Cut = Cut'
{ _cutHeaders :: !(HM.HashMap ChainId BlockHeader)
, _cutChainwebVersion :: !ChainwebVersion
{ _cutHeaders' :: !(HM.HashMap ChainId BlockHeader)
, _cutChainwebVersion' :: !ChainwebVersion

-- Memoize properties that have linear compute cost
, _cutHeight' :: {- lazy -} CutHeight
, _cutMinHeight' :: {- lazy -} BlockHeight
, _cutMaxHeight' :: {- lazy -} BlockHeight
, _cutWeight' :: {- lazy -} BlockWeight
, _cutIsTransition' :: {- lazy -} Bool
}
deriving (Show, Eq, Ord, Generic)
deriving anyclass (NFData)

cutChainwebVersion :: Lens' Cut ChainwebVersion
cutChainwebVersion = lens _cutChainwebVersion $ \c v -> c { _cutChainwebVersion = v }
{-# INLINE cutChainwebVersion #-}
_cutHeaders :: Cut -> (HM.HashMap ChainId BlockHeader)
_cutHeaders = _cutHeaders'
{-# INLINE cutHeaders #-}

cutHeaders :: Getter Cut (HM.HashMap ChainId BlockHeader)
cutHeaders = to _cutHeaders
{-# INLINE _cutHeaders #-}

_cutMap :: Cut -> HM.HashMap ChainId BlockHeader
_cutMap = _cutHeaders
{-# INLINE _cutMap #-}

cutMap :: Getter Cut (HM.HashMap ChainId BlockHeader)
cutMap = cutHeaders
{-# INLINE cutMap #-}

_cutChainwebVersion :: Cut -> ChainwebVersion
_cutChainwebVersion = _cutChainwebVersion'
{-# INLINE _cutChainwebVersion #-}

cutChainwebVersion :: Getter Cut ChainwebVersion
cutChainwebVersion = to _cutChainwebVersion
{-# INLINE cutChainwebVersion #-}

_cutWeight :: Cut -> BlockWeight
_cutWeight = _cutWeight'
{-# INLINE _cutWeight #-}

cutWeight :: Getter Cut BlockWeight
cutWeight = to _cutWeight
{-# INLINE cutWeight #-}

_cutHeight :: Cut -> CutHeight
_cutHeight = _cutHeight'
{-# INLINE _cutHeight #-}

cutHeight :: Getter Cut CutHeight
cutHeight = to _cutHeight
{-# INLINE cutHeight #-}

_cutMinHeight :: Cut -> BlockHeight
_cutMinHeight = _cutMinHeight'
{-# INLINE _cutMinHeight #-}

unsafeCutHeaders :: Setter' Cut (HM.HashMap ChainId BlockHeader)
unsafeCutHeaders = lens _cutHeaders $ \c m -> c { _cutHeaders = m }
{-# INLINE unsafeCutHeaders #-}
cutMinHeight :: Getter Cut BlockHeight
cutMinHeight = to _cutMinHeight
{-# INLINE cutMinHeight #-}

_cutMaxHeight :: Cut -> BlockHeight
_cutMaxHeight = _cutMaxHeight'
{-# INLINE _cutMaxHeight #-}

cutMaxHeight :: Getter Cut BlockHeight
cutMaxHeight = to _cutMaxHeight
{-# INLINE cutMaxHeight #-}

_cutIsTransition :: Cut -> Bool
_cutIsTransition = _cutIsTransition'
{-# INLINE _cutIsTransition #-}

cutIsTransition :: Getter Cut Bool
cutIsTransition = to _cutIsTransition
{-# INLINE cutIsTransition #-}

-- | The chain graph is the graph at the /minimum/ height of the block headers
-- in the cut.
--
instance HasChainGraph Cut where
_chainGraph c = chainGraphAt (_chainwebVersion c) (minChainHeight c)
_chainGraph c = chainGraphAt (_chainwebVersion c) (_cutMinHeight c)
{-# INLINE _chainGraph #-}

instance HasChainwebVersion Cut where
Expand All @@ -205,12 +270,6 @@ instance IxedGet Cut where
ixg i = cutHeaders . ix i
{-# INLINE ixg #-}

_cutMap :: Cut -> HM.HashMap ChainId BlockHeader
_cutMap = _cutHeaders

cutMap :: Getter Cut (HM.HashMap ChainId BlockHeader)
cutMap = cutHeaders

lookupCutM
:: MonadThrow m
=> HasChainId cid
Expand All @@ -222,25 +281,19 @@ lookupCutM cid c = firstOf (ixg (_chainId cid)) c
(Expected $ chainIds c)
(Actual (_chainId cid))

_cutWeight :: Cut -> BlockWeight
_cutWeight = sumOf $ cutHeaders . folded . blockWeight

cutWeight :: Getter Cut BlockWeight
cutWeight = to _cutWeight
{-# INLINE cutWeight #-}

_cutHeight :: Cut -> CutHeight
_cutHeight = sumOf $ cutHeaders . folded . blockHeight . to int

cutHeight :: Getter Cut CutHeight
cutHeight = to _cutHeight
{-# INLINE cutHeight #-}

unsafeMkCut :: ChainwebVersion -> HM.HashMap ChainId BlockHeader -> Cut
unsafeMkCut v hdrs = Cut'
{ _cutHeaders = hdrs
, _cutChainwebVersion = v
{ _cutHeaders' = hdrs
, _cutChainwebVersion' = v
, _cutHeight' = int $ sum $ view blockHeight <$> hdrs
, _cutWeight' = sum $ view blockWeight <$> hdrs
, _cutMinHeight' = minimum $ view blockHeight <$> hdrs
, _cutMaxHeight' = maximum $ view blockHeight <$> hdrs
, _cutIsTransition' = minheight < lastGraphChange v (maxheight)
}
where
minheight = minimum $ view blockHeight <$> hdrs
maxheight = maximum $ view blockHeight <$> hdrs

-- -------------------------------------------------------------------------- --
-- Adjacents
Expand Down Expand Up @@ -291,25 +344,6 @@ chainHeights :: Cut -> [BlockHeight]
chainHeights = fmap (view blockHeight) . toList . _cutHeaders
{-# INLINE chainHeights #-}

meanChainHeight :: Cut -> BlockHeight
meanChainHeight = mean . chainHeights
where
mean l = round $ sum @_ @Double (realToFrac <$> l) / realToFrac (length l)
{-# INLINE meanChainHeight #-}

maxChainHeight :: Cut -> BlockHeight
maxChainHeight = maximum . chainHeights
{-# INLINE maxChainHeight #-}

minChainHeight :: Cut -> BlockHeight
minChainHeight = minimum . chainHeights
{-# INLINE minChainHeight #-}

-- | Returns whether a chain graph transition occurs within the cut.
--
isTransitionCut :: Cut -> Bool
isTransitionCut c = minChainHeight c < lastGraphChange c (maxChainHeight c)

-- -------------------------------------------------------------------------- --
-- Tools for Graph Transitions
--
Expand Down Expand Up @@ -357,6 +391,12 @@ projectChains m = HM.intersection m
$ chainIdsAt (cutHeadersChainwebVersion m) (cutHeadersMinHeight m)
{-# INLINE projectChains #-}

cutProjectChains :: Cut -> Cut
cutProjectChains c = unsafeMkCut v $ projectChains $ _cutHeaders c
where
v = _chainwebVersion c
{-# INLINE cutProjectChains #-}

-- | Extend the chains for the graph at the minimum block height of the input
-- headers. If a header for a chain is missing the genesis block header for that
-- chain is added.
Expand Down Expand Up @@ -410,16 +450,19 @@ limitCut
:: HasCallStack
=> WebBlockHeaderDb
-> BlockHeight
-- upper bound for the block height of each chain. This is not a tight bound.
-- ^ upper bound for the block height of each chain. This is not a tight
-- bound.
-> Cut
-> IO Cut
limitCut wdb h c
| all (\bh -> h >= view blockHeight bh) (view cutHeaders c) =
return c
| otherwise = do
hdrs <- itraverse go $ view cutHeaders c
return $! set unsafeCutHeaders (projectChains $ HM.mapMaybe id hdrs) c
return $! unsafeMkCut v $ projectChains $ HM.mapMaybe id hdrs
where
v = _chainwebVersion c

go :: ChainId -> BlockHeader -> IO (Maybe BlockHeader)
go cid bh = do
if h >= view blockHeight bh
Expand Down Expand Up @@ -449,7 +492,7 @@ tryLimitCut wdb h c
return c
| otherwise = do
hdrs <- itraverse go $ view cutHeaders c
return $! set unsafeCutHeaders hdrs c
return $! unsafeMkCut v hdrs
where
v = _chainwebVersion wdb
go :: ChainId -> BlockHeader -> IO BlockHeader
Expand All @@ -475,10 +518,9 @@ limitCutHeaders
-- ^ upper bound for the block height of each chain. This is not a tight bound.
-> HM.HashMap ChainId BlockHeader
-> IO (HM.HashMap ChainId BlockHeader)
limitCutHeaders whdb h ch = _cutHeaders <$> limitCut whdb h Cut'
{ _cutHeaders = ch
, _cutChainwebVersion = _chainwebVersion whdb
}
limitCutHeaders whdb h ch = _cutHeaders <$> limitCut whdb h (unsafeMkCut v ch)
where
v = _chainwebVersion whdb

-- -------------------------------------------------------------------------- --
-- Genesis Cut
Expand All @@ -499,10 +541,7 @@ limitCutHeaders whdb h ch = _cutHeaders <$> limitCut whdb h Cut'
genesisCut
:: ChainwebVersion
-> Cut
genesisCut v = Cut'
{ _cutHeaders = genesisBlockHeadersAtHeight v 0
, _cutChainwebVersion = v
}
genesisCut v = unsafeMkCut v (genesisBlockHeadersAtHeight v 0)

-- -------------------------------------------------------------------------- --
-- Exceptions
Expand Down Expand Up @@ -669,9 +708,13 @@ tryMonotonicCutExtension
-> m (Maybe Cut)
tryMonotonicCutExtension c h = isMonotonicCutExtension c h >>= \case
False -> return Nothing
True -> return $ Just
$! over unsafeCutHeaders extendChains
$ set (unsafeCutHeaders . ix' (_chainId h)) h c
True -> return $! Just
$! unsafeMkCut v
$ extendChains
$ set (ix' (_chainId h)) h
$ _cutHeaders c
where
v = _chainwebVersion c

-- -------------------------------------------------------------------------- --
-- Join
Expand Down Expand Up @@ -728,11 +771,13 @@ join_
-> IO (Join a)
join_ wdb prioFun a b = do
(m, h) <- runStateT (HM.traverseWithKey f (HM.intersectionWith (,) a' b')) mempty
return $! Join (Cut' m (_chainwebVersion wdb)) h
return $! Join (unsafeMkCut (_chainwebVersion wdb) m) h
where
(a', b') = joinChains a b

f :: ChainId -> (BlockHeader, BlockHeader)
f
:: ChainId
-> (BlockHeader, BlockHeader)
-> StateT (JoinQueue a) IO BlockHeader
f cid (x, y) = do
!q <- get
Expand All @@ -757,7 +802,7 @@ join_ wdb prioFun a b = do
-- Non-existing chains are stripped from the result.
--
applyJoin :: MonadThrow m => Join a -> m Cut
applyJoin m = over unsafeCutHeaders projectChains
applyJoin m = cutProjectChains
<$> foldM
(\c b -> fromMaybe c <$> tryMonotonicCutExtension c (H.payload b))
(_joinBase m)
Expand Down Expand Up @@ -862,7 +907,7 @@ meet
-> IO Cut
meet wdb a b = do
!r <- imapM f $ HM.intersectionWith (,) (_cutHeaders a) (_cutHeaders b)
return $! Cut' r (_chainwebVersion wdb)
return $! unsafeMkCut (_chainwebVersion wdb) r
where
f !cid (!x, !y) = do
db <- getWebBlockHeaderDb wdb cid
Expand Down
Loading
Loading