Skip to content
Closed
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
86 changes: 34 additions & 52 deletions plutus-benchmark/cardano-loans/src/CardanoLoans/Test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,77 +9,59 @@
module CardanoLoans.Test where

import PlutusTx
import PlutusTx.Prelude
import PlutusTx.Prelude hiding ((<>))

import CardanoLoans.Validator (LoanDatum (..), LoanRedeemer (..), loanValidatorCode)
import PlutusLedgerApi.Test.ScriptContextBuilder.Builder
( buildScriptContext
, withAddress
, withInlineDatum
, withOutRef
, withOutput
, withSigner
, withSpendingScript
, withTxOutAddress
, withTxOutValue
, withValidRange
, withValue
)
import PlutusLedgerApi.V1.Address (pubKeyHashAddress)
import PlutusLedgerApi.V1.Value qualified as Value
import PlutusLedgerApi.V2.Tx qualified as Tx
import PlutusLedgerApi.V3
import PlutusTx.AssocMap qualified as Map
import Prelude ((<>))

validatorCodeFullyApplied :: CompiledCode BuiltinUnit
validatorCodeFullyApplied =
loanValidatorCode `unsafeApplyCode` liftCodeDef (toBuiltinData testScriptContext)

testScriptContext :: ScriptContext
testScriptContext =
ScriptContext
{ scriptContextTxInfo = txInfo
, scriptContextRedeemer
, scriptContextScriptInfo
}
buildScriptContext
( withValidRange
( Interval
(LowerBound (Finite 110) True)
(UpperBound (Finite 1100) True)
)
<> withSigner testBeneficiaryPKH
<> withSpendingScript
(toBuiltinData CloseAsk)
( withOutRef txOutRef
<> withAddress (pubKeyHashAddress testBeneficiaryPKH)
<> withValue (Value.lovelaceValue 1000)
<> withInlineDatum (toBuiltinData testLoanDatum)
)
<> withOutput
( withTxOutAddress (pubKeyHashAddress testBeneficiaryPKH)
<> withTxOutValue (Value.lovelaceValue 1000)
)
)
where
txInfo =
TxInfo
{ txInfoInputs =
[ TxInInfo
{ txInInfoOutRef = txOutRef
, txInInfoResolved = Tx.pubKeyHashTxOut (Value.lovelaceValue 1000) testBeneficiaryPKH
}
]
, txInfoReferenceInputs = mempty
, txInfoOutputs =
[ TxOut
{ txOutAddress = pubKeyHashAddress testBeneficiaryPKH
, txOutValue = Value.lovelaceValue 1000
, txOutDatum = NoOutputDatum
, txOutReferenceScript = Nothing
}
]
, txInfoTxCerts = mempty
, txInfoRedeemers = Map.empty
, txInfoVotes = Map.empty
, txInfoProposalProcedures = mempty
, txInfoCurrentTreasuryAmount = Nothing
, txInfoTreasuryDonation = Nothing
, txInfoFee = 0
, txInfoMint = emptyMintValue
, txInfoWdrl = Map.empty
, txInfoValidRange =
Interval
(LowerBound (Finite 110) True)
(UpperBound (Finite 1100) True)
, txInfoSignatories = [testBeneficiaryPKH]
, txInfoData = Map.empty
, txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145"
}

scriptContextRedeemer :: Redeemer
scriptContextRedeemer = Redeemer $ toBuiltinData CloseAsk

txOutRef :: TxOutRef
txOutRef = TxOutRef txOutRefId txOutRefIdx
where
txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145"
txOutRefIdx = 0

scriptContextScriptInfo :: ScriptInfo
scriptContextScriptInfo = SpendingScript txOutRef (Just datum)
where
datum :: Datum
datum = Datum (toBuiltinData testLoanDatum)

testLoanDatum :: LoanDatum
testLoanDatum = askDatum
where
Expand Down
13 changes: 13 additions & 0 deletions plutus-benchmark/linear-vesting/exe/MainOptimized.hs
Original file line number Diff line number Diff line change
@@ -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
89 changes: 41 additions & 48 deletions plutus-benchmark/linear-vesting/src/LinearVesting/Test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,72 +9,65 @@
module LinearVesting.Test where

import PlutusTx
import PlutusTx.Prelude
import PlutusTx.Prelude hiding ((<>))

import LinearVesting.Validator (VestingDatum (..), VestingRedeemer (..), validatorCode)
import PlutusLedgerApi.Data.V3
import PlutusLedgerApi.Data.V3 qualified as PV3D
import PlutusLedgerApi.Test.ScriptContextBuilder.Builder
( buildScriptContext
, withAddress
, withInlineDatum
, withOutRef
, withSigner
, withSpendingScript
, withValidRange
)
import PlutusLedgerApi.V1.Data.Value (assetClass)
import PlutusTx.Data.AssocMap qualified as Map
import PlutusTx.Data.List qualified as List
import PlutusLedgerApi.V3 qualified as PV3
import Prelude ((<>))

