Merge commit from fork

Change `FinalizerSet` inner representation to improve deserialize/serialize performance

Author: soerenbf

.github/workflows/release.yaml

@@ -22,7 +22,7 @@ on:
 env:
   UBUNTU_VERSION: '22.04'
   STATIC_LIBRARIES_IMAGE_TAG: 'rust-1.94_ghc-9.10.2'
-  RUST_VERSION: '1.94'
+  RUST_VERSION: '1.94.0'
   STACK_VERSION: '3.7.1'
   FLATBUFFERS_VERSION: '23.5.26'
   GHC_VERSION: '9.10.2'

CHANGELOG.md

@@ -3,6 +3,7 @@
 ## Unreleased changes
 
 - upgraded rust version to 1.94
+- Change `FinalizerSet` inner representation to `ShortByteString` to improve performance on deserialize/serialize.
 
 # 10.0.8
 

concordium-consensus/src/Concordium/KonsensusV1/Types.hs

@@ -15,14 +15,16 @@ module Concordium.KonsensusV1.Types where
 import Control.Monad
 import Data.Bits
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Short as BSS
 import qualified Data.Map.Strict as Map
 import Data.Maybe
+import qualified Data.ProtoLens.Combinators as Proto
 import Data.Serialize
 import qualified Data.Set as Set
 import Data.Singletons
 import qualified Data.Vector as Vector
 import Data.Word
-import Numeric.Natural
+import Lens.Micro.Platform
 
 import qualified Concordium.Crypto.BlockSignature as BlockSig
 import qualified Concordium.Crypto.BlsSignature as Bls
@@ -43,8 +45,6 @@ import Concordium.Types.TransactionOutcomes
 import Concordium.Types.Transactions
 import Concordium.Utils.BinarySearch
 import Concordium.Utils.Serialization
-import qualified Data.ProtoLens.Combinators as Proto
-import Lens.Micro.Platform
 import qualified Proto.V2.Concordium.Types as Proto
 import qualified Proto.V2.Concordium.Types_Fields as ProtoFields
 
@@ -241,69 +241,80 @@ computeFinalizationCommitteeHash FinalizationCommittee{..} =
 -- | A set of 'FinalizerIndex'es.
 --  This is represented as a bit vector, where the bit @i@ is set iff the finalizer index @i@ is
 --  in the set.
-newtype FinalizerSet = FinalizerSet {theFinalizerSet :: Natural}
+newtype FinalizerSet = FinalizerSet {theFinalizerSet :: BSS.ShortByteString}
     deriving (Eq)
 
 -- | The serialization of a 'FinalizerSet' consists of a length (Word32, big-endian), followed by
 --  that many bytes, the first of which (if any) must be non-zero. These bytes encode the bit-vector
 --  in big-endian. This enforces that the serialization of a finalizer set is unique.
+--
+--  Internally, the bit-vector is stored little-endian, so finalizer index @i@ is represented by
+--  bit @i mod 8@ of byte @i div 8@. This makes membership tests constant time and keeps decoding
+--  linear in the number of serialized bytes.
 instance Serialize FinalizerSet where
-    put fs = do
-        let (byteCount, putBytes) = unroll 0 (return ()) (theFinalizerSet fs)
-        putWord32be byteCount
-        putBytes
-      where
-        unroll :: Word32 -> Put -> Natural -> (Word32, Put)
-        -- Compute the number of bytes and construct a 'Put' that serializes in big-endian.
-        -- We do this by adding the low order byte to the accumulated 'Put' (at the start)
-        -- and recursing with the bitvector shifted right 8 bits.
-        unroll bc cont 0 = (bc, cont)
-        unroll bc cont n = unroll (bc + 1) (putWord8 (fromIntegral n) >> cont) (shiftR n 8)
+    put (FinalizerSet fs) = do
+        putWord32be $ fromIntegral $ BSS.length fs
+        putByteString $ BS.reverse $ BSS.fromShort fs
     get = label "FinalizerSet" $ do
         byteCount <- getWord32be
