From cd7bd22163e55d316113ffcec327a620d4dc1dd5 Mon Sep 17 00:00:00 2001 From: effectfully Date: Tue, 18 Jun 2024 01:37:03 +0200 Subject: [PATCH] Address comments --- .../src/PlutusCore/Builtin/KnownType.hs | 5 ++--- .../src/PlutusCore/Builtin/Meaning.hs | 3 +-- .../src/PlutusCore/Builtin/Result.hs | 17 +++++++++++++++++ .../src/PlutusCore/Builtin/Runtime.hs | 6 ++++++ .../plutus-core/src/PlutusCore/Crypto/Utils.hs | 5 ----- .../src/PlutusCore/Evaluation/Error.hs | 4 ++++ .../src/PlutusCore/Evaluation/ErrorWithCause.hs | 5 +++++ .../PlutusCore/Evaluation/Machine/Exception.hs | 2 ++ .../src/PlutusCore/Evaluation/Result.hs | 1 + 9 files changed, 38 insertions(+), 10 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs index 7249304c36f..3c4b7a79cf9 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/KnownType.hs +++ b/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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index 2c04f75ee56..f7260d203d7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/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 #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs index 87727200801..b1685d6b5fb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs @@ -1,3 +1,4 @@ +-- editorconfig-checker-disable-file {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} @@ -162,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 @@ -253,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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs index a77378a4218..805962c2c62 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs +++ b/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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs b/plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs index a67300c0310..bb80ce83dcb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Crypto/Utils.hs +++ b/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 diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Error.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Error.hs index f0f8e43d108..16e39e11eeb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Error.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Error.hs @@ -62,19 +62,23 @@ mtraverse makeClassyPrisms instance Bifunctor EvaluationError where bimap f _ (OperationalEvaluationError err) = OperationalEvaluationError $ f err bimap _ g (StructuralEvaluationError err) = StructuralEvaluationError $ g err + {-# INLINE bimap #-} instance Bifoldable EvaluationError where bifoldMap f _ (OperationalEvaluationError err) = f err bifoldMap _ g (StructuralEvaluationError err) = g err + {-# INLINE bifoldMap #-} instance Bitraversable EvaluationError where bitraverse f _ (OperationalEvaluationError err) = OperationalEvaluationError <$> f err bitraverse _ g (StructuralEvaluationError err) = StructuralEvaluationError <$> g err + {-# INLINE bitraverse #-} -- | A raw evaluation failure is always an operational error. instance AsEvaluationFailure operational => AsEvaluationFailure (EvaluationError operational structural) where _EvaluationFailure = _OperationalEvaluationError . _EvaluationFailure + {-# INLINE _EvaluationFailure #-} instance ( HasPrettyDefaults config ~ 'True diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs index f63f2588506..146d74d8b75 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs @@ -32,9 +32,11 @@ data ErrorWithCause err cause = ErrorWithCause instance Bifunctor ErrorWithCause where bimap f g (ErrorWithCause err cause) = ErrorWithCause (f err) (g <$> cause) + {-# INLINE bimap #-} instance AsEvaluationFailure err => AsEvaluationFailure (ErrorWithCause err cause) where _EvaluationFailure = iso _ewcError (flip ErrorWithCause Nothing) . _EvaluationFailure + {-# INLINE _EvaluationFailure #-} instance (Pretty err, Pretty cause) => Pretty (ErrorWithCause err cause) where pretty (ErrorWithCause e c) = pretty e <+> "caused by:" <+> pretty c @@ -63,6 +65,7 @@ throwingWithCause :: forall exc e t term m x. (exc ~ ErrorWithCause e term, MonadError exc m) => AReview e t -> t -> Maybe term -> m x throwingWithCause l t cause = reviews l (\e -> throwError $ ErrorWithCause e cause) t +{-# INLINE throwingWithCause #-} -- | "Prismatically" throw a contentless error and its (optional) cause. 'throwingWithCause_' is to -- 'throwingWithCause' as 'throwing_' is to 'throwing'. @@ -71,6 +74,7 @@ throwingWithCause_ :: forall exc e term m x. (exc ~ ErrorWithCause e term, MonadError exc m) => AReview e () -> Maybe term -> m x throwingWithCause_ l = throwingWithCause l () +{-# INLINE throwingWithCause_ #-} -- | Attach a @cause@ to a 'BuiltinError' and throw that. -- Note that an evaluator might require the cause to be computed lazily for best performance on the @@ -86,3 +90,4 @@ throwBuiltinErrorWithCause cause = \case throwingWithCause _UnliftingEvaluationError unlErr $ Just cause BuiltinEvaluationFailure -> throwingWithCause_ _EvaluationFailure $ Just cause +{-# INLINE throwBuiltinErrorWithCause #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs index c56a4e6faed..8dfa83c1abf 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Exception.hs @@ -72,9 +72,11 @@ mtraverse makeClassyPrisms instance structural ~ MachineError fun => AsMachineError (EvaluationError operational structural) fun where _MachineError = _StructuralEvaluationError + {-# INLINE _MachineError #-} instance AsUnliftingError (MachineError fun) where _UnliftingError = _UnliftingMachineError + {-# INLINE _UnliftingError #-} type EvaluationException operational structural = ErrorWithCause (EvaluationError operational structural) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs index 43321ea4c88..caf61ddca47 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs @@ -74,6 +74,7 @@ instance AsEvaluationFailure (EvaluationResult a) where _EvaluationFailure = prism (const EvaluationFailure) $ \case a@EvaluationSuccess{} -> Left a EvaluationFailure -> Right () + {-# INLINE _EvaluationFailure #-} -- This and the next one are two instances that allow us to write the following: --