Skip to content

Commit

Permalink
[Builtins] [Evaluation] Drop lookups
Browse files Browse the repository at this point in the history
  • Loading branch information
@effectfully
effectfully committed Jan 20, 2023
1 parent 10008be commit 9c119e4
Show file tree
Hide file tree
Showing 6 changed files with 86 additions and 68 deletions.
46 changes: 34 additions & 12 deletions plutus-core/plutus-core/src/PlutusCore/Builtin/Meaning.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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@.
Expand Down Expand Up @@ -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
Expand All @@ -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.
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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.
Expand All @@ -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 #-}
46 changes: 26 additions & 20 deletions plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -55,25 +53,33 @@ instance NFData (BuiltinRuntime val) where
-- this to WHNF to get it forced to NF.
rnf = rwhnf

-- | A 'BuiltinRuntime' for each builtin from a set of builtins. Just an 'Array' of cached
-- 'BuiltinRuntime's. We could instantiate 'BuiltinMeaning' on the fly and avoid caching
-- '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)
-- | A @data@ wrapper around a function returning the 'BuiltinRuntime' of a built-in function.
-- We use @data@ rather than @newtype@, because GHC is able to see through @newtype@s and may break
-- carefully set up optimizations, see
-- https://github.com/input-output-hk/plutus/pull/4914#issuecomment-1396306606
--
-- Using @data@ may make things more expensive, however it was verified at the time of writing that
-- the wrapper is removed before the CEK machine starts, leaving the stored function to be used
-- directly.
--
-- In order for lookups to be efficient the 'BuiltinRuntime's need to be cached, i.e. pulled out
-- of the function statically. See 'makeBuiltinMeaning' for how we achieve that.
data BuiltinsRuntime fun val = BuiltinsRuntime
{ unBuiltinsRuntime :: 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 #-}
30 changes: 11 additions & 19 deletions plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/Ck.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -169,16 +168,15 @@ 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
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{} =
Expand All @@ -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
Expand All @@ -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 ())
Expand All @@ -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 ())
Expand All @@ -266,25 +261,22 @@ 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])
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
Expand All @@ -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 ()
Expand All @@ -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 ()
Expand All @@ -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
Expand Down
6 changes: 3 additions & 3 deletions plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters/Default.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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.
17 changes: 8 additions & 9 deletions plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand All @@ -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 ann
-> ExBudgetMode cost uni fun
-> EmitterMode uni fun
Expand Down Expand Up @@ -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 ann
-> ExBudgetMode cost uni fun
-> Term Name uni fun ann
Expand All @@ -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 ann
-> ExBudgetMode cost uni fun
Expand All @@ -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 ann
-> Term Name uni fun ann
Expand All @@ -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 ann
-> Term Name uni fun ann
-> Either (CekEvaluationException Name uni fun) (Term Name uni fun ())
Expand All @@ -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 ann
Expand All @@ -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 ann
-> Term Name uni fun ann
Expand All @@ -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 ann
-> Term Name uni fun ann
Expand Down
9 changes: 4 additions & 5 deletions plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/Internal.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -78,7 +78,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
Expand Down Expand Up @@ -602,7 +601,7 @@ evalBuiltinApp fun term runtime = case runtime of
-- | The entering point to the CEK machine's engine.
enterComputeCek
:: forall uni fun ann s
. (Ix fun, PrettyUni uni fun, GivenCekReqs uni fun ann s)
. (PrettyUni uni fun, GivenCekReqs uni fun ann s)
=> Context uni fun ann
-> CekValEnv uni fun ann
-> Term NamedDeBruijn uni fun ann
Expand Down Expand Up @@ -647,8 +646,8 @@ enterComputeCek = computeCek (toWordArray 0) where
-- s ; ρ ▻ builtin bn ↦ s ◅ builtin bn arity arity [] [] ρ
computeCek !unbudgetedSteps !ctx !_ (Builtin _ bn) = do
!unbudgetedSteps' <- stepAndMaybeSpend BBuiltin unbudgetedSteps
meaning <- lookupBuiltin bn ?cekRuntime
-- The term is a 'Builtin', so it's fully discharged.
let meaning = lookupBuiltin bn ?cekRuntime
-- 'Builtin' is fully discharged.
returnCek unbudgetedSteps' ctx (VBuiltin bn (Builtin () bn) meaning)
-- s ; ρ ▻ error A ↦ <> A
computeCek !_ !_ !_ (Error _) =
Expand Down Expand Up @@ -774,7 +773,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 ann
-> ExBudgetMode cost uni fun
-> EmitterMode uni fun
Expand Down

0 comments on commit 9c119e4

Please sign in to comment.