From c29e5535fae3ed095f95506b793244792b3ca025 Mon Sep 17 00:00:00 2001 From: Philip DiSarro Date: Tue, 3 Feb 2026 20:21:13 -0800 Subject: [PATCH 1/2] feat: native builtin data vs th builtin data benchmark --- .../linear-vesting/exe/MainOptimized.hs | 13 + .../src/LinearVesting/TestOptimized.hs | 12 + .../src/LinearVesting/Validator.hs | 34 +- .../src/LinearVesting/ValidatorOptimized.hs | 407 ++++++++++++++++++ plutus-benchmark/plutus-benchmark.cabal | 12 + 5 files changed, 471 insertions(+), 7 deletions(-) create mode 100644 plutus-benchmark/linear-vesting/exe/MainOptimized.hs create mode 100644 plutus-benchmark/linear-vesting/src/LinearVesting/TestOptimized.hs create mode 100644 plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs diff --git a/plutus-benchmark/linear-vesting/exe/MainOptimized.hs b/plutus-benchmark/linear-vesting/exe/MainOptimized.hs new file mode 100644 index 00000000000..9083073cda1 --- /dev/null +++ b/plutus-benchmark/linear-vesting/exe/MainOptimized.hs @@ -0,0 +1,13 @@ +module Main (main) where + +import Data.Text qualified as Text +import LinearVesting.TestOptimized (validatorOptimizedCodeFullyApplied) +import PlutusTx.Test (displayEvalResult, evaluateCompiledCode) + +main :: IO () +main = do + putStrLn "" + putStrLn $ + Text.unpack $ + displayEvalResult $ + evaluateCompiledCode validatorOptimizedCodeFullyApplied diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/TestOptimized.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/TestOptimized.hs new file mode 100644 index 00000000000..943603702f1 --- /dev/null +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/TestOptimized.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module LinearVesting.TestOptimized where + +import LinearVesting.Test (testScriptContext) +import LinearVesting.ValidatorOptimized (validatorOptimizedCode) +import PlutusTx +import PlutusTx.Prelude + +validatorOptimizedCodeFullyApplied :: CompiledCode BuiltinUnit +validatorOptimizedCodeFullyApplied = + validatorOptimizedCode `unsafeApplyCode` liftCodeDef (toBuiltinData testScriptContext) diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs index a6b252fa3bc..6e9e7672472 100644 --- a/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs @@ -29,6 +29,7 @@ module LinearVesting.Validator where import PlutusTx +import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Prelude import Prelude qualified as Haskell @@ -38,6 +39,8 @@ import PlutusLedgerApi.V3.Data.Contexts (txSignedBy) import PlutusTx.Data.List (List) import PlutusTx.Data.List qualified as List +{-# ANN module ("onchain-contract" :: Haskell.String) #-} + data VestingDatum = VestingDatum { beneficiary :: Address , vestingAsset :: AssetClass @@ -139,13 +142,17 @@ validateVestingFullUnlock ctx = vestingDatum :: VestingDatum = unsafeFromBuiltinData datum PubKeyCredential beneficiaryKey = addressCredential (beneficiary vestingDatum) in - if - | not (txSignedBy txInfo beneficiaryKey) -> - traceError "Missing beneficiary signature" - | vestingPeriodEnd vestingDatum >= currentTimeApproximation -> - traceError "Unlock not permitted until vestingPeriodEnd time" - | otherwise -> - True + BI.ifThenElse + (not (txSignedBy txInfo beneficiaryKey)) + (\_ -> traceError "Missing beneficiary signature") + ( \_ -> + BI.ifThenElse + (vestingPeriodEnd vestingDatum >= currentTimeApproximation) + (\_ -> traceError "Unlock not permitted until vestingPeriodEnd time") + (\_ -> True) + BI.unitval + ) + BI.unitval getLowerInclusiveTimeRange :: POSIXTimeRange -> POSIXTime getLowerInclusiveTimeRange = \case @@ -153,6 +160,19 @@ getLowerInclusiveTimeRange = \case if inclusive then posixTime else posixTime + 1 _ -> traceError "Time range not Finite" +-- Evaluation was SUCCESSFUL, result is: +-- () + +-- Execution budget spent: +-- CPU 30,837,131 +-- MEM 131,619 + +-- Evaluation traces: +-- 1. Parsing ScriptContext... +-- 2. Parsed ScriptContext +-- 3. Parsed Redeemer +-- 4. Full unlock requested +-- 5. Validation completed {-# INLINEABLE typedValidator #-} typedValidator :: ScriptContext -> Bool typedValidator context = diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs new file mode 100644 index 00000000000..a97ca00c6a4 --- /dev/null +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs @@ -0,0 +1,407 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -fno-full-laziness #-} +{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# OPTIONS_GHC -fno-spec-constr #-} +{-# OPTIONS_GHC -fno-specialise #-} +{-# OPTIONS_GHC -fno-strictness #-} +{-# OPTIONS_GHC -fno-unbox-small-strict-fields #-} +{-# OPTIONS_GHC -fno-unbox-strict-fields #-} +{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:conservative-optimisation #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:datatypes=BuiltinCasing #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-remove-trace #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:preserve-logging #-} + +module LinearVesting.ValidatorOptimized where + +import PlutusTx (CompiledCode, compile) +import PlutusTx.Bool (Bool (..)) +import PlutusTx.Builtins.HasOpaque () +import PlutusTx.Builtins.Internal qualified as BI +import PlutusTx.Trace (traceError) + +{-# INLINE builtinIf #-} +builtinIf :: Bool -> (BI.BuiltinUnit -> a) -> (BI.BuiltinUnit -> a) -> a +builtinIf cond t f = BI.ifThenElse cond t f BI.unitval + +{-# INLINE builtinNot #-} +builtinNot :: Bool -> Bool +builtinNot b = builtinIf b (\_ -> False) (\_ -> True) + +{-# INLINE builtinAnd #-} +builtinAnd :: Bool -> Bool -> Bool +builtinAnd b1 b2 = builtinIf b1 (\_ -> b2) (\_ -> False) + +{-# INLINE divCeil #-} +divCeil :: BI.BuiltinInteger -> BI.BuiltinInteger -> BI.BuiltinInteger +divCeil x y = BI.addInteger 1 (BI.divideInteger (BI.subtractInteger x 1) y) + +{-# INLINE lowerInclusiveTime #-} +lowerInclusiveTime :: BI.BuiltinData -> BI.BuiltinInteger +lowerInclusiveTime iv = + let ivFields = BI.snd (BI.unsafeDataAsConstr iv) + lower = BI.head ivFields + !lowerFields = BI.snd (BI.unsafeDataAsConstr lower) + extended = BI.head lowerFields + closureData = BI.head (BI.tail lowerFields) + closureTag = BI.fst (BI.unsafeDataAsConstr closureData) + !extCon = BI.unsafeDataAsConstr extended + extTag = BI.fst extCon + extFields = BI.snd extCon + offset = + builtinIf + (BI.equalsInteger closureTag 1) + (\_ -> 0) + (\_ -> 1) + in builtinIf + (BI.equalsInteger extTag 1) + (\_ -> BI.addInteger (BI.unsafeDataAsI (BI.head extFields)) offset) + (\_ -> traceError "Time range not Finite") + +{-# INLINE txSignedByOptimized #-} +txSignedByOptimized :: BI.BuiltinList BI.BuiltinData -> BI.BuiltinByteString -> Bool +txSignedByOptimized signatories pkh = + BI.caseList' + False + ( \s ss -> + let sBytes = BI.unsafeDataAsB s + in builtinIf + (BI.equalsByteString sBytes pkh) + (\_ -> True) + (\_ -> txSignedByOptimized ss pkh) + ) + signatories + +{-# INLINE findInputByOutRef #-} +findInputByOutRef :: BI.BuiltinData -> BI.BuiltinList BI.BuiltinData -> BI.BuiltinData +findInputByOutRef ref inputs = + BI.caseList' + (traceError "Own input not found") + ( \txIn txIns -> + let txInFields = BI.snd (BI.unsafeDataAsConstr txIn) + txInRef = BI.head txInFields + in builtinIf + (BI.equalsData txInRef ref) + (\_ -> txIn) + (\_ -> findInputByOutRef ref txIns) + ) + inputs + +{-# INLINE findOutputByAddress #-} +findOutputByAddress :: BI.BuiltinData -> BI.BuiltinList BI.BuiltinData -> BI.BuiltinData +findOutputByAddress addr outputs = + BI.caseList' + (traceError "Own output not found") + ( \out outs -> + let outFields = BI.snd (BI.unsafeDataAsConstr out) + outAddr = BI.head outFields + in builtinIf + (BI.equalsData outAddr addr) + (\_ -> out) + (\_ -> findOutputByAddress addr outs) + ) + outputs + +{-# INLINE countInputsAtScript #-} +countInputsAtScript :: BI.BuiltinByteString -> BI.BuiltinList BI.BuiltinData -> BI.BuiltinInteger +countInputsAtScript scriptHash inputs = + BI.caseList' + 0 + ( \txIn txIns -> + let txInFields = BI.snd (BI.unsafeDataAsConstr txIn) + resolvedOut = BI.head (BI.tail txInFields) + resolvedFields = BI.snd (BI.unsafeDataAsConstr resolvedOut) + addr = BI.head resolvedFields + addrFields = BI.snd (BI.unsafeDataAsConstr addr) + cred = BI.head addrFields + !credCon = BI.unsafeDataAsConstr cred + credTag = BI.fst credCon + credFields = BI.snd credCon + rest = countInputsAtScript scriptHash txIns + in builtinIf + (BI.equalsInteger credTag 1) + ( \_ -> + let vh = BI.unsafeDataAsB (BI.head credFields) + in builtinIf + (BI.equalsByteString vh scriptHash) + (\_ -> BI.addInteger 1 rest) + (\_ -> rest) + ) + (\_ -> rest) + ) + inputs + +{-# INLINE valueOf #-} +valueOf :: BI.BuiltinData -> BI.BuiltinByteString -> BI.BuiltinByteString -> BI.BuiltinInteger +valueOf valueData cs tn = + let outer = BI.unsafeDataAsMap valueData + in findCurrency outer + where + findCurrency :: BI.BuiltinList (BI.BuiltinPair BI.BuiltinData BI.BuiltinData) -> BI.BuiltinInteger + findCurrency pairs = + builtinIf + (BI.null pairs) + (\_ -> 0) + ( \_ -> + let pair = BI.head pairs + key = BI.unsafeDataAsB (BI.fst pair) + in builtinIf + (BI.equalsByteString key cs) + (\_ -> findToken (BI.unsafeDataAsMap (BI.snd pair))) + (\_ -> findCurrency (BI.tail pairs)) + ) + + findToken :: BI.BuiltinList (BI.BuiltinPair BI.BuiltinData BI.BuiltinData) -> BI.BuiltinInteger + findToken pairs = + builtinIf + (BI.null pairs) + (\_ -> 0) + ( \_ -> + let pair = BI.head pairs + key = BI.unsafeDataAsB (BI.fst pair) + in builtinIf + (BI.equalsByteString key tn) + (\_ -> BI.unsafeDataAsI (BI.snd pair)) + (\_ -> findToken (BI.tail pairs)) + ) + +{-# INLINE getScriptHashFromAddress #-} +getScriptHashFromAddress :: BI.BuiltinData -> BI.BuiltinByteString +getScriptHashFromAddress addr = + let addrFields = BI.snd (BI.unsafeDataAsConstr addr) + cred = BI.head addrFields + !credCon = BI.unsafeDataAsConstr cred + credTag = BI.fst credCon + credFields = BI.snd credCon + in builtinIf + (BI.equalsInteger credTag 1) + (\_ -> BI.unsafeDataAsB (BI.head credFields)) + (\_ -> traceError "Expected ScriptCredential") + +{-# INLINE getPubKeyHashFromAddress #-} +getPubKeyHashFromAddress :: BI.BuiltinData -> BI.BuiltinByteString +getPubKeyHashFromAddress addr = + let addrFields = BI.snd (BI.unsafeDataAsConstr addr) + cred = BI.head addrFields + !credCon = BI.unsafeDataAsConstr cred + credTag = BI.fst credCon + credFields = BI.snd credCon + in builtinIf + (BI.equalsInteger credTag 0) + (\_ -> BI.unsafeDataAsB (BI.head credFields)) + (\_ -> traceError "Expected PubKeyCredential") + +{-# INLINE getSpendingInfo #-} +getSpendingInfo :: BI.BuiltinData -> BI.BuiltinPair BI.BuiltinData BI.BuiltinData +getSpendingInfo scriptInfo = + let con = BI.unsafeDataAsConstr scriptInfo + tag = BI.fst con + fields = BI.snd con + in builtinIf + (BI.equalsInteger tag 1) + ( \_ -> + let ownRef = BI.head fields + maybeDatum = BI.head (BI.tail fields) + !mdCon = BI.unsafeDataAsConstr maybeDatum + mdTag = BI.fst mdCon + mdFields = BI.snd mdCon + in builtinIf + (BI.equalsInteger mdTag 0) + (\_ -> BI.mkPairData ownRef (BI.head mdFields)) + (\_ -> traceError "Missing datum") + ) + (\_ -> traceError "Not spending script") + +{-# INLINE validateVestingPartialUnlockOptimized #-} +validateVestingPartialUnlockOptimized + :: BI.BuiltinList BI.BuiltinData + -> BI.BuiltinList BI.BuiltinData + -> BI.BuiltinData + -> BI.BuiltinList BI.BuiltinData + -> BI.BuiltinData + -> BI.BuiltinData + -> Bool +validateVestingPartialUnlockOptimized txInputs txOutputs txValidRange txSignatories ownRef vestingDatum = + let ownInput = findInputByOutRef ownRef txInputs + ownInputFields = BI.snd (BI.unsafeDataAsConstr ownInput) + resolvedOut = BI.head (BI.tail ownInputFields) + !resolvedFields = BI.snd (BI.unsafeDataAsConstr resolvedOut) + !inputAddress = BI.head resolvedFields + + scriptHash = getScriptHashFromAddress inputAddress + ownOutput = findOutputByAddress inputAddress txOutputs + !ownOutputFields = BI.snd (BI.unsafeDataAsConstr ownOutput) + outputDatum = BI.head (BI.tail (BI.tail ownOutputFields)) + + resolvedDatum = BI.head (BI.tail (BI.tail resolvedFields)) + + vdFields = BI.snd (BI.unsafeDataAsConstr vestingDatum) + vdFields1 = BI.tail vdFields + !vdFields2 = BI.tail vdFields1 + !vdFields3 = BI.tail vdFields2 + !vdFields4 = BI.tail vdFields3 + !vdFields5 = BI.tail vdFields4 + !vdFields6 = BI.tail vdFields5 + + beneficiaryAddr = BI.head vdFields + assetClassData = BI.head vdFields1 + totalVestingQty = BI.unsafeDataAsI (BI.head vdFields2) + vestingPeriodStart = BI.unsafeDataAsI (BI.head vdFields3) + vestingPeriodEnd = BI.unsafeDataAsI (BI.head vdFields4) + firstUnlockPossibleAfter = BI.unsafeDataAsI (BI.head vdFields5) + totalInstallments = BI.unsafeDataAsI (BI.head vdFields6) + + assetCon = BI.unsafeDataAsConstr assetClassData + assetFields = BI.snd assetCon + assetCs = BI.unsafeDataAsB (BI.head assetFields) + assetTn = BI.unsafeDataAsB (BI.head (BI.tail assetFields)) + + oldRemainingQty = valueOf (BI.head (BI.tail resolvedFields)) assetCs assetTn + newRemainingQty = valueOf (BI.head (BI.tail ownOutputFields)) assetCs assetTn + + vestingPeriodLength = BI.subtractInteger vestingPeriodEnd vestingPeriodStart + currentTimeApproximation = lowerInclusiveTime txValidRange + vestingTimeRemaining = BI.subtractInteger vestingPeriodEnd currentTimeApproximation + timeBetweenTwoInstallments = divCeil vestingPeriodLength totalInstallments + futureInstallments = divCeil vestingTimeRemaining timeBetweenTwoInstallments + expectedRemainingQty = + divCeil (BI.multiplyInteger futureInstallments totalVestingQty) totalInstallments + + beneficiaryHash = getPubKeyHashFromAddress beneficiaryAddr + signed = txSignedByOptimized txSignatories beneficiaryHash + in builtinIf + (builtinNot signed) + (\_ -> traceError "Missing beneficiary signature") + ( \_ -> + builtinIf + (BI.lessThanEqualsInteger currentTimeApproximation firstUnlockPossibleAfter) + (\_ -> traceError "Unlock not permitted until firstUnlockPossibleAfter time") + ( \_ -> + builtinIf + (BI.lessThanEqualsInteger newRemainingQty 0) + (\_ -> traceError "Zero remaining assets not allowed") + ( \_ -> + builtinIf + (BI.lessThanEqualsInteger oldRemainingQty newRemainingQty) + (\_ -> traceError "Remaining asset is not decreasing") + ( \_ -> + builtinIf + (builtinNot (BI.equalsInteger expectedRemainingQty newRemainingQty)) + (\_ -> traceError "Mismatched remaining asset") + ( \_ -> + builtinIf + (builtinNot (BI.equalsData resolvedDatum outputDatum)) + (\_ -> traceError "Datum Modification Prohibited") + ( \_ -> + builtinIf + (builtinNot (BI.equalsInteger (countInputsAtScript scriptHash txInputs) 1)) + (\_ -> traceError "Double satisfaction") + (\_ -> True) + ) + ) + ) + ) + ) + ) + +{-# INLINE validateVestingFullUnlockOptimized #-} +validateVestingFullUnlockOptimized + :: BI.BuiltinData + -> BI.BuiltinList BI.BuiltinData + -> BI.BuiltinData + -> Bool +validateVestingFullUnlockOptimized txValidRange txSignatories vestingDatum = + let !vdFields = BI.snd (BI.unsafeDataAsConstr vestingDatum) + vdFields1 = BI.tail vdFields + vdFields2 = BI.tail vdFields1 + vdFields3 = BI.tail vdFields2 + vdFields4 = BI.tail vdFields3 + + beneficiaryAddr = BI.head vdFields + vestingPeriodEnd = BI.unsafeDataAsI (BI.head vdFields4) + currentTimeApproximation = lowerInclusiveTime txValidRange + beneficiaryHash = getPubKeyHashFromAddress beneficiaryAddr + in builtinIf + (builtinNot (txSignedByOptimized txSignatories beneficiaryHash)) + (\_ -> traceError "Missing beneficiary signature") + ( \_ -> + builtinIf + (BI.lessThanEqualsInteger currentTimeApproximation vestingPeriodEnd) + (\_ -> traceError "Unlock not permitted until vestingPeriodEnd time") + (\_ -> True) + ) + +{-# INLINEABLE untypedValidatorOptimized #-} +untypedValidatorOptimized :: BI.BuiltinData -> BI.BuiltinUnit +untypedValidatorOptimized scriptContextData = + let ctx = BI.trace "Parsing ScriptContext..." scriptContextData + ctxFields = BI.snd (BI.unsafeDataAsConstr ctx) + txInfoData = BI.head ctxFields + redeemerData = BI.head (BI.tail ctxFields) + scriptInfoData = BI.head (BI.tail (BI.tail ctxFields)) + + txInfoFields = BI.snd (BI.unsafeDataAsConstr txInfoData) + txInfoFields1 = BI.tail txInfoFields + txInfoFields2 = BI.tail txInfoFields1 + txInfoFields3 = BI.tail txInfoFields2 + txInfoFields4 = BI.tail txInfoFields3 + txInfoFields5 = BI.tail txInfoFields4 + txInfoFields6 = BI.tail txInfoFields5 + txInfoFields7 = BI.tail txInfoFields6 + txInfoFields8 = BI.tail txInfoFields7 + + txInputs = BI.unsafeDataAsList (BI.head txInfoFields) + txOutputs = BI.unsafeDataAsList (BI.head txInfoFields2) + txValidRange = BI.head txInfoFields7 + txSignatories = BI.unsafeDataAsList (BI.head txInfoFields8) + + spendingInfo = getSpendingInfo scriptInfoData + ownRef = BI.fst spendingInfo + datumData = BI.snd spendingInfo + + redeemerTag = BI.fst (BI.unsafeDataAsConstr redeemerData) + + result = + BI.trace + "Parsed ScriptContext" + ( BI.trace + "Parsed Redeemer" + ( builtinIf + (BI.equalsInteger redeemerTag 1) + ( \_ -> + BI.trace + "Full unlock requested" + (validateVestingFullUnlockOptimized txValidRange txSignatories datumData) + ) + ( \_ -> + builtinIf + (BI.equalsInteger redeemerTag 0) + ( \_ -> + BI.trace + "Partial unlock requested" + ( validateVestingPartialUnlockOptimized + txInputs + txOutputs + txValidRange + txSignatories + ownRef + datumData + ) + ) + (\_ -> traceError "Failed to parse Redeemer") + ) + ) + ) + in builtinIf + result + (\_ -> BI.trace "Validation completed" BI.unitval) + (\_ -> traceError "Validation failed") + +validatorOptimizedCode :: CompiledCode (BI.BuiltinData -> BI.BuiltinUnit) +validatorOptimizedCode = $$(compile [||untypedValidatorOptimized||]) diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal index 5bfd9da2ad9..9c6ca3b5b6f 100644 --- a/plutus-benchmark/plutus-benchmark.cabal +++ b/plutus-benchmark/plutus-benchmark.cabal @@ -740,7 +740,9 @@ library linear-vesting-internal hs-source-dirs: linear-vesting/src exposed-modules: LinearVesting.Test + LinearVesting.TestOptimized LinearVesting.Validator + LinearVesting.ValidatorOptimized build-depends: , base >=4.9 && <5 @@ -758,6 +760,16 @@ executable linear-vesting , plutus-tx:plutus-tx-testlib , text +executable linear-vesting-optimized + import: lang, ghc-version-support, os-support + main-is: MainOptimized.hs + hs-source-dirs: linear-vesting/exe + build-depends: + , base >=4.9 && <5 + , linear-vesting-internal + , plutus-tx:plutus-tx-testlib + , text + ------------------ Cardano Open Oracle Protocol ------------------- library coop From 6d75987f37eaec13d3746a8a7bd7346b601b54d3 Mon Sep 17 00:00:00 2001 From: Yuriy Lazaryev Date: Wed, 11 Feb 2026 10:47:26 +0100 Subject: [PATCH 2/2] experiment: replace builtinIf with standard guards in optimized validator Replace all builtinIf/builtinNot/builtinAnd (lambda/unit pattern) with standard if/then/else and multi-way if guards, while keeping all BI.* low-level operations identical. This isolates the cost of the builtinIf pattern vs standard Haskell conditionals. --- .../src/LinearVesting/ValidatorOptimized.hs | 254 +++++++----------- 1 file changed, 96 insertions(+), 158 deletions(-) diff --git a/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs b/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs index a97ca00c6a4..b60df55bac3 100644 --- a/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs +++ b/plutus-benchmark/linear-vesting/src/LinearVesting/ValidatorOptimized.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -21,23 +22,11 @@ module LinearVesting.ValidatorOptimized where import PlutusTx (CompiledCode, compile) -import PlutusTx.Bool (Bool (..)) +import PlutusTx.Bool (Bool (..), not, otherwise) import PlutusTx.Builtins.HasOpaque () import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Trace (traceError) -{-# INLINE builtinIf #-} -builtinIf :: Bool -> (BI.BuiltinUnit -> a) -> (BI.BuiltinUnit -> a) -> a -builtinIf cond t f = BI.ifThenElse cond t f BI.unitval - -{-# INLINE builtinNot #-} -builtinNot :: Bool -> Bool -builtinNot b = builtinIf b (\_ -> False) (\_ -> True) - -{-# INLINE builtinAnd #-} -builtinAnd :: Bool -> Bool -> Bool -builtinAnd b1 b2 = builtinIf b1 (\_ -> b2) (\_ -> False) - {-# INLINE divCeil #-} divCeil :: BI.BuiltinInteger -> BI.BuiltinInteger -> BI.BuiltinInteger divCeil x y = BI.addInteger 1 (BI.divideInteger (BI.subtractInteger x 1) y) @@ -55,14 +44,10 @@ lowerInclusiveTime iv = extTag = BI.fst extCon extFields = BI.snd extCon offset = - builtinIf - (BI.equalsInteger closureTag 1) - (\_ -> 0) - (\_ -> 1) - in builtinIf - (BI.equalsInteger extTag 1) - (\_ -> BI.addInteger (BI.unsafeDataAsI (BI.head extFields)) offset) - (\_ -> traceError "Time range not Finite") + if BI.equalsInteger closureTag 1 then 0 else 1 + in if BI.equalsInteger extTag 1 + then BI.addInteger (BI.unsafeDataAsI (BI.head extFields)) offset + else traceError "Time range not Finite" {-# INLINE txSignedByOptimized #-} txSignedByOptimized :: BI.BuiltinList BI.BuiltinData -> BI.BuiltinByteString -> Bool @@ -71,10 +56,9 @@ txSignedByOptimized signatories pkh = False ( \s ss -> let sBytes = BI.unsafeDataAsB s - in builtinIf - (BI.equalsByteString sBytes pkh) - (\_ -> True) - (\_ -> txSignedByOptimized ss pkh) + in if BI.equalsByteString sBytes pkh + then True + else txSignedByOptimized ss pkh ) signatories @@ -86,10 +70,9 @@ findInputByOutRef ref inputs = ( \txIn txIns -> let txInFields = BI.snd (BI.unsafeDataAsConstr txIn) txInRef = BI.head txInFields - in builtinIf - (BI.equalsData txInRef ref) - (\_ -> txIn) - (\_ -> findInputByOutRef ref txIns) + in if BI.equalsData txInRef ref + then txIn + else findInputByOutRef ref txIns ) inputs @@ -101,10 +84,9 @@ findOutputByAddress addr outputs = ( \out outs -> let outFields = BI.snd (BI.unsafeDataAsConstr out) outAddr = BI.head outFields - in builtinIf - (BI.equalsData outAddr addr) - (\_ -> out) - (\_ -> findOutputByAddress addr outs) + in if BI.equalsData outAddr addr + then out + else findOutputByAddress addr outs ) outputs @@ -124,16 +106,13 @@ countInputsAtScript scriptHash inputs = credTag = BI.fst credCon credFields = BI.snd credCon rest = countInputsAtScript scriptHash txIns - in builtinIf - (BI.equalsInteger credTag 1) - ( \_ -> - let vh = BI.unsafeDataAsB (BI.head credFields) - in builtinIf - (BI.equalsByteString vh scriptHash) - (\_ -> BI.addInteger 1 rest) - (\_ -> rest) - ) - (\_ -> rest) + in if BI.equalsInteger credTag 1 + then + let vh = BI.unsafeDataAsB (BI.head credFields) + in if BI.equalsByteString vh scriptHash + then BI.addInteger 1 rest + else rest + else rest ) inputs @@ -145,31 +124,25 @@ valueOf valueData cs tn = where findCurrency :: BI.BuiltinList (BI.BuiltinPair BI.BuiltinData BI.BuiltinData) -> BI.BuiltinInteger findCurrency pairs = - builtinIf - (BI.null pairs) - (\_ -> 0) - ( \_ -> - let pair = BI.head pairs - key = BI.unsafeDataAsB (BI.fst pair) - in builtinIf - (BI.equalsByteString key cs) - (\_ -> findToken (BI.unsafeDataAsMap (BI.snd pair))) - (\_ -> findCurrency (BI.tail pairs)) - ) + if BI.null pairs + then 0 + else + let pair = BI.head pairs + key = BI.unsafeDataAsB (BI.fst pair) + in if BI.equalsByteString key cs + then findToken (BI.unsafeDataAsMap (BI.snd pair)) + else findCurrency (BI.tail pairs) findToken :: BI.BuiltinList (BI.BuiltinPair BI.BuiltinData BI.BuiltinData) -> BI.BuiltinInteger findToken pairs = - builtinIf - (BI.null pairs) - (\_ -> 0) - ( \_ -> - let pair = BI.head pairs - key = BI.unsafeDataAsB (BI.fst pair) - in builtinIf - (BI.equalsByteString key tn) - (\_ -> BI.unsafeDataAsI (BI.snd pair)) - (\_ -> findToken (BI.tail pairs)) - ) + if BI.null pairs + then 0 + else + let pair = BI.head pairs + key = BI.unsafeDataAsB (BI.fst pair) + in if BI.equalsByteString key tn + then BI.unsafeDataAsI (BI.snd pair) + else findToken (BI.tail pairs) {-# INLINE getScriptHashFromAddress #-} getScriptHashFromAddress :: BI.BuiltinData -> BI.BuiltinByteString @@ -179,10 +152,9 @@ getScriptHashFromAddress addr = !credCon = BI.unsafeDataAsConstr cred credTag = BI.fst credCon credFields = BI.snd credCon - in builtinIf - (BI.equalsInteger credTag 1) - (\_ -> BI.unsafeDataAsB (BI.head credFields)) - (\_ -> traceError "Expected ScriptCredential") + in if BI.equalsInteger credTag 1 + then BI.unsafeDataAsB (BI.head credFields) + else traceError "Expected ScriptCredential" {-# INLINE getPubKeyHashFromAddress #-} getPubKeyHashFromAddress :: BI.BuiltinData -> BI.BuiltinByteString @@ -192,10 +164,9 @@ getPubKeyHashFromAddress addr = !credCon = BI.unsafeDataAsConstr cred credTag = BI.fst credCon credFields = BI.snd credCon - in builtinIf - (BI.equalsInteger credTag 0) - (\_ -> BI.unsafeDataAsB (BI.head credFields)) - (\_ -> traceError "Expected PubKeyCredential") + in if BI.equalsInteger credTag 0 + then BI.unsafeDataAsB (BI.head credFields) + else traceError "Expected PubKeyCredential" {-# INLINE getSpendingInfo #-} getSpendingInfo :: BI.BuiltinData -> BI.BuiltinPair BI.BuiltinData BI.BuiltinData @@ -203,20 +174,17 @@ getSpendingInfo scriptInfo = let con = BI.unsafeDataAsConstr scriptInfo tag = BI.fst con fields = BI.snd con - in builtinIf - (BI.equalsInteger tag 1) - ( \_ -> - let ownRef = BI.head fields - maybeDatum = BI.head (BI.tail fields) - !mdCon = BI.unsafeDataAsConstr maybeDatum - mdTag = BI.fst mdCon - mdFields = BI.snd mdCon - in builtinIf - (BI.equalsInteger mdTag 0) - (\_ -> BI.mkPairData ownRef (BI.head mdFields)) - (\_ -> traceError "Missing datum") - ) - (\_ -> traceError "Not spending script") + in if BI.equalsInteger tag 1 + then + let ownRef = BI.head fields + maybeDatum = BI.head (BI.tail fields) + !mdCon = BI.unsafeDataAsConstr maybeDatum + mdTag = BI.fst mdCon + mdFields = BI.snd mdCon + in if BI.equalsInteger mdTag 0 + then BI.mkPairData ownRef (BI.head mdFields) + else traceError "Missing datum" + else traceError "Not spending script" {-# INLINE validateVestingPartialUnlockOptimized #-} validateVestingPartialUnlockOptimized @@ -275,40 +243,22 @@ validateVestingPartialUnlockOptimized txInputs txOutputs txValidRange txSignator beneficiaryHash = getPubKeyHashFromAddress beneficiaryAddr signed = txSignedByOptimized txSignatories beneficiaryHash - in builtinIf - (builtinNot signed) - (\_ -> traceError "Missing beneficiary signature") - ( \_ -> - builtinIf - (BI.lessThanEqualsInteger currentTimeApproximation firstUnlockPossibleAfter) - (\_ -> traceError "Unlock not permitted until firstUnlockPossibleAfter time") - ( \_ -> - builtinIf - (BI.lessThanEqualsInteger newRemainingQty 0) - (\_ -> traceError "Zero remaining assets not allowed") - ( \_ -> - builtinIf - (BI.lessThanEqualsInteger oldRemainingQty newRemainingQty) - (\_ -> traceError "Remaining asset is not decreasing") - ( \_ -> - builtinIf - (builtinNot (BI.equalsInteger expectedRemainingQty newRemainingQty)) - (\_ -> traceError "Mismatched remaining asset") - ( \_ -> - builtinIf - (builtinNot (BI.equalsData resolvedDatum outputDatum)) - (\_ -> traceError "Datum Modification Prohibited") - ( \_ -> - builtinIf - (builtinNot (BI.equalsInteger (countInputsAtScript scriptHash txInputs) 1)) - (\_ -> traceError "Double satisfaction") - (\_ -> True) - ) - ) - ) - ) - ) - ) + in if + | not signed -> + traceError "Missing beneficiary signature" + | BI.lessThanEqualsInteger currentTimeApproximation firstUnlockPossibleAfter -> + traceError "Unlock not permitted until firstUnlockPossibleAfter time" + | BI.lessThanEqualsInteger newRemainingQty 0 -> + traceError "Zero remaining assets not allowed" + | BI.lessThanEqualsInteger oldRemainingQty newRemainingQty -> + traceError "Remaining asset is not decreasing" + | not (BI.equalsInteger expectedRemainingQty newRemainingQty) -> + traceError "Mismatched remaining asset" + | not (BI.equalsData resolvedDatum outputDatum) -> + traceError "Datum Modification Prohibited" + | not (BI.equalsInteger (countInputsAtScript scriptHash txInputs) 1) -> + traceError "Double satisfaction" + | otherwise -> True {-# INLINE validateVestingFullUnlockOptimized #-} validateVestingFullUnlockOptimized @@ -327,15 +277,12 @@ validateVestingFullUnlockOptimized txValidRange txSignatories vestingDatum = vestingPeriodEnd = BI.unsafeDataAsI (BI.head vdFields4) currentTimeApproximation = lowerInclusiveTime txValidRange beneficiaryHash = getPubKeyHashFromAddress beneficiaryAddr - in builtinIf - (builtinNot (txSignedByOptimized txSignatories beneficiaryHash)) - (\_ -> traceError "Missing beneficiary signature") - ( \_ -> - builtinIf - (BI.lessThanEqualsInteger currentTimeApproximation vestingPeriodEnd) - (\_ -> traceError "Unlock not permitted until vestingPeriodEnd time") - (\_ -> True) - ) + in if + | not (txSignedByOptimized txSignatories beneficiaryHash) -> + traceError "Missing beneficiary signature" + | BI.lessThanEqualsInteger currentTimeApproximation vestingPeriodEnd -> + traceError "Unlock not permitted until vestingPeriodEnd time" + | otherwise -> True {-# INLINEABLE untypedValidatorOptimized #-} untypedValidatorOptimized :: BI.BuiltinData -> BI.BuiltinUnit @@ -372,36 +319,27 @@ untypedValidatorOptimized scriptContextData = "Parsed ScriptContext" ( BI.trace "Parsed Redeemer" - ( builtinIf - (BI.equalsInteger redeemerTag 1) - ( \_ -> - BI.trace - "Full unlock requested" - (validateVestingFullUnlockOptimized txValidRange txSignatories datumData) - ) - ( \_ -> - builtinIf - (BI.equalsInteger redeemerTag 0) - ( \_ -> - BI.trace - "Partial unlock requested" - ( validateVestingPartialUnlockOptimized - txInputs - txOutputs - txValidRange - txSignatories - ownRef - datumData - ) - ) - (\_ -> traceError "Failed to parse Redeemer") - ) + ( BI.caseInteger + redeemerTag + [ BI.trace + "Partial unlock requested" + ( validateVestingPartialUnlockOptimized + txInputs + txOutputs + txValidRange + txSignatories + ownRef + datumData + ) + , BI.trace + "Full unlock requested" + (validateVestingFullUnlockOptimized txValidRange txSignatories datumData) + ] ) ) - in builtinIf - result - (\_ -> BI.trace "Validation completed" BI.unitval) - (\_ -> traceError "Validation failed") + in if result + then BI.trace "Validation completed" BI.unitval + else traceError "Validation failed" validatorOptimizedCode :: CompiledCode (BI.BuiltinData -> BI.BuiltinUnit) validatorOptimizedCode = $$(compile [||untypedValidatorOptimized||])