-        FinalizerSet <$> roll1 byteCount
-      where
-        roll1 0 = return 0
-        roll1 bc = do
-            b <- getWord8
-            when (b == 0) $ fail "unexpected 0 byte"
-            roll (bc - 1) (fromIntegral b)
-        roll 0 n = return n
-        roll bc n = do
-            b <- getWord8
-            roll (bc - 1) (shiftL n 8 .|. fromIntegral b)
+        remainingBytes <- remaining
+        when (toInteger byteCount > toInteger remainingBytes) $
+            fail "FinalizerSet length exceeds remaining input"
+        bytes <- getByteString (fromIntegral byteCount)
+        when (not (BS.null bytes) && BS.head bytes == 0) $
+            fail "unexpected 0 byte"
+        return $! FinalizerSet $! BSS.toShort $! BS.reverse bytes
 
 -- | Convert a 'FinalizerSet' to a list of 'FinalizerIndex', in ascending order.
 finalizerList :: FinalizerSet -> [FinalizerIndex]
-finalizerList = unroll 0 . theFinalizerSet
+finalizerList (FinalizerSet fs) = concat $ zipWith finalizersInByte [0, 8 ..] (BSS.unpack fs)
   where
-    unroll _ 0 = []
-    unroll i x
-        | testBit x 0 = FinalizerIndex i : r
-        | otherwise = r
-      where
-        r = unroll (i + 1) (shiftR x 1)
+    finalizersInByte base byte =
+        [ FinalizerIndex (base + bitIndex)
+        | bitIndex <- [0 .. 7],
+          testBit byte (fromIntegral bitIndex)
+        ]
 
 -- | The empty set of finalizers
 emptyFinalizerSet :: FinalizerSet
-emptyFinalizerSet = FinalizerSet 0
+emptyFinalizerSet = FinalizerSet BSS.empty
 
 -- | Add a finalizer to a 'FinalizerSet'.
 addFinalizer :: FinalizerSet -> FinalizerIndex -> FinalizerSet
-addFinalizer (FinalizerSet setOfFinalizers) (FinalizerIndex i) = FinalizerSet $ setBit setOfFinalizers (fromIntegral i)
+addFinalizer (FinalizerSet setOfFinalizers) (FinalizerIndex i) =
+    FinalizerSet $ BSS.pack $ case splitAt byteIndex paddedBytes of
+        (prefix, oldByte : suffix) -> prefix ++ setBit oldByte bitIndex : suffix
+        -- This case cannot occur because 'paddedBytes' has length at least @byteIndex + 1@.
+        _ -> paddedBytes
+  where
+    byteIndex = fromIntegral (i `div` 8)
+    bitIndex = fromIntegral (i `mod` 8)
+    bytes = BSS.unpack setOfFinalizers
+    paddedBytes = bytes ++ replicate (byteIndex + 1 - length bytes) 0
 
 -- | Test whether a given finalizer index is present in a finalizer set.
 memberFinalizerSet :: FinalizerIndex -> FinalizerSet -> Bool
-memberFinalizerSet (FinalizerIndex fi) (FinalizerSet setOfFinalizers) =
-    testBit setOfFinalizers (fromIntegral fi)
+memberFinalizerSet (FinalizerIndex fi) (FinalizerSet setOfFinalizers)
+    | byteIndex >= BSS.length setOfFinalizers = False
+    | otherwise = testBit (BSS.index setOfFinalizers byteIndex) bitIndex
+  where
+    byteIndex = fromIntegral (fi `div` 8)
+    bitIndex = fromIntegral (fi `mod` 8)
 
 -- | Convert a list of [FinalizerIndex] to a 'FinalizerSet'.
 finalizerSet :: [FinalizerIndex] -> FinalizerSet
-finalizerSet = foldl' addFinalizer (FinalizerSet 0)
+finalizerSet = foldl' addFinalizer emptyFinalizerSet
 
 -- | Test if the first finalizer set is a subset of the second.
 subsetFinalizerSet :: FinalizerSet -> FinalizerSet -> Bool
