[Builtins] Replace 'EvaluationResult' with 'BuiltinResult'

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