SCP-2417: Add builtin function: serialiseData

cost-model stubs for serialiseData added plugin golden tests added agda syntax and semantics of serialiseData Added SerializeData to protocol-6.0
IntersectMBO · Mar 11, 2022 · e69d00b · e69d00b
1 parent ec1ac44
commit e69d00b
Show file tree

Hide file tree

Showing 31 changed files with 159 additions and 5 deletions.
diff --git 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
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
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
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -0,0 +1 @@
+(fun (con data) (con bytestring))
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -1,12 +1,34 @@
+{-# 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
 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
@@ -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
@@ -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