Add cost model key to the schema and use it for caching

Author: Unisay

database/db.dbm

@@ -3,8 +3,8 @@
 CAUTION: Do not modify this file unless you know what you are doing.
  Unexpected results may occur if the code is changed deliberately.
 -->
-<dbmodel pgmodeler-ver="1.1.5" use-changelog="false" max-obj-count="18"
-	 last-position="147,221" last-zoom="1" scene-rect="0,0,1570.8,1076.8"
+<dbmodel pgmodeler-ver="1.1.6" use-changelog="false" max-obj-count="18"
+	 last-position="0,0" last-zoom="1" scene-rect="0,0,1570.8,1076.8"
 	 default-schema="public" default-owner="postgres"
 	 layers="Default layer"
 	 active-layers="0"
@@ -219,6 +219,7 @@ ORDER BY
   SEE.EVALUATED_SUCCESSFULLY,
   SEE.EXEC_BUDGET_CPU,
   SEE.EXEC_BUDGET_MEM,
+  CMP.PK AS COST_MODEL_KEY,
   CMP.PARAM_VALUES AS COST_MODEL_PARAM_VALUES,
   SEE.DATUM,
   SEE.REDEEMER,

database/db.sql

@@ -1,5 +1,5 @@
 -- Database generated with pgModeler (PostgreSQL Database Modeler).
--- pgModeler version: 1.1.4
+-- pgModeler version: 1.1.6
 -- PostgreSQL version: 16.0
 -- Project Site: pgmodeler.io
 -- Model Author: ---
@@ -191,6 +191,32 @@ COMMENT ON MATERIALIZED VIEW public.builtin_version_num_scripts IS E'For each co
 ALTER MATERIALIZED VIEW public.builtin_version_num_scripts OWNER TO "plutus-indexer";
 -- ddl-end --
 
+-- object: public.script_evaluations | type: VIEW --
+-- DROP VIEW IF EXISTS public.script_evaluations CASCADE;
+CREATE VIEW public.script_evaluations
+AS 
+SELECT
+  SEE.SLOT,
+  SEE.BLOCK,
+  SEE.EVALUATED_SUCCESSFULLY,
+  SEE.EXEC_BUDGET_CPU,
+  SEE.EXEC_BUDGET_MEM,
+  CMP.PK AS COST_MODEL_KEY,
+  CMP.PARAM_VALUES AS COST_MODEL_PARAM_VALUES,
+  SEE.DATUM,
+  SEE.REDEEMER,
+  SEE.SCRIPT_CONTEXT,
+  SS.LEDGER_LANGUAGE,
+  SS.MAJOR_PROTOCOL_VER,
+  SS.SERIALISED
+FROM
+  SCRIPT_EVALUATION_EVENTS AS SEE
+  JOIN SERIALISED_SCRIPTS SS ON SEE.SCRIPT_HASH = SS.HASH
+  JOIN COST_MODEL_PARAMS CMP ON SEE.COST_MODEL_PARAMS = CMP.PK;
+-- ddl-end --
+ALTER VIEW public.script_evaluations OWNER TO "plutus-admin";
+-- ddl-end --
+
 -- object: cost_model_params_fk | type: CONSTRAINT --
 -- ALTER TABLE public.script_evaluation_events DROP CONSTRAINT IF EXISTS cost_model_params_fk CASCADE;
 ALTER TABLE public.script_evaluation_events ADD CONSTRAINT cost_model_params_fk FOREIGN KEY (cost_model_params)
@@ -290,4 +316,16 @@ GRANT SELECT
    TO "plutus-indexer";
 -- ddl-end --
 
+-- object: grant_r_9fddb7f795 | type: PERMISSION --
+GRANT SELECT
+   ON TABLE public.script_evaluations
+   TO "plutus-reader";
+-- ddl-end --
+
+-- object: grant_r_e6b216ebea | type: PERMISSION --
+GRANT SELECT
+   ON TABLE public.script_evaluations
+   TO "plutus-admin";
+-- ddl-end --
+
 