-subsetFinalizerSet (FinalizerSet s1) (FinalizerSet s2) = s1 .&. s2 == s1
+subsetFinalizerSet (FinalizerSet s1) (FinalizerSet s2) = go 0 (BSS.unpack s1)
+  where
+    go _ [] = True
+    go byteIndex (b1 : rest) = b1 .&. b2 == b1 && go (byteIndex + 1) rest
+      where
+        b2
+            | byteIndex < BSS.length s2 = BSS.index s2 byteIndex
+            | otherwise = 0
 
 instance Show FinalizerSet where
     show = show . finalizerList
@@ -329,7 +340,7 @@ data QuorumCertificate = QuorumCertificate
 
 -- | For generating a genesis quorum certificate with empty signature and empty finalizer set.
 genesisQuorumCertificate :: BlockHash -> QuorumCertificate
-genesisQuorumCertificate genesisHash = QuorumCertificate genesisHash 0 0 mempty $ FinalizerSet 0
+genesisQuorumCertificate genesisHash = QuorumCertificate genesisHash 0 0 mempty emptyFinalizerSet
 
 instance Serialize QuorumCertificate where
     put QuorumCertificate{..} = do
@@ -1091,6 +1102,7 @@ data DerivableBlockHashesBHV (bhv :: BlockHashVersion) where
         DerivableBlockHashesBHV 'BlockHashVersion1
 
 deriving instance Show (DerivableBlockHashesBHV bhv)
+
 deriving instance Eq (DerivableBlockHashesBHV bhv)
 
 -- | Serialize derivable hashes.

concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Common.hs

@@ -59,7 +59,7 @@ dummyQuorumCertificate blockHash =
           qcRound = 0,
           qcEpoch = 0,
           qcAggregateSignature = mempty,
-          qcSignatories = FinalizerSet 0
+          qcSignatories = emptyFinalizerSet
         }
 
 -- | A BlockNonce consisting

concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Consensus.hs

@@ -81,7 +81,7 @@ dummyCertifiedBlock r =
               qcRound = r,
               qcEpoch = 0,
               qcAggregateSignature = mempty,
-              qcSignatories = FinalizerSet 0
+              qcSignatories = emptyFinalizerSet
             }
 
 -- | Checking that advancing rounds via a quorum certificate results

concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/LMDB.hs

@@ -67,7 +67,7 @@ dummyQC =
           qcRound = 1,
           qcEpoch = 1,
           qcAggregateSignature = QuorumSignature $ Bls.sign "someMessage" dummyBlsSK,
-          qcSignatories = FinalizerSet 0
+          qcSignatories = emptyFinalizerSet
         }
 
 -- | A block signature keypair used to construct a block signature.

concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Timeout.hs

@@ -130,7 +130,7 @@ dummyTimeoutMessage' sProtocolVersion fid e qce =
               tsmQCRound = 0,
               tsmQCEpoch = 0
             }
-    quorumCert = QuorumCertificate (genesisHash sProtocolVersion) 0 qce mempty $ FinalizerSet 0
+    quorumCert = QuorumCertificate (genesisHash sProtocolVersion) 0 qce mempty $ emptyFinalizerSet
 
 -- | Generate a timeout message signed by the finalizer index @fid@ from
 --  'bakers' above in epoch @e@ and qc epoch @e@.

concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/TransactionProcessingTest.hs

@@ -619,7 +619,7 @@ testProcessBlockItems sProtocolVersion = describe "processBlockItems" $ do
                           qcRound = 0,
                           qcEpoch = 0,
                           qcAggregateSignature = mempty,
-                          qcSignatories = FinalizerSet 0
+                          qcSignatories = emptyFinalizerSet
                         },
                   ..
                 }

concordium-consensus/tests/consensus/ConcordiumTests/KonsensusV1/Types.hs

@@ -7,6 +7,9 @@
 module ConcordiumTests.KonsensusV1.Types where
 
 import qualified Data.ByteString as BS
