diff --git a/doc/reference/builtin-parameters.csv b/doc/reference/builtin-parameters.csv index 2d6044e9ad3..8bc34336496 100644 --- a/doc/reference/builtin-parameters.csv +++ b/doc/reference/builtin-parameters.csv @@ -35,7 +35,7 @@ decodeUtf8,decodeUtf8-memory-arguments-slope,Linear model coefficient for the me divideInteger,divideInteger-cpu-arguments-constant,Constant CPU cost (argument sizes above diagonal) divideInteger,divideInteger-cpu-arguments-model-arguments-intercept,Linear model intercept for the CPU calculation (argument sizes on or below diagonal) divideInteger,divideInteger-cpu-arguments-model-arguments-slope,Linear model coefficient for the CPU calculation (argument sizes on or below diagonal) -divideInteger,divideInteger-memory-arguments-intercept,Linear model intercept for the memory calculation (argument sizes on or below diagonal) +divideInteger,divideInteger-memory-arguments-intercept,Linear model intercept for the memory calculation (argument sizes on or below diagonal) divideInteger,divideInteger-memory-arguments-minimum,Constant memory cost (argument sizes above diagonal) divideInteger,divideInteger-memory-arguments-slope,Linear model coefficient for the memory calculation (argument sizes on or below diagonal) encodeUtf8,encodeUtf8-cpu-arguments-intercept,Linear model intercept for the CPU calculation below diagonal @@ -98,7 +98,7 @@ modInteger,modInteger-cpu-arguments-model-arguments-slope,Linear model coefficie modInteger,modInteger-memory-arguments-intercept,Linear model intercept for the memory calculation modInteger,modInteger-memory-arguments-minimum,Constant memory cost (argument sizes above diagonal) modInteger,modInteger-memory-arguments-slope,Linear model coefficient for the memory calculation (argument sizes on or below diagonal) -multiplyInteger,multiplyInteger-cpu-arguments-intercept,Linear model intercept for the CPU calculation +multiplyInteger,multiplyInteger-cpu-arguments-intercept,Linear model intercept for the CPU calculation multiplyInteger,multiplyInteger-cpu-arguments-slope,Linear model coefficient for the CPU calculation multiplyInteger,multiplyInteger-memory-arguments-intercept,Linear model intercept for the memory calculation multiplyInteger,multiplyInteger-memory-arguments-slope,Linear model coefficient for the memory calculation @@ -116,6 +116,10 @@ remainderInteger,remainderInteger-cpu-arguments-model-arguments-slope,Linear mod remainderInteger,remainderInteger-memory-arguments-intercept,Linear model intercept for the memory calculation (argument sizes on or below diagonal) remainderInteger,remainderInteger-memory-arguments-minimum,Constant memory cost (argument sizes above diagonal) remainderInteger,remainderInteger-memory-arguments-slope,Linear model coefficient for the memory calculation (argument sizes on or below diagonal) +serialiseData,serialiseData-cpu-arguments-intercept,TODO +serialiseData,serialiseData-cpu-arguments-slope,TODO +serialiseData,serialiseData-memory-arguments-intercept,TODO +serialiseData,serialiseData-memory-arguments-slope,TODO sha2_256,sha2_256-cpu-arguments-intercept,Linear model intercept for the CPU calculation sha2_256,sha2_256-cpu-arguments-slope,Linear model coefficient for the CPU calculation sha2_256,sha2_256-memory-arguments,Constant memory cost diff --git a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-ledger-api.nix b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-ledger-api.nix index 029c266deb1..9b5a750c148 100644 --- a/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-ledger-api.nix +++ b/nix/pkgs/haskell/materialized-darwin/.plan.nix/plutus-ledger-api.nix @@ -86,6 +86,8 @@ (hsPkgs."plutus-core" or (errorHandler.buildDepError "plutus-core")) (hsPkgs."plutus-core".components.sublibs.plutus-core-testlib or (errorHandler.buildDepError "plutus-core:plutus-core-testlib")) (hsPkgs."plutus-ledger-api" or (errorHandler.buildDepError "plutus-ledger-api")) + (hsPkgs."plutus-tx-plugin" or (errorHandler.buildDepError "plutus-tx-plugin")) + (hsPkgs."plutus-tx" or (errorHandler.buildDepError "plutus-tx")) (hsPkgs."hedgehog" or (errorHandler.buildDepError "hedgehog")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hedgehog" or (errorHandler.buildDepError "tasty-hedgehog")) diff --git a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-ledger-api.nix b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-ledger-api.nix index 029c266deb1..9b5a750c148 100644 --- a/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-ledger-api.nix +++ b/nix/pkgs/haskell/materialized-linux/.plan.nix/plutus-ledger-api.nix @@ -86,6 +86,8 @@ (hsPkgs."plutus-core" or (errorHandler.buildDepError "plutus-core")) (hsPkgs."plutus-core".components.sublibs.plutus-core-testlib or (errorHandler.buildDepError "plutus-core:plutus-core-testlib")) (hsPkgs."plutus-ledger-api" or (errorHandler.buildDepError "plutus-ledger-api")) + (hsPkgs."plutus-tx-plugin" or (errorHandler.buildDepError "plutus-tx-plugin")) + (hsPkgs."plutus-tx" or (errorHandler.buildDepError "plutus-tx")) (hsPkgs."hedgehog" or (errorHandler.buildDepError "hedgehog")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hedgehog" or (errorHandler.buildDepError "tasty-hedgehog")) diff --git a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-ledger-api.nix b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-ledger-api.nix index 029c266deb1..9b5a750c148 100644 --- a/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-ledger-api.nix +++ b/nix/pkgs/haskell/materialized-windows/.plan.nix/plutus-ledger-api.nix @@ -86,6 +86,8 @@ (hsPkgs."plutus-core" or (errorHandler.buildDepError "plutus-core")) (hsPkgs."plutus-core".components.sublibs.plutus-core-testlib or (errorHandler.buildDepError "plutus-core:plutus-core-testlib")) (hsPkgs."plutus-ledger-api" or (errorHandler.buildDepError "plutus-ledger-api")) + (hsPkgs."plutus-tx-plugin" or (errorHandler.buildDepError "plutus-tx-plugin")) + (hsPkgs."plutus-tx" or (errorHandler.buildDepError "plutus-tx")) (hsPkgs."hedgehog" or (errorHandler.buildDepError "hedgehog")) (hsPkgs."tasty" or (errorHandler.buildDepError "tasty")) (hsPkgs."tasty-hedgehog" or (errorHandler.buildDepError "tasty-hedgehog")) diff --git a/plutus-core/cost-model/budgeting-bench/Benchmarks/Data.hs b/plutus-core/cost-model/budgeting-bench/Benchmarks/Data.hs index b8420135a18..277b6c6a6f5 100644 --- a/plutus-core/cost-model/budgeting-bench/Benchmarks/Data.hs +++ b/plutus-core/cost-model/budgeting-bench/Benchmarks/Data.hs @@ -126,6 +126,10 @@ benchEqualsData = where args1 = dataSampleForEq -- 400 elements: should take about 35 minutes to benchmark args2 = fmap copyData args1 +benchSerialiseData :: Benchmark +benchSerialiseData = + createOneTermBuiltinBench SerialiseData [] args + where args = dataSampleForEq -- FIXME: is this a good sample for serialization? makeBenchmarks :: StdGen -> [Benchmark] makeBenchmarks gen = @@ -141,4 +145,5 @@ makeBenchmarks gen = , benchUnIData , benchUnBData , benchEqualsData + , benchSerialiseData ] diff --git a/plutus-core/cost-model/create-cost-model/CostModelCreation.hs b/plutus-core/cost-model/create-cost-model/CostModelCreation.hs index 51c91c7c312..956631b50aa 100644 --- a/plutus-core/cost-model/create-cost-model/CostModelCreation.hs +++ b/plutus-core/cost-model/create-cost-model/CostModelCreation.hs @@ -95,6 +95,7 @@ builtinCostModelNames = BuiltinCostModelBase , paramMkPairData = "mkPairDataModel" , paramMkNilData = "mkNilDataModel" , paramMkNilPairData = "mkNilPairDataModel" + , paramSerialiseData = "serialiseDataModel" } @@ -175,6 +176,7 @@ createBuiltinCostModel = paramUnIData <- getParams unIData paramUnIData paramUnBData <- getParams unBData paramUnBData paramEqualsData <- getParams equalsData paramEqualsData + paramSerialiseData <- getParams serialiseData paramSerialiseData -- Misc constructors paramMkPairData <- getParams mkPairData paramMkPairData paramMkNilData <- getParams mkNilData paramMkNilData @@ -676,6 +678,12 @@ equalsData cpuModelR = do worst case it may have to examine almost all of the smaller argument before realising that the two arguments are different. -} +serialiseData :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelOneArgument) +serialiseData cpuModelR = do + cpuModel <- ModelOneArgumentLinearCost <$> readModelLinearInX cpuModelR + let memModel = ModelOneArgumentLinearCost $ ModelLinearSize 0 0 + pure $ CostingFun cpuModel memModel + ---------------- Misc constructors ---------------- mkPairData :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelTwoArguments) diff --git a/plutus-core/cost-model/data/builtinCostModel.json b/plutus-core/cost-model/data/builtinCostModel.json index aafcce0f458..e5fa536bffc 100644 --- a/plutus-core/cost-model/data/builtinCostModel.json +++ b/plutus-core/cost-model/data/builtinCostModel.json @@ -389,6 +389,22 @@ "type": "constant_cost" } }, + "serialiseData": { + "memory": { + "arguments": { + "slope": 0, + "intercept": 0 + }, + "type": "linear_cost" + }, + "cpu": { + "arguments": { + "slope": 0, + "intercept": 0 + }, + "type": "linear_cost" + } + }, "addInteger": { "memory": { "arguments": { diff --git a/plutus-core/cost-model/data/models.R b/plutus-core/cost-model/data/models.R index 3ed862157f1..fede2532044 100644 --- a/plutus-core/cost-model/data/models.R +++ b/plutus-core/cost-model/data/models.R @@ -77,6 +77,7 @@ arity <- function(name) { "AppendString" = 2, "EqualsString" = 2, "EncodeUtf8" = 1, + "SerialiseData" = 1, "DecodeUtf8" = 1, "IfThenElse" = 3, "ChooseUnit" = 2, @@ -550,6 +551,12 @@ modelFun <- function(path) { adjustModel(m2,fname) } + serialiseDataModel <- { + fname <- "SerialiseData" + #FIXME + } + + mkPairDataModel <- constantModel ("MkPairData") mkNilDataModel <- constantModel ("MkNilData") mkNilPairDataModel <- constantModel ("MkNilPairData") @@ -605,6 +612,7 @@ modelFun <- function(path) { equalsDataModel = equalsDataModel, mkPairDataModel = mkPairDataModel, mkNilDataModel = mkNilDataModel, - mkNilPairDataModel = mkNilPairDataModel + mkNilPairDataModel = mkNilPairDataModel, + serialiseDataModel = serialiseDataModel ) } diff --git a/plutus-core/cost-model/test/TestCostModels.hs b/plutus-core/cost-model/test/TestCostModels.hs index 5680c0c43a3..6d974345d76 100644 --- a/plutus-core/cost-model/test/TestCostModels.hs +++ b/plutus-core/cost-model/test/TestCostModels.hs @@ -345,6 +345,7 @@ main = , $(genTest 1 "unIData") , $(genTest 1 "unBData") , $(genTest 2 "equalsData") Everywhere + , $(genTest 1 "serialiseData") -- Misc constructors , $(genTest 2 "mkPairData") Everywhere diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index bb4a85b4aaf..bd53dbbe5e6 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -23,9 +23,11 @@ import PlutusCore.Evaluation.Machine.ExMemory import PlutusCore.Evaluation.Result import PlutusCore.Pretty +import Codec.Serialise (serialise) import Crypto (verifySignature) import Data.ByteString qualified as BS import Data.ByteString.Hash qualified as Hash +import Data.ByteString.Lazy qualified as BS (toStrict) import Data.Char import Data.Ix import Data.Text (Text) @@ -102,6 +104,7 @@ data DefaultFun | UnIData | UnBData | EqualsData + | SerialiseData -- Misc constructors -- Constructors that we need for constructing e.g. Data. Polymorphic builtin -- constructors are often problematic (See note [Representable built-in @@ -972,6 +975,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where makeBuiltinMeaning ((==) @Data) (runCostingFunTwoArguments . paramEqualsData) + toBuiltinMeaning SerialiseData = + makeBuiltinMeaning + (BS.toStrict . serialise @Data) + (runCostingFunOneArgument . paramSerialiseData) -- Misc constructors toBuiltinMeaning MkPairData = makeBuiltinMeaning @@ -1065,6 +1072,7 @@ instance Flat DefaultFun where MkPairData -> 48 MkNilData -> 49 MkNilPairData -> 50 + SerialiseData -> 53 decode = go =<< decodeBuiltin where go 0 = pure AddInteger @@ -1118,6 +1126,7 @@ instance Flat DefaultFun where go 48 = pure MkPairData go 49 = pure MkNilData go 50 = pure MkNilPairData + go 53 = pure SerialiseData go t = fail $ "Failed to decode builtin tag, got: " ++ show t size _ n = n + builtinTagWidth diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs index b7226518788..a01e9cd9562 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs @@ -153,6 +153,7 @@ data BuiltinCostModelBase f = , paramMkPairData :: f ModelTwoArguments , paramMkNilData :: f ModelOneArgument , paramMkNilPairData :: f ModelOneArgument + , paramSerialiseData :: f ModelOneArgument } deriving stock (Generic) deriving anyclass (FunctorB, TraversableB, ConstraintsB) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index 19e827a0b5e..74f103f6f7e 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -163,4 +163,5 @@ unitCostBuiltinCostModel = BuiltinCostModelBase , paramMkPairData = unitCostTwoArguments , paramMkNilData = unitCostOneArgument , paramMkNilPairData = unitCostOneArgument + , paramSerialiseData = unitCostOneArgument } diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs index 99235bc77fa..9527f34c844 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs @@ -202,6 +202,7 @@ builtinFnList = , (UnIData,"unIData") , (UnBData,"unBData") , (EqualsData,"equalsData") + , (SerialiseData,"serialiseData") , (MkPairData,"mkPairData") , (MkNilData,"mkNilData") , (MkNilPairData,"mkNilPairData") diff --git a/plutus-core/plutus-core/test/CostModelInterface/defaultCostModelParams.json b/plutus-core/plutus-core/test/CostModelInterface/defaultCostModelParams.json index 13928b129b7..2e29e480bcb 100644 --- a/plutus-core/plutus-core/test/CostModelInterface/defaultCostModelParams.json +++ b/plutus-core/plutus-core/test/CostModelInterface/defaultCostModelParams.json @@ -132,6 +132,10 @@ "remainderInteger-memory-arguments-intercept": 0, "remainderInteger-memory-arguments-minimum": 1, "remainderInteger-memory-arguments-slope": 1, + "serialiseData-cpu-arguments-intercept": 0, + "serialiseData-cpu-arguments-slope": 0, + "serialiseData-memory-arguments-intercept": 0, + "serialiseData-memory-arguments-slope": 0, "sha2_256-cpu-arguments-intercept": 2477736, "sha2_256-cpu-arguments-slope": 29175, "sha2_256-memory-arguments": 4, diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/SerialiseData.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/SerialiseData.plc.golden new file mode 100644 index 00000000000..3097cf511ba --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/SerialiseData.plc.golden @@ -0,0 +1 @@ +(fun (con data) (con bytestring)) \ No newline at end of file diff --git a/plutus-core/testlib/PlutusCore/Generators/NEAT/Term.hs b/plutus-core/testlib/PlutusCore/Generators/NEAT/Term.hs index 5378f973a25..6da79e42395 100644 --- a/plutus-core/testlib/PlutusCore/Generators/NEAT/Term.hs +++ b/plutus-core/testlib/PlutusCore/Generators/NEAT/Term.hs @@ -423,7 +423,7 @@ defaultFunTypes = Map.fromList [(TyFunG (TyBuiltinG TyIntegerG) (TyFunG (TyBuilt ,(TyFunG (TyBuiltinG TyDataG) (TyBuiltinG TyIntegerG) ,[UnIData]) ,(TyFunG (TyBuiltinG TyDataG) (TyBuiltinG TyByteStringG) - ,[UnBData]) + ,[UnBData, SerialiseData]) ] instance Ord tyname => Check (TypeG tyname) DefaultFun where diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index f901fa39b5e..7541c13c972 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -477,6 +477,7 @@ test_Data = testCase "Data" $ do evals @[(Data, Data)] [(B "", I 3)] UnMapData [cons $ Map [(B "", I 3)]] evals @[Data] [] UnListData [cons $ List []] evals @[Data] [I 3, I 4, B ""] UnListData [cons $ List [I 3, I 4, B ""]] + evals @ByteString "\162\ETX@Ehello8c" SerialiseData [cons $ Map [(I 3, B ""), (B "hello", I $ -100)]] -- ChooseData let actualExp = mkIterApp () @@ -539,7 +540,6 @@ test_Crypto = testCase "Crypto" $ do evals @ByteString "%l\131\178\151\DC1M \ESC0\ETB\159?\SO\240\202\206\151\131b-\165\151C&\180\&6\ETB\138\238\246\DLE" Blake2b_256 [cons @ByteString "hello world"] - -- Test all remaining builtins of the default universe test_Other :: TestTree test_Other = testCase "Other" $ do diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal index 5c553005278..59d8ea46332 100644 --- a/plutus-ledger-api/plutus-ledger-api.cabal +++ b/plutus-ledger-api/plutus-ledger-api.cabal @@ -95,6 +95,8 @@ test-suite plutus-ledger-api-test plutus-core -any, plutus-core:plutus-core-testlib -any, plutus-ledger-api -any, + plutus-tx-plugin -any, + plutus-tx -any, hedgehog -any, tasty -any, tasty-hedgehog -any, diff --git a/plutus-ledger-api/src/Plutus/ApiCommon.hs b/plutus-ledger-api/src/Plutus/ApiCommon.hs index 9a7c43be1a4..774952fbee7 100644 --- a/plutus-ledger-api/src/Plutus/ApiCommon.hs +++ b/plutus-ledger-api/src/Plutus/ApiCommon.hs @@ -73,6 +73,9 @@ builtinsIntroducedIn = Map.fromList [ ChooseList, MkCons, HeadList, TailList, NullList, ChooseData, ConstrData, MapData, ListData, IData, BData, UnConstrData, UnMapData, UnListData, UnIData, UnBData, EqualsData, MkPairData, MkNilData, MkNilPairData + ]), + (ProtocolVersion 6 0, Set.fromList [ + SerialiseData ]) ] diff --git a/plutus-ledger-api/test/Spec/Builtins.hs b/plutus-ledger-api/test/Spec/Builtins.hs index 8f6c0b5c49d..c8a059ae583 100644 --- a/plutus-ledger-api/test/Spec/Builtins.hs +++ b/plutus-ledger-api/test/Spec/Builtins.hs @@ -1,5 +1,21 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:debug-context #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations=0 #-} module Spec.Builtins where +import Data.Proxy +import Plutus.V1.Ledger.Api +import PlutusTx.Builtins qualified as Builtins +import PlutusTx.Code +import PlutusTx.Plugin + +import Codec.Serialise +import Data.ByteString.Lazy as BSL +import Data.ByteString.Short import Data.Foldable (fold, for_) import Data.Map qualified as Map import Data.Set qualified as Set @@ -7,6 +23,12 @@ import Plutus.ApiCommon import Test.Tasty import Test.Tasty.HUnit +serialiseDataEx :: CompiledCode Builtins.BuiltinByteString +serialiseDataEx = plc (Proxy @"serialiseDataEx") (Builtins.serialiseData (Builtins.mkI 1)) + +serialiseDataExScript :: SerializedScript +serialiseDataExScript = toShort . toStrict . serialise $ fromCompiledCode serialiseDataEx + tests :: TestTree tests = testGroup @@ -16,4 +38,7 @@ tests = allBuiltins = [(toEnum 0)..] in for_ allBuiltins $ \f -> assertBool (show f) (f `Set.member` allPvBuiltins) , testCase "builtins aren't available before v5" $ assertBool "empty" (Set.null $ builtinsAvailableIn (ProtocolVersion 4 0)) + , testCase "serializeData is only available in v6" $ do + assertBool "in v5 " $ not $ isScriptWellFormed (ProtocolVersion 5 0) serialiseDataExScript + assertBool "not in v6" $ isScriptWellFormed (ProtocolVersion 6 0) serialiseDataExScript ] diff --git a/plutus-metatheory/src/Algorithmic.lagda b/plutus-metatheory/src/Algorithmic.lagda index 31d3cc5558c..9b035586457 100644 --- a/plutus-metatheory/src/Algorithmic.lagda +++ b/plutus-metatheory/src/Algorithmic.lagda @@ -140,6 +140,7 @@ sig unListData = _ ,, ∅ , con Data ,, con (list (con Data)) sig unIData = _ ,, ∅ , con Data ,, con integer sig unBData = _ ,, ∅ , con Data ,, con bytestring sig equalsData = _ ,, ∅ , con Data , con Data ,, con bool +sig serialiseData = _ ,, ∅ , con Data ,, con bytestring sig chooseData = _ ,, diff --git a/plutus-metatheory/src/Algorithmic/CEKV.lagda.md b/plutus-metatheory/src/Algorithmic/CEKV.lagda.md index 5a0b29dddbb..bb85a1d31b3 100644 --- a/plutus-metatheory/src/Algorithmic/CEKV.lagda.md +++ b/plutus-metatheory/src/Algorithmic/CEKV.lagda.md @@ -197,6 +197,8 @@ BUILTIN equalsString (app _ (app _ base (V-con (string s))) (V-con (string s'))) BUILTIN unIData (app _ base (V-con (Data (iDATA i)))) = inj₂ (V-con (integer i)) BUILTIN unBData (app _ base (V-con (Data (bDATA b)))) = inj₂ (V-con (bytestring b)) +BUILTIN serialiseData (app _ base (V-con (Data d))) = + inj₂ (V-con (bytestring (serialiseDATA d))) BUILTIN _ {A} _ = inj₁ A convBApp : (b : Builtin) → ∀{az}{as}(p p' : az <>> as ∈ arity b) @@ -460,6 +462,9 @@ bappTermLem equalsData {as = as} (bubble {as = az} p) q with <>>-cancel-both' az _ (([] :< Term) :< Term) as p refl bappTermLem equalsData (bubble (start _)) (app _ base _) | refl ,, refl ,, refl = _ ,, _ ,, refl +bappTermLem serialiseData {az = az} {as} p q + with <>>-cancel-both az ([] :< Term) as p +bappTermLem serialiseData (start _) base | refl ,, refl = _ ,, _ ,, refl bappTermLem chooseData (bubble (start _)) (app⋆ _ base refl) = _ ,, _ ,, refl bappTermLem chooseData @@ -713,6 +718,9 @@ bappTypeLem unBData {az = az} p q bappTypeLem equalsData (bubble {as = az} p) _ with <>>-cancel-both' az _ (([] :< Term) :< Term) _ p refl ... | refl ,, refl ,, () +bappTypeLem serialiseData {az = az} p q + with <>>-cancel-both' az _ ([] :< Term) _ p refl +... | refl ,, refl ,, () bappTypeLem chooseData (start _) base = _ ,, _ ,, refl bappTypeLem chooseData (bubble (bubble (bubble (bubble (bubble (bubble {as = az} p)))))) _ with <>>-cancel-both' az _ ([] <>< arity chooseData) _ p refl @@ -855,6 +863,7 @@ ival unListData = V-I⇒ unListData (start _) base ival unIData = V-I⇒ unIData (start _) base ival unBData = V-I⇒ unBData (start _) base ival equalsData = V-I⇒ equalsData (start _) base +ival serialiseData = V-I⇒ serialiseData (start _) base ival chooseData = V-IΠ chooseData (start _) base ival chooseUnit = V-IΠ chooseUnit (start _) base ival mkPairData = V-I⇒ mkPairData (start _) base diff --git a/plutus-metatheory/src/Algorithmic/ReductionEC.lagda.md b/plutus-metatheory/src/Algorithmic/ReductionEC.lagda.md index 18f061cc719..4896e90474c 100644 --- a/plutus-metatheory/src/Algorithmic/ReductionEC.lagda.md +++ b/plutus-metatheory/src/Algorithmic/ReductionEC.lagda.md @@ -183,6 +183,7 @@ BUILTIN decodeUtf8 (step _ (base refl) (V-con (bytestring b))) ... | just s = con (string s) BUILTIN unIData (step _ (base refl) (V-con (Data (iDATA i)))) = con (integer i) BUILTIN unBData (step _ (base refl) (V-con (Data (bDATA b)))) = con (bytestring b) +BUILTIN serialiseData (step _ (base refl) (V-con (Data d))) = con (bytestring (serialiseDATA d)) BUILTIN _ _ = error _ @@ -584,6 +585,9 @@ bappTermLem equalsData {as = as} _ (bubble {as = az} p) q with <>>-cancel-both' az _ (([] :< Term) :< Term) as p refl bappTermLem equalsData _ (bubble (start _)) (step _ (base refl) _) | refl ,, refl ,, refl = _ ,, _ ,, refl +bappTermLem serialiseData {az = az} {as} M p q + with <>>-cancel-both az ([] :< Term) as p +bappTermLem serialiseData _ (start _) (base refl) | refl ,, refl = _ ,, _ ,, refl bappTermLem chooseData _ (bubble (start _)) (step⋆ _ (base refl) refl) = _ ,, _ ,, refl bappTermLem chooseData @@ -782,6 +786,9 @@ bappTypeLem unBData {az = az} _ p q bappTypeLem equalsData _ (bubble {as = az} p) _ with <>>-cancel-both' az _ (([] :< Term) :< Term) _ p refl ... | refl ,, refl ,, () +bappTypeLem serialiseData {az = az} _ p q + with <>>-cancel-both' az _ ([] :< Term) _ p refl +... | refl ,, refl ,, () bappTypeLem chooseData _ (start _) (base refl) = _ ,, _ ,, refl bappTypeLem chooseData _ (bubble (bubble (bubble (bubble (bubble (bubble {as = az} p)))))) _ with <>>-cancel-both' az _ ([] <>< arity chooseData) _ p refl @@ -913,6 +920,7 @@ ival unListData = V-I _ (start _) (base refl) ival unIData = V-I _ (start _) (base refl) ival unBData = V-I _ (start _) (base refl) ival equalsData = V-I _ (start _) (base refl) +ival serialiseData = V-I _ (start _) (base refl) ival chooseData = V-I _ (start _) (base refl) ival chooseUnit = V-I _ (start _) (base refl) ival mkPairData = V-I _ (start _) (base refl) diff --git a/plutus-metatheory/src/Builtin.lagda.md b/plutus-metatheory/src/Builtin.lagda.md index fe3c7f92332..74518cfbe27 100644 --- a/plutus-metatheory/src/Builtin.lagda.md +++ b/plutus-metatheory/src/Builtin.lagda.md @@ -73,6 +73,7 @@ data Builtin : Set where unIData : Builtin unBData : Builtin equalsData : Builtin + serialiseData : Builtin -- Misc constructors mkPairData : Builtin mkNilData : Builtin @@ -127,6 +128,7 @@ data Builtin : Set where | UnIData | UnBData | EqualsData + | SerialiseData | MkPairData | MkNilData | MkNilPairData @@ -158,6 +160,7 @@ postulate equals : ByteString → ByteString → Bool ENCODEUTF8 : String → ByteString DECODEUTF8 : ByteString → Maybe String + serialiseDATA : DATA → ByteString ``` # What builtin operations should be compiled to if we compile to Haskell diff --git a/plutus-metatheory/src/Untyped/CEK.lagda.md b/plutus-metatheory/src/Untyped/CEK.lagda.md index 123b1fb6f0a..4e62d8ddbf1 100644 --- a/plutus-metatheory/src/Untyped/CEK.lagda.md +++ b/plutus-metatheory/src/Untyped/CEK.lagda.md @@ -168,6 +168,8 @@ BUILTIN equalsString (app _ (app _ base (V-con (string s))) (V-con (string s'))) BUILTIN unIData (app _ base (V-con (Data (iDATA i)))) = inj₂ (V-con (integer i)) BUILTIN unBData (app _ base (V-con (Data (bDATA b)))) = inj₂ (V-con (bytestring b)) +BUILTIN serialiseData (app _ base (V-con (Data d))) = + inj₂ (V-con (bytestring (serialiseDATA d))) BUILTIN _ _ = inj₁ userError convBApp : (b : Builtin) → ∀{az}{as}(p p' : az <>> as ∈ arity b) @@ -225,6 +227,7 @@ ival unListData = V-I⇒ unListData (start _) base ival unIData = V-I⇒ unIData (start _) base ival unBData = V-I⇒ unBData (start _) base ival equalsData = V-I⇒ equalsData (start _) base +ival serialiseData = V-I⇒ serialiseData (start _) base ival chooseData = V-IΠ chooseData (start _) base ival chooseUnit = V-IΠ chooseUnit (start _) base ival mkPairData = V-I⇒ mkPairData (start _) base diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index cea7cdfe4f1..861771e537e 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -223,6 +223,7 @@ builtinNames = [ , ''Builtins.BuiltinData , 'Builtins.chooseData , 'Builtins.equalsData + , 'Builtins.serialiseData , 'Builtins.mkConstr , 'Builtins.mkMap , 'Builtins.mkList @@ -351,6 +352,7 @@ defineBuiltinTerms = do defineBuiltinTerm 'Builtins.unsafeDataAsList $ mkBuiltin PLC.UnListData defineBuiltinTerm 'Builtins.unsafeDataAsB $ mkBuiltin PLC.UnBData defineBuiltinTerm 'Builtins.unsafeDataAsI $ mkBuiltin PLC.UnIData + defineBuiltinTerm 'Builtins.serialiseData $ mkBuiltin PLC.SerialiseData defineBuiltinTypes :: CompilingDefault uni fun m diff --git a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs index 3f3cd635bbc..53885240804 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs @@ -59,6 +59,8 @@ primitives = testNested "Primitives" [ , goldenPir "stringLiteral" stringLiteral , goldenUEval "equalsString" [ getPlc stringEquals, liftProgram ("hello" :: Builtins.BuiltinString), liftProgram ("hello" :: Builtins.BuiltinString)] , goldenPir "encodeUtf8" stringEncode + , goldenPir "serialiseData" dataEncode + , goldenUEval "serialiseDataApply" [ toUPlc dataEncode, toUPlc constructData1 ] , goldenUEval "constructData1" [ constructData1 ] -- It's interesting to look at one of these to make sure all the specialisation is working out nicely and for -- debugging when it isn't @@ -162,6 +164,9 @@ stringEquals = plc (Proxy @"string32Equals") (\(x :: Builtins.BuiltinString) (y stringEncode :: CompiledCode (Builtins.BuiltinByteString) stringEncode = plc (Proxy @"stringEncode") (Builtins.encodeUtf8 "abc") +dataEncode :: CompiledCode (Builtins.BuiltinData -> Builtins.BuiltinByteString) +dataEncode = plc (Proxy @"dataEncode") Builtins.serialiseData + constructData1 :: CompiledCode (Builtins.BuiltinData) constructData1 = plc (Proxy @"constructData1") (Builtins.mkI 1) diff --git a/plutus-tx-plugin/test/Plugin/Primitives/serialiseData.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/serialiseData.plc.golden new file mode 100644 index 00000000000..0c171d4e32a --- /dev/null +++ b/plutus-tx-plugin/test/Plugin/Primitives/serialiseData.plc.golden @@ -0,0 +1,16 @@ +(program + (let + (nonrec) + (termbind + (strict) + (vardecl serialiseData (fun (con data) (con bytestring))) + (builtin serialiseData) + ) + (termbind + (nonstrict) + (vardecl serialiseData (fun (con data) (con bytestring))) + serialiseData + ) + serialiseData + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Primitives/serialiseDataApply.plc.golden b/plutus-tx-plugin/test/Plugin/Primitives/serialiseDataApply.plc.golden new file mode 100644 index 00000000000..9d0671c076f --- /dev/null +++ b/plutus-tx-plugin/test/Plugin/Primitives/serialiseDataApply.plc.golden @@ -0,0 +1 @@ +(con bytestring #01) \ No newline at end of file diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 792025d7ad2..033c55f1666 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -43,6 +43,7 @@ module PlutusTx.Builtins ( , matchData , matchData' , equalsData + , serialiseData , mkConstr , mkMap , mkList @@ -262,6 +263,11 @@ matchList l nilCase consCase = BI.chooseList l (const nilCase) (\_ -> consCase ( chooseData :: forall a . BuiltinData -> a -> a -> a -> a -> a -> a chooseData = BI.chooseData +{-# INLINABLE serialiseData #-} +-- | Convert a String into a ByteString. +serialiseData :: BuiltinData -> BuiltinByteString +serialiseData = BI.serialiseData + {-# INLINABLE mkConstr #-} -- | Constructs a 'BuiltinData' value with the @Constr@ constructor. mkConstr :: Integer -> [BuiltinData] -> BuiltinData diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index e85f92eae63..5c83d73264e 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -19,6 +19,7 @@ import Crypto qualified import Data.ByteArray qualified as BA import Data.ByteString as BS import Data.ByteString.Hash qualified as Hash +import Data.ByteString.Lazy as BS (toStrict) import Data.Coerce (coerce) import Data.Data import Data.Hashable (Hashable (..)) @@ -460,3 +461,7 @@ unsafeDataAsB _ = Haskell.error "not a B" {-# NOINLINE equalsData #-} equalsData :: BuiltinData -> BuiltinData -> BuiltinBool equalsData (BuiltinData b1) (BuiltinData b2) = BuiltinBool $ b1 Haskell.== b2 + +{-# NOINLINE serialiseData #-} +serialiseData :: BuiltinData -> BuiltinByteString +serialiseData (BuiltinData b) = BuiltinByteString $ BS.toStrict $ serialise b