validatorCodeFullyApplied :: CompiledCode BuiltinUnit
validatorCodeFullyApplied =
validatorCode `unsafeApplyCode` liftCodeDef (toBuiltinData testScriptContext)

testScriptContext :: ScriptContext
testScriptContext :: PV3.ScriptContext
testScriptContext =
ScriptContext
{ scriptContextTxInfo = txInfo
, scriptContextRedeemer
, scriptContextScriptInfo
}
buildScriptContext
( withValidRange
( PV3.Interval
(PV3.LowerBound (PV3.Finite 110) True)
(PV3.UpperBound (PV3.Finite 1100) True)
)
<> withSigner testBeneficiaryPKH
<> withSpendingScript
(toBuiltinData FullUnlock)
( withOutRef (PV3.TxOutRef txOutRefId txOutRefIdx)
<> withAddress (PV3.Address (PV3.ScriptCredential scriptHash) Nothing)
<> withInlineDatum (toBuiltinData testVestingDatum)
)
)
where
txInfo =
TxInfo
{ txInfoInputs = mempty
, txInfoReferenceInputs = mempty
, txInfoOutputs = mempty
, txInfoTxCerts = mempty
, txInfoRedeemers = Map.empty
, txInfoVotes = Map.empty
, txInfoProposalProcedures = mempty
, txInfoCurrentTreasuryAmount = Nothing
, txInfoTreasuryDonation = Nothing
, txInfoFee = 0
, txInfoMint = emptyMintValue
, txInfoWdrl = Map.empty
, txInfoValidRange =
Interval
(LowerBound (Finite 110) True)
(UpperBound (Finite 1100) True)
, txInfoSignatories = List.singleton testBeneficiaryPKH
, txInfoData = Map.empty
, txInfoId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145"
}

scriptContextRedeemer :: Redeemer
scriptContextRedeemer = Redeemer (toBuiltinData FullUnlock)

scriptContextScriptInfo :: ScriptInfo
scriptContextScriptInfo =
SpendingScript (TxOutRef txOutRefId txOutRefIdx) (Just datum)
where
txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145"
txOutRefIdx = 0
datum :: Datum
datum = Datum (toBuiltinData testVestingDatum)
txOutRefId :: PV3.TxId
txOutRefId = "058fdca70be67c74151cea3846be7f73342d92c0090b62c1052e6790ad83f145"
txOutRefIdx :: Integer
txOutRefIdx = 0
scriptHash :: PV3.ScriptHash
scriptHash = PV3.ScriptHash "deadbeef"

testVestingDatum :: VestingDatum
testVestingDatum =
VestingDatum
{ beneficiary = Address (PubKeyCredential testBeneficiaryPKH) Nothing
, vestingAsset = assetClass (CurrencySymbol "$") (TokenName "test-asset")
{ beneficiary = PV3D.Address (PV3D.PubKeyCredential testBeneficiaryPKHData) Nothing
, vestingAsset = assetClass (PV3D.CurrencySymbol "$") (PV3D.TokenName "test-asset")
, totalVestingQty = 1000
, vestingPeriodStart = 0
, vestingPeriodEnd = 100
, firstUnlockPossibleAfter = 10
, totalInstallments = 10
}

testBeneficiaryPKH :: PubKeyHash
testBeneficiaryPKH = PubKeyHash ""
testBeneficiaryPKH :: PV3.PubKeyHash
testBeneficiaryPKH = PV3.PubKeyHash ""

testBeneficiaryPKHData :: PV3D.PubKeyHash
testBeneficiaryPKHData = PV3D.PubKeyHash ""
12 changes: 12 additions & 0 deletions plutus-benchmark/linear-vesting/src/LinearVesting/TestOptimized.hs
Original file line number Diff line number Diff line change
@@ -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)
34 changes: 27 additions & 7 deletions plutus-benchmark/linear-vesting/src/LinearVesting/Validator.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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
Expand Down Expand Up @@ -139,20 +142,37 @@ 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
Copy link
Copy Markdown
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I did an experiment and results demonstate that multiway-if compiled by the plugin is actually better than hand-rolled lazy ifthenelse pattern you employ here:
#7578

Copy link
Copy Markdown
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Good point, I guess similar could be achieved with ifThenElseLazy predicate ~a ~b = BI.ifThenElse predicate a b right? And if the branches don't contain an error and the terms are small (ie. for && which has only True and False as branches, then we would want to use BI.ifThenElse because multiway if isn't smart enough to know whether it can be safely optimized to strict (and whether it should based on the terms in the branches).

I'll update the implementation to use multiway if, I'm sure it could be further optimized, but I just did a rough translated to BuiltinData and didn't put much effort into optimization and it is already optimized to around 35% of the budget of the TH Data version.


getLowerInclusiveTimeRange :: POSIXTimeRange -> POSIXTime
getLowerInclusiveTimeRange = \case
Interval (LowerBound (Finite posixTime) inclusive) _upperBound ->
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 =
Expand Down
Loading