Add goldenUEvalProfile fn and use it in Profiling.hs.

IntersectMBO · Sep 16, 2021 · 2ee433c · 2ee433c
1 parent ec58b2a
commit 2ee433c
Show file tree

Hide file tree

Showing 2 changed files with 49 additions and 26 deletions.
diff --git a/plutus-core/common/PlcTestUtils.hs b/plutus-core/common/PlcTestUtils.hs
@@ -24,6 +24,7 @@ module PlcTestUtils (
     goldenUEval,
     goldenTEvalCatch,
     goldenUEvalCatch,
+    goldenUEvalProfile,
     NoMarkRenameT(..),
     noMarkRename,
     NoRenameT(..),
@@ -40,24 +41,25 @@ import           PlutusPrelude
 
 import           Common
 
-import qualified PlutusCore                               as TPLC
+import qualified PlutusCore                                           as TPLC
 import           PlutusCore.Check.Scoping
 import           PlutusCore.DeBruijn
 import           PlutusCore.Default.Universe
-import qualified PlutusCore.Evaluation.Machine.Ck         as TPLC
+import qualified PlutusCore.Evaluation.Machine.Ck                     as TPLC
 import           PlutusCore.Generators
 import           PlutusCore.Generators.AST
 import           PlutusCore.Pretty
-import qualified PlutusCore.Rename.Monad                  as TPLC
+import qualified PlutusCore.Rename.Monad                              as TPLC
 
-import qualified UntypedPlutusCore                        as UPLC
-import qualified UntypedPlutusCore.Evaluation.Machine.Cek as UPLC
+import qualified UntypedPlutusCore                                    as UPLC
+import qualified UntypedPlutusCore.Evaluation.Machine.Cek             as UPLC
+import           UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode (logWithTimeEmitter)
 
 import           Control.Exception
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import           Control.Monad.State
-import qualified Data.Text.Prettyprint.Doc                as PP
+import qualified Data.Text.Prettyprint.Doc                            as PP
 import           Hedgehog
 import           System.IO.Unsafe
 import           Test.Tasty
@@ -136,6 +138,21 @@ runUPlc values = do
     let (UPLC.Program _ _ t) = foldl1 UPLC.applyProgram ps
     liftEither $ first toException $ TPLC.extractEvaluationResult $ UPLC.evaluateCekNoEmit TPLC.defaultCekParameters t
 
+runUPlcProfile :: (Traversable t, ToUPlc a DefaultUni UPLC.DefaultFun) =>
+    t a
+    -> ExceptT
+     SomeException
+     IO
+     (UPLC.EvaluationResult
+        (UPLC.Term UPLC.Name DefaultUni UPLC.DefaultFun ()))
+runUPlcProfile values = do
+    ps <- traverse toUPlc values
+    let (UPLC.Program _ _ t) = foldl1 UPLC.applyProgram ps
+    liftEither
+        $ first toException
+            $ TPLC.extractEvaluationResult
+                $ fst $ UPLC.evaluateCek logWithTimeEmitter TPLC.defaultCekParameters t
+
 ppCatch :: PrettyPlc a => ExceptT SomeException IO a -> IO (Doc ann)
 ppCatch value = either (PP.pretty . show) prettyPlcClassicDebug <$> runExceptT value
 
@@ -190,6 +207,12 @@ goldenUEvalCatch
     => String -> [a] -> TestNested
 goldenUEvalCatch name values = nestedGoldenVsDocM name $ ppCatch $ runUPlc values
 
+-- | Similar to @goldenUEval@ but with profiling turned on.
+goldenUEvalProfile
+    :: ToUPlc a DefaultUni TPLC.DefaultFun
+    => String -> [a] -> TestNested
+goldenUEvalProfile name values = nestedGoldenVsDocM name $ prettyPlcClassicDebug <$> (rethrow $ runUPlcProfile values)
+
 -- See Note [Marking].
 -- | A version of 'RenameT' that fails to take free variables into account.
 newtype NoMarkRenameT ren m a = NoMarkRenameT

diff --git a/plutus-tx-plugin/test/Plugin/Primitives/Profiling.hs b/plutus-tx-plugin/test/Plugin/Primitives/Profiling.hs
@@ -38,47 +38,47 @@ primitives = testNested "Primitives" [
   , goldenPir "int2" int2
   , goldenPir "bool" bool
   , goldenPir "and" andPlc
-  , goldenUEval "andApply" [ toUPlc andPlc, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False ]
+  , goldenUEvalProfile "andApply" [ toUPlc andPlc, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False ]
   , goldenPir "tuple" tuple
   , goldenPir "tupleMatch" tupleMatch
-  , goldenUEval "tupleConstDest" [ toUPlc tupleMatch, toUPlc tuple ]
+  , goldenUEvalProfile "tupleConstDest" [ toUPlc tupleMatch, toUPlc tuple ]
   , goldenPir "intCompare" intCompare
   , goldenPir "intEq" intEq
-  , goldenUEval "intEqApply" [ toUPlc intEq, toUPlc int, toUPlc int ]
+  , goldenUEvalProfile "intEqApply" [ toUPlc intEq, toUPlc int, toUPlc int ]
   , goldenPir "void" void
   , goldenPir "intPlus" intPlus
   , goldenPir "intDiv" intDiv
-  , goldenUEval "intPlusApply" [ toUPlc intPlus, toUPlc int, toUPlc int2 ]
+  , goldenUEvalProfile "intPlusApply" [ toUPlc intPlus, toUPlc int, toUPlc int2 ]
   , goldenPir "error" errorPlc
   , goldenPir "ifThenElse" ifThenElse
-  , goldenUEval "ifThenElseApply" [ toUPlc ifThenElse, toUPlc int, toUPlc int2 ]
+  , goldenUEvalProfile "ifThenElseApply" [ toUPlc ifThenElse, toUPlc int, toUPlc int2 ]
   , goldenPir "emptyByteString" emptyByteString
-  , goldenUEval "emptyByteStringApply" [ getPlc emptyByteString, liftProgram Builtins.emptyByteString ]
+  , goldenUEvalProfile "emptyByteStringApply" [ getPlc emptyByteString, liftProgram Builtins.emptyByteString ]
   , goldenPir "bytestring" bytestring
-  , goldenUEval "bytestringApply" [ getPlc bytestring, liftProgram ("hello" ::Builtins.BuiltinByteString) ]
-  , goldenUEval "sha2_256" [ getPlc sha2, liftProgram ("hello" :: Builtins.BuiltinByteString)]
-  , goldenUEval "equalsByteString" [ getPlc bsEquals, liftProgram ("hello" :: Builtins.BuiltinByteString), liftProgram ("hello" :: Builtins.BuiltinByteString)]
-  , goldenUEval "ltByteString" [ getPlc bsLt, liftProgram ("hello" :: Builtins.BuiltinByteString), liftProgram ("world" :: Builtins.BuiltinByteString)]
-  , goldenUEval "decodeUtf8" [ getPlc bsDecode, liftProgram ("hello" :: Builtins.BuiltinByteString)]
-  , goldenUEval "lengthOfByteString" [ getPlc bsLength, liftProgram ("hello" :: Builtins.BuiltinByteString)]
-  , goldenUEval "indexByteString" [ getPlc bsIndex, liftProgram ("hello" :: Builtins.BuiltinByteString), liftProgram (0 :: Integer)]
-  , goldenUEval "consByteString" [ getPlc bsCons, liftProgram (104 :: Integer), liftProgram ("ello" :: Builtins.BuiltinByteString)]
+  , goldenUEvalProfile "bytestringApply" [ getPlc bytestring, liftProgram ("hello" ::Builtins.BuiltinByteString) ]
+  , goldenUEvalProfile "sha2_256" [ getPlc sha2, liftProgram ("hello" :: Builtins.BuiltinByteString)]
+  , goldenUEvalProfile "equalsByteString" [ getPlc bsEquals, liftProgram ("hello" :: Builtins.BuiltinByteString), liftProgram ("hello" :: Builtins.BuiltinByteString)]
+  , goldenUEvalProfile "ltByteString" [ getPlc bsLt, liftProgram ("hello" :: Builtins.BuiltinByteString), liftProgram ("world" :: Builtins.BuiltinByteString)]
+  , goldenUEvalProfile "decodeUtf8" [ getPlc bsDecode, liftProgram ("hello" :: Builtins.BuiltinByteString)]
+  , goldenUEvalProfile "lengthOfByteString" [ getPlc bsLength, liftProgram ("hello" :: Builtins.BuiltinByteString)]
+  , goldenUEvalProfile "indexByteString" [ getPlc bsIndex, liftProgram ("hello" :: Builtins.BuiltinByteString), liftProgram (0 :: Integer)]
+  , goldenUEvalProfile "consByteString" [ getPlc bsCons, liftProgram (104 :: Integer), liftProgram ("ello" :: Builtins.BuiltinByteString)]
   , goldenPir "verify" verify
   , goldenPir "trace" trace
   , goldenPir "traceComplex" traceComplex
   , goldenPir "stringLiteral" stringLiteral
-  , goldenUEval "equalsString" [ getPlc stringEquals, liftProgram ("hello" :: Builtins.BuiltinString), liftProgram ("hello" :: Builtins.BuiltinString)]
+  , goldenUEvalProfile "equalsString" [ getPlc stringEquals, liftProgram ("hello" :: Builtins.BuiltinString), liftProgram ("hello" :: Builtins.BuiltinString)]
   , goldenPir "encodeUtf8" stringEncode
-  , goldenUEval "constructData1" [ constructData1 ]
+  , goldenUEvalProfile "constructData1" [ constructData1 ]
   -- It's interesting to look at one of these to make sure all the specialisation is working out nicely and for
   -- debugging when it isn't
   , goldenPir "deconstructorData1" deconstructData1
   -- Check that matchData works (and isn't too strict)
-  , goldenUEval "matchData1" [ toUPlc matchData1, toUPlc constructData1 ]
-  , goldenUEval "deconstructData1" [ toUPlc deconstructData1, toUPlc constructData1 ]
+  , goldenUEvalProfile "matchData1" [ toUPlc matchData1, toUPlc constructData1 ]
+  , goldenUEvalProfile "deconstructData1" [ toUPlc deconstructData1, toUPlc constructData1 ]
   , goldenPir "deconstructorData2" deconstructData2
-  , goldenUEval "deconstructData2" [ toUPlc deconstructData2, toUPlc constructData2 ]
-  , goldenUEval "deconstructData3" [ toUPlc deconstructData3, toUPlc constructData3 ]
+  , goldenUEvalProfile "deconstructData2" [ toUPlc deconstructData2, toUPlc constructData2 ]
+  , goldenUEvalProfile "deconstructData3" [ toUPlc deconstructData3, toUPlc constructData3 ]
   ]
 
 string :: CompiledCode Builtins.BuiltinString