[Builtins] [Evaluation] Drop lookups

IntersectMBO · Oct 19, 2022 · 1c973b2 · 1c973b2
1 parent 179eecc
commit 1c973b2
Show file tree

Hide file tree

Showing 5 changed files with 40 additions and 51 deletions.
diff --git 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
@@ -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
@@ -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,16 +222,15 @@ 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
 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,25 +314,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
@@ -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
@@ -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
@@ -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