A task to evaluate patched CEK machine on the mainnet scripts.

Author: Unisay

README.md

@@ -36,4 +36,6 @@ locally. You can use this program as a basis for your own re-evaluation, where
 you can modify various parameters to suit your needs:
 
 - The [Main module](plutus-script-evaluation/evaluate-scripts/Main.hs) of the `evaluate-scripts` executable.
-- The main workhorse, function `evaluateScripts` in the [Evaluation module](plutus-script-evaluation/evaluate-scripts/Evaluation.hs) does the boring parts (aggregating relevant script evaluation inputs, streaming the data from DB to a local computer, decoding CBOR) so that you can do the interesting part: fold over the script evaluations from the Mainnet accessing all of the original evaluation inputs, to re-interpret them accordingly to your task, maintaining local state (accumulator) if needed. 
+- The main workhorse, function `evaluateScripts` in the [Evaluation module](plutus-script-evaluation/evaluate-scripts/Evaluation.hs) does the boring parts (aggregating relevant script evaluation inputs, streaming the data from DB to a local computer, decoding CBOR, forking worker threads) so that you can do the interesting part: traverse script evaluations from the Mainnet accessing all of the original evaluation inputs to re-interpret them accordingly to your task;
+
+If a task requires maintaining local state (accumulator) during the evaluation, you can use the `accumulateScripts` function in the [Evaluation module](plutus-script-evaluation/evaluate-scripts/Evaluation.hs). This function is a more general version of `evaluateScripts` that allows you to maintain local state during the evaluation.

nix/shell.nix

@@ -74,7 +74,7 @@ cabalProject: {
       description = "Evaluate Plutus Scripts from mainnet";
       group = "general";
       exec = ''
-        cabal run evaluate-scripts -- --database-conn-str "$DB_CONN_STRING"
+        cabal run evaluate-scripts -- --start-block=0 --database-conn-str "$DB_CONN_STRING"
       '';
     };
   };

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

@@ -15,10 +15,10 @@ main :: IO ()
 main = withUtf8 do
   hSetBuffering stdin LineBuffering
   hSetBuffering stdout LineBuffering
-  Options{optsDatabaseConnStr} <- execParser parserInfo
+  Options{optsDatabaseConnStr, startBlock} <- execParser parserInfo
   displaySqlError $
     bracket (PG.connectPostgreSQL optsDatabaseConnStr) PG.close \conn -> do
-      _result <- evaluateScripts conn mempty onScriptEvaluationInput
+      evaluateScripts conn startBlock onScriptEvaluationInput
       putStrLn "Done evaluating scripts"
 
 displaySqlError :: IO () -> IO ()

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

@@ -8,10 +8,14 @@ module Options (
 )
 where
 
+import Cardano.Slotting.Block (BlockNo (BlockNo))
 import Data.ByteString (ByteString)
 import Options.Applicative qualified as O
 
-newtype Options = Options {optsDatabaseConnStr :: ByteString}
+data Options = Options
+  { optsDatabaseConnStr :: ByteString
+  , startBlock :: BlockNo
+  }
   deriving (Show)
 
 options :: O.Parser Options
@@ -27,6 +31,15 @@ options = do
               \/docs/current/libpq-connect.html#LIBPQ-CONNSTRING"
           ]
       )
+  startBlock <-
+    O.option
+      (O.maybeReader (Just . BlockNo . read))
+      ( mconcat
+          [ O.long "start-block"
+          , O.metavar "BLOCK_NO"
+          , O.help "Block number to start from"
+          ]
+      )
   pure Options{..}
 
 parserInfo :: O.ParserInfo Options

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

@@ -1,8 +1,8 @@
 module Database.Query where
 
+import Cardano.Slotting.Block (BlockNo (..))
 import Cardano.Slotting.Slot (SlotNo)
 import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
-import Data.Function ((&))
 import Data.Profunctor.Product.Default (Default)
 import Database.Orphans ()
 import Database.PostgreSQL.Simple (Connection)
