From 21bb075a0308786107d50c32885d77e8bc25fe8b Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 8 Mar 2024 01:53:13 +0100 Subject: [PATCH] Make 'CostingPart' into a function --- .../src/PlutusCore/Default/Builtins.hs | 305 +++++++++--------- .../Evaluation/Machine/ExBudgetingDefaults.hs | 13 +- .../Evaluation/Machine/MachineParameters.hs | 2 +- 3 files changed, 162 insertions(+), 158 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 8b1c1bac8f9..0c735634b14 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1069,7 +1069,7 @@ do it quite yet, even though it worked (the Plutus Tx part wasn't implemented). -} instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where - type CostingPart uni DefaultFun = BuiltinCostModel + type CostingPart uni DefaultFun = BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel {- | Allow different variants of builtins with different implementations, and possibly different semantics. Note that DefaultFunSemanticsVariant1, @@ -1086,96 +1086,96 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where :: forall val. HasMeaningIn uni val => BuiltinSemanticsVariant DefaultFun -> DefaultFun - -> BuiltinMeaning val BuiltinCostModel + -> BuiltinMeaning val (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) - toBuiltinMeaning _semvar AddInteger = + toBuiltinMeaning semvar AddInteger = let addIntegerDenotation :: Integer -> Integer -> Integer addIntegerDenotation = (+) {-# INLINE addIntegerDenotation #-} in makeBuiltinMeaning addIntegerDenotation - (runCostingFunTwoArguments . paramAddInteger) + (runCostingFunTwoArguments . paramAddInteger . ($ semvar)) - toBuiltinMeaning _semvar SubtractInteger = + toBuiltinMeaning semvar SubtractInteger = let subtractIntegerDenotation :: Integer -> Integer -> Integer subtractIntegerDenotation = (-) {-# INLINE subtractIntegerDenotation #-} in makeBuiltinMeaning subtractIntegerDenotation - (runCostingFunTwoArguments . paramSubtractInteger) + (runCostingFunTwoArguments . paramSubtractInteger . ($ semvar)) - toBuiltinMeaning _semvar MultiplyInteger = + toBuiltinMeaning semvar MultiplyInteger = let multiplyIntegerDenotation :: Integer -> Integer -> Integer multiplyIntegerDenotation = (*) {-# INLINE multiplyIntegerDenotation #-} in makeBuiltinMeaning multiplyIntegerDenotation - (runCostingFunTwoArguments . paramMultiplyInteger) + (runCostingFunTwoArguments . paramMultiplyInteger . ($ semvar)) - toBuiltinMeaning _semvar DivideInteger = + toBuiltinMeaning semvar DivideInteger = let divideIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer divideIntegerDenotation = nonZeroSecondArg div {-# INLINE divideIntegerDenotation #-} in makeBuiltinMeaning divideIntegerDenotation - (runCostingFunTwoArguments . paramDivideInteger) + (runCostingFunTwoArguments . paramDivideInteger . ($ semvar)) - toBuiltinMeaning _semvar QuotientInteger = + toBuiltinMeaning semvar QuotientInteger = let quotientIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer quotientIntegerDenotation = nonZeroSecondArg quot {-# INLINE quotientIntegerDenotation #-} in makeBuiltinMeaning quotientIntegerDenotation - (runCostingFunTwoArguments . paramQuotientInteger) + (runCostingFunTwoArguments . paramQuotientInteger . ($ semvar)) - toBuiltinMeaning _semvar RemainderInteger = + toBuiltinMeaning semvar RemainderInteger = let remainderIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer remainderIntegerDenotation = nonZeroSecondArg rem {-# INLINE remainderIntegerDenotation #-} in makeBuiltinMeaning remainderIntegerDenotation - (runCostingFunTwoArguments . paramRemainderInteger) + (runCostingFunTwoArguments . paramRemainderInteger . ($ semvar)) - toBuiltinMeaning _semvar ModInteger = + toBuiltinMeaning semvar ModInteger = let modIntegerDenotation :: Integer -> Integer -> EvaluationResult Integer modIntegerDenotation = nonZeroSecondArg mod {-# INLINE modIntegerDenotation #-} in makeBuiltinMeaning modIntegerDenotation - (runCostingFunTwoArguments . paramModInteger) + (runCostingFunTwoArguments . paramModInteger . ($ semvar)) - toBuiltinMeaning _semvar EqualsInteger = + toBuiltinMeaning semvar EqualsInteger = let equalsIntegerDenotation :: Integer -> Integer -> Bool equalsIntegerDenotation = (==) {-# INLINE equalsIntegerDenotation #-} in makeBuiltinMeaning equalsIntegerDenotation - (runCostingFunTwoArguments . paramEqualsInteger) + (runCostingFunTwoArguments . paramEqualsInteger . ($ semvar)) - toBuiltinMeaning _semvar LessThanInteger = + toBuiltinMeaning semvar LessThanInteger = let lessThanIntegerDenotation :: Integer -> Integer -> Bool lessThanIntegerDenotation = (<) {-# INLINE lessThanIntegerDenotation #-} in makeBuiltinMeaning lessThanIntegerDenotation - (runCostingFunTwoArguments . paramLessThanInteger) + (runCostingFunTwoArguments . paramLessThanInteger . ($ semvar)) - toBuiltinMeaning _semvar LessThanEqualsInteger = + toBuiltinMeaning semvar LessThanEqualsInteger = let lessThanEqualsIntegerDenotation :: Integer -> Integer -> Bool lessThanEqualsIntegerDenotation = (<=) {-# INLINE lessThanEqualsIntegerDenotation #-} in makeBuiltinMeaning lessThanEqualsIntegerDenotation - (runCostingFunTwoArguments . paramLessThanEqualsInteger) + (runCostingFunTwoArguments . paramLessThanEqualsInteger . ($ semvar)) -- Bytestrings - toBuiltinMeaning _semvar AppendByteString = + toBuiltinMeaning semvar AppendByteString = let appendByteStringDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString appendByteStringDenotation = BS.append {-# INLINE appendByteStringDenotation #-} in makeBuiltinMeaning appendByteStringDenotation - (runCostingFunTwoArguments . paramAppendByteString) + (runCostingFunTwoArguments . paramAppendByteString . ($ semvar)) -- See Note [Builtin semantics variants] toBuiltinMeaning semvar ConsByteString = @@ -1184,8 +1184,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where -- different types ('Integer' vs 'Word8'), the costing function needs to -- by polymorphic over the type of constant. let costingFun - :: ExMemoryUsage a => BuiltinCostModel -> a -> BS.ByteString -> ExBudgetStream - costingFun = runCostingFunTwoArguments . paramConsByteString + :: ExMemoryUsage a + => (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) + -> a -> BS.ByteString -> ExBudgetStream + costingFun = runCostingFunTwoArguments . paramConsByteString . ($ semvar) {-# INLINE costingFun #-} consByteStringMeaning_V1 = let consByteStringDenotation :: Integer -> BS.ByteString -> BS.ByteString @@ -1208,23 +1210,23 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where DefaultFunSemanticsVariant1 -> consByteStringMeaning_V1 DefaultFunSemanticsVariant2 -> consByteStringMeaning_V2 - toBuiltinMeaning _semvar SliceByteString = + toBuiltinMeaning semvar SliceByteString = let sliceByteStringDenotation :: Int -> Int -> BS.ByteString -> BS.ByteString sliceByteStringDenotation start n xs = BS.take n (BS.drop start xs) {-# INLINE sliceByteStringDenotation #-} in makeBuiltinMeaning sliceByteStringDenotation - (runCostingFunThreeArguments . paramSliceByteString) + (runCostingFunThreeArguments . paramSliceByteString . ($ semvar)) - toBuiltinMeaning _semvar LengthOfByteString = + toBuiltinMeaning semvar LengthOfByteString = let lengthOfByteStringDenotation :: BS.ByteString -> Int lengthOfByteStringDenotation = BS.length {-# INLINE lengthOfByteStringDenotation #-} in makeBuiltinMeaning lengthOfByteStringDenotation - (runCostingFunOneArgument . paramLengthOfByteString) + (runCostingFunOneArgument . paramLengthOfByteString . ($ semvar)) - toBuiltinMeaning _semvar IndexByteString = + toBuiltinMeaning semvar IndexByteString = let indexByteStringDenotation :: BS.ByteString -> Int -> EvaluationResult Word8 indexByteStringDenotation xs n = do -- TODO: fix this mess with @indexMaybe@ from @bytestring >= 0.11.0.0@. @@ -1233,56 +1235,56 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE indexByteStringDenotation #-} in makeBuiltinMeaning indexByteStringDenotation - (runCostingFunTwoArguments . paramIndexByteString) + (runCostingFunTwoArguments . paramIndexByteString . ($ semvar)) - toBuiltinMeaning _semvar EqualsByteString = + toBuiltinMeaning semvar EqualsByteString = let equalsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool equalsByteStringDenotation = (==) {-# INLINE equalsByteStringDenotation #-} in makeBuiltinMeaning equalsByteStringDenotation - (runCostingFunTwoArguments . paramEqualsByteString) + (runCostingFunTwoArguments . paramEqualsByteString . ($ semvar)) - toBuiltinMeaning _semvar LessThanByteString = + toBuiltinMeaning semvar LessThanByteString = let lessThanByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool lessThanByteStringDenotation = (<) {-# INLINE lessThanByteStringDenotation #-} in makeBuiltinMeaning lessThanByteStringDenotation - (runCostingFunTwoArguments . paramLessThanByteString) + (runCostingFunTwoArguments . paramLessThanByteString . ($ semvar)) - toBuiltinMeaning _semvar LessThanEqualsByteString = + toBuiltinMeaning semvar LessThanEqualsByteString = let lessThanEqualsByteStringDenotation :: BS.ByteString -> BS.ByteString -> Bool lessThanEqualsByteStringDenotation = (<=) {-# INLINE lessThanEqualsByteStringDenotation #-} in makeBuiltinMeaning lessThanEqualsByteStringDenotation - (runCostingFunTwoArguments . paramLessThanEqualsByteString) + (runCostingFunTwoArguments . paramLessThanEqualsByteString . ($ semvar)) -- Cryptography and hashes - toBuiltinMeaning _semvar Sha2_256 = + toBuiltinMeaning semvar Sha2_256 = let sha2_256Denotation :: BS.ByteString -> BS.ByteString sha2_256Denotation = Hash.sha2_256 {-# INLINE sha2_256Denotation #-} in makeBuiltinMeaning sha2_256Denotation - (runCostingFunOneArgument . paramSha2_256) + (runCostingFunOneArgument . paramSha2_256 . ($ semvar)) - toBuiltinMeaning _semvar Sha3_256 = + toBuiltinMeaning semvar Sha3_256 = let sha3_256Denotation :: BS.ByteString -> BS.ByteString sha3_256Denotation = Hash.sha3_256 {-# INLINE sha3_256Denotation #-} in makeBuiltinMeaning sha3_256Denotation - (runCostingFunOneArgument . paramSha3_256) + (runCostingFunOneArgument . paramSha3_256 . ($ semvar)) - toBuiltinMeaning _semvar Blake2b_256 = + toBuiltinMeaning semvar Blake2b_256 = let blake2b_256Denotation :: BS.ByteString -> BS.ByteString blake2b_256Denotation = Hash.blake2b_256 {-# INLINE blake2b_256Denotation #-} in makeBuiltinMeaning blake2b_256Denotation - (runCostingFunOneArgument . paramBlake2b_256) + (runCostingFunOneArgument . paramBlake2b_256 . ($ semvar)) toBuiltinMeaning semvar VerifyEd25519Signature = let verifyEd25519SignatureDenotation @@ -1298,7 +1300,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where -- Benchmarks indicate that the two variants have very similar -- execution times, so it's safe to use the same costing function for -- both. - (runCostingFunThreeArguments . paramVerifyEd25519Signature) + (runCostingFunThreeArguments . paramVerifyEd25519Signature . ($ semvar)) {- Note [ECDSA secp256k1 signature verification]. An ECDSA signature consists of a pair of values (r,s), and for each value of r there are in @@ -1316,86 +1318,86 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where https://github.com/bitcoin-core/secp256k1. -} - toBuiltinMeaning _semvar VerifyEcdsaSecp256k1Signature = + toBuiltinMeaning semvar VerifyEcdsaSecp256k1Signature = let verifyEcdsaSecp256k1SignatureDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool verifyEcdsaSecp256k1SignatureDenotation = verifyEcdsaSecp256k1Signature {-# INLINE verifyEcdsaSecp256k1SignatureDenotation #-} in makeBuiltinMeaning verifyEcdsaSecp256k1SignatureDenotation - (runCostingFunThreeArguments . paramVerifyEcdsaSecp256k1Signature) + (runCostingFunThreeArguments . paramVerifyEcdsaSecp256k1Signature . ($ semvar)) - toBuiltinMeaning _semvar VerifySchnorrSecp256k1Signature = + toBuiltinMeaning semvar VerifySchnorrSecp256k1Signature = let verifySchnorrSecp256k1SignatureDenotation :: BS.ByteString -> BS.ByteString -> BS.ByteString -> BuiltinResult Bool verifySchnorrSecp256k1SignatureDenotation = verifySchnorrSecp256k1Signature {-# INLINE verifySchnorrSecp256k1SignatureDenotation #-} in makeBuiltinMeaning verifySchnorrSecp256k1SignatureDenotation - (runCostingFunThreeArguments . paramVerifySchnorrSecp256k1Signature) + (runCostingFunThreeArguments . paramVerifySchnorrSecp256k1Signature . ($ semvar)) -- Strings - toBuiltinMeaning _semvar AppendString = + toBuiltinMeaning semvar AppendString = let appendStringDenotation :: Text -> Text -> Text appendStringDenotation = (<>) {-# INLINE appendStringDenotation #-} in makeBuiltinMeaning appendStringDenotation - (runCostingFunTwoArguments . paramAppendString) + (runCostingFunTwoArguments . paramAppendString . ($ semvar)) - toBuiltinMeaning _semvar EqualsString = + toBuiltinMeaning semvar EqualsString = let equalsStringDenotation :: Text -> Text -> Bool equalsStringDenotation = (==) {-# INLINE equalsStringDenotation #-} in makeBuiltinMeaning equalsStringDenotation - (runCostingFunTwoArguments . paramEqualsString) + (runCostingFunTwoArguments . paramEqualsString . ($ semvar)) - toBuiltinMeaning _semvar EncodeUtf8 = + toBuiltinMeaning semvar EncodeUtf8 = let encodeUtf8Denotation :: Text -> BS.ByteString encodeUtf8Denotation = encodeUtf8 {-# INLINE encodeUtf8Denotation #-} in makeBuiltinMeaning encodeUtf8Denotation - (runCostingFunOneArgument . paramEncodeUtf8) + (runCostingFunOneArgument . paramEncodeUtf8 . ($ semvar)) - toBuiltinMeaning _semvar DecodeUtf8 = + toBuiltinMeaning semvar DecodeUtf8 = let decodeUtf8Denotation :: BS.ByteString -> EvaluationResult Text decodeUtf8Denotation = reoption . decodeUtf8' {-# INLINE decodeUtf8Denotation #-} in makeBuiltinMeaning decodeUtf8Denotation - (runCostingFunOneArgument . paramDecodeUtf8) + (runCostingFunOneArgument . paramDecodeUtf8 . ($ semvar)) -- Bool - toBuiltinMeaning _semvar IfThenElse = + toBuiltinMeaning semvar IfThenElse = let ifThenElseDenotation :: Bool -> a -> a -> a ifThenElseDenotation b x y = if b then x else y {-# INLINE ifThenElseDenotation #-} in makeBuiltinMeaning ifThenElseDenotation - (runCostingFunThreeArguments . paramIfThenElse) + (runCostingFunThreeArguments . paramIfThenElse . ($ semvar)) -- Unit - toBuiltinMeaning _semvar ChooseUnit = + toBuiltinMeaning semvar ChooseUnit = let chooseUnitDenotation :: () -> a -> a chooseUnitDenotation () x = x {-# INLINE chooseUnitDenotation #-} in makeBuiltinMeaning chooseUnitDenotation - (runCostingFunTwoArguments . paramChooseUnit) + (runCostingFunTwoArguments . paramChooseUnit . ($ semvar)) -- Tracing - toBuiltinMeaning _semvar Trace = + toBuiltinMeaning semvar Trace = let traceDenotation :: Text -> a -> Emitter a traceDenotation text a = a <$ emit text {-# INLINE traceDenotation #-} in makeBuiltinMeaning traceDenotation - (runCostingFunTwoArguments . paramTrace) + (runCostingFunTwoArguments . paramTrace . ($ semvar)) -- Pairs - toBuiltinMeaning _semvar FstPair = + toBuiltinMeaning semvar FstPair = let fstPairDenotation :: SomeConstant uni (a, b) -> EvaluationResult (Opaque val a) fstPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = do DefaultUniPair uniA _ <- pure uniPairAB @@ -1403,9 +1405,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE fstPairDenotation #-} in makeBuiltinMeaning fstPairDenotation - (runCostingFunOneArgument . paramFstPair) + (runCostingFunOneArgument . paramFstPair . ($ semvar)) - toBuiltinMeaning _semvar SndPair = + toBuiltinMeaning semvar SndPair = let sndPairDenotation :: SomeConstant uni (a, b) -> EvaluationResult (Opaque val b) sndPairDenotation (SomeConstant (Some (ValueOf uniPairAB xy))) = do DefaultUniPair _ uniB <- pure uniPairAB @@ -1413,10 +1415,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE sndPairDenotation #-} in makeBuiltinMeaning sndPairDenotation - (runCostingFunOneArgument . paramSndPair) + (runCostingFunOneArgument . paramSndPair . ($ semvar)) -- Lists - toBuiltinMeaning _semvar ChooseList = + toBuiltinMeaning semvar ChooseList = let chooseListDenotation :: SomeConstant uni [a] -> b -> b -> EvaluationResult b chooseListDenotation (SomeConstant (Some (ValueOf uniListA xs))) a b = do DefaultUniList _ <- pure uniListA @@ -1426,9 +1428,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE chooseListDenotation #-} in makeBuiltinMeaning chooseListDenotation - (runCostingFunThreeArguments . paramChooseList) + (runCostingFunThreeArguments . paramChooseList . ($ semvar)) - toBuiltinMeaning _semvar MkCons = + toBuiltinMeaning semvar MkCons = let mkConsDenotation :: SomeConstant uni a -> SomeConstant uni [a] -> EvaluationResult (Opaque val [a]) mkConsDenotation @@ -1446,9 +1448,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkConsDenotation #-} in makeBuiltinMeaning mkConsDenotation - (runCostingFunTwoArguments . paramMkCons) + (runCostingFunTwoArguments . paramMkCons . ($ semvar)) - toBuiltinMeaning _semvar HeadList = + toBuiltinMeaning semvar HeadList = let headListDenotation :: SomeConstant uni [a] -> EvaluationResult (Opaque val a) headListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList uniA <- pure uniListA @@ -1457,9 +1459,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE headListDenotation #-} in makeBuiltinMeaning headListDenotation - (runCostingFunOneArgument . paramHeadList) + (runCostingFunOneArgument . paramHeadList . ($ semvar)) - toBuiltinMeaning _semvar TailList = + toBuiltinMeaning semvar TailList = let tailListDenotation :: SomeConstant uni [a] -> EvaluationResult (Opaque val [a]) tailListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList _ <- pure uniListA @@ -1468,9 +1470,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE tailListDenotation #-} in makeBuiltinMeaning tailListDenotation - (runCostingFunOneArgument . paramTailList) + (runCostingFunOneArgument . paramTailList . ($ semvar)) - toBuiltinMeaning _semvar NullList = + toBuiltinMeaning semvar NullList = let nullListDenotation :: SomeConstant uni [a] -> EvaluationResult Bool nullListDenotation (SomeConstant (Some (ValueOf uniListA xs))) = do DefaultUniList _ <- pure uniListA @@ -1478,10 +1480,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE nullListDenotation #-} in makeBuiltinMeaning nullListDenotation - (runCostingFunOneArgument . paramNullList) + (runCostingFunOneArgument . paramNullList . ($ semvar)) -- Data - toBuiltinMeaning _semvar ChooseData = + toBuiltinMeaning semvar ChooseData = let chooseDataDenotation :: Data -> a -> a -> a -> a -> a -> a chooseDataDenotation d xConstr xMap xList xI xB = case d of @@ -1493,49 +1495,49 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE chooseDataDenotation #-} in makeBuiltinMeaning chooseDataDenotation - (runCostingFunSixArguments . paramChooseData) + (runCostingFunSixArguments . paramChooseData . ($ semvar)) - toBuiltinMeaning _semvar ConstrData = + toBuiltinMeaning semvar ConstrData = let constrDataDenotation :: Integer -> [Data] -> Data constrDataDenotation = Constr {-# INLINE constrDataDenotation #-} in makeBuiltinMeaning constrDataDenotation - (runCostingFunTwoArguments . paramConstrData) + (runCostingFunTwoArguments . paramConstrData . ($ semvar)) - toBuiltinMeaning _semvar MapData = + toBuiltinMeaning semvar MapData = let mapDataDenotation :: [(Data, Data)] -> Data mapDataDenotation = Map {-# INLINE mapDataDenotation #-} in makeBuiltinMeaning mapDataDenotation - (runCostingFunOneArgument . paramMapData) + (runCostingFunOneArgument . paramMapData . ($ semvar)) - toBuiltinMeaning _semvar ListData = + toBuiltinMeaning semvar ListData = let listDataDenotation :: [Data] -> Data listDataDenotation = List {-# INLINE listDataDenotation #-} in makeBuiltinMeaning listDataDenotation - (runCostingFunOneArgument . paramListData) + (runCostingFunOneArgument . paramListData . ($ semvar)) - toBuiltinMeaning _semvar IData = + toBuiltinMeaning semvar IData = let iDataDenotation :: Integer -> Data iDataDenotation = I {-# INLINE iDataDenotation #-} in makeBuiltinMeaning iDataDenotation - (runCostingFunOneArgument . paramIData) + (runCostingFunOneArgument . paramIData . ($ semvar)) - toBuiltinMeaning _semvar BData = + toBuiltinMeaning semvar BData = let bDataDenotation :: BS.ByteString -> Data bDataDenotation = B {-# INLINE bDataDenotation #-} in makeBuiltinMeaning bDataDenotation - (runCostingFunOneArgument . paramBData) + (runCostingFunOneArgument . paramBData . ($ semvar)) - toBuiltinMeaning _semvar UnConstrData = + toBuiltinMeaning semvar UnConstrData = let unConstrDataDenotation :: Data -> EvaluationResult (Integer, [Data]) unConstrDataDenotation = \case Constr i ds -> EvaluationSuccess (i, ds) @@ -1543,9 +1545,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unConstrDataDenotation #-} in makeBuiltinMeaning unConstrDataDenotation - (runCostingFunOneArgument . paramUnConstrData) + (runCostingFunOneArgument . paramUnConstrData . ($ semvar)) - toBuiltinMeaning _semvar UnMapData = + toBuiltinMeaning semvar UnMapData = let unMapDataDenotation :: Data -> EvaluationResult [(Data, Data)] unMapDataDenotation = \case Map es -> EvaluationSuccess es @@ -1553,9 +1555,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unMapDataDenotation #-} in makeBuiltinMeaning unMapDataDenotation - (runCostingFunOneArgument . paramUnMapData) + (runCostingFunOneArgument . paramUnMapData . ($ semvar)) - toBuiltinMeaning _semvar UnListData = + toBuiltinMeaning semvar UnListData = let unListDataDenotation :: Data -> EvaluationResult [Data] unListDataDenotation = \case List ds -> EvaluationSuccess ds @@ -1563,9 +1565,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unListDataDenotation #-} in makeBuiltinMeaning unListDataDenotation - (runCostingFunOneArgument . paramUnListData) + (runCostingFunOneArgument . paramUnListData . ($ semvar)) - toBuiltinMeaning _semvar UnIData = + toBuiltinMeaning semvar UnIData = let unIDataDenotation :: Data -> EvaluationResult Integer unIDataDenotation = \case I i -> EvaluationSuccess i @@ -1573,9 +1575,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unIDataDenotation #-} in makeBuiltinMeaning unIDataDenotation - (runCostingFunOneArgument . paramUnIData) + (runCostingFunOneArgument . paramUnIData . ($ semvar)) - toBuiltinMeaning _semvar UnBData = + toBuiltinMeaning semvar UnBData = let unBDataDenotation :: Data -> EvaluationResult BS.ByteString unBDataDenotation = \case B b -> EvaluationSuccess b @@ -1583,34 +1585,34 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE unBDataDenotation #-} in makeBuiltinMeaning unBDataDenotation - (runCostingFunOneArgument . paramUnBData) + (runCostingFunOneArgument . paramUnBData . ($ semvar)) - toBuiltinMeaning _semvar EqualsData = + toBuiltinMeaning semvar EqualsData = let equalsDataDenotation :: Data -> Data -> Bool equalsDataDenotation = (==) {-# INLINE equalsDataDenotation #-} in makeBuiltinMeaning equalsDataDenotation - (runCostingFunTwoArguments . paramEqualsData) + (runCostingFunTwoArguments . paramEqualsData . ($ semvar)) - toBuiltinMeaning _semvar SerialiseData = + toBuiltinMeaning semvar SerialiseData = let serialiseDataDenotation :: Data -> BS.ByteString serialiseDataDenotation = BSL.toStrict . serialise {-# INLINE serialiseDataDenotation #-} in makeBuiltinMeaning serialiseDataDenotation - (runCostingFunOneArgument . paramSerialiseData) + (runCostingFunOneArgument . paramSerialiseData . ($ semvar)) -- Misc constructors - toBuiltinMeaning _semvar MkPairData = + toBuiltinMeaning semvar MkPairData = let mkPairDataDenotation :: Data -> Data -> (Data, Data) mkPairDataDenotation = (,) {-# INLINE mkPairDataDenotation #-} in makeBuiltinMeaning mkPairDataDenotation - (runCostingFunTwoArguments . paramMkPairData) + (runCostingFunTwoArguments . paramMkPairData . ($ semvar)) - toBuiltinMeaning _semvar MkNilData = + toBuiltinMeaning semvar MkNilData = -- Nullary built-in functions don't work, so we need a unit argument. -- We don't really need this built-in function, see Note [Constants vs built-in functions], -- but we keep it around for historical reasons and convenience. @@ -1619,9 +1621,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkNilDataDenotation #-} in makeBuiltinMeaning mkNilDataDenotation - (runCostingFunOneArgument . paramMkNilData) + (runCostingFunOneArgument . paramMkNilData . ($ semvar)) - toBuiltinMeaning _semvar MkNilPairData = + toBuiltinMeaning semvar MkNilPairData = -- Nullary built-in functions don't work, so we need a unit argument. -- We don't really need this built-in function, see Note [Constants vs built-in functions], -- but we keep it around for historical reasons and convenience. @@ -1630,141 +1632,141 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE mkNilPairDataDenotation #-} in makeBuiltinMeaning mkNilPairDataDenotation - (runCostingFunOneArgument . paramMkNilPairData) + (runCostingFunOneArgument . paramMkNilPairData . ($ semvar)) -- BLS12_381.G1 - toBuiltinMeaning _semvar Bls12_381_G1_add = + toBuiltinMeaning semvar Bls12_381_G1_add = let bls12_381_G1_addDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_addDenotation = BLS12_381.G1.add {-# INLINE bls12_381_G1_addDenotation #-} in makeBuiltinMeaning bls12_381_G1_addDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_add) + (runCostingFunTwoArguments . paramBls12_381_G1_add . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_neg = + toBuiltinMeaning semvar Bls12_381_G1_neg = let bls12_381_G1_negDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_negDenotation = BLS12_381.G1.neg {-# INLINE bls12_381_G1_negDenotation #-} in makeBuiltinMeaning bls12_381_G1_negDenotation - (runCostingFunOneArgument . paramBls12_381_G1_neg) + (runCostingFunOneArgument . paramBls12_381_G1_neg . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_scalarMul = + toBuiltinMeaning semvar Bls12_381_G1_scalarMul = let bls12_381_G1_scalarMulDenotation :: Integer -> BLS12_381.G1.Element -> BLS12_381.G1.Element bls12_381_G1_scalarMulDenotation = BLS12_381.G1.scalarMul {-# INLINE bls12_381_G1_scalarMulDenotation #-} in makeBuiltinMeaning bls12_381_G1_scalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul) + (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_compress = + toBuiltinMeaning semvar Bls12_381_G1_compress = let bls12_381_G1_compressDenotation :: BLS12_381.G1.Element -> BS.ByteString bls12_381_G1_compressDenotation = BLS12_381.G1.compress {-# INLINE bls12_381_G1_compressDenotation #-} in makeBuiltinMeaning bls12_381_G1_compressDenotation - (runCostingFunOneArgument . paramBls12_381_G1_compress) + (runCostingFunOneArgument . paramBls12_381_G1_compress . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_uncompress = + toBuiltinMeaning semvar Bls12_381_G1_uncompress = let bls12_381_G1_uncompressDenotation :: BS.ByteString -> Emitter (EvaluationResult BLS12_381.G1.Element) bls12_381_G1_uncompressDenotation = eitherToEmitter . BLS12_381.G1.uncompress {-# INLINE bls12_381_G1_uncompressDenotation #-} in makeBuiltinMeaning bls12_381_G1_uncompressDenotation - (runCostingFunOneArgument . paramBls12_381_G1_uncompress) + (runCostingFunOneArgument . paramBls12_381_G1_uncompress . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_hashToGroup = + toBuiltinMeaning semvar Bls12_381_G1_hashToGroup = let bls12_381_G1_hashToGroupDenotation :: BS.ByteString -> BS.ByteString -> Emitter (EvaluationResult BLS12_381.G1.Element) bls12_381_G1_hashToGroupDenotation = eitherToEmitter .* BLS12_381.G1.hashToGroup {-# INLINE bls12_381_G1_hashToGroupDenotation #-} in makeBuiltinMeaning bls12_381_G1_hashToGroupDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup) + (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G1_equal = + toBuiltinMeaning semvar Bls12_381_G1_equal = let bls12_381_G1_equalDenotation :: BLS12_381.G1.Element -> BLS12_381.G1.Element -> Bool bls12_381_G1_equalDenotation = (==) {-# INLINE bls12_381_G1_equalDenotation #-} in makeBuiltinMeaning bls12_381_G1_equalDenotation - (runCostingFunTwoArguments . paramBls12_381_G1_equal) + (runCostingFunTwoArguments . paramBls12_381_G1_equal . ($ semvar)) -- BLS12_381.G2 - toBuiltinMeaning _semvar Bls12_381_G2_add = + toBuiltinMeaning semvar Bls12_381_G2_add = let bls12_381_G2_addDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_addDenotation = BLS12_381.G2.add {-# INLINE bls12_381_G2_addDenotation #-} in makeBuiltinMeaning bls12_381_G2_addDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_add) + (runCostingFunTwoArguments . paramBls12_381_G2_add . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_neg = + toBuiltinMeaning semvar Bls12_381_G2_neg = let bls12_381_G2_negDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_negDenotation = BLS12_381.G2.neg {-# INLINE bls12_381_G2_negDenotation #-} in makeBuiltinMeaning bls12_381_G2_negDenotation - (runCostingFunOneArgument . paramBls12_381_G2_neg) + (runCostingFunOneArgument . paramBls12_381_G2_neg . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_scalarMul = + toBuiltinMeaning semvar Bls12_381_G2_scalarMul = let bls12_381_G2_scalarMulDenotation :: Integer -> BLS12_381.G2.Element -> BLS12_381.G2.Element bls12_381_G2_scalarMulDenotation = BLS12_381.G2.scalarMul {-# INLINE bls12_381_G2_scalarMulDenotation #-} in makeBuiltinMeaning bls12_381_G2_scalarMulDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul) + (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_compress = + toBuiltinMeaning semvar Bls12_381_G2_compress = let bls12_381_G2_compressDenotation :: BLS12_381.G2.Element -> BS.ByteString bls12_381_G2_compressDenotation = BLS12_381.G2.compress {-# INLINE bls12_381_G2_compressDenotation #-} in makeBuiltinMeaning bls12_381_G2_compressDenotation - (runCostingFunOneArgument . paramBls12_381_G2_compress) + (runCostingFunOneArgument . paramBls12_381_G2_compress . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_uncompress = + toBuiltinMeaning semvar Bls12_381_G2_uncompress = let bls12_381_G2_uncompressDenotation :: BS.ByteString -> Emitter (EvaluationResult BLS12_381.G2.Element) bls12_381_G2_uncompressDenotation = eitherToEmitter . BLS12_381.G2.uncompress {-# INLINE bls12_381_G2_uncompressDenotation #-} in makeBuiltinMeaning bls12_381_G2_uncompressDenotation - (runCostingFunOneArgument . paramBls12_381_G2_uncompress) + (runCostingFunOneArgument . paramBls12_381_G2_uncompress . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_hashToGroup = + toBuiltinMeaning semvar Bls12_381_G2_hashToGroup = let bls12_381_G2_hashToGroupDenotation :: BS.ByteString -> BS.ByteString -> Emitter (EvaluationResult BLS12_381.G2.Element) bls12_381_G2_hashToGroupDenotation = eitherToEmitter .* BLS12_381.G2.hashToGroup {-# INLINE bls12_381_G2_hashToGroupDenotation #-} in makeBuiltinMeaning bls12_381_G2_hashToGroupDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup) + (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_G2_equal = + toBuiltinMeaning semvar Bls12_381_G2_equal = let bls12_381_G2_equalDenotation :: BLS12_381.G2.Element -> BLS12_381.G2.Element -> Bool bls12_381_G2_equalDenotation = (==) {-# INLINE bls12_381_G2_equalDenotation #-} in makeBuiltinMeaning bls12_381_G2_equalDenotation - (runCostingFunTwoArguments . paramBls12_381_G2_equal) + (runCostingFunTwoArguments . paramBls12_381_G2_equal . ($ semvar)) -- BLS12_381.Pairing - toBuiltinMeaning _semvar Bls12_381_millerLoop = + toBuiltinMeaning semvar Bls12_381_millerLoop = let bls12_381_millerLoopDenotation :: BLS12_381.G1.Element -> BLS12_381.G2.Element -> BLS12_381.Pairing.MlResult bls12_381_millerLoopDenotation = BLS12_381.Pairing.millerLoop {-# INLINE bls12_381_millerLoopDenotation #-} in makeBuiltinMeaning bls12_381_millerLoopDenotation - (runCostingFunTwoArguments . paramBls12_381_millerLoop) + (runCostingFunTwoArguments . paramBls12_381_millerLoop . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_mulMlResult = + toBuiltinMeaning semvar Bls12_381_mulMlResult = let bls12_381_mulMlResultDenotation :: BLS12_381.Pairing.MlResult -> BLS12_381.Pairing.MlResult @@ -1773,36 +1775,36 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE bls12_381_mulMlResultDenotation #-} in makeBuiltinMeaning bls12_381_mulMlResultDenotation - (runCostingFunTwoArguments . paramBls12_381_mulMlResult) + (runCostingFunTwoArguments . paramBls12_381_mulMlResult . ($ semvar)) - toBuiltinMeaning _semvar Bls12_381_finalVerify = + toBuiltinMeaning semvar Bls12_381_finalVerify = let bls12_381_finalVerifyDenotation :: BLS12_381.Pairing.MlResult -> BLS12_381.Pairing.MlResult -> Bool bls12_381_finalVerifyDenotation = BLS12_381.Pairing.finalVerify {-# INLINE bls12_381_finalVerifyDenotation #-} in makeBuiltinMeaning bls12_381_finalVerifyDenotation - (runCostingFunTwoArguments . paramBls12_381_finalVerify) + (runCostingFunTwoArguments . paramBls12_381_finalVerify . ($ semvar)) - toBuiltinMeaning _semvar Keccak_256 = + toBuiltinMeaning semvar Keccak_256 = let keccak_256Denotation :: BS.ByteString -> BS.ByteString keccak_256Denotation = Hash.keccak_256 {-# INLINE keccak_256Denotation #-} in makeBuiltinMeaning keccak_256Denotation - (runCostingFunOneArgument . paramKeccak_256) + (runCostingFunOneArgument . paramKeccak_256 . ($ semvar)) - toBuiltinMeaning _semvar Blake2b_224 = + toBuiltinMeaning semvar Blake2b_224 = let blake2b_224Denotation :: BS.ByteString -> BS.ByteString blake2b_224Denotation = Hash.blake2b_224 {-# INLINE blake2b_224Denotation #-} in makeBuiltinMeaning blake2b_224Denotation - (runCostingFunOneArgument . paramBlake2b_224) + (runCostingFunOneArgument . paramBlake2b_224 . ($ semvar)) -- Conversions {- See Note [Input length limitation for IntegerToByteString] -} - toBuiltinMeaning _semvar IntegerToByteString = + toBuiltinMeaning semvar IntegerToByteString = let integerToByteStringDenotation :: Bool -> LiteralByteSize -> Integer -> BuiltinResult BS.ByteString {- The second argument is wrapped in a LiteralByteSize to allow us to interpret it as a size during costing. It appears as an integer in UPLC: see Note [Integral types as Integer]. -} @@ -1810,14 +1812,15 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where {-# INLINE integerToByteStringDenotation #-} in makeBuiltinMeaning integerToByteStringDenotation - (runCostingFunThreeArguments . paramIntegerToByteString) - toBuiltinMeaning _semvar ByteStringToInteger = + (runCostingFunThreeArguments . paramIntegerToByteString . ($ semvar)) + + toBuiltinMeaning semvar ByteStringToInteger = let byteStringToIntegerDenotation :: Bool -> BS.ByteString -> Integer byteStringToIntegerDenotation = byteStringToIntegerWrapper {-# INLINE byteStringToIntegerDenotation #-} in makeBuiltinMeaning byteStringToIntegerDenotation - (runCostingFunTwoArguments . paramByteStringToInteger) + (runCostingFunTwoArguments . paramByteStringToInteger . ($ semvar)) -- See Note [Inlining meanings of builtins]. {-# INLINE toBuiltinMeaning #-} 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 9a2843e7412..1ff4d39e563 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -34,8 +34,8 @@ import GHC.Magic (noinline) import PlutusPrelude -- | The default cost model for built-in functions. -defaultBuiltinCostModel :: BuiltinCostModel -defaultBuiltinCostModel = +defaultBuiltinCostModel :: BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel +defaultBuiltinCostModel _ = $$(readJSONFromFile DFP.builtinCostModelFile) {- Note [Modifying the cost model] @@ -76,13 +76,14 @@ defaultCekMachineCosts = evaluation the ledger passes a cost model to the Plutus Core evaluator using the `mkEvaluationContext` functions in PlutusLedgerApi. -} -defaultCekCostModel :: CostModel CekMachineCosts BuiltinCostModel +defaultCekCostModel + :: CostModel CekMachineCosts (BuiltinSemanticsVariant DefaultFun -> BuiltinCostModel) defaultCekCostModel = CostModel defaultCekMachineCosts defaultBuiltinCostModel -- | The default cost model data. This is exposed to the ledger, so let's not -- confuse anybody by mentioning the CEK machine -defaultCostModelParams :: Maybe CostModelParams -defaultCostModelParams = extractCostModelParams defaultCekCostModel +defaultCostModelParams :: BuiltinSemanticsVariant DefaultFun -> Maybe CostModelParams +defaultCostModelParams semvar = extractCostModelParams $ sequence defaultCekCostModel semvar defaultCekParameters :: Typeable ann => MachineParameters CekMachineCosts (BuiltinsRuntime DefaultFun (CekValue DefaultUni DefaultFun ann)) -- See Note [noinline for saving on ticks]. @@ -98,7 +99,7 @@ unitCekParameters :: Typeable ann => MachineParameters CekMachineCosts (Builtins unitCekParameters = -- See Note [noinline for saving on ticks]. noinline mkMachineParameters def $ - CostModel unitCekMachineCosts unitCostBuiltinCostModel + CostModel unitCekMachineCosts (const unitCostBuiltinCostModel) defaultBuiltinsRuntimeForSemanticsVariant :: HasMeaningIn DefaultUni term diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs index f2f86687fce..92a3c5be4f3 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs @@ -30,7 +30,7 @@ data CostModel machinecosts builtincosts = CostModel { _machineCostModel :: machinecosts , _builtinCostModel :: builtincosts - } deriving stock (Eq, Show) + } deriving stock (Eq, Show, Functor, Foldable, Traversable) makeLenses ''CostModel {-| At execution time we need a 'BuiltinsRuntime' object which includes both the