Skip to content

Commit

Permalink
Fully Data-backed V3.ScriptContext (#6700)
Browse files Browse the repository at this point in the history
  • Loading branch information
ana-pantilie authored Dec 17, 2024
1 parent d304a48 commit c1c9ad5
Show file tree
Hide file tree
Showing 29 changed files with 3,024 additions and 3,971 deletions.
Original file line number Diff line number Diff line change
@@ -1,14 +1,23 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module PlutusBenchmark.Data.ScriptContexts where

import PlutusLedgerApi.Data.V3 (OutputDatum (NoOutputDatum), PubKeyHash (..), Redeemer (..),
ScriptContext (..), ScriptInfo (SpendingScript), TxId (..),
TxInfo (..), TxOut (..), TxOutRef (..), always)
import PlutusLedgerApi.V1.Address
import PlutusLedgerApi.Data.V1 qualified as PlutusTx
import PlutusLedgerApi.Data.V3 (PubKeyHash (..), Redeemer (..), ScriptContext, TxId (..), TxInfo,
TxOut, always, pattern NoOutputDatum, pattern ScriptContext,
pattern SpendingScript, pattern TxInfo, pattern TxOut,
pattern TxOutRef, txInfoCurrentTreasuryAmount, txInfoData,
txInfoFee, txInfoId, txInfoInputs, txInfoMint, txInfoOutputs,
txInfoProposalProcedures, txInfoRedeemers, txInfoReferenceInputs,
txInfoSignatories, txInfoTreasuryDonation, txInfoTxCerts,
txInfoValidRange, txInfoVotes, txInfoWdrl, txOutAddress, txOutDatum,
txOutReferenceScript, txOutValue)
import PlutusLedgerApi.V1.Data.Address
import PlutusLedgerApi.V1.Data.Value
import PlutusTx qualified
import PlutusTx.Builtins qualified as PlutusTx
Expand All @@ -17,43 +26,45 @@ import PlutusTx.Data.List qualified as Data.List
import PlutusTx.Plugin ()
import PlutusTx.Prelude qualified as PlutusTx

-- | A very crude deterministic generator for 'ScriptContext's with size
-- approximately proportional to the input integer.
{-| A very crude deterministic generator for 'ScriptContext's with size
approximately proportional to the input integer.
-}
mkScriptContext :: Integer -> ScriptContext
mkScriptContext i =
ScriptContext
(mkTxInfo i)
(Redeemer (PlutusTx.toBuiltinData (1 :: Integer)))
(SpendingScript (TxOutRef (TxId "") 0) Nothing)


mkTxInfo :: Integer -> TxInfo
mkTxInfo i = TxInfo {
txInfoInputs=mempty,
txInfoReferenceInputs=mempty,
txInfoOutputs=Data.List.map mkTxOut (Data.List.fromSOP ([1..i] :: [Integer])),
txInfoFee=10000,
txInfoMint=mempty,
txInfoTxCerts=mempty,
txInfoWdrl=Map.empty,
txInfoValidRange=always,
txInfoSignatories=mempty,
txInfoRedeemers=Map.empty,
txInfoData=Map.empty,
txInfoId=TxId "",
txInfoVotes=Map.empty,
txInfoProposalProcedures=mempty,
txInfoCurrentTreasuryAmount=Nothing,
txInfoTreasuryDonation=Nothing
}
mkTxInfo i =
TxInfo
{ txInfoInputs = mempty
, txInfoReferenceInputs = mempty
, txInfoOutputs = Data.List.map mkTxOut (Data.List.fromSOP ([1 .. i] :: [Integer]))
, txInfoFee = 10000
, txInfoMint = mempty
, txInfoTxCerts = mempty
, txInfoWdrl = Map.empty
, txInfoValidRange = always
, txInfoSignatories = mempty
, txInfoRedeemers = Map.empty
, txInfoData = Map.empty
, txInfoId = TxId ""
, txInfoVotes = Map.empty
, txInfoProposalProcedures = mempty
, txInfoCurrentTreasuryAmount = Nothing
, txInfoTreasuryDonation = Nothing
}

mkTxOut :: Integer -> TxOut
mkTxOut i = TxOut {
txOutAddress=pubKeyHashAddress (PubKeyHash ""),
txOutValue=mkValue i,
txOutDatum=NoOutputDatum,
txOutReferenceScript=Nothing
}
mkTxOut i =
TxOut
{ txOutAddress = pubKeyHashAddress (PubKeyHash "")
, txOutValue = mkValue i
, txOutDatum = NoOutputDatum
, txOutReferenceScript = Nothing
}

mkValue :: Integer -> Value
mkValue i = assetClassValue (assetClass adaSymbol adaToken) i
Expand All @@ -68,43 +79,38 @@ checkScriptContext1 d =
-- since we do use it later
let !sc = PlutusTx.unsafeFromBuiltinData d
ScriptContext txi _ _ = sc
in
if Data.List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0
then ()
else PlutusTx.traceError "Odd number of outputs"
{-# INLINABLE checkScriptContext1 #-}
in if Data.List.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0
then ()
else PlutusTx.traceError "Odd number of outputs"
{-# INLINEABLE checkScriptContext1 #-}

mkCheckScriptContext1Code :: ScriptContext -> PlutusTx.CompiledCode ()
mkCheckScriptContext1Code sc =
let d = PlutusTx.toBuiltinData sc
in
$$(PlutusTx.compile [|| checkScriptContext1 ||])
`PlutusTx.unsafeApplyCode`
PlutusTx.liftCodeDef d
in $$(PlutusTx.compile [||checkScriptContext1||])
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d

-- This example aims to *force* the decoding of the script context and then ignore it entirely.
-- This corresponds to the unfortunate case where the decoding "wrapper" around a script forces
-- all the decoding work to be done even if it isn't used.
checkScriptContext2 :: PlutusTx.BuiltinData -> ()
checkScriptContext2 d =
let (sc :: ScriptContext) = PlutusTx.unsafeFromBuiltinData d
-- Just using a bang pattern was not enough to stop GHC from getting
-- rid of the dead binding before we even hit the plugin, this works
-- for now!
in case sc of
!_ ->
if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer)
then ()
else PlutusTx.traceError "Got my sums wrong"
{-# INLINABLE checkScriptContext2 #-}
in -- Just using a bang pattern was not enough to stop GHC from getting
-- rid of the dead binding before we even hit the plugin, this works
-- for now!
case sc of
!_ ->
if 48 PlutusTx.* 9900 PlutusTx.== (475200 :: Integer)
then ()
else PlutusTx.traceError "Got my sums wrong"
{-# INLINEABLE checkScriptContext2 #-}

mkCheckScriptContext2Code :: ScriptContext -> PlutusTx.CompiledCode ()
mkCheckScriptContext2Code sc =
let d = PlutusTx.toBuiltinData sc
in
$$(PlutusTx.compile [|| checkScriptContext2 ||])
`PlutusTx.unsafeApplyCode`
PlutusTx.liftCodeDef d
in $$(PlutusTx.compile [||checkScriptContext2||])
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d

{- Note [Redundant arguments to equality benchmarks]
The arguments for the benchmarks are passed as terms created with `liftCodeDef`.
Expand All @@ -124,26 +130,26 @@ scriptContextEqualityData :: ScriptContext -> PlutusTx.BuiltinData -> ()
-- See Note [Redundant arguments to equality benchmarks]
scriptContextEqualityData _ d =
if PlutusTx.equalsData d d
then ()
else PlutusTx.traceError "The argument is not equal to itself"
{-# INLINABLE scriptContextEqualityData #-}
then ()
else PlutusTx.traceError "The argument is not equal to itself"
{-# INLINEABLE scriptContextEqualityData #-}

mkScriptContextEqualityDataCode :: ScriptContext -> PlutusTx.CompiledCode ()
mkScriptContextEqualityDataCode sc =
let d = PlutusTx.toBuiltinData sc
in $$(PlutusTx.compile [|| scriptContextEqualityData ||])
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d
in $$(PlutusTx.compile [||scriptContextEqualityData||])
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d

-- This example is just the overhead from the previous two
-- See Note [Redundant arguments to equality benchmarks]
scriptContextEqualityOverhead :: ScriptContext -> PlutusTx.BuiltinData -> ()
scriptContextEqualityOverhead _ _ = ()
{-# INLINABLE scriptContextEqualityOverhead #-}
{-# INLINEABLE scriptContextEqualityOverhead #-}

mkScriptContextEqualityOverheadCode :: ScriptContext -> PlutusTx.CompiledCode ()
mkScriptContextEqualityOverheadCode sc =
let d = PlutusTx.toBuiltinData sc
in $$(PlutusTx.compile [|| scriptContextEqualityOverhead ||])
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d
in $$(PlutusTx.compile [||scriptContextEqualityOverhead||])
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef sc
`PlutusTx.unsafeApplyCode` PlutusTx.liftCodeDef d
Original file line number Diff line number Diff line change
@@ -1,2 +1,2 @@
({cpu: 50148035
| mem: 195889})
({cpu: 33072854
| mem: 126955})
Original file line number Diff line number Diff line change
@@ -1,2 +1,2 @@
({cpu: 31987795
| mem: 120721})
({cpu: 16448614
| mem: 61387})
Loading

1 comment on commit c1c9ad5

@github-actions
Copy link
Contributor

Choose a reason for hiding this comment

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

⚠️ Performance Alert ⚠️

Possible performance regression was detected for benchmark 'Plutus Benchmarks'.
Benchmark result of this commit is worse than the previous benchmark result exceeding threshold 1.05.

Benchmark suite Current: c1c9ad5 Previous: d304a48 Ratio
validation-decode-prism-1 166.4 μs 157.2 μs 1.06
validation-decode-pubkey-1 170.1 μs 159.9 μs 1.06

This comment was automatically generated by workflow using github-action-benchmark.

CC: @IntersectMBO/plutus-core

Please sign in to comment.