diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs index c6770fe96c1..98a5f5d9096 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs @@ -317,9 +317,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 d559df8f123..3e8b1dce823 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs @@ -74,9 +74,19 @@ 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' 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) mtraverse makeClassyPrisms @@ -174,43 +184,43 @@ throwNotAConstant = throwing _StructuralUnliftingError "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 63c9a8f0cfb..89caba6a46d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs @@ -74,9 +74,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 fed45bfdb13..1826d96dbe6 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 @@ -658,11 +658,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 0127f3b3513..58e259c5977 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 @@ -445,11 +445,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 843b63ccc4c..229e0968d92 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -258,10 +258,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)) $ - Haskell.error "Ed25519 signature verification errored." BuiltinSuccess b -> BuiltinBool b BuiltinSuccessWithLogs logs b -> traceAll logs $ BuiltinBool b + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + Haskell.error "Ed25519 signature verification errored." {-# NOINLINE verifyEcdsaSecp256k1Signature #-} verifyEcdsaSecp256k1Signature :: @@ -271,10 +271,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)) $ - Haskell.error "ECDSA SECP256k1 signature verification errored." BuiltinSuccess b -> BuiltinBool b BuiltinSuccessWithLogs logs b -> traceAll logs $ BuiltinBool b + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + Haskell.error "ECDSA SECP256k1 signature verification errored." {-# NOINLINE verifySchnorrSecp256k1Signature #-} verifySchnorrSecp256k1Signature :: @@ -284,10 +284,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)) $ - Haskell.error "Schnorr SECP256k1 signature verification errored." BuiltinSuccess b -> BuiltinBool b BuiltinSuccessWithLogs logs b -> traceAll logs $ BuiltinBool b + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + Haskell.error "Schnorr SECP256k1 signature verification errored." traceAll :: forall (a :: Type) (f :: Type -> Type) . (Foldable f) => f Text -> a -> a @@ -694,10 +694,10 @@ integerToByteString -> BuiltinByteString integerToByteString (BuiltinBool endiannessArg) paddingArg input = case Convert.integerToByteStringWrapper endiannessArg paddingArg input of - BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ - Haskell.error "Integer to ByteString conversion errored." BuiltinSuccess bs -> BuiltinByteString bs BuiltinSuccessWithLogs logs bs -> traceAll logs $ BuiltinByteString bs + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + Haskell.error "Integer to ByteString conversion errored." {-# NOINLINE byteStringToInteger #-} byteStringToInteger