@@ -29,6 +29,7 @@ import Opaleye (
   (.==),
   (.>=),
  )
+import Opaleye.Internal.Column (SqlNum (pgFromInteger))
 
 insertCostModelValues
   :: (Default ToFields CostModelValuesRecord CostModelValuesRecordFields)
@@ -98,13 +99,17 @@ selectSerialisedScriptsBatch conn count =
 withScriptEvaluationEvents
   :: (MonadUnliftIO m)
   => Connection
+  -> BlockNo
   -> a
   -> (a -> ScriptEvaluationRecord -> m a)
   -> m a
-withScriptEvaluationEvents conn a f = do
-  let select =
-        selectTable scriptEvaluations
-          & orderBy (asc seBlockNo)
+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)
+        pure res
   withRunInIO \runInIO ->
     runSelectFold conn select a \accum record ->
       runInIO (f accum record)

plutus-script-evaluation/lib/Evaluate.hs

@@ -1,12 +1,15 @@
 module Evaluate where
 
+import Cardano.Slotting.Block (unBlockNo)
 import Codec.Serialise (deserialise)
+import Control.Concurrent (getNumCapabilities)
 import Control.Monad (when)
 import Control.Monad.IO.Unlift (MonadUnliftIO)
 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.Either (isRight)
 import Data.Text qualified as Text
 import Data.Text.IO qualified as TIO
 import Data.Time.Clock (getCurrentTime)
@@ -31,6 +34,8 @@ import PlutusLedgerApi.V1 qualified as V1
 import PlutusLedgerApi.V2 qualified as V2
 import PlutusLedgerApi.V3 qualified as V3
 import Text.PrettyBy qualified as Pretty
+import UnliftIO (IORef, atomicModifyIORef', liftIO, newIORef, readIORef)
+import UnliftIO.Concurrent (forkFinally, threadDelay)
 
 data ScriptEvaluationInput = MkScriptEvaluationInput
   { seiPlutusLedgerLanguage :: PlutusLedgerLanguage
@@ -63,20 +68,49 @@ renderScriptEvaluationInput MkScriptEvaluationInput{..} =
           in Pretty.display uplc
        )
 
-evaluateScripts
+accumulateScripts
   :: (MonadFail m, MonadUnliftIO m)
   => Postgres.Connection
   -- ^ Database connection
+  -> BlockNo
+  -- ^ Block number to start from
   -> a
   -- ^ Initial accumulator
   -> (ScriptEvaluationInput -> a -> m a)
   -- ^ Accumulation function
   -> m a
-evaluateScripts conn initialAccum accumulate =
-  Db.withScriptEvaluationEvents conn initialAccum \accum record -> do
+accumulateScripts conn startBlock initialAccum accumulate =
+  Db.withScriptEvaluationEvents conn startBlock initialAccum \accum record -> do
     scriptInput <- inputFromRecord record
     accumulate scriptInput accum
 
+evaluateScripts
+  :: forall m
+   . (MonadFail m, MonadUnliftIO m)
+  => Postgres.Connection
+  -- ^ Database connection
+  -> BlockNo
+  -- ^ Block number to start from
+  -> (ScriptEvaluationInput -> m ())
+  -- ^ Callback
+  -> m ()
+evaluateScripts conn startBlock callback = do
+  maxThreads <- liftIO getNumCapabilities
+  threadCounter <- newIORef 0
+  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, ())
+    pure ()
+ where
+  waitForAFreeThread :: Int -> IORef Int -> m ()
+  waitForAFreeThread maxThreads counter = do
+    threadCount <- readIORef counter
+    when (threadCount >= maxThreads) do
+      threadDelay 60_000 -- wait for 60ms
+      waitForAFreeThread maxThreads counter
+
 inputFromRecord
   :: (MonadFail m)
   => Db.ScriptEvaluationRecord
