Builtin Pattern Matching

plutus-benchmark/common/PlutusBenchmark/Common.hs

@@ -107,7 +107,8 @@ mkEvalCtx ll semvar =
       let errOrCtx =
             LedgerApi.mkDynEvaluationContext
               ll
-              (\_ -> PLC.CaserBuiltin PLC.caseBuiltin)
+              (\_ -> PLC.availableCaserBuiltin)
+              (PLC.unavailableMatcherBuiltin . LedgerApi.getMajorProtocolVersion)
               [semvar]
               (const semvar)
               p

plutus-benchmark/flat-decode/bench/Main.hs

@@ -7,6 +7,7 @@
 module Main where
 
 import PlutusCore.Default
+import PlutusCore.Flat qualified as PlutusFlat
 import PlutusCore.MkPlc
 import PlutusCore.Version
 import PlutusLedgerApi.Common.Versions
@@ -59,6 +60,43 @@ mkProg
   -> UPLC.Program DeBruijn DefaultUni DefaultFun ()
 mkProg a = UPLC.Program () plcVersion100 $ mkConstant () a
 
+-- Decode an unpadded Integer directly, so this benchmark isolates the Flat
+-- integer decoder from UPLC term decoding and validation.
+unsafeUnflatRawInteger :: BS.ByteString -> Integer
+unsafeUnflatRawInteger encoded =
+  case PlutusFlat.unflatRaw encoded of
+    Left err -> throw err
+    Right value -> value
+
+-- A sparse input establishes the cost of reading the bytes and constructing
+-- the final Integer while doing only one nonzero shift.
+sparseIntegerEncoding :: Int -> BS.ByteString
+sparseIntegerEncoding chunks =
+  BS.replicate (chunks - 1) 0x80 <> BS.singleton 0x02
+
+-- Every payload chunk is nonzero. The first payload digit is even so ZigZag
+-- decodes the result as a positive Integer; the last byte terminates the value.
+denseIntegerEncoding :: Int -> BS.ByteString
+denseIntegerEncoding chunks
+  | chunks == 1 = BS.singleton 0x02
+  | otherwise =
+      BS.singleton 0x82
+        <> BS.replicate (chunks - 2) 0x81
+        <> BS.singleton 0x01
+
+integerEncodingSizes :: [Int]
+integerEncodingSizes = [128, 256, 512, 1024, 2048, 4096, 8192, 16384]
+
+mkIntegerMagnitudeBMs :: String -> (Int -> BS.ByteString) -> Benchmark
+mkIntegerMagnitudeBMs label mkEncoding =
+  bgroup label $
+    fmap
+      ( \chunks ->
+          env (pure $ force $ mkEncoding chunks) $ \ ~encoded ->
+            bench (show chunks) $ nf unsafeUnflatRawInteger encoded
+      )
+      integerEncodingSizes
+
 main :: IO ()
 main =
   let lengths :: [Integer] = fmap (100 *) [1 .. 20]
