[Evaluation] Tweaked some budgeting-related stuff a bit (#3321)

plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs

@@ -28,6 +28,7 @@ module PlutusCore.Constant.Typed
     , TyAppRep
     , TyForallRep
     , Opaque (..)
+    , throwNotAConstant
     , AsConstant (..)
     , FromConstant (..)
     , HasConstant
@@ -356,21 +357,26 @@ newtype Opaque term (rep :: GHC.Type) = Opaque
     { unOpaque :: term
     } deriving newtype (Pretty)
 
+-- | Throw an 'UnliftingError' saying that the received argument is not a constant.
+throwNotAConstant
+    :: (MonadError (ErrorWithCause err term) m, AsUnliftingError err)
+    => term -> m r
+throwNotAConstant = throwingWithCause _UnliftingError "Not a constant" . Just
+
 class AsConstant term where
-    -- | Unwrap a shallowly embedded Haskell value from a @term@ or fail.
-    asConstant :: term -> Maybe (Some (ValueOf (UniOf term)))
+    -- | Unlift from the 'Constant' constructor throwing an 'UnliftingError' if the provided @term@
+    -- is not a 'Constant'.
+    asConstant
+        :: (MonadError (ErrorWithCause err term) m, AsUnliftingError err)
+        => term -> m (Some (ValueOf (UniOf term)))
 
 class FromConstant term where
     -- | Wrap a Haskell value as a @term@.
     fromConstant :: Some (ValueOf (UniOf term)) -> term
 
 instance AsConstant (Term TyName Name uni fun ann) where
-    asConstant (Constant _ val) = Just val
-    asConstant _                = Nothing
-
-instance (Closed uni, uni `Everywhere` ExMemoryUsage) =>
-            FromConstant (Term tyname name uni fun ExMemory) where
-    fromConstant value = Constant (memoryUsage value) value
+    asConstant (Constant _ val) = pure val
+    asConstant term             = throwNotAConstant term
 
 instance FromConstant (Term tyname name uni fun ()) where
     fromConstant = Constant ()
@@ -387,16 +393,6 @@ type HasConstant term = (AsConstant term, FromConstant term)
 -- and connects @term@ and its @uni@.
 type HasConstantIn uni term = (UniOf term ~ uni, HasConstant term)
 
--- | Unlift from the 'Constant' constructor throwing an 'UnliftingError' if the provided @term@
--- is not a 'Constant'.
-unliftSomeValue
-    :: (MonadError (ErrorWithCause err term) m, AsUnliftingError err, AsConstant term)
-    => term -> m (Some (ValueOf (UniOf term)))
-unliftSomeValue term =
-    case asConstant term of
-        Nothing  -> throwingWithCause _UnliftingError "Not a constant" $ Just term
-        Just val -> pure val
-
 class KnownTypeAst uni (a :: k) where
     -- | The type representing @a@ used on the PLC side.
     toTypeAst :: proxy a -> Type TyName uni ()
@@ -445,7 +441,7 @@ class KnownTypeAst (UniOf term) a => KnownType term a where
            )
         => term -> m a
     readKnown term = do
-        Some (ValueOf uniAct x) <- unliftSomeValue term
+        Some (ValueOf uniAct x) <- asConstant term
         let uniExp = knownUni @_ @(UniOf term) @a
         case uniAct `geq` uniExp of
             Just Refl -> pure x