plutus-script-evaluation/evaluate-scripts/Main.hs

@@ -1,3 +1,8 @@
+{- | This module contains the main entry point
+into the program which CEK-evaluates scripts using
+the information recorded in the database in a
+streaming fashion.
+-}
 module Main where
 
 import Control.Exception (bracket, catch)

plutus-script-evaluation/lib/Database/Query.hs

@@ -106,9 +106,8 @@ withScriptEvaluationEvents
 withScriptEvaluationEvents conn blockNo a f = do
   let startBlock = pgFromInteger (fromIntegral (unBlockNo blockNo))
       select = orderBy (asc seBlockNo) do
-        res@(MkScriptEvaluationRecord' _slot block _ _ _ _ _ _ _ _ _ _) <-
-          selectTable scriptEvaluations
-        where_ (block .>= startBlock)
+        res <- selectTable scriptEvaluations
+        where_ (seBlockNo res .>= startBlock)
         pure res
   withRunInIO \runInIO ->
     runSelectFold conn select a \accum record ->

plutus-script-evaluation/lib/Database/Schema.hs

@@ -169,6 +169,7 @@ data
     datum
     redeemer
     scriptContext
+    costModelKey
     costModel
     majorProtoVer
     ledgerLang
@@ -182,6 +183,7 @@ data
   , seDatum :: datum
   , seRedeemer :: redeemer
   , seScriptContext :: scriptContext
+  , seCostModelKey :: costModelKey
   , seCostModelParams :: costModel
   , seMajorProtocolVersion :: majorProtoVer
   , seLedgerLanguage :: ledgerLang
@@ -199,6 +201,7 @@ type ScriptEvaluationRecord =
     (Maybe ByteString) -- datum
     (Maybe ByteString) -- redeemer
     ByteString -- script_context
+    Hash64 -- cost_model_key
     [Int64] -- cost_model_params
     MajorProtocolVersion -- major_protocol_version
     PlutusLedgerLanguage -- ledger_language
@@ -210,10 +213,11 @@ type ScriptEvaluationRecordFields =
     (Field SqlBool) -- evaluated_successfully
     (Field SqlInt4) -- exec_budget_cpu
     (Field SqlInt4) -- exec_budget_mem
-    (Field SqlBytea) -- script_hash
+    (Field SqlBytea) -- script
     (FieldNullable SqlBytea) -- datum
     (FieldNullable SqlBytea) -- redeemer
     (Field SqlBytea) -- script_context
+    (Field SqlInt8) -- cost_model_params
     (Field (SqlArray SqlInt8)) -- cost_model_params
     (Field SqlInt2) -- major_protocol_version
     (Field SqlInt2) -- ledger_language
@@ -259,10 +263,11 @@ scriptEvaluations =
         , seEvaluatedSuccessfully = tableField "evaluated_successfully"
         , seExecBudgetCpu = tableField "exec_budget_cpu"
         , seExecBudgetMem = tableField "exec_budget_mem"
-        , seScript = tableField "serialised"
+        , seScript = tableField "script_serialised"
         , seDatum = tableField "datum"
         , seRedeemer = tableField "redeemer"
         , seScriptContext = tableField "script_context"
+        , seCostModelKey = tableField "cost_model_key"
         , seCostModelParams = tableField "cost_model_param_values"
         , seMajorProtocolVersion = tableField "major_protocol_ver"
         , seLedgerLanguage = tableField "ledger_language"

plutus-script-evaluation/lib/Evaluate.hs

@@ -9,10 +9,14 @@ import Control.Monad.Trans.Except (runExceptT)
 import Control.Monad.Trans.Writer (WriterT (runWriterT))
 import Data.ByteString qualified as BSL
 import Data.ByteString.Short qualified as BSS
+import Data.Digest.Murmur64 (Hash64)
 import Data.Either (isRight)
+import Data.Map (Map)
+import Data.Map qualified as Map
 import Data.Text qualified as Text
 import Data.Text.IO qualified as TIO
-import Data.Time.Clock (getCurrentTime)
+import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds)
+import Data.Word (Word32)
 import Database qualified as Db
 import Database.PostgreSQL.Simple qualified as Postgres
 import Database.Schema (ScriptEvaluationRecord' (..))
@@ -33,19 +37,20 @@ import PlutusLedgerApi.Common (
 import PlutusLedgerApi.V1 qualified as V1
 import PlutusLedgerApi.V2 qualified as V2
 import PlutusLedgerApi.V3 qualified as V3
+import System.Exit (ExitCode (..), exitWith)
 import Text.PrettyBy qualified as Pretty
-import UnliftIO (IORef, atomicModifyIORef', liftIO, newIORef, readIORef)
+import UnliftIO (IORef, MonadIO, atomicModifyIORef', liftIO, newIORef, readIORef, writeIORef)
 import UnliftIO.Concurrent (forkFinally, threadDelay)
 
 data ScriptEvaluationInput = MkScriptEvaluationInput
-  { seiPlutusLedgerLanguage :: PlutusLedgerLanguage
-  , seiMajorProtocolVersion :: MajorProtocolVersion
-  , seiEvaluationContext :: EvaluationContext
+  { seiPlutusLedgerLanguage :: !PlutusLedgerLanguage
+  , seiMajorProtocolVersion :: !MajorProtocolVersion
+  , seiEvaluationContext :: !EvaluationContext
   , seiData :: [Data]
-  , seiScript :: ScriptForEvaluation
-  , seiExBudget :: ExBudget
-  , seiEvaluationSuccess :: Bool
-  , seiBlock :: BlockNo
+  , seiScript :: !ScriptForEvaluation
+  , seiExBudget :: !ExBudget
+  , seiEvaluationSuccess :: !Bool
+  , seiBlock :: !BlockNo
   }
 
 renderScriptEvaluationInput :: ScriptEvaluationInput -> String
@@ -79,9 +84,10 @@ accumulateScripts
   -> (ScriptEvaluationInput -> a -> m a)
   -- ^ Accumulation function
   -> m a
-accumulateScripts conn startBlock initialAccum accumulate =
+accumulateScripts conn startBlock initialAccum accumulate = do
+  evaluationContexts <- newIORef Map.empty
   Db.withScriptEvaluationEvents conn startBlock initialAccum \accum record -> do
-    scriptInput <- inputFromRecord record
+    scriptInput <- inputFromRecord evaluationContexts record
     accumulate scriptInput accum
 
 evaluateScripts
@@ -96,42 +102,96 @@ evaluateScripts
   -> m ()
 evaluateScripts conn startBlock callback = do
   maxThreads <- liftIO getNumCapabilities
-  threadCounter <- newIORef 0
+  st <-
+    newIORef
+      ( 0 -- current number of threads
+      , 0 -- number of evaluated scripts
+      , 0 -- average processing time (millis)
+      , 0 -- average evaluation time (millis)
+      )
+  evalContexts <- newIORef Map.empty -- cashed evaluation contexts
   Db.withScriptEvaluationEvents conn startBlock () \_unit record -> do
-    waitForAFreeThread maxThreads threadCounter
-    atomicModifyIORef' threadCounter \n -> (n + 1, ())
-    _threadId <- forkFinally (callback =<< inputFromRecord record) \_ ->
-      atomicModifyIORef' threadCounter \n -> (n - 1, ())
+    startProcessing <- liftIO getCurrentTime
+    waitForAFreeThread maxThreads st
+    atomicModifyIORef' st \(threads, n, a, s) ->
+      ((threads + 1, n, a, s), ())
+    let work = do
+          input <- inputFromRecord evalContexts record
+          startEvaluation <- liftIO getCurrentTime
+          callback input
+          end <- liftIO getCurrentTime
+          pure
+            ( nominalDiffTimeToMillis (end `diffUTCTime` startProcessing)
+            , nominalDiffTimeToMillis (end `diffUTCTime` startEvaluation)
+            )
+    _threadId <- forkFinally work \case
+      Left err -> liftIO do
+        putStrLn $ "Failed to evaluate script: " <> show err
+        exitWith (ExitFailure 1)
+      Right (!dtp, !dte) -> do
+        atomicModifyIORef' st \(threads, n, pt, et) ->
+          let pt' =
+                if pt == 0
+                  then dtp
+                  else
+                    round @Double @Word32 $
+                      fromIntegral (pt * (n - 1) + dtp) / fromIntegral n
+              et' =
+                if et == 0
+                  then dte
+                  else
+                    round @Double @Word32 $
+                      fromIntegral (et * (n - 1) + dte) / fromIntegral n
+           in ((threads - 1, n + 1, pt', et'), ())
     pure ()
  where
-  waitForAFreeThread :: Int -> IORef Int -> m ()
+  {-
+  (_, n, pt, et) <- readIORef st
+  when (n `mod` 100 == 0) $ liftIO do
+    putStrLn $ "Average time: processing " <> show pt <> "ms, "
+      <> "evaluation " <> show et <> "ms"
+  -}
+
+  waitForAFreeThread :: Int -> IORef (Int, Word32, Word32, Word32) -> m ()
   waitForAFreeThread maxThreads counter = do
-    threadCount <- readIORef counter
+    (threadCount, _, _, _) <- readIORef counter
     when (threadCount >= maxThreads) do
       threadDelay 1_000 -- wait for 1ms
       waitForAFreeThread maxThreads counter
 
+  nominalDiffTimeToMillis :: NominalDiffTime -> Word32
+  nominalDiffTimeToMillis dt = round (1000 * nominalDiffTimeToSeconds dt)
+
 inputFromRecord
-  :: (MonadFail m)
-  => Db.ScriptEvaluationRecord
+  :: (MonadFail m, MonadIO m)
+  => IORef (Map Hash64 EvaluationContext)
+  -> Db.ScriptEvaluationRecord
   -> m ScriptEvaluationInput
-inputFromRecord MkScriptEvaluationRecord'{..} = do
+inputFromRecord evalCtxRef MkScriptEvaluationRecord'{..} = do
   let mkEvalCtx f =
         runExceptT (runWriterT f) >>= \case
           Left e -> fail $ "Failed to create evaluation context: " <> show e
           Right (ctx, _warnings) -> pure ctx
-  seiEvaluationContext <-
-    mkEvalCtx case seLedgerLanguage of
-      PlutusV1 -> V1.mkEvaluationContext seCostModelParams
-      PlutusV2 -> V2.mkEvaluationContext seCostModelParams
-      PlutusV3 -> V3.mkEvaluationContext seCostModelParams
+  seiEvaluationContext <- do
+    keyedEvalCtxs <- liftIO $ readIORef evalCtxRef
+    case Map.lookup seCostModelKey keyedEvalCtxs of
+      Just ctx -> pure ctx
+      Nothing -> do
+        ctx <- mkEvalCtx case seLedgerLanguage of
+          PlutusV1 -> V1.mkEvaluationContext seCostModelParams
+          PlutusV2 -> V2.mkEvaluationContext seCostModelParams
+          PlutusV3 -> V3.mkEvaluationContext seCostModelParams
+        let keyedEvalCtxs' = Map.insert seCostModelKey ctx keyedEvalCtxs
+        liftIO $ writeIORef evalCtxRef keyedEvalCtxs'
+        pure ctx
   seiScript <-
     case deserialiseScript
       seLedgerLanguage
       seMajorProtocolVersion
       (BSS.toShort seScript) of
       Left err -> fail $ "Failed to deserialise script: " <> show err
       Right script -> pure script
+
   pure
     MkScriptEvaluationInput
       { seiPlutusLedgerLanguage = seLedgerLanguage