diff --git a/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs b/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs index c1cb770741d..50f8efeebf2 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs +++ b/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: " 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 e371c14cd1a..202688588c5 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs +++ b/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 _ -> diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs index 5cb7d30387c..32b8d37fc1f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs +++ b/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 diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs index 8a3ce40ba74..73c1633fe82 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs +++ b/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 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs index c69b7fcfe2e..9dda265eae0 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Type.hs +++ b/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,8 +77,8 @@ 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 () @@ -87,12 +86,6 @@ instance TPLC.FromConstant (Term name uni fun ()) where 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 diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/HOAS.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/HOAS.hs index 4b5c6c4ec73..5e016bf1f85 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/HOAS.hs +++ b/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 () 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 b384317b377..cc44ca8b224 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 @@ -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