@@ -76,6 +114,11 @@ main =
       mkArrayBMs mkInput = fmap mkBM $ fmap (\n -> (n, fmap mkInput $ V.fromList [1 .. n])) lengths
    in defaultMain
         [ bgroup
+            "single-integer/by-varint-bytes"
+            [ mkIntegerMagnitudeBMs "dense-payload" denseIntegerEncoding
+            , mkIntegerMagnitudeBMs "sparse-payload" sparseIntegerEncoding
+            ]
+        , bgroup
             "list"
             [ bgroup "bool" . mkListBMs $ \i -> i `mod` 2 == 0
             , bgroup

plutus-benchmark/matching/bench/Bench.hs

@@ -0,0 +1,172 @@
+{-# LANGUAGE BangPatterns #-}
+
+-- | Benchmarks for matching patterns against builtin values.
+module Main (main) where
+
+import Criterion.Main
+
+import PlutusBenchmark.Common (Term, getConfig, mkMostRecentEvalCtx)
+import PlutusCore qualified as Core
+import PlutusCore.Builtin qualified as PLC
+import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..), ExRestrictingBudget (..))
+import PlutusCore.Evaluation.Machine.MachineParameters (MachineParameters (..))
+import PlutusLedgerApi.Common (EvaluationContext)
+import PlutusLedgerApi.Common qualified as LedgerApi
+import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek
+
+import PlutusBenchmark.Matching qualified as Matching
+
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Data.Functor
+
+benchmarks :: EvaluationContext -> [Benchmark]
+benchmarks ctx =
+  [ bgroup
+      "matching"
+      [ mkMatchBMs "wildcard" Matching.matchingWildcard
+      , mkMatchBMs "integer" Matching.matchingInteger
+      , mkMatchBMs "exact list" Matching.matchingExactList
+      , mkMatchBMs "capture list" Matching.matchingCaptureList
+      , bgroup
+          "list prefix"
+          [ bgroup ("prefix " <> show prefixWidth) $
+              [ bgroup
+                  "wildcard rest"
+                  [ bench ("suffix " <> show suffixWidth) $
+                      benchTermCekWithMatch ctx $
+                        Matching.matchingListPrefixWildcard prefixWidth suffixWidth
+                  | suffixWidth <- [0, 1, 16, 128, 1200]
+                  ]
+              , bgroup
+                  "capture rest"
+                  [ bench ("suffix " <> show suffixWidth) $
+                      benchTermCekWithMatch ctx $
+                        Matching.matchingListPrefixCaptureRest prefixWidth suffixWidth
+                  | suffixWidth <- [0, 1, 16, 128, 1200]
+                  ]
+              ]
+          | prefixWidth <- [0, 1, 3, 16, 128]
+          ]
+      , mkMatchBMs "alternatives" Matching.matchingAlternatives
+      , bgroup
+          "Data.Constr comparison"
+          [ bgroup ("width " <> show width) $
+              let (directUnConstr, checkedUnConstr, wildcardMatch, captureMatch) =
+                    Matching.dataConstrMatchComparison width
+               in [ bench "direct UnConstrData" $ benchTermCekWithMatch ctx directUnConstr
+                  , bench "checked ChooseData + UnConstrData" $
+                      benchTermCekWithMatch ctx checkedUnConstr
+                  , bench "Match wildcards" $ benchTermCekWithMatch ctx wildcardMatch
+                  , bench "Match captures" $ benchTermCekWithMatch ctx captureMatch
+                  ]
+          | width <- [0, 1, 3, 16, 128]
+          ]
+      , bgroup
+          "fixed-point exhaustion"
+          [ mkExhaustionBM "exact list/1200" $ Matching.matchingFixpointExactList 1200
+          , mkExhaustionBM "late list mismatch/1200" $
+              Matching.matchingFixpointLateListMismatch 1200
+          , mkExhaustionBM "abandoned captures/700" $
+              Matching.matchingFixpointAbandonedCaptures 700
+          , mkExhaustionBM "short list arity/1200" $
+              Matching.matchingFixpointListArityMismatch 1200 (-1)
+          , mkExhaustionBM "long list arity/1200" $
+              Matching.matchingFixpointListArityMismatch 1200 1
+          , mkExhaustionBM "capture list/700" $ Matching.matchingFixpointCaptureList 700
+          , mkExhaustionBM "alternatives/1000" $ Matching.matchingFixpointAlternatives 1000
+          , mkExhaustionBM "wide alternatives/16x64" $
+              Matching.matchingFixpointWideAlternatives 16 64
+          , mkExhaustionBM "nested Data/1000" $ Matching.matchingFixpointNestedData 1000
+          , mkExhaustionBM "nested Data.Constr/1000" $
+              Matching.matchingFixpointNestedDataConstr 1000
+          , mkExhaustionBM "empty Data.Constr" Matching.matchingFixpointEmptyDataConstr
+          , mkExhaustionBM "small integer" Matching.matchingFixpointSmallInteger
+          , mkExhaustionBM "small bytestring" Matching.matchingFixpointSmallByteString
+          , mkExhaustionBM "wide Data.Constr/1200" $
+              Matching.matchingFixpointWideDataConstr 1200
+          , mkExhaustionBM "max Int64 integer" Matching.matchingFixpointMaxInteger
+          , mkExhaustionBM "large bytestring/1000 words" $
+              Matching.matchingFixpointLargeByteString 1000
+          , mkExhaustionBM "max Word64 Data tag" Matching.matchingFixpointMaxDataTag
+          ]
+      ]
+  ]
+  where
+    mkMatchBMs name f =
+      bgroup name $
+        [200, 400 .. 1200] <&> \n ->
+          bench (show n) $ benchTermCekWithMatch ctx (f n)
+    mkExhaustionBM name term =
+      bench name $ benchTermCekWithMatchExhaustion ctx term
+
+{-| Benchmark an experimental 'UPLC.Match' term using the production CEK and the same
+machine variant/cost model as 'benchTermCek', but with the 'DefaultUni' matcher enabled
+for this invocation only. Ledger evaluation contexts deliberately keep matching disabled
+until PLC 1.2 receives a ledger activation. -}
+benchTermCekWithMatch :: EvaluationContext -> Term -> Benchmarkable
+benchTermCekWithMatch evalCtx term =
+  let !term' = force term
+   in whnf (either (error . show) (const ()) . evaluateTermWithMatch evalCtx) term'
+
+type MatchParameters =
+  MachineParameters
+    Cek.CekMachineCosts
+    Core.DefaultFun
+    (Cek.CekValue Core.DefaultUni Core.DefaultFun ())
+
+evaluateTermWithMatch
+  :: EvaluationContext
+  -> Term
+  -> Either
+       ( Cek.CekEvaluationException
+           Core.NamedDeBruijn
+           Core.DefaultUni
+           Core.DefaultFun
+       )
+       Term
+evaluateTermWithMatch evalCtx =
+  Cek.cekResultToEither
+    . Cek._cekReportResult
+    . Cek.runCekDeBruijn (matchParameters evalCtx) Cek.restrictingEnormous Cek.noEmitter
+
+matchParameters :: EvaluationContext -> MatchParameters
+matchParameters evalCtx =
+  case LedgerApi.toMachineParameters benchmarkProtocolVersion evalCtx of
+    MachineParameters caser _matcher variantParameters ->
+      MachineParameters caser PLC.availableMatcherBuiltin variantParameters
+  where
+    -- Keep this aligned with 'PlutusBenchmark.Common.evaluateCekLikeInProd'.
+    benchmarkProtocolVersion = LedgerApi.ledgerLanguageIntroducedIn LedgerApi.PlutusV1
+
+{-| Benchmark recursive experimental matches that are expected to consume a ledger-scale budget.
+The result is checked specifically for budget exhaustion so a malformed benchmark or unrelated CEK
+failure cannot be mistaken for a fast successful run. -}
+benchTermCekWithMatchExhaustion :: EvaluationContext -> Term -> Benchmarkable
+benchTermCekWithMatchExhaustion evalCtx term =
+  let !term' = force term
+   in whnf runMatchToExhaustion term'
+  where
+    runMatchToExhaustion term' =
+      case Cek.cekResultToEither . Cek._cekReportResult $
+        Cek.runCekDeBruijn
+          exhaustionParameters
+          (Cek.restricting nearMaximumCpuBudget)
+          Cek.noEmitter
+          term' of
+        Left (Cek.ErrorWithCause (Cek.OperationalError (Cek.CekOutOfExError _)) _) -> ()
+        result -> error $ "fixed-point Match did not exhaust its budget: " <> show result
+    exhaustionParameters =
+      case LedgerApi.toMachineParameters benchmarkProtocolVersion evalCtx of
+        MachineParameters caser _matcher variantParameters ->
+          MachineParameters caser PLC.availableMatcherBuiltin variantParameters
+    -- Keep memory nonbinding to measure the worst latency at the current ledger CPU ceiling.
+    nearMaximumCpuBudget = ExRestrictingBudget $ ExBudget 10000000000 1000000000
+    benchmarkProtocolVersion = LedgerApi.ledgerLanguageIntroducedIn LedgerApi.PlutusV1
+
+main :: IO ()
+main = do
+  -- Run each benchmark for at least 15 seconds. Change this with -L or --time-limit.
+  config <- getConfig 15.0
+  evalCtx <- evaluate mkMostRecentEvalCtx
+  defaultMainWith config $ benchmarks evalCtx

plutus-benchmark/matching/costing/.gitignore

@@ -0,0 +1 @@
+results/