@@ -113,63 +147,42 @@ inputFromRecord MkScriptEvaluationRecord'{..} = do
       , seiBlock = seBlockNo
       }
 
-onScriptEvaluationInput :: ScriptEvaluationInput -> () -> IO ()
-onScriptEvaluationInput input@MkScriptEvaluationInput{..} _accum = do
+onScriptEvaluationInput :: ScriptEvaluationInput -> IO ()
+onScriptEvaluationInput input@MkScriptEvaluationInput{..} = do
   let
     (_logOutput, evaluationResult) =
       evaluateScriptRestricting
         seiPlutusLedgerLanguage
         seiMajorProtocolVersion
         Quiet
         seiEvaluationContext
-        (ExBudget maxBound maxBound) -- will check the budget separately
+        seiExBudget
         seiScript
         seiData
 
-  let budgetExceeded (ExBudget cpu mem) =
-        let ExBudget cpuPaidFor memPaidFor = seiExBudget
-         in cpu > cpuPaidFor || mem > memPaidFor
-
-  let evaluationSuccess =
-        either (const False) (not . budgetExceeded) evaluationResult
-
   print seiBlock
 
+  let evaluationSuccess = isRight evaluationResult
+
   when (evaluationSuccess /= seiEvaluationSuccess) do
     let msg =
           "Script evaluation result ("
             ++ show evaluationSuccess
             ++ ") does not match the recorded result ("
             ++ show seiEvaluationSuccess
             ++ ")"
+            ++ "\n\nEvaluation result:\n"
+            ++ show evaluationResult
+            ++ "\n\nScript evaluation inputs:\n"
+            ++ renderScriptEvaluationInput input
+            ++ "\n\n"
+    putStr msg
 
     nonce <- getCurrentTime
-    let logFile = show seiBlock ++ "_" ++ show nonce ++ ".log"
-
-    putStrLn msg
+    let logFile = show (unBlockNo seiBlock) ++ "_" ++ show nonce ++ ".log"
     putStrLn $ "Writing log to " ++ logFile
-
-    TIO.writeFile logFile $
-      Text.pack msg
-        <> "\n\nEvaluation result:\n"
-        <> Text.pack (show evaluationResult)
-        <> "\n\nScript evaluation inputs:\n"
-        <> Text.pack (renderScriptEvaluationInput input)
+    TIO.writeFile logFile (Text.pack msg)
 
   case evaluationResult of
-    Left err ->
-      putStrLn $ "Script evaluation was not successful: " <> show err
-    Right spentExBudget -> do
-      if budgetExceeded spentExBudget
-        then do
-          putStrLn "Budget exceeded!"
-          putStrLn $ "Paid for: " <> show seiExBudget
-          putStrLn $ "Consumed: " <> show spentExBudget
-        else
-          if seiExBudget == spentExBudget
-            then do
-              putStrLn $ "Budget matches exactly: " <> show spentExBudget
-            else do
-              putStrLn "Budget is sufficient:"
-              putStrLn $ "Paid for: " <> show seiExBudget
-              putStrLn $ "Consumed: " <> show spentExBudget
+    Right _spentExBudget -> pure ()
+    Left err -> putStrLn $ "Script evaluation was not successful: " <> show err

plutus-script-evaluation/plutus-script-evaluation.cabal

@@ -112,6 +112,7 @@ library
     , text
     , time
     , transformers
+    , unliftio
     , unliftio-core
     , vector
 
@@ -158,9 +159,10 @@ executable evaluate-scripts
   import:         lang, deps-exe
   hs-source-dirs: evaluate-scripts
   main-is:        Main.hs
-  ghc-options:    -threaded -rtsopts
+  ghc-options:    -threaded -with-rtsopts=-N
   other-modules:  Options
   build-depends:
-    , cardano-api    ^>=10.4
+    , cardano-api       ^>=10.4
+    , cardano-slotting
     , text
     , unliftio-core