From 1c973b26282c748b27e971e219d4f861f0430c4b Mon Sep 17 00:00:00 2001 From: effectfully Date: Thu, 20 Oct 2022 00:44:08 +0200 Subject: [PATCH] [Builtins] [Evaluation] Drop lookups --- .../src/PlutusCore/Builtin/Meaning.hs | 15 ++++++---- .../src/PlutusCore/Builtin/Runtime.hs | 22 ++++++-------- .../src/PlutusCore/Evaluation/Machine/Ck.hs | 30 +++++++------------ .../Evaluation/Machine/Cek.hs | 17 +++++------ .../Evaluation/Machine/Cek/Internal.hs | 7 ++--- 5 files changed, 40 insertions(+), 51 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index f69cd3801a9..27f8eb203ca 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs @@ -31,11 +31,12 @@ import PlutusCore.Evaluation.Machine.ExBudget import PlutusCore.Evaluation.Machine.ExMemory import PlutusCore.Name +import Control.DeepSeq import Data.Array import Data.Kind qualified as GHC import Data.Proxy import Data.Some.GADT -import GHC.Exts (inline, oneShot) +import GHC.Exts (inline, lazy, oneShot) import GHC.TypeLits -- | Turn a list of Haskell types @args@ into a functional type ending in @res@. @@ -381,10 +382,10 @@ instance BuiltinRuntimeOptions -- See Note [Optimizations of runCostingFun*] for why we use strict @case@. { _broImmediateF = - \cost -> case toExF cost of + \cost -> lazy $ case toExF cost of !exF -> toPolyImmediateF @binds @val @args @res (f, exF) , _broDeferredF = - \cost -> case toExF cost of + \cost -> lazy $ case toExF cost of !exF -> toPolyDeferredF @binds @val @args @res $ pure (f, exF) } {-# INLINE makeBuiltinMeaning #-} @@ -402,7 +403,9 @@ toBuiltinsRuntime :: (cost ~ CostingPart uni fun, ToBuiltinMeaning uni fun, HasMeaningIn uni val) => BuiltinVersion fun -> UnliftingMode -> cost -> BuiltinsRuntime fun val toBuiltinsRuntime ver unlMode cost = - let arr = tabulateArray $ toBuiltinRuntime unlMode cost . inline toBuiltinMeaning ver - in -- Force array elements to WHNF - foldr seq (BuiltinsRuntime arr) arr + let runtime = BuiltinsRuntime $ toBuiltinRuntime unlMode cost . inline toBuiltinMeaning ver + {-# INLINE runtime #-} + -- Force array elements to WHNF. Inlining 'force' manually, since it doesn't have an + -- @INLINE@ pragma. + in runtime `deepseq` runtime {-# INLINE toBuiltinsRuntime #-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs index c3d90de695c..b5113e20031 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs @@ -4,14 +4,12 @@ module PlutusCore.Builtin.Runtime where +import PlutusPrelude + import PlutusCore.Builtin.KnownType import PlutusCore.Evaluation.Machine.ExBudget -import PlutusCore.Evaluation.Machine.Exception import Control.DeepSeq -import Control.Lens (ix, (^?)) -import Control.Monad.Except -import Data.Array import NoThunks.Class -- | A 'BuiltinRuntime' represents a possibly partial builtin application. @@ -93,20 +91,18 @@ instance NFData (BuiltinRuntime val) where -- 'BuiltinRuntime' in an array, but we've tried it and it was much slower as we do rely on caching -- (especially for costing). newtype BuiltinsRuntime fun val = BuiltinsRuntime - { unBuiltinRuntime :: Array fun (BuiltinRuntime val) + { unBuiltinRuntime :: fun -> BuiltinRuntime val } -deriving newtype instance (NFData fun) => NFData (BuiltinsRuntime fun val) +instance (Bounded fun, Enum fun) => NFData (BuiltinsRuntime fun val) where + rnf (BuiltinsRuntime env) = foldr (\fun res -> env fun `seq` res) () enumerate instance NoThunks (BuiltinsRuntime fun val) where - wNoThunks ctx (BuiltinsRuntime arr) = allNoThunks (noThunks ctx <$> elems arr) + wNoThunks ctx (BuiltinsRuntime env) = noThunks ctx env showTypeOf = const "PlutusCore.Builtin.Runtime.BuiltinsRuntime" -- | Look up the runtime info of a built-in function during evaluation. -lookupBuiltin - :: (MonadError (ErrorWithCause err cause) m, AsMachineError err fun, Ix fun) - => fun -> BuiltinsRuntime fun val -> m (BuiltinRuntime val) +lookupBuiltin :: fun -> BuiltinsRuntime fun val -> BuiltinRuntime val -- @Data.Array@ doesn't seem to have a safe version of @(!)@, hence we use a prism. -lookupBuiltin fun (BuiltinsRuntime env) = case env ^? ix fun of - Nothing -> throwingWithCause _MachineError (UnknownBuiltin fun) Nothing - Just runtime -> pure runtime +lookupBuiltin fun (BuiltinsRuntime env) = env fun +{-# INLINE lookupBuiltin #-} 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 ba31fd44a81..8133cb90823 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs @@ -39,7 +39,6 @@ import PlutusCore.Pretty (PrettyConfigPlc, PrettyConst) import Control.Monad.Except import Control.Monad.Reader import Control.Monad.ST -import Data.Array import Data.DList (DList) import Data.DList qualified as DList import Data.STRef @@ -223,8 +222,7 @@ substTyInTy tn0 ty0 = go where -- > s ▷ con cn ↦ s ◁ con cn -- > s ▷ error A ↦ ◆ (|>) - :: Ix fun - => Context uni fun -> Term TyName Name uni fun () -> CkM uni fun s (Term TyName Name uni fun ()) + :: Context uni fun -> Term TyName Name uni fun () -> CkM uni fun s (Term TyName Name uni fun ()) stack |> TyInst _ fun ty = FrameTyInstArg ty : stack |> fun stack |> Apply _ fun arg = FrameApplyArg arg : stack |> fun stack |> IWrap _ pat arg term = FrameIWrap pat arg : stack |> term @@ -232,7 +230,7 @@ stack |> Unwrap _ term = FrameUnwrap : stack |> term stack |> TyAbs _ tn k term = stack <| VTyAbs tn k term stack |> LamAbs _ name ty body = stack <| VLamAbs name ty body stack |> Builtin _ bn = do - runtime <- asksM $ lookupBuiltin bn . ckEnvRuntime + runtime <- lookupBuiltin bn . ckEnvRuntime <$> ask stack <| VBuiltin (Builtin () bn) runtime stack |> Constant _ val = stack <| VCon val _ |> Error{} = @@ -253,8 +251,7 @@ _ |> var@Var{} = -- > s , (wrap α S _) ◁ V ↦ s ◁ wrap α S V -- > s , (unwrap _) ◁ wrap α A V ↦ s ◁ V (<|) - :: Ix fun - => Context uni fun -> CkValue uni fun -> CkM uni fun s (Term TyName Name uni fun ()) + :: Context uni fun -> CkValue uni fun -> CkM uni fun s (Term TyName Name uni fun ()) [] <| val = pure $ ckValueToTerm val FrameTyInstArg ty : stack <| fun = instantiateEvaluate stack ty fun FrameApplyArg arg : stack <| fun = FrameApplyFun fun : stack |> arg @@ -271,8 +268,7 @@ FrameUnwrap : stack <| wrapped = case wrapped of -- 'TyInst' on top of its 'Term' representation depending on whether the application is saturated or -- not. In any other case, fail. instantiateEvaluate - :: Ix fun - => Context uni fun + :: Context uni fun -> Type TyName uni () -> CkValue uni fun -> CkM uni fun s (Term TyName Name uni fun ()) @@ -296,8 +292,7 @@ instantiateEvaluate _ _ val = -- and either calculate the builtin application or stick a 'Apply' on top of its 'Term' -- representation depending on whether the application is saturated or not. applyEvaluate - :: Ix fun - => Context uni fun + :: Context uni fun -> CkValue uni fun -> CkValue uni fun -> CkM uni fun s (Term TyName Name uni fun ()) @@ -319,8 +314,7 @@ applyEvaluate _ val _ = throwingWithCause _MachineError NonFunctionalApplicationMachineError $ Just $ ckValueToTerm val runCk - :: Ix fun - => BuiltinsRuntime fun (CkValue uni fun) + :: BuiltinsRuntime fun (CkValue uni fun) -> Bool -> Term TyName Name uni fun () -> (Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()), [Text]) @@ -328,16 +322,14 @@ runCk runtime emitting term = runCkM runtime emitting $ [] |> term -- | Evaluate a term using the CK machine with logging enabled. evaluateCk - :: Ix fun - => BuiltinsRuntime fun (CkValue uni fun) + :: BuiltinsRuntime fun (CkValue uni fun) -> Term TyName Name uni fun () -> (Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()), [Text]) evaluateCk runtime = runCk runtime True -- | Evaluate a term using the CK machine with logging disabled. evaluateCkNoEmit - :: Ix fun - => BuiltinsRuntime fun (CkValue uni fun) + :: BuiltinsRuntime fun (CkValue uni fun) -> Term TyName Name uni fun () -> Either (CkEvaluationException uni fun) (Term TyName Name uni fun ()) evaluateCkNoEmit runtime = fst . runCk runtime False @@ -346,7 +338,7 @@ evaluateCkNoEmit runtime = fst . runCk runtime False unsafeEvaluateCk :: ( Pretty (SomeTypeIn uni), Closed uni , Typeable uni, Typeable fun, uni `Everywhere` PrettyConst - , Pretty fun, Ix fun + , Pretty fun ) => BuiltinsRuntime fun (CkValue uni fun) -> Term TyName Name uni fun () @@ -357,7 +349,7 @@ unsafeEvaluateCk runtime = first unsafeExtractEvaluationResult . evaluateCk runt unsafeEvaluateCkNoEmit :: ( Pretty (SomeTypeIn uni), Closed uni , Typeable uni, Typeable fun, uni `Everywhere` PrettyConst - , Pretty fun, Ix fun + , Pretty fun ) => BuiltinsRuntime fun (CkValue uni fun) -> Term TyName Name uni fun () @@ -366,7 +358,7 @@ unsafeEvaluateCkNoEmit runtime = unsafeExtractEvaluationResult . evaluateCkNoEmi -- | Unlift a value using the CK machine. readKnownCk - :: (Ix fun, ReadKnown (Term TyName Name uni fun ()) a) + :: ReadKnown (Term TyName Name uni fun ()) a => BuiltinsRuntime fun (CkValue uni fun) -> Term TyName Name uni fun () -> Either (CkEvaluationException uni fun) a diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs index b7ea250e415..e987846bbbe 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs @@ -72,7 +72,6 @@ import PlutusCore.Quote import Control.Monad.Except import Control.Monad.State import Data.Bifunctor -import Data.Ix (Ix) import Data.Text (Text) import Universe @@ -92,7 +91,7 @@ A wrapper around the internal runCek to debruijn input and undebruijn output. *THIS FUNCTION IS PARTIAL if the input term contains free variables* -} runCek - :: (Ix fun, PrettyUni uni fun) + :: PrettyUni uni fun => MachineParameters CekMachineCosts CekValue uni fun -> ExBudgetMode cost uni fun -> EmitterMode uni fun @@ -123,7 +122,7 @@ runCek params mode emitMode term = -- | Evaluate a term using the CEK machine with logging disabled and keep track of costing. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* runCekNoEmit - :: (Ix fun, PrettyUni uni fun) + :: PrettyUni uni fun => MachineParameters CekMachineCosts CekValue uni fun -> ExBudgetMode cost uni fun -> Term Name uni fun () @@ -139,7 +138,7 @@ May throw a 'CekMachineException'. unsafeRunCekNoEmit :: ( Pretty (SomeTypeIn uni), Typeable uni , Closed uni, uni `Everywhere` PrettyConst - , Ix fun, Pretty fun, Typeable fun + , Pretty fun, Typeable fun ) => MachineParameters CekMachineCosts CekValue uni fun -> ExBudgetMode cost uni fun @@ -152,7 +151,7 @@ unsafeRunCekNoEmit params mode = -- | Evaluate a term using the CEK machine with logging enabled. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* evaluateCek - :: (Ix fun, PrettyUni uni fun) + :: PrettyUni uni fun => EmitterMode uni fun -> MachineParameters CekMachineCosts CekValue uni fun -> Term Name uni fun () @@ -164,7 +163,7 @@ evaluateCek emitMode params = -- | Evaluate a term using the CEK machine with logging disabled. -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* evaluateCekNoEmit - :: (Ix fun, PrettyUni uni fun) + :: PrettyUni uni fun => MachineParameters CekMachineCosts CekValue uni fun -> Term Name uni fun () -> Either (CekEvaluationException Name uni fun) (Term Name uni fun ()) @@ -175,7 +174,7 @@ evaluateCekNoEmit params = fst . runCekNoEmit params restrictingEnormous unsafeEvaluateCek :: ( Pretty (SomeTypeIn uni), Typeable uni , Closed uni, uni `Everywhere` PrettyConst - , Ix fun, Pretty fun, Typeable fun + , Pretty fun, Typeable fun ) => EmitterMode uni fun -> MachineParameters CekMachineCosts CekValue uni fun @@ -190,7 +189,7 @@ unsafeEvaluateCek emitTime params = unsafeEvaluateCekNoEmit :: ( Pretty (SomeTypeIn uni), Typeable uni , Closed uni, uni `Everywhere` PrettyConst - , Ix fun, Pretty fun, Typeable fun + , Pretty fun, Typeable fun ) => MachineParameters CekMachineCosts CekValue uni fun -> Term Name uni fun () @@ -201,7 +200,7 @@ unsafeEvaluateCekNoEmit params = unsafeExtractEvaluationResult . evaluateCekNoEm -- *THIS FUNCTION IS PARTIAL if the input term contains free variables* readKnownCek :: ( ReadKnown (Term Name uni fun ()) a - , Ix fun, PrettyUni uni fun + , PrettyUni uni fun ) => MachineParameters CekMachineCosts CekValue uni fun -> Term Name uni fun () 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 adc0b5b8d35..d81c87e93fc 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 @@ -73,7 +73,6 @@ import Control.Monad.Catch import Control.Monad.Except import Control.Monad.ST import Control.Monad.ST.Unsafe -import Data.Array hiding (index) import Data.DList (DList) import Data.Hashable (Hashable) import Data.Kind qualified as GHC @@ -597,7 +596,7 @@ evalBuiltinApp fun term runtime = case runtime of -- | The entering point to the CEK machine's engine. enterComputeCek :: forall uni fun s - . (Ix fun, PrettyUni uni fun, GivenCekReqs uni fun s) + . (PrettyUni uni fun, GivenCekReqs uni fun s) => Context uni fun -> CekValEnv uni fun -> Term NamedDeBruijn uni fun () @@ -642,7 +641,7 @@ enterComputeCek = computeCek (toWordArray 0) where -- s ; ρ ▻ builtin bn ↦ s ◅ builtin bn arity arity [] [] ρ computeCek !unbudgetedSteps !ctx !_ term@(Builtin _ bn) = do !unbudgetedSteps' <- stepAndMaybeSpend BBuiltin unbudgetedSteps - meaning <- lookupBuiltin bn ?cekRuntime + let meaning = lookupBuiltin bn ?cekRuntime -- The @term@ is a 'Builtin', so it's fully discharged. returnCek unbudgetedSteps' ctx (VBuiltin bn term meaning) -- s ; ρ ▻ error A ↦ <> A @@ -771,7 +770,7 @@ enterComputeCek = computeCek (toWordArray 0) where -- See Note [Compilation peculiarities]. -- | Evaluate a term using the CEK machine and keep track of costing, logging is optional. runCekDeBruijn - :: (Ix fun, PrettyUni uni fun) + :: PrettyUni uni fun => MachineParameters CekMachineCosts CekValue uni fun -> ExBudgetMode cost uni fun -> EmitterMode uni fun