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

Author: Unisay

database/db.dbm

@@ -4,7 +4,7 @@ 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="257,118" last-zoom="1" scene-rect="0,0,1570.8,1076.8"
+	 last-position="0,14" last-zoom="1" scene-rect="0,0,1570.8,1076.8"
 	 default-schema="public" default-owner="postgres"
 	 layers="Default layer"
 	 active-layers="0"
@@ -217,18 +217,20 @@ ORDER BY
 	<role name="&quot;plutus-admin&quot;"/>
 	<position x="1060" y="520"/>
 	<definition> <![CDATA[SELECT
+  SEE.PK,
   SEE.SLOT,
   SEE.BLOCK,
   SEE.MAJOR_PROTOCOL_VERSION,
   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,
+  SS.SERIALISED AS SCRIPT_SERIALISED,
   SEE.DATUM,
   SEE.REDEEMER,
   SEE.SCRIPT_CONTEXT,
-  SS.LEDGER_LANGUAGE,
-  SS.SERIALISED
+  SS.LEDGER_LANGUAGE
 FROM
   SCRIPT_EVALUATION_EVENTS AS SEE
   JOIN SERIALISED_SCRIPTS SS ON SEE.SCRIPT_HASH = SS.HASH

database/db.png

@@ -1,6 +1,6 @@
 -- Database generated with pgModeler (PostgreSQL Database Modeler).
 -- pgModeler version: 1.1.5
--- PostgreSQL version: 16.0
+-- PostgreSQL version: 17.0
 -- Project Site: pgmodeler.io
 -- Model Author: ---
 -- object: "plutus-admin" | type: ROLE --
@@ -193,18 +193,20 @@ ALTER MATERIALIZED VIEW public.builtin_version_num_scripts OWNER TO "plutus-inde
 CREATE VIEW public.script_evaluations
 AS 
 SELECT
+  SEE.PK,
   SEE.SLOT,
   SEE.BLOCK,
   SEE.MAJOR_PROTOCOL_VERSION,
   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,
+  SS.SERIALISED AS SCRIPT_SERIALISED,
   SEE.DATUM,
   SEE.REDEEMER,
   SEE.SCRIPT_CONTEXT,
-  SS.LEDGER_LANGUAGE,
-  SS.SERIALISED
+  SS.LEDGER_LANGUAGE
 FROM
   SCRIPT_EVALUATION_EVENTS AS SEE
   JOIN SERIALISED_SCRIPTS SS ON SEE.SCRIPT_HASH = SS.HASH

database/db.sql

@@ -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/evaluate-scripts/Main.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/Query.hs

@@ -193,6 +193,7 @@ data
     datum
     redeemer
     scriptContext
+    costModelKey
     costModel
   = MkScriptEvaluationRecord'
   { sePk :: pk
@@ -207,6 +208,7 @@ data
   , seDatum :: datum
   , seRedeemer :: redeemer
   , seScriptContext :: scriptContext
+  , seCostModelKey :: costModelKey
   , seCostModelParams :: costModel
   }
   deriving (Show, Eq)
@@ -225,6 +227,7 @@ type ScriptEvaluationRecord =
     (Maybe ByteString) -- datum
     (Maybe ByteString) -- redeemer
     ByteString -- script_context
+    Hash64 -- cost_model_key
     [Int64] -- cost_model_params
 
 type ScriptEvaluationRecordFields =
@@ -237,10 +240,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
 
 --------------------------------------------------------------------------------
@@ -292,10 +296,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"
         }
 

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

@@ -1,5 +1,6 @@
 module Deserialise where
 
+import Codec.CBOR.Decoding qualified as CBOR
 import Codec.CBOR.Read qualified as CBOR
 import Codec.Extras.SerialiseViaFlat (decodeViaFlatWith, readDeserialiseFailureInfo)
 import Control.Exception (throwIO)
@@ -10,6 +11,7 @@ import Data.Aeson qualified as Json
 import Data.Base64.Types qualified as Base64
 import Data.ByteString qualified as BS
 import Data.ByteString.Base64 qualified as Base64
+import Data.Coerce (coerce)
 import Data.Function ((&))
 import Data.Some (withSome)
 import Data.String.Interpolate (i)
@@ -18,6 +20,7 @@ import Database qualified as DB
 import Database.PostgreSQL.Simple (Connection)
 import Numeric.Natural (Natural)
 import PlutusCore (DefaultUni (..), ValueOf (..))
+import PlutusCore.DeBruijn.Internal (FakeNamedDeBruijn (..))
 import PlutusCore.Default (noMoreTypeFunctions)
 import PlutusCore.Default qualified as U
 import PlutusCore.Pretty (pretty, render)
@@ -59,16 +62,20 @@ deserialiseScript
 deserialiseScript
   (DB.MkSerialisedScriptRecord hash _ledgerLang serialised) = do
     let builtinPredicate _fun = Nothing -- Don't check builtins compatibility
+        decoder
+          :: CBOR.Decoder
+              s
+              (U.Program U.FakeNamedDeBruijn DefaultUni U.DefaultFun ())
         decoder = decodeViaFlatWith (U.decodeProgram builtinPredicate)
-    uplc <-
+    uplc :: U.Program U.NamedDeBruijn DefaultUni U.DefaultFun () <-
       case CBOR.deserialiseFromBytes decoder (BS.fromStrict serialised) of
         Left err ->
           throwError $ CBORDeserialiseError $ readDeserialiseFailureInfo err
         Right (remainder, _uplc)
           | remainder /= mempty ->
               throwError $ RemainderError remainder
         Right (_rest, uplc) ->
-          pure uplc
+          pure $ coerce uplc
     pure . DB.MkDeserialisedScriptRecord hash . termToJson $ U._progTerm uplc
 
 termToJson :: U.Term U.NamedDeBruijn U.DefaultUni U.DefaultFun () -> Json.Value

plutus-script-evaluation/lib/Deserialise.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