fixup! O.C.Peras.Weight: add takeVolatileSuffix

Author: amesgen

ouroboros-consensus/bench/PerasCertDB-bench/Main.hs

@@ -1,9 +1,10 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- | This module contains benchmarks for Peras chain weight calculation as
---   implemented by the by the
---   'Ouroboros.Consensus.Peras.Weight.weightBoostOfFragment' function.
+--   implemented in the 'Ouroboros.Consensus.Peras.Weight' module.
 --
 --   We benchmark the calculation on a static sequence of chain fragments of
 --   increasing length, ranging from 0 to 'fragmentMaxLength', with a step size
@@ -12,13 +13,16 @@
 --   with weight 'boostWeight'. All parameters are set in 'benchmarkParams'.
 module Main (main) where
 
+import Cardano.Ledger.BaseTypes.NonZero (knownNonZeroBounded)
 import Data.List (iterate')
 import Data.Word (Word64)
 import Numeric.Natural (Natural)
 import Ouroboros.Consensus.Block (PerasWeight (PerasWeight), SlotNo (..))
+import Ouroboros.Consensus.Config.SecurityParam
 import Ouroboros.Consensus.Peras.Weight
   ( PerasWeightSnapshot
   , mkPerasWeightSnapshot
+  , takeVolatileSuffix
   , weightBoostOfFragment
   )
 import Ouroboros.Network.AnchoredFragment qualified as AF
@@ -65,7 +69,11 @@ benchmarkParams =
 
 main :: IO ()
 main =
-  Test.Tasty.Bench.defaultMain $ map benchWeightBoostOfFragment inputs
+  Test.Tasty.Bench.defaultMain $
+    concat
+      [ map benchWeightBoostOfFragment inputs
+      , map benchTakeVolatileSuffix inputs
+      ]
  where
   -- NOTE: we do not use the 'env' combinator to set up the test data since
   --       it requires 'NFData' for 'AF.AnchoredFragment'. While the necessary
@@ -84,6 +92,14 @@ benchWeightBoostOfFragment (i, (weightSnapshot, fragment)) =
   bench ("weightBoostOfFragment of length " <> show i) $
     whnf (weightBoostOfFragment weightSnapshot) fragment
 
+benchTakeVolatileSuffix ::
+  (Natural, (PerasWeightSnapshot TestBlock, AF.AnchoredFragment TestBlock)) -> Benchmark
+benchTakeVolatileSuffix (i, (weightSnapshot, fragment)) =
+  bench ("takeVolatileSuffix of length " <> show i) $
+    whnf (takeVolatileSuffix weightSnapshot k) fragment
+ where
+  k = SecurityParam $ knownNonZeroBounded @2160
+
 -- | An infinite list of chain fragments
 fragments :: [AF.AnchoredFragment TestBlock]
 fragments = iterate' addSuccessorBlock genesisFragment

ouroboros-consensus/ouroboros-consensus.cabal

@@ -906,6 +906,7 @@ benchmark PerasCertDB-bench
   other-modules:
   build-depends:
     base,
+    cardano-ledger-core,
     ouroboros-consensus,
     ouroboros-network-api,
     tasty-bench,

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Weight.hs

@@ -34,13 +34,15 @@ module Ouroboros.Consensus.Peras.Weight
 import Data.Foldable as Foldable (foldl')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.Word (Word64)
+import Data.Maybe (fromJust)
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block
 import Ouroboros.Consensus.Config.SecurityParam
 import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import qualified Ouroboros.Network.AnchoredFragment as AF
+import Ouroboros.Network.AnchoredSeq (AnchoredSeq)
+import qualified Ouroboros.Network.AnchoredSeq as AS
 
 -- | Data structure for tracking the weight of blocks due to Peras boosts.
 newtype PerasWeightSnapshot blk = PerasWeightSnapshot
@@ -367,34 +369,67 @@ takeVolatileSuffix ::
   SecurityParam ->
   AnchoredFragment h ->
   AnchoredFragment h
-takeVolatileSuffix snap secParam frag
+takeVolatileSuffix snap secParam
   | Map.null $ getPerasWeightSnapshot snap =
       -- Optimize the case where Peras is disabled.
-      AF.anchorNewest (unPerasWeight k) frag
-  | hasAtMostWeightK frag = frag
-  | otherwise = go 0 lenFrag (AF.Empty $ AF.headAnchor frag)
+      AF.anchorNewest (unPerasWeight k)
+  | otherwise =
+      takeLongestSuffix (totalWeightOfFragment snap) (<= k)
  where
   k :: PerasWeight
   k = maxRollbackWeight secParam
 
-  hasAtMostWeightK :: AnchoredFragment h -> Bool
-  hasAtMostWeightK f = totalWeightOfFragment snap f <= k
-
-  lenFrag = fromIntegral $ AF.length frag
-
-  -- Binary search for the longest suffix of @frag@ which 'hasAtMostWeightK'.
+-- | Take the longest suffix of an 'AnchoredSeq' @as@ satisfying the given
+-- predicate @p@ on the monoidal summary given by @f@.
+--
+-- TODO: upstream this function
+--
+-- === PRECONDITIONS:
+--
+-- For @as0, as1@ such that @AS.join as0 as1 = Just as2@, we must have the
+-- following homomorphism property:
+--
+-- > f as0 <> f as1 ≡ f as2
+--
+-- For empty @ase@, we must have @f ase ≡ mempty@.
+--
+-- The predicate must be monotonic, ie when @suf0@ is a suffix of @as@ and
+-- @suf1@ is a suffix of @suf0@, then @p (f suf0)@ must imply @p (f suf1)@.
+-- Furthermore, we must have @p mempty@.
+takeLongestSuffix ::
+  forall s v a b.
+  (Monoid s, AS.Anchorable v a b) =>
+  -- | @f@: Compute a monoidal summary of a fragment.
+  (AnchoredSeq v a b -> s) ->
+  -- | @p@: Predicate on the summary of a fragment.
+  (s -> Bool) ->
+  -- | Input sequence @as@.
+  AnchoredSeq v a b ->
+  -- | A suffix of the input sequence.
+  AnchoredSeq v a b
+takeLongestSuffix f p as =
+  go (AS.Empty $ AS.headAnchor as) mempty as
+ where
   go ::
-    Word64 -> -- lb. The length lb suffix satisfies 'hasAtMostWeightK'.
-    Word64 -> -- ub. The length ub suffix does not satisfy 'hasAtMostWeightK'.
-    AnchoredFragment h -> -- The length lb suffix.
-    AnchoredFragment h
-  go lb ub lbFrag
-    | lb + 1 == ub = lbFrag
-    | hasAtMostWeightK midFrag = go mid ub midFrag
-    | otherwise = go lb mid lbFrag
+    -- @suf@: the longest suffix of @as@ for which we currently know that @p (f
+    -- suf)@.
+    AnchoredSeq v a b ->
+    -- Equal to @f suf@.
+    s ->
+    -- @pre@: longest infix of @as@ ending just before @suf@ such that we don't
+    -- know whether @p (f (AS.join pre suf))@.
+    AnchoredSeq v a b ->
+    -- Longest suffix of @as@ satisfying @p . f@.
+    AnchoredSeq v a b
+  go suf sufS pre
+    | AS.null pre = suf
+    | p suf'S = go suf' suf'S pre0
+    | AS.null pre0 = suf
+    | otherwise = go suf sufS pre1
    where
-    mid = (lb + ub) `div` 2
-    midFrag = AF.anchorNewest mid frag
+    (pre0, pre1) = AS.splitAt (AS.length pre `div` 2) pre
+    suf' = fromJust (AS.join (\_ _ -> True) pre1 suf)
+    suf'S = f pre1 <> sufS
 
 -- $setup
 -- >>> import Cardano.Ledger.BaseTypes