+import qualified Data.ByteString.Short as BSS
+import Data.Either (isLeft)
+import qualified Data.FixedByteString as FBS
 import qualified Data.Map.Strict as Map
 import Data.Serialize
 import qualified Data.Vector as Vector
@@ -28,15 +31,20 @@ import Concordium.Types
 import qualified Concordium.Types.DummyData as Dummy
 import Concordium.Types.Option
 import Concordium.Types.Transactions
-import qualified Data.FixedByteString as FBS
 
 import qualified Concordium.Types.TransactionOutcomes as TransactionOutcomes
 import qualified ConcordiumTests.KonsensusV1.Common as Common
 
--- | Generate a 'FinalizerSet'. The size parameter determines the size of the committee that
---  the finalizers are (nominally) sampled from.
+-- | Generate a 'FinalizerSet'. The size parameter determines the size of the inner byte array, which
+-- amounts to s * 8 finalizer indices.
 genFinalizerSet :: Gen FinalizerSet
-genFinalizerSet = sized $ \s -> FinalizerSet . fromInteger <$> chooseInteger (0, 2 ^ s)
+genFinalizerSet = sized $ \s -> do
+    len <- chooseInt (0, max 0 s)
+    if len == 0
+        then return $ FinalizerSet BSS.empty
+        else do
+            bytes <- vectorOf len (arbitrary @Word8) `suchThat` ((/= 0) . last)
+            return $ FinalizerSet $ BSS.pack bytes
 
 -- | An arbitrarily-chosen 'Bls.SecretKey'.
 someBlsSecretKey :: Bls.SecretKey
@@ -435,6 +443,60 @@ propFinalizerListIsInverseOfFinalizerSet =
             fis
             (finalizerSet $ finalizerList fis)
 
+-- | Malformed 'FinalizerSet' serialization where the encoded byte count exceeds the payload.
+truncatedFinalizerSetBytes :: BS.ByteString
+truncatedFinalizerSetBytes = runPut $ do
+    putWord32be 2
+    putWord8 0xff
+
+-- | Non-canonical 'FinalizerSet' serialization with a leading zero byte.
+nonCanonicalFinalizerSetBytes :: BS.ByteString
+nonCanonicalFinalizerSetBytes = runPut $ do
+    putWord32be 2
+    putWord8 0x00
+    putWord8 0xff
+
+-- | Wire encoding of finalizer set @{0, 1, 3, 10}@.
+encodedFinalizerSet01310 :: BS.ByteString
+encodedFinalizerSet01310 = runPut $ do
+    putWord32be 2
+    putWord8 0x04
+    putWord8 0x0b
+
+genSmallFinalizerIndex :: Gen FinalizerIndex
+genSmallFinalizerIndex = FinalizerIndex . fromIntegral <$> chooseInt (0, 255)
+
+-- | 'memberFinalizerSet' returns 'True' for all finalizer indices in the list of finalizer
+-- indices used to construct the `FinalizerSet`
+propMemberFinalizerSetMatchesListMembership :: Property
+propMemberFinalizerSetMatchesListMembership =
+    forAll (listOf genSmallFinalizerIndex) $ \indices ->
+        let fs = finalizerSet indices
+        in  all (`memberFinalizerSet` fs) indices === True
+
+-- | 'memberFinalizerSet' returns 'False' for any finalizer index _not_ in the list of finalizer
+-- indices used to construct the `FinalizerSet`
+propMemberFinalizerSetRejectsAbsent :: Property
+propMemberFinalizerSetRejectsAbsent =
+    forAll (listOf genSmallFinalizerIndex) $ \indices ->
+        forAll (listOf1 (suchThat genSmallFinalizerIndex (`notElem` indices))) $ \notIndices ->
+            let fs = finalizerSet indices
+            in  any (`memberFinalizerSet` fs) notIndices === False
+
+propSubsetFinalizerSetMatchesListSubset :: Property
+propSubsetFinalizerSetMatchesListSubset =
+    forAll (listOf genSmallFinalizerIndex) $ \xs ->
+        forAll (sublistOf xs) $ \ys ->
+            subsetFinalizerSet (finalizerSet ys) (finalizerSet xs) === True
+
+propSubsetFinalizerSetRejectsMissingMember :: Property
+propSubsetFinalizerSetRejectsMissingMember =
+    withMaxSuccess 1000 $
+        forAll (listOf genSmallFinalizerIndex) $ \ys ->
+            forAll (suchThat genSmallFinalizerIndex (`notElem` ys)) $ \missing ->
+                let xs = missing : ys
+                in  subsetFinalizerSet (finalizerSet xs) (finalizerSet ys) === False
+
 tests :: Spec
 tests = describe "KonsensusV1.Types" $ do
     it "FinalizerSet serialization" propSerializeFinalizerSet
