Merge pull request #3683 from input-output-hk/erikd/umap-size-bench

Add two new bench mark programs

hie.yaml

@@ -186,6 +186,12 @@ cradle:
     - path: "libs/cardano-ledger-core/test"
       component: "cardano-ledger-core:test:tests"
 
+    - path: "libs/cardano-ledger-core/bench/UMap.hs"
+      component: "cardano-ledger-core:bench:umap"
+
+    - path: "libs/cardano-ledger-core/bench/Addr.hs"
+      component: "cardano-ledger-core:bench:addr"
+
     - path: "libs/cardano-ledger-pretty/src"
       component: "lib:cardano-ledger-pretty"
 

libs/cardano-ledger-core/bench/Addr.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+import Cardano.Ledger.Address (Addr, decodeAddrEither, serialiseAddr)
+import Cardano.Ledger.Crypto (StandardCrypto)
+
+import Control.Monad (replicateM)
+
+import Criterion (Benchmark, bench, env, nf)
+import Criterion.Main (defaultMain)
+
+import Data.ByteString.Char8 (ByteString)
+import Data.Either (lefts)
+
+import Test.Cardano.Ledger.Core.Arbitrary ()
+import Test.QuickCheck (arbitrary, generate)
+
+main :: IO ()
+main = do
+  defaultMain $
+    map (\c -> env (generateAddrAsBytestring c) decodeAddrBench) (map (* 500) [1 .. 2])
+  where
+    decodeAddrBench :: [ByteString] -> Benchmark
+    decodeAddrBench xs =
+      bench ("decodeAddr (" ++ show (length xs) ++ ")") (nf tryDecodeAddr xs)
+
+-- -------------------------------------------------------------------------------------------------
+
+generateAddrAsBytestring :: Int -> IO [ByteString]
+generateAddrAsBytestring count =
+  replicateM count (serialiseAddr <$> genAddr)
+  where
+    genAddr :: IO (Addr StandardCrypto)
+    genAddr = generate arbitrary
+
+tryDecodeAddr :: [ByteString] -> ()
+tryDecodeAddr xs =
+  case lefts $ map decode xs of
+    [] -> ()
+    ys -> error $ "tryDecodeAddr: " ++ show ys
+  where
+    decode :: ByteString -> Either String (Addr StandardCrypto)
+    decode = decodeAddrEither

libs/cardano-ledger-core/bench/UMap.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+
+import Cardano.Ledger.Crypto (StandardCrypto)
+import Cardano.Ledger.UMap (UMap)
+import qualified Cardano.Ledger.UMap as UMap
+
+import Control.Monad (replicateM)
+
+import Criterion (Benchmark, bench, env, nf)
+import Criterion.Main (defaultMain)
+
+import qualified Data.Map.Strict as Map
+
+import Test.Cardano.Ledger.Core.Arbitrary ()
+import Test.QuickCheck (arbitrary, generate)
+
+main :: IO ()
+main = do
+  defaultMain $
+    map (\c -> env (generateUMap c) umapSizeBench) (map (* 10000) [1 .. 2])
+  where
+    umapSizeBench :: UMap StandardCrypto -> Benchmark
+    umapSizeBench umap =
+      bench ("compositeSize (" ++ show (compositeSize umap) ++ ")") (nf compositeSize umap)
+
+-- -------------------------------------------------------------------------------------------------
+
+compositeSize :: UMap StandardCrypto -> Int
+compositeSize umap =
+  sum
+    [ UMap.size (UMap.RewDepUView umap)
+    , UMap.size (UMap.PtrUView umap)
+    , UMap.size (UMap.SPoolUView umap)
+    , UMap.size (UMap.DRepUView umap)
+    ]
+
+-- Generate a UView of exactly the size specified.
+generateUMap :: Int -> IO (UMap StandardCrypto)
+generateUMap size =
+  generate $ do
+    ptrs <- replicateM size arbitrary
+    sPools <- replicateM size arbitrary
+    dReps <- replicateM size arbitrary
+    creds <- replicateM size arbitrary
+    rdPairs <- replicateM size arbitrary
+    pure $
+      UMap.unify
+        (Map.fromList $ zip creds rdPairs)
+        (Map.fromList $ zip ptrs creds)
+        (Map.fromList $ zip creds sPools)
+        (Map.fromList $ zip creds dReps)

libs/cardano-ledger-core/cardano-ledger-core.cabal

@@ -191,3 +191,39 @@ test-suite tests
         genvalidity,
         genvalidity-scientific,
         scientific
+
+benchmark umap
+    type:             exitcode-stdio-1.0
+    main-is:          UMap.hs
+    hs-source-dirs:   bench
+    default-language: Haskell2010
+    ghc-options:
+        -Wall -Wcompat -Wincomplete-record-updates
+        -Wincomplete-uni-patterns -Wredundant-constraints -Wunused-packages
+        -threaded -rtsopts -O2
+
+    build-depends:
+        base,
+        cardano-ledger-core,
+        testlib,
+        containers,
+        criterion,
+        QuickCheck
+
+benchmark addr
+    type:             exitcode-stdio-1.0
+    main-is:          Addr.hs
+    hs-source-dirs:   bench
+    default-language: Haskell2010
+    ghc-options:
+        -Wall -Wcompat -Wincomplete-record-updates
+        -Wincomplete-uni-patterns -Wredundant-constraints -Wunused-packages
+        -threaded -rtsopts -O2
+
+    build-depends:
+        base,
+        bytestring,
+        cardano-ledger-core,
+        testlib,
+        criterion,
+        QuickCheck