[Builtins] Replace 'EvaluationResult' with 'BuiltinResult' (#5926)

This replaces several `Emitter (EvaluationResult a)` occurrences with `BuiltinResult`, something that I missed the last [time](#5728).

In addition to that, it also replaces `EvaluationResult` with `BuiltinResult` in general. It doesn't matter performance-wise (modulo a regression that we didn't notice some time ago), but `BuiltinResult`, unlike `EvaluationResult`, allows one to attach an error message to a failure, which we do in this PR as well, meaning we now get better error messages. And we also now respect the operational vs structural evaluation errors distinction.

The PR also replaces `Emitter` with `BuiltinResult`. And makes the GHC Core of builtins smaller by making error-throwing functions (not) inline (see `Note [INLINE and OPAQUE on error-related definitions]` for details).

plutus-core/changelog.d/20240618_023306_effectfully_replace_EvaluationResult_with_BuiltinResult.md

@@ -0,0 +1,3 @@
+### Changed
+
+- Forbade using `EvaluationResult` in the builtins code in favor of `BuiltinResult` in #5926, so that builtins throw errors with more helpful messages.

plutus-core/cost-model/budgeting-bench/Benchmarks/Nops.hs

@@ -22,6 +22,7 @@ import PlutusCore.Evaluation.Machine.BuiltinCostModel hiding (BuiltinCostModel)
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults
 import PlutusCore.Evaluation.Machine.ExMemoryUsage (ExMemoryUsage)
 import PlutusCore.Evaluation.Machine.MachineParameters
+import PlutusCore.Evaluation.Result (evaluationFailure)
 import PlutusCore.Pretty
 import PlutusPrelude
 import UntypedPlutusCore.Evaluation.Machine.Cek
@@ -132,12 +133,12 @@ nopCostParameters =
 infixr >:
 (>:) :: uni ~ DefaultUni
  => SomeConstant uni Integer
- -> EvaluationResult Integer
- -> EvaluationResult Integer
+ -> BuiltinResult Integer
+ -> BuiltinResult Integer
 n >: k =
  case n of
  SomeConstant (Some (ValueOf DefaultUniInteger _)) -> k
- _ -> EvaluationFailure
+ _ -> evaluationFailure
 
 {- | The meanings of the builtins. Each one takes a number of arguments and
  returns a result without doing any other work. A builtin can process its
@@ -225,27 +226,27 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni NopFun where
  -- Integers unlifted via SomeConstant
  toBuiltinMeaning _semvar Nop1c =
  makeBuiltinMeaning
- (\c1 -> c1 >: EvaluationSuccess 11)
+ (\c1 -> c1 >: BuiltinSuccess 11)
  (runCostingFunOneArgument . paramNop1)
  toBuiltinMeaning _semvar Nop2c =
  makeBuiltinMeaning
- (\c1 c2 -> c1 >: c2 >: EvaluationSuccess 22)
+ (\c1 c2 -> c1 >: c2 >: BuiltinSuccess 22)
  (runCostingFunTwoArguments . paramNop2)
  toBuiltinMeaning _semvar Nop3c =
  makeBuiltinMeaning
- (\c1 c2 c3 -> c1 >: c2 >: c3 >: EvaluationSuccess 33)
+ (\c1 c2 c3 -> c1 >: c2 >: c3 >: BuiltinSuccess 33)
  (runCostingFunThreeArguments . paramNop3)
  toBuiltinMeaning _semvar Nop4c =
  makeBuiltinMeaning
- (\c1 c2 c3 c4 -> c1 >: c2 >: c3 >: c4 >: EvaluationSuccess 44)
+ (\c1 c2 c3 c4 -> c1 >: c2 >: c3 >: c4 >: BuiltinSuccess 44)
  (runCostingFunFourArguments . paramNop4)
  toBuiltinMeaning _semvar Nop5c =
  makeBuiltinMeaning
- (\c1 c2 c3 c4 c5 -> c1 >: c2 >: c3 >: c4 >: c5 >: EvaluationSuccess 55)
+ (\c1 c2 c3 c4 c5 -> c1 >: c2 >: c3 >: c4 >: c5 >: BuiltinSuccess 55)
  (runCostingFunFiveArguments . paramNop5)
  toBuiltinMeaning _semvar Nop6c =
  makeBuiltinMeaning
- (\c1 c2 c3 c4 c5 c6 -> c1 >: c2 >: c3 >: c4 >: c5 >: c6 >: EvaluationSuccess 66)
+ (\c1 c2 c3 c4 c5 c6 -> c1 >: c2 >: c3 >: c4 >: c5 >: c6 >: BuiltinSuccess 66)
  (runCostingFunSixArguments . paramNop6)
  -- Opaque Integers
  toBuiltinMeaning _semvar Nop1o =

plutus-core/plutus-core/examples/PlutusCore/Examples/Builtins.hs

@@ -24,6 +24,7 @@ import PlutusCore.Data
 import PlutusCore.Evaluation.Machine.BuiltinCostModel
 import PlutusCore.Evaluation.Machine.ExBudget
 import PlutusCore.Evaluation.Machine.ExBudgetStream
+import PlutusCore.Evaluation.Result (evaluationFailure)
 import PlutusCore.Pretty
 
 import PlutusCore.StdLib.Data.ScottList qualified as Plc
@@ -277,31 +278,31 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
  idAssumeCheckBoolPlc
  whatever
  where
- idAssumeCheckBoolPlc :: Opaque val Bool -> EvaluationResult Bool
+ idAssumeCheckBoolPlc :: Opaque val Bool -> BuiltinResult Bool
  idAssumeCheckBoolPlc val =
  case asConstant val of
- Right (Some (ValueOf DefaultUniBool b)) -> EvaluationSuccess b
- _ -> EvaluationFailure
+ Right (Some (ValueOf DefaultUniBool b)) -> pure b
+ _ -> evaluationFailure
 
  toBuiltinMeaning _semvar IdSomeConstantBool =
  makeBuiltinMeaning
  idSomeConstantBoolPlc
  whatever
  where
- idSomeConstantBoolPlc :: SomeConstant uni Bool -> EvaluationResult Bool
+ idSomeConstantBoolPlc :: SomeConstant uni Bool -> BuiltinResult Bool
  idSomeConstantBoolPlc = \case
- SomeConstant (Some (ValueOf DefaultUniBool b)) -> EvaluationSuccess b
- _ -> EvaluationFailure
+ SomeConstant (Some (ValueOf DefaultUniBool b)) -> pure b
+ _ -> evaluationFailure
 
  toBuiltinMeaning _semvar IdIntegerAsBool =
  makeBuiltinMeaning
  idIntegerAsBool
  whatever
  where
- idIntegerAsBool :: SomeConstant uni Integer -> EvaluationResult (SomeConstant uni Integer)
+ idIntegerAsBool :: SomeConstant uni Integer -> BuiltinResult (SomeConstant uni Integer)
  idIntegerAsBool = \case
- con@(SomeConstant (Some (ValueOf DefaultUniBool _))) -> EvaluationSuccess con
- _ -> EvaluationFailure
+ con@(SomeConstant (Some (ValueOf DefaultUniBool _))) -> pure con
+ _ -> evaluationFailure
 
  toBuiltinMeaning _semvar IdFInteger =
  makeBuiltinMeaning
@@ -380,8 +381,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
  whatever
  where
  unsafeCoerceElPlc
- :: SomeConstant DefaultUni [a]
- -> EvaluationResult (SomeConstant DefaultUni [b])
+ :: SomeConstant DefaultUni [a] -> BuiltinResult (SomeConstant DefaultUni [b])
  unsafeCoerceElPlc (SomeConstant (Some (ValueOf uniList xs))) = do
  DefaultUniList _ <- pure uniList
  pure $ fromValueOf uniList xs
@@ -398,7 +398,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
 
  toBuiltinMeaning _semvar ErrorPrime =
  makeBuiltinMeaning
- EvaluationFailure
+ (evaluationFailure :: forall a. BuiltinResult a)
  whatever
 
  toBuiltinMeaning _semvar Comma =
@@ -422,7 +422,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
  :: SomeConstant uni a
  -> SomeConstant uni b
  -> SomeConstant uni (a, b)
- -> EvaluationResult (SomeConstant uni (a, b))
+ -> BuiltinResult (SomeConstant uni (a, b))
  biconstPairPlc
  (SomeConstant (Some (ValueOf uniA x)))
  (SomeConstant (Some (ValueOf uniB y)))
@@ -439,7 +439,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
  where
  swapPlc
  :: SomeConstant uni (a, b)
- -> EvaluationResult (SomeConstant uni (b, a))
+ -> BuiltinResult (SomeConstant uni (b, a))
  swapPlc (SomeConstant (Some (ValueOf uniPairAB p))) = do
  DefaultUniPair uniA uniB <- pure uniPairAB
  pure $ fromValueOf (DefaultUniPair uniB uniA) (snd p, fst p)
@@ -452,7 +452,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
  -- The type reads as @[(a, Bool)] -> [(Bool, a)]@.
  swapElsPlc
  :: SomeConstant uni [SomeConstant uni (a, Bool)]
- -> EvaluationResult (SomeConstant uni [SomeConstant uni (Bool, a)])
+ -> BuiltinResult (SomeConstant uni [SomeConstant uni (Bool, a)])
  swapElsPlc (SomeConstant (Some (ValueOf uniList xs))) = do
  DefaultUniList (DefaultUniPair uniA DefaultUniBool) <- pure uniList
  let uniList' = DefaultUniList $ DefaultUniPair DefaultUniBool uniA
@@ -462,10 +462,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni ExtensionFun where
  -- See Note [Builtin semantics variants]
  toBuiltinMeaning semvar ExtensionVersion =
  makeBuiltinMeaning
- @(() -> EvaluationResult Integer)
- (\(_ :: ()) -> EvaluationSuccess $ case semvar of
-  ExtensionFunSemanticsVariantX -> 0
-  ExtensionFunSemanticsVariantY -> 1)
+ @(() -> Integer)
+ (\_ -> case semvar of
+ ExtensionFunSemanticsVariantX -> 0
+ ExtensionFunSemanticsVariantY -> 1)
  whatever
 
  -- We want to know if the CEK machine releases individual budgets after accounting for them and

plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs

@@ -248,9 +248,8 @@ typeMismatchError uniExp uniAct =
  , "expected: " ++ displayBy botRenderContext (SomeTypeIn uniExp)
  , "; actual: " ++ displayBy botRenderContext (SomeTypeIn uniAct)
  ]
--- Just for tidier Core to get generated, we don't care about performance here, since it's just a
--- failure message and evaluation is about to be shut anyway.
-{-# NOINLINE typeMismatchError #-}
+-- See Note [INLINE and OPAQUE on error-related definitions].
+{-# OPAQUE typeMismatchError #-}
 
 -- Normally it's a good idea for an exported abstraction not to be a type synonym, since a @newtype@
 -- is cheap, looks good in error messages and clearly emphasize an abstraction barrier. However we
@@ -322,11 +321,6 @@ readKnownSelf
 readKnownSelf val = fromRightM (throwBuiltinErrorWithCause val) $ readKnown val
 {-# INLINE readKnownSelf #-}
 
-instance MakeKnownIn uni val a => MakeKnownIn uni val (EvaluationResult a) where
- makeKnown EvaluationFailure = evaluationFailure
- makeKnown (EvaluationSuccess x) = makeKnown x
- {-# INLINE makeKnown #-}
-
 instance MakeKnownIn uni val a => MakeKnownIn uni val (BuiltinResult a) where
  makeKnown res = res >>= makeKnown
  {-# INLINE makeKnown #-}
@@ -338,24 +332,38 @@ instance MakeKnownIn uni val a => MakeKnownIn uni val (BuiltinResult a) where
 -- I.e. it would essentially allow us to catch errors and handle them in a programmable way.
 -- We forbid this, because it complicates code and isn't supported by evaluation engines anyway.
 instance
- ( TypeError ('Text "‘EvaluationResult’ cannot appear in the type of an argument")
+ ( TypeError ('Text "‘BuiltinResult’ cannot appear in the type of an argument")
+ , uni ~ UniOf val
+ ) => ReadKnownIn uni val (BuiltinResult a) where
+ readKnown _ = throwUnderTypeError
+ {-# INLINE readKnown #-}
+
+instance
+ ( TypeError ('Text "Use ‘BuiltinResult’ instead of ‘EvaluationResult’")
+ , uni ~ UniOf val
+ ) => MakeKnownIn uni val (EvaluationResult a) where
+ makeKnown _ = throwUnderTypeError
+ {-# INLINE makeKnown #-}
+
+instance
+ ( TypeError ('Text "Use ‘BuiltinResult’ instead of ‘EvaluationResult’")
  , uni ~ UniOf val
  ) => ReadKnownIn uni val (EvaluationResult a) where
- readKnown _ = throwing _StructuralUnliftingError "Panic: 'TypeError' was bypassed"
- -- Just for 'readKnown' not to appear in the generated Core.
+ readKnown _ = throwUnderTypeError
  {-# INLINE readKnown #-}
 
-instance MakeKnownIn uni val a => MakeKnownIn uni val (Emitter a) where
- makeKnown a = case runEmitter a of
- (x, logs) -> withLogs logs $ makeKnown x
+instance
+ ( TypeError ('Text "Use ‘BuiltinResult’ instead of ‘Emitter’")
+ , uni ~ UniOf val
+ ) => MakeKnownIn uni val (Emitter a) where
+ makeKnown _ = throwUnderTypeError
  {-# INLINE makeKnown #-}
 
 instance
- ( TypeError ('Text "‘Emitter’ cannot appear in the type of an argument")
+ ( TypeError ('Text "Use ‘BuiltinResult’ instead of ‘Emitter’")
  , uni ~ UniOf val
  ) => ReadKnownIn uni val (Emitter a) where
- readKnown _ = throwing _StructuralUnliftingError "Panic: 'TypeError' was bypassed"
- -- Just for 'readKnown' not to appear in the generated Core.
+ readKnown _ = throwUnderTypeError
  {-# INLINE readKnown #-}
 
 instance HasConstantIn uni val => MakeKnownIn uni val (SomeConstant uni rep) where

plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs

@@ -30,7 +30,6 @@ import PlutusCore.Evaluation.Machine.ExBudgetStream
 import PlutusCore.Evaluation.Machine.ExMemoryUsage
 import PlutusCore.Name.Unique
 
-import Control.Monad.Except (throwError)
 import Data.Array
 import Data.Kind qualified as GHC
 import Data.Proxy
@@ -244,7 +243,7 @@ instance (Typeable res, KnownTypeAst TyName (UniOf val) res, MakeKnown val res)
  -- either a budgeting failure or a budgeting success with a cost and a 'BuiltinResult'
  -- computation inside, but that would slow things down a bit and the current strategy is
  -- reasonable enough.
- (BuiltinCostedResult (ExBudgetLast mempty) . throwError)
+ builtinRuntimeFailure
  (\(x, cost) -> BuiltinCostedResult cost $ makeKnown x)
  {-# INLINE toMonoF #-}
 

plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs

@@ -1,9 +1,11 @@
+-- editorconfig-checker-disable-file
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module PlutusCore.Builtin.Result
@@ -21,6 +23,7 @@ module PlutusCore.Builtin.Result
  , _StructuralUnliftingError
  , _OperationalUnliftingError
  , throwNotAConstant
+ , throwUnderTypeError
  , withLogs
  , throwing
  , throwing_
@@ -39,13 +42,14 @@ import Data.Bitraversable
 import Data.DList (DList)
 import Data.String (IsString)
 import Data.Text (Text)
+import Data.Text qualified as Text
 import Prettyprinter
 
 -- | The error message part of an 'UnliftingEvaluationError'.
 newtype UnliftingError = MkUnliftingError
  { unUnliftingError :: Text
  } deriving stock (Show, Eq)
- deriving newtype (IsString, Semigroup, NFData)
+ deriving newtype (IsString, Semigroup, Monoid, NFData)
 
 -- | When unlifting of a PLC term into a Haskell value fails, this error is thrown.
 newtype UnliftingEvaluationError = MkUnliftingEvaluationError
@@ -55,7 +59,7 @@ newtype UnliftingEvaluationError = MkUnliftingEvaluationError
 
 -- | The type of errors that 'readKnown' and 'makeKnown' can return.
 data BuiltinError
- = BuiltinUnliftingEvaluationError !UnliftingEvaluationError
+ = BuiltinUnliftingEvaluationError UnliftingEvaluationError
  | BuiltinEvaluationFailure
  deriving stock (Show, Eq)
 
@@ -143,6 +147,10 @@ instance MonadEmitter BuiltinResult where
  emit txt = BuiltinSuccessWithLogs (pure txt) ()
  {-# INLINE emit #-}
 
+instance MonadFail BuiltinResult where
+ fail err = BuiltinFailure (pure $ Text.pack err) BuiltinEvaluationFailure
+ {-# INLINE fail #-}
+
 instance Pretty UnliftingError where
  pretty (MkUnliftingError err) = fold
  [ "Could not unlift a value:", hardline
@@ -155,6 +163,21 @@ instance Pretty BuiltinError where
  pretty (BuiltinUnliftingEvaluationError err) = "Builtin evaluation failure:" <+> pretty err
  pretty BuiltinEvaluationFailure = "Builtin evaluation failure"
 
+{- Note [INLINE and OPAQUE on error-related definitions]
+We mark error-related definitions such as prisms like '_StructuralUnliftingError' and regular
+functions like 'throwNotAConstant' with @INLINE@, because this produces significantly less cluttered
+GHC Core. Not doing so results in 20+% larger Core for builtins.
+
+However in a few specific cases we use @OPAQUE@ instead to get tighter Core. @OPAQUE@ is the same as
+@NOINLINE@ except the former _actually_ prevents GHC from inlining the definition unlike the latter.
+See this for details: https://github.com/ghc-proposals/ghc-proposals/blob/5577fd008924de8d89cfa9855fa454512e7dcc75/proposals/0415-opaque-pragma.rst
+
+It's hard to predict where @OPAQUE@ instead of @INLINE@ will help to make GHC Core tidier, so it's
+mostly just looking into the Core and seeing where there's obvious duplication that can be removed.
+Such cases tend to be functions returning a value of a concrete error type (as opposed to a type
+variable).
+-}
+
 -- See Note [Ignoring context in OperationalEvaluationError].
 -- | Construct a prism focusing on the @*EvaluationFailure@ part of @err@ by taking
 -- that @*EvaluationFailure@ and
@@ -181,6 +204,10 @@ throwNotAConstant :: MonadError BuiltinError m => m void
 throwNotAConstant = throwing _StructuralUnliftingError "Not a constant"
 {-# INLINE throwNotAConstant #-}
 
+throwUnderTypeError :: MonadError BuiltinError m => m void
+throwUnderTypeError = throwing _StructuralUnliftingError "Panic: 'TypeError' was bypassed"
+{-# INLINE throwUnderTypeError #-}
+
 -- | Prepend logs to a 'BuiltinResult' computation.
 withLogs :: DList Text -> BuiltinResult a -> BuiltinResult a
 withLogs logs1 = \case
@@ -242,6 +269,7 @@ instance MonadError BuiltinError BuiltinResult where
  (OperationalEvaluationError
  (MkUnliftingError operationalErr))) -> pure operationalErr
  _ -> mempty
+ {-# INLINE throwError #-}
 
  -- Throwing logs out is lame, but embedding them into the error would be weird, since that
  -- would change the error. Not that any of that matters, we only implement this because it's a

plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs

@@ -10,6 +10,7 @@ import PlutusCore.Builtin.KnownType
 import PlutusCore.Evaluation.Machine.ExBudgetStream
 
 import Control.DeepSeq
+import Control.Monad.Except (throwError)
 import NoThunks.Class
 
 -- | A 'BuiltinRuntime' represents a possibly partial builtin application, including an empty
@@ -78,6 +79,11 @@ instance (Bounded fun, Enum fun) => NoThunks (BuiltinsRuntime fun val) where
  wNoThunks ctx (BuiltinsRuntime env) = allNoThunks $ map (wNoThunks ctx . env) enumerate
  showTypeOf = const "PlutusCore.Builtin.Runtime.BuiltinsRuntime"
 
+builtinRuntimeFailure :: BuiltinError -> BuiltinRuntime val
+builtinRuntimeFailure = BuiltinCostedResult (ExBudgetLast mempty) . throwError
+-- See Note [INLINE and OPAQUE on error-related definitions].
+{-# OPAQUE builtinRuntimeFailure #-}
+
 -- | Look up the runtime info of a built-in function during evaluation.
 lookupBuiltin :: fun -> BuiltinsRuntime fun val -> BuiltinRuntime val
 lookupBuiltin fun (BuiltinsRuntime env) = env fun

plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs

@@ -12,11 +12,6 @@ import Data.Kind (Type)
 import Data.Text (Text)
 import Text.Printf (printf)
 
--- TODO: Something like 'failWithMessage x y *> foo' should really fail with
--- 'EvaluationFailure' without evaluating 'foo', but currently it will. This
--- requires a fix to how Emitter and EvaluationResult work, and since we don't
--- expect 'failWithMessage' to be used this way, we note this for future
--- reference only for when such fixes are made.
 failWithMessage :: forall (a :: Type). Text -> Text -> BuiltinResult a
 failWithMessage location reason = do
  emit $ location <> ": " <> reason