@@ -454,6 +516,31 @@ tests = describe "KonsensusV1.Types" $ do
     it "QuorumSignatureMessage signature check fails with different key" propSignQuorumSignatureMessageDiffKey
     it "QuorumSignatureMessage signature check fails with different body" propSignQuorumSignatureMessageDiffBody
     it "Conversion to and from FinalizerSet" propFinalizerListIsInverseOfFinalizerSet
+    it "FinalizerSet membership matches list membership" propMemberFinalizerSetMatchesListMembership
+    it "FinalizerSet membership rejects absent indices" propMemberFinalizerSetRejectsAbsent
+    it "FinalizerSet membership reflects added finalizers" $ do
+        let fs = finalizerSet [FinalizerIndex 0, FinalizerIndex 3, FinalizerIndex 7, FinalizerIndex 9]
+        memberFinalizerSet (FinalizerIndex 0) fs `shouldBe` True
+        memberFinalizerSet (FinalizerIndex 1) fs `shouldBe` False
+        memberFinalizerSet (FinalizerIndex 3) fs `shouldBe` True
+        memberFinalizerSet (FinalizerIndex 7) fs `shouldBe` True
+        memberFinalizerSet (FinalizerIndex 8) fs `shouldBe` False
+        memberFinalizerSet (FinalizerIndex 9) fs `shouldBe` True
+    it "FinalizerSet subset matches list subset" propSubsetFinalizerSetMatchesListSubset
+    it "FinalizerSet subset rejects if missing member" propSubsetFinalizerSetRejectsMissingMember
+    it "FinalizerSet subset checks set inclusion" $ do
+        let fs = finalizerSet [FinalizerIndex 0, FinalizerIndex 1, FinalizerIndex 3, FinalizerIndex 9]
+            subset = finalizerSet [FinalizerIndex 0, FinalizerIndex 9]
+            notSubset = finalizerSet [FinalizerIndex 1, FinalizerIndex 8]
+        subsetFinalizerSet subset fs `shouldBe` True
+        subsetFinalizerSet notSubset fs `shouldBe` False
+    it "FinalizerSet serialization uses canonical big-endian wire encoding" $ do
+        encode (finalizerSet [FinalizerIndex 0, FinalizerIndex 1, FinalizerIndex 3, FinalizerIndex 10]) `shouldBe` encodedFinalizerSet01310
+        decode encodedFinalizerSet01310 `shouldBe` Right (finalizerSet [FinalizerIndex 0, FinalizerIndex 1, FinalizerIndex 3, FinalizerIndex 10])
+    it "FinalizerSet deserialization rejects non-canonical leading zero byte" $ do
+        (decode nonCanonicalFinalizerSetBytes :: Either String FinalizerSet) `shouldSatisfy` isLeft
+    it "FinalizerSet deserialization rejects a byte count that exceeds the remaining input" $ do
+        (decode truncatedFinalizerSetBytes :: Either String FinalizerSet) `shouldSatisfy` isLeft
     Common.forEveryProtocolVersionConsensusV1 $ \spv pvString -> do
         describe pvString $ do
             it "FinalizationEntry serialization" $ propSerializeFinalizationEntry spv