From b1ee0ff59616575d50a1fe64df573682893905a5 Mon Sep 17 00:00:00 2001 From: effectfully Date: Mon, 8 Apr 2024 23:21:01 +0200 Subject: [PATCH 1/2] [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 458d9bebd2e707ce148cf57031dd0f0a24440f4b Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 30 May 2024 14:01:18 +0200 Subject: [PATCH 2/2] A comment --- .../plutus-core/src/PlutusCore/Builtin/Result.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs index d7ce6e31b5c..0e20320cc0d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs @@ -58,7 +58,17 @@ 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 + = -- 'BuiltinSuccess' is the first constructor to make it a bit more likely for GHC to + -- branch-predict it (which is something that we want, because most builtins return this + -- constructor). It is however not guaranteed that GHC will predict it, because even though + -- it's likely going to be a recursive case (it certainly is in the CEK machine) and thus the + -- constructor has precedence over 'BuiltinFailure', it doesn't have precedence over + -- 'BuiltinSuccessWithLogs', since that case is equally likely to be recursive. + -- + -- Unfortunately, GHC doesn't offer any explicit control over branch-prediction (see this + -- ticket: https://gitlab.haskell.org/ghc/ghc/-/issues/849), so relying on hope is the best we + -- can do here. + BuiltinSuccess a | BuiltinSuccessWithLogs (DList Text) a | BuiltinFailure (DList Text) BuiltinError deriving stock (Show, Foldable)