From b1ee0ff59616575d50a1fe64df573682893905a5 Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 8 Apr 2024 23:21:01 +0200 Subject: [PATCH 1/8] [Builtins] Make 'BuiltinFailure' the last constructor --- .../src/PlutusCore/Builtin/KnownType.hs | 2 +- .../plutus-core/src/PlutusCore/Builtin/Result.hs | 16 ++++++++-------- .../src/PlutusCore/Evaluation/Machine/Ck.hs | 2 +- .../Evaluation/Machine/Cek/Internal.hs | 4 ++-- .../Evaluation/Machine/SteppableCek/Internal.hs | 4 ++-- plutus-tx/src/PlutusTx/Builtins/Internal.hs | 16 ++++++++-------- 6 files changed, 22 insertions(+), 22 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs index b3385aa3851..2a022e12bc9 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs @@ -328,9 +328,9 @@ type ReadKnown val = ReadKnownIn (UniOf val) val -- | Same as 'makeKnown', but allows for neither emitting nor storing the cause of a failure. makeKnownOrFail :: MakeKnownIn uni val a => a -> EvaluationResult val makeKnownOrFail x = case makeKnown x of - BuiltinFailure _ _ -> EvaluationFailure BuiltinSuccess val -> EvaluationSuccess val BuiltinSuccessWithLogs _ val -> EvaluationSuccess val + BuiltinFailure _ _ -> EvaluationFailure {-# INLINE makeKnownOrFail #-} -- | Same as 'readKnown', but the cause of a potential failure is the provided term itself. diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs index 19e0270c2b6..d7ce6e31b5c 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs @@ -58,9 +58,9 @@ data BuiltinError -- logging, since there's no logging on the chain and builtins don't emit much anyway. Otherwise -- we'd have to use @text-builder@ or @text-builder-linear@ or something of this sort. data BuiltinResult a - = BuiltinFailure (DList Text) BuiltinError - | BuiltinSuccess a + = BuiltinSuccess a | BuiltinSuccessWithLogs (DList Text) a + | BuiltinFailure (DList Text) BuiltinError deriving stock (Show, Foldable) mtraverse makeClassyPrisms @@ -113,43 +113,43 @@ throwNotAConstant = throwError $ BuiltinUnliftingError "Not a constant" -- | Prepend logs to a 'BuiltinResult' computation. withLogs :: DList Text -> BuiltinResult a -> BuiltinResult a withLogs logs1 = \case - BuiltinFailure logs2 err -> BuiltinFailure (logs1 <> logs2) err BuiltinSuccess x -> BuiltinSuccessWithLogs logs1 x BuiltinSuccessWithLogs logs2 x -> BuiltinSuccessWithLogs (logs1 <> logs2) x + BuiltinFailure logs2 err -> BuiltinFailure (logs1 <> logs2) err {-# INLINE withLogs #-} instance Functor BuiltinResult where - fmap _ (BuiltinFailure logs err) = BuiltinFailure logs err fmap f (BuiltinSuccess x) = BuiltinSuccess (f x) fmap f (BuiltinSuccessWithLogs logs x) = BuiltinSuccessWithLogs logs (f x) + fmap _ (BuiltinFailure logs err) = BuiltinFailure logs err {-# INLINE fmap #-} -- Written out explicitly just in case. - _ <$ BuiltinFailure logs err = BuiltinFailure logs err x <$ BuiltinSuccess _ = BuiltinSuccess x x <$ BuiltinSuccessWithLogs logs _ = BuiltinSuccessWithLogs logs x + _ <$ BuiltinFailure logs err = BuiltinFailure logs err {-# INLINE (<$) #-} instance Applicative BuiltinResult where pure = BuiltinSuccess {-# INLINE pure #-} - BuiltinFailure logs err <*> _ = BuiltinFailure logs err BuiltinSuccess f <*> a = fmap f a BuiltinSuccessWithLogs logs f <*> a = withLogs logs $ fmap f a + BuiltinFailure logs err <*> _ = BuiltinFailure logs err {-# INLINE (<*>) #-} -- Better than the default implementation, because the value in the 'BuiltinSuccess' case -- doesn't need to be retained. - BuiltinFailure logs err *> _ = BuiltinFailure logs err BuiltinSuccess _ *> b = b BuiltinSuccessWithLogs logs _ *> b = withLogs logs b + BuiltinFailure logs err *> _ = BuiltinFailure logs err {-# INLINE (*>) #-} instance Monad BuiltinResult where - BuiltinFailure logs err >>= _ = BuiltinFailure logs err BuiltinSuccess x >>= f = f x BuiltinSuccessWithLogs logs x >>= f = withLogs logs $ f x + BuiltinFailure logs err >>= _ = BuiltinFailure logs err {-# INLINE (>>=) #-} (>>) = (*>) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs index e188b2cfa73..bc15f805fff 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs @@ -75,9 +75,9 @@ evalBuiltinApp -> CkM uni fun s (CkValue uni fun) evalBuiltinApp term runtime = case runtime of BuiltinCostedResult _ getX -> case getX of - BuiltinFailure logs err -> emitCkM logs *> throwBuiltinErrorWithCause term err BuiltinSuccess x -> pure x BuiltinSuccessWithLogs logs x -> emitCkM logs $> x + BuiltinFailure logs err -> emitCkM logs *> throwBuiltinErrorWithCause term err _ -> pure $ VBuiltin term runtime ckValueToTerm :: CkValue uni fun -> Term TyName Name uni fun () diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index d310786a018..397bf8f90ea 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -655,11 +655,11 @@ evalBuiltinApp fun term runtime = case runtime of BuiltinCostedResult budgets getX -> do spendBudgetStreamCek (BBuiltinApp fun) budgets case getX of + BuiltinSuccess x -> pure x + BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x BuiltinFailure logs err -> do ?cekEmitter logs throwBuiltinErrorWithCause term err - BuiltinSuccess x -> pure x - BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x _ -> pure $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index 5cf72765816..d6eaafbd807 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -439,11 +439,11 @@ evalBuiltinApp fun term runtime = case runtime of BuiltinCostedResult budgets getX -> do spendBudgetStreamCek (BBuiltinApp fun) budgets case getX of + BuiltinSuccess x -> pure x + BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x BuiltinFailure logs err -> do ?cekEmitter logs throwBuiltinErrorWithCause term err - BuiltinSuccess x -> pure x - BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x _ -> pure $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index cdaa73e6eb3..6ee6bad857b 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -259,10 +259,10 @@ keccak_256 (BuiltinByteString b) = BuiltinByteString $ Hash.keccak_256 b verifyEd25519Signature :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString -> BuiltinBool verifyEd25519Signature (BuiltinByteString vk) (BuiltinByteString msg) (BuiltinByteString sig) = case PlutusCore.Crypto.Ed25519.verifyEd25519Signature_V1 vk msg sig of - BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ - mustBeReplaced "Ed25519 signature verification errored." BuiltinSuccess b -> BuiltinBool b BuiltinSuccessWithLogs logs b -> traceAll logs $ BuiltinBool b + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + mustBeReplaced "Ed25519 signature verification errored." {-# NOINLINE verifyEcdsaSecp256k1Signature #-} verifyEcdsaSecp256k1Signature :: @@ -272,10 +272,10 @@ verifyEcdsaSecp256k1Signature :: BuiltinBool verifyEcdsaSecp256k1Signature (BuiltinByteString vk) (BuiltinByteString msg) (BuiltinByteString sig) = case PlutusCore.Crypto.Secp256k1.verifyEcdsaSecp256k1Signature vk msg sig of - BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ - mustBeReplaced "ECDSA SECP256k1 signature verification errored." BuiltinSuccess b -> BuiltinBool b BuiltinSuccessWithLogs logs b -> traceAll logs $ BuiltinBool b + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + mustBeReplaced "ECDSA SECP256k1 signature verification errored." {-# NOINLINE verifySchnorrSecp256k1Signature #-} verifySchnorrSecp256k1Signature :: @@ -285,10 +285,10 @@ verifySchnorrSecp256k1Signature :: BuiltinBool verifySchnorrSecp256k1Signature (BuiltinByteString vk) (BuiltinByteString msg) (BuiltinByteString sig) = case PlutusCore.Crypto.Secp256k1.verifySchnorrSecp256k1Signature vk msg sig of - BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ - mustBeReplaced "Schnorr SECP256k1 signature verification errored." BuiltinSuccess b -> BuiltinBool b BuiltinSuccessWithLogs logs b -> traceAll logs $ BuiltinBool b + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + mustBeReplaced "Schnorr SECP256k1 signature verification errored." traceAll :: forall (a :: Type) (f :: Type -> Type) . (Foldable f) => f Text -> a -> a @@ -695,10 +695,10 @@ integerToByteString -> BuiltinByteString integerToByteString (BuiltinBool endiannessArg) paddingArg input = case Convert.integerToByteStringWrapper endiannessArg paddingArg input of - BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ - mustBeReplaced "Integer to ByteString conversion errored." BuiltinSuccess bs -> BuiltinByteString bs BuiltinSuccessWithLogs logs bs -> traceAll logs $ BuiltinByteString bs + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + mustBeReplaced "Integer to ByteString conversion errored." {-# NOINLINE byteStringToInteger #-} byteStringToInteger From 104c911c51a9c222de0093372420295cdeea5211 Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 26 Apr 2024 00:20:10 +0200 Subject: [PATCH 2/8] Make the 'BuiltinSuccess' case recursive. What? Yes --- .../Evaluation/Machine/Cek/Internal.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index 2ca5f446861..5c15abae8d1 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -653,12 +653,13 @@ evalBuiltinApp evalBuiltinApp fun term runtime = case runtime of BuiltinCostedResult budgets getX -> do spendBudgetStreamCek (BBuiltinApp fun) budgets - case getX of - BuiltinSuccess x -> pure x - BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x - BuiltinFailure logs err -> do - ?cekEmitter logs - throwBuiltinErrorWithCause term err + let go f = f $ \case + BuiltinSuccess x -> go (\_ -> pure x) + BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x + BuiltinFailure logs err -> do + ?cekEmitter logs + throwBuiltinErrorWithCause term err + go ($ getX) _ -> pure $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} From a99ec23fb4f22dddeb2a94816ec4691efb018073 Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 26 Apr 2024 17:32:21 +0200 Subject: [PATCH 3/8] Try a 'noinline' --- .../Evaluation/Machine/Cek/Internal.hs | 105 +++++++++--------- .../Machine/SteppableCek/Internal.hs | 17 ++- 2 files changed, 64 insertions(+), 58 deletions(-) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index 5c15abae8d1..f7a386c4899 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -48,7 +48,6 @@ module UntypedPlutusCore.Evaluation.Machine.Cek.Internal , StepKind(..) , ThrowableBuiltins , extractEvaluationResult - , spendBudgetStreamCek , runCekDeBruijn , dischargeCekValue , Context (..) @@ -101,6 +100,7 @@ import Data.Semigroup (stimes) import Data.Text (Text) import Data.Vector qualified as V import Data.Word +import GHC.Magic (noinline) import GHC.TypeLits import Prettyprinter import Universe @@ -489,9 +489,6 @@ instance Pretty CekUserError where ] pretty CekEvaluationFailure = "The machine terminated because of an error, either from a built-in function or from an explicit use of 'error'." -spendBudgetCek :: GivenCekSpender uni fun s => ExBudgetCategory fun -> ExBudget -> CekM uni fun s () -spendBudgetCek = let (CekBudgetSpender spend) = ?cekBudgetSpender in spend - -- see Note [Scoping]. -- | Instantiate all the free variables of a term by looking them up in an environment. -- Mutually recursive with dischargeCekVal. @@ -619,50 +616,6 @@ runCekM (MachineParameters costs runtime) (ExBudgetMode getExBudgetInfo) (Emitte pure (errOrRes, st, logs) {-# INLINE runCekM #-} --- | Look up a variable name in the environment. -lookupVarName - :: forall uni fun ann s - . ThrowableBuiltins uni fun - => NamedDeBruijn -> CekValEnv uni fun ann -> CekM uni fun s (CekValue uni fun ann) -lookupVarName varName@(NamedDeBruijn _ varIx) varEnv = - case varEnv `Env.indexOne` coerce varIx of - Nothing -> throwingWithCause _MachineError OpenTermEvaluatedMachineError $ Just var where - var = Var () varName - Just val -> pure val - --- | Spend each budget from the given stream of budgets. -spendBudgetStreamCek - :: GivenCekReqs uni fun ann s - => ExBudgetCategory fun - -> ExBudgetStream - -> CekM uni fun s () -spendBudgetStreamCek exCat = go where - go (ExBudgetLast budget) = spendBudgetCek exCat budget - go (ExBudgetCons budget budgets) = spendBudgetCek exCat budget *> go budgets -{-# INLINE spendBudgetStreamCek #-} - --- | Take pieces of a possibly partial builtin application and either create a 'CekValue' using --- 'makeKnown' or a partial builtin application depending on whether the built-in function is --- fully saturated or not. -evalBuiltinApp - :: (GivenCekReqs uni fun ann s, ThrowableBuiltins uni fun) - => fun - -> NTerm uni fun () - -> BuiltinRuntime (CekValue uni fun ann) - -> CekM uni fun s (CekValue uni fun ann) -evalBuiltinApp fun term runtime = case runtime of - BuiltinCostedResult budgets getX -> do - spendBudgetStreamCek (BBuiltinApp fun) budgets - let go f = f $ \case - BuiltinSuccess x -> go (\_ -> pure x) - BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x - BuiltinFailure logs err -> do - ?cekEmitter logs - throwBuiltinErrorWithCause term err - go ($ getX) - _ -> pure $ VBuiltin fun term runtime -{-# INLINE evalBuiltinApp #-} - -- See Note [Compilation peculiarities]. -- | The entering point to the CEK machine's engine. enterComputeCek @@ -797,12 +750,11 @@ enterComputeCek = computeCek case runtime of -- It's only possible to force a builtin application if the builtin expects a type -- argument next. - BuiltinExpectForce runtime' -> do + BuiltinExpectForce runtime' -> -- We allow a type argument to appear last in the type of a built-in function, -- otherwise we could just assemble a 'VBuiltin' without trying to evaluate the -- application. - res <- evalBuiltinApp fun term' runtime' - returnCek ctx res + evalBuiltinApp fun term' runtime' $ returnCek ctx _ -> throwingWithCause _MachineError BuiltinTermArgumentExpectedMachineError (Just term') forceEvaluate !_ val = @@ -832,9 +784,7 @@ enterComputeCek = computeCek case runtime of -- It's only possible to apply a builtin application if the builtin expects a term -- argument next. - BuiltinExpectArgument f -> do - res <- evalBuiltinApp fun term' $ f arg - returnCek ctx res + BuiltinExpectArgument f -> evalBuiltinApp fun term' (f arg) $ returnCek ctx _ -> throwingWithCause _MachineError UnexpectedBuiltinTermArgumentMachineError (Just term') applyEvaluate !_ val _ = @@ -871,6 +821,51 @@ enterComputeCek = computeCek -- steps by 1 and then check this condition. when (unbudgetedStepsTotal >= ?cekSlippage) spendAccumulatedBudget + -- | Take pieces of a possibly partial builtin application and either create a 'CekValue' using + -- 'makeKnown' or a partial builtin application depending on whether the built-in function is + -- fully saturated or not. + evalBuiltinApp + :: fun + -> NTerm uni fun () + -> BuiltinRuntime (CekValue uni fun ann) + -> (CekValue uni fun ann -> CekM uni fun s (NTerm uni fun ())) + -> CekM uni fun s (NTerm uni fun ()) + evalBuiltinApp fun term runtime cont = case runtime of + BuiltinCostedResult budgets getX -> do + spendBudgetStreamCek (BBuiltinApp fun) budgets + case getX of + BuiltinSuccess x -> cont x + BuiltinSuccessWithLogs logs x -> ?cekEmitter logs *> noinline ($) cont x + BuiltinFailure logs err -> do + ?cekEmitter logs + throwBuiltinErrorWithCause term err + _ -> cont $ VBuiltin fun term runtime + {-# INLINE evalBuiltinApp #-} + + -- | Spend each budget from the given stream of budgets. + spendBudgetStreamCek + :: ExBudgetCategory fun + -> ExBudgetStream + -> CekM uni fun s () + spendBudgetStreamCek exCat = go where + go (ExBudgetLast budget) = spendBudgetCek exCat budget + go (ExBudgetCons budget budgets) = spendBudgetCek exCat budget *> go budgets + {-# INLINE spendBudgetStreamCek #-} + + spendBudgetCek :: ExBudgetCategory fun -> ExBudget -> CekM uni fun s () + spendBudgetCek = unCekBudgetSpender ?cekBudgetSpender + {-# INLINE spendBudgetCek #-} + + -- | Look up a variable name in the environment. + lookupVarName :: NamedDeBruijn -> CekValEnv uni fun ann -> CekM uni fun s (CekValue uni fun ann) + lookupVarName varName@(NamedDeBruijn _ varIx) varEnv = + case varEnv `Env.indexOne` coerce varIx of + Nothing -> + throwingWithCause _MachineError OpenTermEvaluatedMachineError $ + Just $ Var () varName + Just val -> pure val + {-# INLINE lookupVarName #-} + -- See Note [Compilation peculiarities]. -- | Evaluate a term using the CEK machine and keep track of costing, logging is optional. runCekDeBruijn @@ -882,7 +877,7 @@ runCekDeBruijn -> (Either (CekEvaluationException NamedDeBruijn uni fun) (NTerm uni fun ()), cost, [Text]) runCekDeBruijn params mode emitMode term = runCekM params mode emitMode $ do - spendBudgetCek BStartup $ runIdentity $ cekStartupCost ?cekCosts + unCekBudgetSpender ?cekBudgetSpender BStartup $ runIdentity $ cekStartupCost ?cekCosts enterComputeCek NoFrame Env.empty term {- Note [Accumulators for terms] diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index 58e259c5977..524524a2a04 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -39,15 +39,14 @@ module UntypedPlutusCore.Evaluation.Machine.SteppableCek.Internal ) where -import Control.Monad.Primitive import PlutusCore.Builtin import PlutusCore.DeBruijn import PlutusCore.Evaluation.Machine.ExBudget +import PlutusCore.Evaluation.Machine.ExBudgetStream import PlutusCore.Evaluation.Machine.Exception import PlutusCore.Evaluation.Machine.MachineParameters import PlutusCore.Evaluation.Result import PlutusPrelude -import Universe import UntypedPlutusCore.Core import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts, CekMachineCostsBase (..)) @@ -57,6 +56,7 @@ import UntypedPlutusCore.Evaluation.Machine.Cek.StepCounter import Control.Lens hiding (Context) import Control.Monad +import Control.Monad.Primitive import Data.Proxy import Data.RandomAccessList.Class qualified as Env import Data.Semigroup (stimes) @@ -64,6 +64,7 @@ import Data.Text (Text) import Data.Vector qualified as V import Data.Word (Word64) import GHC.TypeNats +import Universe {- Note [Debuggable vs Original versions of CEK] @@ -454,7 +455,17 @@ evalBuiltinApp fun term runtime = case runtime of {-# INLINE evalBuiltinApp #-} spendBudgetCek :: GivenCekSpender uni fun s => ExBudgetCategory fun -> ExBudget -> CekM uni fun s () -spendBudgetCek = let (CekBudgetSpender spend) = ?cekBudgetSpender in spend +spendBudgetCek = unCekBudgetSpender ?cekBudgetSpender + +-- | Spend each budget from the given stream of budgets. +spendBudgetStreamCek + :: GivenCekReqs uni fun ann s + => ExBudgetCategory fun + -> ExBudgetStream + -> CekM uni fun s () +spendBudgetStreamCek exCat = go where + go (ExBudgetLast budget) = spendBudgetCek exCat budget + go (ExBudgetCons budget budgets) = spendBudgetCek exCat budget *> go budgets -- | Spend the budget that has been accumulated for a number of machine steps. -- From 4c1f9cf0546d67151649df7b5aa388ba6483d816 Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 26 Apr 2024 20:36:59 +0200 Subject: [PATCH 4/8] Give up on 'noinline' --- .../Evaluation/Machine/Cek/Internal.hs | 37 +++++++------------ 1 file changed, 14 insertions(+), 23 deletions(-) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index f7a386c4899..4c616ab0213 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -100,7 +100,6 @@ import Data.Semigroup (stimes) import Data.Text (Text) import Data.Vector qualified as V import Data.Word -import GHC.Magic (noinline) import GHC.TypeLits import Prettyprinter import Universe @@ -465,17 +464,6 @@ instance ThrowableBuiltins uni fun => MonadError (CekEvaluationException NamedDe unsafeRunCekM :: CekM uni fun s a -> IO a unsafeRunCekM = unsafeSTToIO . unCekM --- It would be really nice to define this instance, so that we can use 'makeKnown' directly in --- the 'CekM' monad without the 'WithEmitterT' nonsense. Unfortunately, GHC doesn't like --- implicit params in instance contexts. As GHC's docs explain: --- --- > Reason: exactly which implicit parameter you pick up depends on exactly where you invoke a --- > function. But the "invocation" of instance declarations is done behind the scenes by the --- > compiler, so it's hard to figure out exactly where it is done. The easiest thing is to outlaw --- > the offending types. --- instance GivenCekEmitter s => MonadEmitter (CekM uni fun s) where --- emit = emitCek - instance AsEvaluationFailure CekUserError where _EvaluationFailure = _EvaluationFailureVia CekEvaluationFailure @@ -750,11 +738,12 @@ enterComputeCek = computeCek case runtime of -- It's only possible to force a builtin application if the builtin expects a type -- argument next. - BuiltinExpectForce runtime' -> + BuiltinExpectForce runtime' -> do -- We allow a type argument to appear last in the type of a built-in function, -- otherwise we could just assemble a 'VBuiltin' without trying to evaluate the -- application. - evalBuiltinApp fun term' runtime' $ returnCek ctx + res <- evalBuiltinApp fun term' runtime' + returnCek ctx res _ -> throwingWithCause _MachineError BuiltinTermArgumentExpectedMachineError (Just term') forceEvaluate !_ val = @@ -784,7 +773,9 @@ enterComputeCek = computeCek case runtime of -- It's only possible to apply a builtin application if the builtin expects a term -- argument next. - BuiltinExpectArgument f -> evalBuiltinApp fun term' (f arg) $ returnCek ctx + BuiltinExpectArgument f -> do + res <- evalBuiltinApp fun term' $ f arg + returnCek ctx res _ -> throwingWithCause _MachineError UnexpectedBuiltinTermArgumentMachineError (Just term') applyEvaluate !_ val _ = @@ -796,16 +787,16 @@ enterComputeCek = computeCek let ctr = ?cekStepCounter iforCounter_ ctr spend resetCounter ctr + {-# INLINE spendAccumulatedBudget #-} -- Making this a definition of its own causes it to inline better than actually writing it inline, for -- some reason. -- Skip index 7, that's the total counter! -- See Note [Structure of the step counter] - {-# INLINE spend #-} spend !i !w = unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ let kind = toEnum i in spendBudgetCek (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) + {-# INLINE spend #-} - {-# INLINE stepAndMaybeSpend #-} -- | Accumulate a step, and maybe spend the budget that has accumulated for a number of machine steps, but only if we've exceeded our slippage. stepAndMaybeSpend :: StepKind -> CekM uni fun s () stepAndMaybeSpend !kind = do @@ -820,6 +811,7 @@ enterComputeCek = computeCek -- There's no risk of overflow here, since we only ever increment the total -- steps by 1 and then check this condition. when (unbudgetedStepsTotal >= ?cekSlippage) spendAccumulatedBudget + {-# INLINE stepAndMaybeSpend #-} -- | Take pieces of a possibly partial builtin application and either create a 'CekValue' using -- 'makeKnown' or a partial builtin application depending on whether the built-in function is @@ -828,18 +820,17 @@ enterComputeCek = computeCek :: fun -> NTerm uni fun () -> BuiltinRuntime (CekValue uni fun ann) - -> (CekValue uni fun ann -> CekM uni fun s (NTerm uni fun ())) - -> CekM uni fun s (NTerm uni fun ()) - evalBuiltinApp fun term runtime cont = case runtime of + -> CekM uni fun s (CekValue uni fun ann) + evalBuiltinApp fun term runtime = case runtime of BuiltinCostedResult budgets getX -> do spendBudgetStreamCek (BBuiltinApp fun) budgets case getX of - BuiltinSuccess x -> cont x - BuiltinSuccessWithLogs logs x -> ?cekEmitter logs *> noinline ($) cont x + BuiltinSuccess x -> pure x + BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x BuiltinFailure logs err -> do ?cekEmitter logs throwBuiltinErrorWithCause term err - _ -> cont $ VBuiltin fun term runtime + _ -> pure $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} -- | Spend each budget from the given stream of budgets. From 8b909522167c2004f1bccba88e12b890c3edae46 Mon Sep 17 00:00:00 2001 From: effectfully Date: Sat, 27 Apr 2024 02:04:19 +0200 Subject: [PATCH 5/8] NOINLINE 'spendAccumulatedBudget'? --- .../Evaluation/Machine/Cek/Internal.hs | 28 ++++++++----------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index 4c616ab0213..36446893e56 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -787,14 +787,14 @@ enterComputeCek = computeCek let ctr = ?cekStepCounter iforCounter_ ctr spend resetCounter ctr - {-# INLINE spendAccumulatedBudget #-} + {-# NOINLINE spendAccumulatedBudget #-} -- Making this a definition of its own causes it to inline better than actually writing it inline, for -- some reason. -- Skip index 7, that's the total counter! -- See Note [Structure of the step counter] spend !i !w = unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ - let kind = toEnum i in spendBudgetCek (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) + let kind = toEnum i in spendBudget (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) {-# INLINE spend #-} -- | Accumulate a step, and maybe spend the budget that has accumulated for a number of machine steps, but only if we've exceeded our slippage. @@ -822,8 +822,12 @@ enterComputeCek = computeCek -> BuiltinRuntime (CekValue uni fun ann) -> CekM uni fun s (CekValue uni fun ann) evalBuiltinApp fun term runtime = case runtime of - BuiltinCostedResult budgets getX -> do - spendBudgetStreamCek (BBuiltinApp fun) budgets + BuiltinCostedResult budgets0 getX -> do + let exCat = BBuiltinApp fun + spendBudgets (ExBudgetLast budget) = spendBudget exCat budget + spendBudgets (ExBudgetCons budget budgets) = + spendBudget exCat budget *> spendBudgets budgets + spendBudgets budgets0 case getX of BuiltinSuccess x -> pure x BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x @@ -833,19 +837,9 @@ enterComputeCek = computeCek _ -> pure $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} - -- | Spend each budget from the given stream of budgets. - spendBudgetStreamCek - :: ExBudgetCategory fun - -> ExBudgetStream - -> CekM uni fun s () - spendBudgetStreamCek exCat = go where - go (ExBudgetLast budget) = spendBudgetCek exCat budget - go (ExBudgetCons budget budgets) = spendBudgetCek exCat budget *> go budgets - {-# INLINE spendBudgetStreamCek #-} - - spendBudgetCek :: ExBudgetCategory fun -> ExBudget -> CekM uni fun s () - spendBudgetCek = unCekBudgetSpender ?cekBudgetSpender - {-# INLINE spendBudgetCek #-} + spendBudget :: ExBudgetCategory fun -> ExBudget -> CekM uni fun s () + spendBudget = unCekBudgetSpender ?cekBudgetSpender + {-# INLINE spendBudget #-} -- | Look up a variable name in the environment. lookupVarName :: NamedDeBruijn -> CekValEnv uni fun ann -> CekM uni fun s (CekValue uni fun ann) From cd7761816a3d6dbfb5e85e88c0cf385b91f48315 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 21 May 2024 14:48:06 +0200 Subject: [PATCH 6/8] Make 'BuiltinFailure' the first constructor again --- plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs index d7ce6e31b5c..947ef9fea7b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs @@ -58,9 +58,9 @@ data BuiltinError -- logging, since there's no logging on the chain and builtins don't emit much anyway. Otherwise -- we'd have to use @text-builder@ or @text-builder-linear@ or something of this sort. data BuiltinResult a - = BuiltinSuccess a + = BuiltinFailure (DList Text) BuiltinError + | BuiltinSuccess a | BuiltinSuccessWithLogs (DList Text) a - | BuiltinFailure (DList Text) BuiltinError deriving stock (Show, Foldable) mtraverse makeClassyPrisms From 5a1b730f21476ddf6c91986e8400addc6fc8de1c Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 11 Jun 2024 02:54:03 +0200 Subject: [PATCH 7/8] Polishing --- .../Evaluation/Machine/Cek/Internal.hs | 25 ++++++------------- 1 file changed, 8 insertions(+), 17 deletions(-) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs index 41676135ffc..f6fe8bc0456 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs @@ -1,9 +1,5 @@ -- editorconfig-checker-disable-file -- | The CEK machine. --- The CEK machine relies on variables having non-equal 'Unique's whenever they have non-equal --- string names. I.e. 'Unique's are used instead of string names. This is for efficiency reasons. --- The CEK machines handles name capture by design. - {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} @@ -140,30 +136,24 @@ Hence we don't export 'computeCek' and instead define 'runCek' in this file and though the rest of the user-facing API (which 'runCek' is a part of) is defined downstream. Another problem is handling mutual recursion in the 'computeCek'/'returnCek'/'forceEvaluate'/etc -family. If we keep these functions at the top level, GHC won't be able to pull the constraints out of -the family (confirmed by inspecting Core: GHC thinks that since the superclass constraints +family. If we keep these functions at the top level, GHC won't be able to pull the constraints out +of the family (confirmed by inspecting Core: GHC thinks that since the superclass constraints populating the dictionary representing the @Ix fun@ constraint are redundant, they can be replaced with calls to 'error' in a recursive call, but that changes the dictionary and so it can no longer be pulled out of recursion). But that entails passing a redundant argument around, which slows down the machine a tiny little bit. -Hence we define a number of the functions as local functions making use of a -shared context from their parent function. This also allows GHC to inline almost -all of the machine into a single definition (with a bunch of recursive join -points in it). +Hence we define a all happy-path functions having CEK-machine-specific constraints as local +functions making use of a shared context from their parent function. This also allows GHC to inline +almost all of the machine into a single definition (with a bunch of recursive join points in it). In general, it's advised to run benchmarks (and look at Core output if the results are suspicious) on any changes in this file. -Finally, it's important to put bang patterns on any Int arguments to ensure that GHC unboxes them: +Finally, it's important to put bang patterns on any 'Int' arguments to ensure that GHC unboxes them: this can make a surprisingly large difference. -} -{- Note [Scoping] -The CEK machine does not rely on the global uniqueness condition, so the renamer pass is not a -prerequisite. The CEK machine correctly handles name shadowing. --} - -- | The 'Term's that CEK can execute must have DeBruijn binders -- 'Name' is not necessary but we leave it here for simplicity and debuggability. type NTerm uni fun = Term NamedDeBruijn uni fun @@ -481,7 +471,6 @@ instance Pretty CekUserError where ] pretty CekEvaluationFailure = "The machine terminated because of an error, either from a built-in function or from an explicit use of 'error'." --- see Note [Scoping]. -- | Instantiate all the free variables of a term by looking them up in an environment. -- Mutually recursive with dischargeCekVal. dischargeCekValEnv :: forall uni fun ann. CekValEnv uni fun ann -> NTerm uni fun () -> NTerm uni fun () @@ -791,6 +780,8 @@ enterComputeCek = computeCek let ctr = ?cekStepCounter iforCounter_ ctr spend resetCounter ctr + -- It's very important for this definition not to get inlined. Inlining it caused performance to + -- degrade by 16+%: https://github.com/IntersectMBO/plutus/pull/5931 {-# NOINLINE spendAccumulatedBudget #-} -- Making this a definition of its own causes it to inline better than actually writing it inline, for From 02c35b381e5c78f7172f9a2c0bcd9885c6843a37 Mon Sep 17 00:00:00 2001 From: effectfully Date: Fri, 14 Jun 2024 19:53:43 +0200 Subject: [PATCH 8/8] Address comments --- .../Machine/SteppableCek/Internal.hs | 27 +++++++------------ 1 file changed, 10 insertions(+), 17 deletions(-) diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs index 524524a2a04..953d1f85326 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/SteppableCek/Internal.hs @@ -284,7 +284,7 @@ runCekDeBruijn -> (Either (CekEvaluationException NamedDeBruijn uni fun) (NTerm uni fun ()), cost, [Text]) runCekDeBruijn params mode emitMode term = runCekM params mode emitMode $ do - spendBudgetCek BStartup $ runIdentity $ cekStartupCost ?cekCosts + spendBudget BStartup $ runIdentity $ cekStartupCost ?cekCosts enterComputeCek NoFrame Env.empty term -- See Note [Compilation peculiarities]. @@ -443,8 +443,12 @@ evalBuiltinApp -> BuiltinRuntime (CekValue uni fun ann) -> CekM uni fun s (CekValue uni fun ann) evalBuiltinApp fun term runtime = case runtime of - BuiltinCostedResult budgets getX -> do - spendBudgetStreamCek (BBuiltinApp fun) budgets + BuiltinCostedResult budgets0 getX -> do + let exCat = BBuiltinApp fun + spendBudgets (ExBudgetLast budget) = spendBudget exCat budget + spendBudgets (ExBudgetCons budget budgets) = + spendBudget exCat budget *> spendBudgets budgets + spendBudgets budgets0 case getX of BuiltinSuccess x -> pure x BuiltinSuccessWithLogs logs x -> ?cekEmitter logs $> x @@ -454,21 +458,10 @@ evalBuiltinApp fun term runtime = case runtime of _ -> pure $ VBuiltin fun term runtime {-# INLINE evalBuiltinApp #-} -spendBudgetCek :: GivenCekSpender uni fun s => ExBudgetCategory fun -> ExBudget -> CekM uni fun s () -spendBudgetCek = unCekBudgetSpender ?cekBudgetSpender - --- | Spend each budget from the given stream of budgets. -spendBudgetStreamCek - :: GivenCekReqs uni fun ann s - => ExBudgetCategory fun - -> ExBudgetStream - -> CekM uni fun s () -spendBudgetStreamCek exCat = go where - go (ExBudgetLast budget) = spendBudgetCek exCat budget - go (ExBudgetCons budget budgets) = spendBudgetCek exCat budget *> go budgets +spendBudget :: GivenCekSpender uni fun s => ExBudgetCategory fun -> ExBudget -> CekM uni fun s () +spendBudget = unCekBudgetSpender ?cekBudgetSpender -- | Spend the budget that has been accumulated for a number of machine steps. --- spendAccumulatedBudget :: (GivenCekReqs uni fun ann s) => CekM uni fun s () spendAccumulatedBudget = do let ctr = ?cekStepCounter @@ -481,7 +474,7 @@ spendAccumulatedBudget = do -- See Note [Structure of the step counter] {-# INLINE spend #-} spend !i !w = unless (i == (fromIntegral $ natVal $ Proxy @TotalCountIndex)) $ - let kind = toEnum i in spendBudgetCek (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) + let kind = toEnum i in spendBudget (BStep kind) (stimes w (cekStepCost ?cekCosts kind)) -- | Accumulate a step, and maybe spend the budget that has accumulated for a number of machine steps, but only if we've exceeded our slippage. stepAndMaybeSpend :: (GivenCekReqs uni fun ann s) => StepKind -> CekM uni fun s ()