@@ -499,7 +495,7 @@ instance (uni ~ uni', KnownTypeAst uni rep) => KnownTypeAst uni (SomeConstant un
 instance (HasConstantIn uni term, KnownTypeAst uni rep) =>
             KnownType term (SomeConstant uni rep) where
     makeKnown = pure . fromConstant . unSomeConstant
-    readKnown = fmap SomeConstant . unliftSomeValue
+    readKnown = fmap SomeConstant . asConstant
 
 {- | 'SomeConstantOf' is similar to 'SomeConstant': while the latter is for unlifting any
 constants, the former is for unlifting constants of a specific polymorphic built-in type
@@ -564,7 +560,7 @@ instance (KnownBuiltinTypeIn uni term f, All (KnownTypeAst uni) reps, HasUniAppl
     makeKnown = pure . fromConstant . runSomeConstantOf
 
     readKnown term = do
-        Some (ValueOf uni xs) <- unliftSomeValue term
+        Some (ValueOf uni xs) <- asConstant term
         let uniF = knownUni @_ @_ @f
             err = fromString $ concat
                 [ "Type mismatch: "

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs

@@ -30,7 +30,6 @@ import           PlutusPrelude
 
 import           PlutusCore.Constant
 import           PlutusCore.Core
-import           PlutusCore.Evaluation.Machine.ExBudget
 import           PlutusCore.Evaluation.Machine.Exception
 import           PlutusCore.Evaluation.Result
 import           PlutusCore.Name
@@ -130,11 +129,8 @@ instance FromConstant (CkValue uni fun) where
     fromConstant = VCon
 
 instance AsConstant (CkValue uni fun) where
-    asConstant (VCon val) = Just val
-    asConstant _          = Nothing
-
-instance ToExMemory (CkValue uni fun) where
-    toExMemory _ = 0
+    asConstant (VCon val) = pure val
+    asConstant term       = throwNotAConstant term
 
 data Frame uni fun
     = FrameApplyFun (CkValue uni fun)                       -- ^ @[V _]@
@@ -306,7 +302,7 @@ applyEvaluate
     -> CkValue uni fun
     -> CkM uni fun s (Term TyName Name uni fun ())
 applyEvaluate stack (VLamAbs name _ body) arg = stack |> substituteDb name (ckValueToTerm arg) body
-applyEvaluate stack (VBuiltin term (BuiltinRuntime sch f exF)) arg = do
+applyEvaluate stack (VBuiltin term (BuiltinRuntime sch f _)) arg = do
     let term' = Apply () term $ ckValueToTerm arg
     case sch of
         -- It's only possible to apply a builtin application if the builtin expects a term
@@ -316,7 +312,8 @@ applyEvaluate stack (VBuiltin term (BuiltinRuntime sch f exF)) arg = do
             -- than a 'Term', hence 'withErrorDischarging'.
             let dischargeError = hoist $ withExceptT $ mapCauseInMachineException ckValueToTerm
             x <- dischargeError $ readKnown arg
-            let runtime' = BuiltinRuntime schB (f x) . exF $ toExMemory arg
+            let noCosting = error "The CK machine does not support costing"
+                runtime' = BuiltinRuntime schB (f x) noCosting
             res <- evalBuiltinApp term' runtime'
             stack <| res
         _ ->

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs

@@ -137,7 +137,6 @@ possible to adjust them at runtime.
 
 module PlutusCore.Evaluation.Machine.ExBudget
     ( ExBudget(..)
-    , ToExMemory(..)
     , ExBudgetBuiltin(..)
     , ExRestrictingBudget(..)
     , enormousBudget
@@ -146,26 +145,12 @@ where
 
 import           PlutusPrelude                          hiding (toList)
 
-import           PlutusCore.Core
-import           PlutusCore.Name
-
 import           Data.Semigroup
 import           Data.Text.Prettyprint.Doc
 import           Deriving.Aeson
 import           Language.Haskell.TH.Lift               (Lift)
 import           PlutusCore.Evaluation.Machine.ExMemory
 
-class ToExMemory term where
-    -- | Get the 'ExMemory' of a @term@. If the @term@ is not annotated with 'ExMemory', then
-    -- return something arbitrary just to fit such a term into the builtin application machinery.
-    toExMemory :: term -> ExMemory
-
-instance ToExMemory (Term TyName Name uni fun ()) where
-    toExMemory _ = 0
-
-instance ToExMemory (Term TyName Name uni fun ExMemory) where
-    toExMemory = termAnn
-
 -- | A class for injecting a 'Builtin' into an @exBudgetCat@.
 -- We need it, because the constant application machinery calls 'spendBudget' before reducing a
 -- constant application and we want to be general over @exBudgetCat@ there, but still track the

plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs

@@ -25,7 +25,7 @@ import           PlutusPrelude
 
 import           PlutusCore          (Kind, Name, TyName, Type (..))
 import qualified PlutusCore          as PLC
-import           PlutusCore.Constant (AsConstant (..), FromConstant (..))
+import           PlutusCore.Constant (AsConstant (..), FromConstant (..), throwNotAConstant)
 import           PlutusCore.Core     (UniOf)
 import           PlutusCore.Flat     ()
 import           PlutusCore.MkPlc    (Def (..), TermLike (..), TyVarDecl (..), VarDecl (..))
@@ -148,11 +148,11 @@ data Term tyname name uni fun a =
 type instance UniOf (Term tyname name uni fun ann) = uni
 
 instance AsConstant (Term tyname name uni fun ann) where
-    asConstant (Constant _ val) = Just val
-    asConstant _                = Nothing
+    asConstant (Constant _ val) = pure val
+    asConstant term             = throwNotAConstant term
 
 instance FromConstant (Term tyname name uni fun ()) where
-    fromConstant value = Constant () value
+    fromConstant = Constant ()
 
 instance ( PLC.Closed uni
          , uni `PLC.Everywhere` Flat

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs

@@ -25,7 +25,6 @@ import           PlutusPrelude
 
 import qualified PlutusCore.Constant                    as TPLC
 import qualified PlutusCore.Core                        as TPLC
-import           PlutusCore.Evaluation.Machine.ExBudget
 import           PlutusCore.Evaluation.Machine.ExMemory
 import           PlutusCore.MkPlc
 import qualified PlutusCore.Name                        as TPLC
@@ -78,21 +77,15 @@ instance TermLike (Term name uni fun) TPLC.TyName name uni fun where
     error    = \ann _ -> Error ann
 
 instance TPLC.AsConstant (Term name uni fun ann) where
-    asConstant (Constant _ val) = Just val
-    asConstant _                = Nothing
+    asConstant (Constant _ val) = pure val
+    asConstant term             = TPLC.throwNotAConstant term
 
 instance TPLC.FromConstant (Term name uni fun ()) where
     fromConstant = Constant ()
 
 type instance TPLC.HasUniques (Term name uni fun ann) = TPLC.HasUnique name TPLC.TermUnique
 type instance TPLC.HasUniques (Program name uni fun ann) = TPLC.HasUniques (Term name uni fun ann)
 
-instance ToExMemory (Term name uni fun ()) where
-    toExMemory _ = 0
-
-instance ToExMemory (Term name uni fun ExMemory) where
-    toExMemory = termAnn
-
 deriving via GenericExMemoryUsage (Term name uni fun ann) instance
     ( ExMemoryUsage name, ExMemoryUsage fun, ExMemoryUsage ann
     , Closed uni, uni `Everywhere` ExMemoryUsage

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/HOAS.hs

@@ -60,8 +60,8 @@ data HTerm m name uni fun ann
 type instance UniOf (HTerm m name uni fun ann) = uni
 
 instance AsConstant (HTerm m name uni fun ann) where
-    asConstant (HConstant _ val) = Just val
-    asConstant _                 = Nothing
+    asConstant (HConstant _ val) = pure val
+    asConstant term              = throwNotAConstant term
 
 instance FromConstant (HTerm m name uni fun ()) where
     fromConstant = HConstant ()

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs

@@ -507,18 +507,11 @@ instance (Closed uni, GShow uni, uni `Everywhere` PrettyConst, Pretty fun) =>
 type instance UniOf (CekValue uni fun) = uni
 
 instance FromConstant (CekValue uni fun) where
-    fromConstant val = VCon val
+    fromConstant = VCon
 
 instance AsConstant (CekValue uni fun) where
-    asConstant (VCon val) = Just val
-    asConstant _          = Nothing
-
-instance (Closed uni, uni `Everywhere` ExMemoryUsage) => ToExMemory (CekValue uni fun) where
-    toExMemory = \case
-        VCon c      -> memoryUsage c
-        VDelay {}   -> 1
-        VLamAbs {}  -> 1
-        VBuiltin {} -> 1
+    asConstant (VCon val) = pure val
+    asConstant term       = throwNotAConstant term
 
 data Frame uni fun
     = FrameApplyFun (CekValue uni fun)                         -- ^ @[V _]@
@@ -528,6 +521,15 @@ data Frame uni fun
 
 type Context uni fun = [Frame uni fun]
 
+toExMemory :: (Closed uni, uni `Everywhere` ExMemoryUsage) => CekValue uni fun -> ExMemory
+toExMemory = \case
+    VCon c      -> memoryUsage c
+    VDelay {}   -> 1
+    VLamAbs {}  -> 1
+    VBuiltin {} -> 1
+{-# INLINE toExMemory #-}  -- It probably gets inlined anyway, but an explicit pragma
+                           -- shouldn't hurt.
+
 -- | A 'MonadError' version of 'try'.
 tryError :: MonadError e m => m a -> m (Either e a)
 tryError a = (Right <$> a) `catchError` (pure . Left)
@@ -721,6 +723,8 @@ enterComputeCek = computeCek (toWordArray 0) where
                 -- than a 'Term', hence 'withCekValueErrors'.
                 x <- withCekValueErrors $ readKnown arg
                 -- TODO: should we bother computing that 'ExMemory' eagerly? We may not need it.
+                -- We pattern match on @arg@ twice: in 'readKnown' and in 'toExMemory'.
+                -- Maybe we could fuse the two?
                 let runtime' = BuiltinRuntime schB (f x) . exF $ toExMemory arg
                 res <- evalBuiltinApp fun term' env runtime'
                 returnCek unbudgetedSteps ctx res