diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs index 79e45cb1e9c..e78449d285b 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@. @@ -126,7 +127,7 @@ denotation is. 'KnownPolytype' and 'KnownMonotype' are responsible for deriving polymorphic and monomorphic types, respectively. -'KnownPolytype' turns every bound variable into a 'TypeSchemeAll'/'RuntimeSchemeAll'. We extract +'KnownPolytype' turns every bound variable into a 'TypeSchemeAll'/'BuiltinExpectForce'. We extract variables from the type of the Haskell denotation using the 'ToBinds' associated type family. Variables are collected in the order that they appear in (i.e. just like in Haskell). For example, processing a type like @@ -141,7 +142,7 @@ with 'ToBinds' results in the following list of bindings: '[ 'Some ('TyNameRep "b" 1), 'Some ('TyNameRep "a" 0) ] 'KnownMonotype' turns every argument that the Haskell denotation of a builtin receives into a -'TypeSchemeArrow'/'RuntimeSchemeArrow'. We extract the arguments from the type of the Haskell +'TypeSchemeArrow'/'BuiltinExpectArgument'. We extract the arguments from the type of the Haskell denotation using the 'GetArgs' type family. Higher-kinded type variables are fully supported. @@ -261,7 +262,7 @@ instance -- Ironically computing the unlifted value strictly is the best way of doing deferred -- unlifting. This means that while the resulting 'ReadKnownM' is only handled upon full -- saturation and any evaluation failure is only registered when the whole builtin - -- application is evaluated. + -- application is evaluated, a Haskell exception will occur immediately. -- It shouldn't matter though, because a builtin is not supposed to throw an -- exception at any stage, that would be a bug regardless. toMonoF @val @args @res $! do @@ -343,11 +344,17 @@ instance , ElaborateFromTo 0 j val a, KnownPolytype binds val args res ) => MakeBuiltinMeaning a val where makeBuiltinMeaning f toExF = - BuiltinMeaning (knownPolytype @binds @val @args @res) f $ - -- See Note [Optimizations of runCostingFun*] for why we use strict @case@. - \cost -> - case toExF cost of - !exF -> toPolyF @binds @val @args @res $ pure (f, exF) + BuiltinMeaning (knownPolytype @binds @val @args @res) f $ \cost -> + -- In order to make the 'BuiltinRuntime' of a builtin cacheable we need to tell GHC to + -- create a thunk for it, which we achieve by applying 'lazy' to the 'BuiltinRuntime' + -- here. + -- + -- Those thunks however require a lot of care to be properly shared rather than + -- recreated every time a builtin application is evaluated, see 'toBuiltinsRuntime' for + -- how we sort it out. + lazy $ case toExF cost of + -- See Note [Optimizations of runCostingFun*] for why we use strict @case@. + !exF -> toPolyF @binds @val @args @res $ pure (f, exF) {-# INLINE makeBuiltinMeaning #-} -- | Convert a 'BuiltinMeaning' to a 'BuiltinRuntime' given a cost model. @@ -362,7 +369,22 @@ toBuiltinsRuntime :: (cost ~ CostingPart uni fun, ToBuiltinMeaning uni fun, HasMeaningIn uni val) => BuiltinVersion fun -> cost -> BuiltinsRuntime fun val toBuiltinsRuntime ver cost = - let arr = tabulateArray $ toBuiltinRuntime cost . inline toBuiltinMeaning ver - in -- Force array elements to WHNF - foldr seq (BuiltinsRuntime arr) arr + let runtime = BuiltinsRuntime $ toBuiltinRuntime cost . inline toBuiltinMeaning ver + {-# INLINE runtime #-} + -- Force array elements to WHNF. Inlining 'force' manually, since it doesn't have an @INLINE@ + -- pragma. This allows GHC to get to the 'NFData' instance for 'BuiltinsRuntime', which + -- forces all the freshly created 'BuiltinRuntime' thunks. Which is important, because the + -- thunks are behind a lambda binding the @cost@ variable and GHC would supply the @cost@ + -- value (the one that is in the current scope) at runtime, if we didn't tell it that the + -- thunks need to be forced early. Which would be detrimental to performance, since it would + -- mean that the thunks would be created at runtime over and over again, each time we go + -- under the lambda binding the @cost@ variable, i.e. each time the 'BuiltinRuntime' is + -- retrieved from the environment. The 'deepseq' nagging causes GHC to supply the @cost@ + -- value at compile time, thus allocating the thunks within this entire function allowing + -- them to be reused each time the 'BuiltinRuntime' is looked up (after the initial phase + -- forcing all of them at once). + -- + -- Note that despite @runtime@ being used twice, we don't get all the multiple thousands of + -- Core duplicated, because the 'BuiltinRuntime' thunks are shared in the two @runtime@s. + 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 c04d9ad1344..dff6c02f3af 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. @@ -60,20 +58,21 @@ 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 + -- Force every 'BuiltinRuntime' stored in the environment. + 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) +instance (Bounded fun, Enum fun) => NoThunks (BuiltinsRuntime fun val) where + -- Ensure that every 'BuiltinRuntime' doesn't contain thunks after forcing it initially + -- (we can't avoid the initial forcing, because we can't lookup the 'BuiltinRuntime' without + -- forcing it, see https://stackoverflow.com/q/63441862). + wNoThunks ctx (BuiltinsRuntime env) = allNoThunks $ map (wNoThunks ctx . env) enumerate 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) --- @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 fun val -> BuiltinRuntime val +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 5715812eb9e..1518ddd098f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs @@ -40,7 +40,6 @@ import PlutusCore.Subst 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 @@ -169,8 +168,7 @@ runCkM runtime emitting a = runST $ do -- > 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 @@ -178,7 +176,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{} = @@ -199,8 +197,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 @@ -217,8 +214,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 ()) @@ -244,8 +240,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 ()) @@ -266,8 +261,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]) @@ -275,16 +269,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 @@ -293,7 +285,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 () @@ -304,7 +296,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 () @@ -313,7 +305,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/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs index 53605f925f9..fff682dc241 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs @@ -45,6 +45,6 @@ mkMachineParametersFor :: (MonadError CostModelApplyError m) mkMachineParametersFor ver newCMP = inline mkMachineParameters ver <$> applyCostModelParams defaultCekCostModel newCMP --- {-# INLINE mkMachineParametersFor #-} was removed because [benchmarking --- results](https://github.com/input-output-hk/plutus/pull/4879#issuecomment-1301052379) show that --- the pragma isn't helping anymore. +-- Not marking this function with @INLINE@, since at this point everything we wanted to be inlined +-- is inlined and there's zero reason to duplicate thousands and thousands of lines of Core down +-- the line. 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 33c8f9f96a5..04efce947bf 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 @@ -769,7 +768,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