Skip to content

Commit

Permalink
Fix the budget tallying output in the PLC executables (#5347)
Browse files Browse the repository at this point in the history
  • Loading branch information
@kwxm
kwxm committed May 23, 2023
1 parent 95c83d0 commit b0fc9a3
Show file tree
Hide file tree
Showing 5 changed files with 165 additions and 83 deletions.
16 changes: 16 additions & 0 deletions plutus-core/changelog.d/20230523_135203_kenneth.mackenzie_plc_exe_fixes.md
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,16 @@
<!--
A new scriv changelog fragment.
Uncomment the section that is right (remove the HTML comment wrapper).
-->

### Added

- An `apply-to-data` command was added to the `plc` and `uplc` executables which
allows a script to be applied to a list of flat-encoded data objects (the
existing `apply` command requires all inputs to be programs).

### Fixed

- The plc and uplc commands were failing to account for the new Constr and Case
constructors for sums of products.
85 changes: 60 additions & 25 deletions plutus-core/executables/plc/Main.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,16 +6,19 @@ module Main (main) where

import PlutusCore qualified as PLC
import PlutusCore.Compiler.Erase qualified as PLC (eraseProgram)
import PlutusCore.Data
import PlutusCore.Evaluation.Machine.Ck qualified as Ck
import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
import PlutusCore.Executable.Common
import PlutusCore.Executable.Parsers
import PlutusCore.MkPlc (mkConstant)
import PlutusCore.Pretty qualified as PP

import Data.Text.IO qualified as T
import PlutusPrelude

import Control.DeepSeq (rnf)
import Data.ByteString.Lazy qualified as BSL (readFile)
import Data.Text.IO qualified as T
import Flat (unflat)
import Options.Applicative
import System.Exit (exitSuccess)

Expand All @@ -31,14 +34,15 @@ data EraseOptions = EraseOptions Input Format Output Format PrintMode


-- Main commands
data Command = Apply ApplyOptions
| Typecheck TypecheckOptions
| Optimise OptimiseOptions
| Convert ConvertOptions
| Print PrintOptions
| Example ExampleOptions
| Erase EraseOptions
| Eval EvalOptions
data Command = Apply ApplyOptions
| ApplyToData ApplyOptions
| Typecheck TypecheckOptions
| Optimise OptimiseOptions
| Convert ConvertOptions
| Print PrintOptions
| Example ExampleOptions
| Erase EraseOptions
| Eval EvalOptions
| DumpModel
| PrintBuiltinSignatures

Expand Down Expand Up @@ -67,12 +71,20 @@ plutusOpts :: Parser Command
plutusOpts = hsubparser $
command "apply"
(info (Apply <$> applyOpts)
(progDesc $
"Given a list of input scripts f g1 g2 ... gn, output a script consisting of "
++ "(... ((f g1) g2) ... gn); "
++ "for example, "
++ "'plc apply --if flat Validator.flat Datum.flat Redeemer.flat Context.flat"
++" --of flat -o Script.flat'."))
(progDesc $ "Given a list of input files f g1 g2 ... gn " <>
"containing Typed Plutus Core scripts, " <>
"output a script consisting of (... ((f g1) g2) ... gn); " <>
"for example, 'plc apply --if flat Validator.flat " <>
"Datum.flat Redeemer.flat Context.flat --of flat -o Script.flat'."))
<> command "apply-to-data"
(info (ApplyToData <$> applyOpts)
(progDesc $ "Given a list f d1 d2 ... dn where f is a " <>
"Typed Plutus Core script and d1,...,dn are files " <>
"containing flat-encoded data ojbects, output a script " <>
"consisting of f applied to the data objects; " <>
"for example, 'plc apply-to-data --if " <>
"flat Validator.flat Datum.flat Redeemer.flat Context.flat " <>
"--of flat -o Script.flat'."))
<> command "print"
(info (Print <$> printOpts)
(progDesc "Parse a program then prettyprint it."))
Expand Down Expand Up @@ -108,7 +120,8 @@ plutusOpts = hsubparser $

---------------- Script application ----------------

-- | Apply one script to a list of others.
-- | Apply one script to a list of others and output the result. All of the
-- scripts must be PLC.Program objects.
runApply :: ApplyOptions -> IO ()
runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do
scripts <- mapM ((readProgram ifmt :: Input -> IO (PlcProg PLC.SrcSpan)) . FileInput) inputfiles
Expand All @@ -119,6 +132,27 @@ runApply (ApplyOptions inputfiles ifmt outp ofmt mode) = do
foldl1 (unsafeFromRight .* PLC.applyProgram) progAndargs
writeProgram outp ofmt mode appliedScript

-- | Apply a PLC program to script to a list of flat-encoded Data objects and
-- output the result.
runApplyToData :: ApplyOptions -> IO ()
runApplyToData (ApplyOptions inputfiles ifmt outp ofmt mode) = do
case inputfiles of
[] -> errorWithoutStackTrace "No input files"
p:ds -> do
prog@(PLC.Program _ version _) :: PlcProg PLC.SrcSpan <- readProgram ifmt (FileInput p)
args <- mapM (getDataObject version) ds
let prog' = () <$ prog
appliedScript = foldl1 (unsafeFromRight .* PLC.applyProgram) (prog':args)
writeProgram outp ofmt mode appliedScript
where getDataObject :: PLC.Version -> FilePath -> IO (PlcProg ())
getDataObject ver path = do
bs <- BSL.readFile path
case unflat bs of
Left err -> fail ("Error reading " ++ show path ++ ": " ++ show err)
Right (d :: Data) ->
pure $ PLC.Program () ver $ mkConstant () d


---------------- Typechecking ----------------

runTypecheck :: TypecheckOptions -> IO ()
Expand Down Expand Up @@ -179,13 +213,14 @@ main :: IO ()
main = do
options <- customExecParser (prefs showHelpOnEmpty) plcInfoCommand
case options of
Apply opts -> runApply opts
Typecheck opts -> runTypecheck opts
Optimise opts -> runOptimisations opts
Eval opts -> runEval opts
Example opts -> runPlcPrintExample opts
Erase opts -> runErase opts
Print opts -> runPrint @PlcProg opts
Convert opts -> runConvert @PlcProg opts
Apply opts -> runApply opts
ApplyToData opts -> runApplyToData opts
Typecheck opts -> runTypecheck opts
Optimise opts -> runOptimisations opts
Eval opts -> runEval opts
Example opts -> runPlcPrintExample opts
Erase opts -> runErase opts
Print opts -> runPrint @PlcProg opts
Convert opts -> runConvert @PlcProg opts
DumpModel -> runDumpModel
PrintBuiltinSignatures -> runPrintBuiltinSignatures
48 changes: 19 additions & 29 deletions plutus-core/executables/src/PlutusCore/Executable/Common.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -161,35 +161,29 @@ printBudgetStateTally ::
Cek.CekExTally fun ->
IO ()
printBudgetStateTally term model (Cek.CekExTally costs) = do
putStrLn $ "Const " ++ pbudget (Cek.BStep Cek.BConst)
putStrLn $ "Var " ++ pbudget (Cek.BStep Cek.BVar)
putStrLn $ "LamAbs " ++ pbudget (Cek.BStep Cek.BLamAbs)
putStrLn $ "Apply " ++ pbudget (Cek.BStep Cek.BApply)
putStrLn $ "Delay " ++ pbudget (Cek.BStep Cek.BDelay)
putStrLn $ "Force " ++ pbudget (Cek.BStep Cek.BForce)
putStrLn $ "Builtin " ++ pbudget (Cek.BStep Cek.BBuiltin)
traverse_ printStepCost allStepKinds
putStrLn ""
putStrLn $ "startup " ++ pbudget Cek.BStartup
putStrLn $ "compute " ++ printf "%-20s" (budgetToString totalComputeCost)
putStrLn $ "startup " ++ (budgetToString $ getSpent Cek.BStartup)
putStrLn $ "compute " ++ budgetToString totalComputeCost
putStrLn $ "AST nodes " ++ printf "%15d" (UPLC.unSize $ UPLC.termSize term)
putStrLn ""
putStrLn $ "BuiltinApp " ++ budgetToString builtinCosts
case model of
Default ->
do
putStrLn $
printf
"Time spent executing builtins: %4.2f%%\n"
(100 * (getCPU builtinCosts) / totalTime)
putStrLn ""
traverse_
( \(b, cost) ->
putStrLn $ printf "%-22s %s" (show b) (budgetToString cost :: String)
)
builtinsAndCosts
putStrLn ""
putStrLn $ "Total budget spent: " ++ printf (budgetToString totalCost)
putStrLn $ "Predicted execution time: " ++ formatTimePicoseconds totalTime
putStrLn $ "Total builtin costs: " ++ budgetToString totalBuiltinCosts
printf "Time spent executing builtins: %4.2f%%\n"
(100 * (getCPU totalBuiltinCosts) / (getCPU totalCost))
putStrLn ""
putStrLn $ "Total budget spent: " ++ printf (budgetToString totalCost)
putStrLn $ "Predicted execution time: "
++ (formatTimePicoseconds $ getCPU totalCost)
Unit -> do
putStrLn ""
traverse_
Expand All @@ -198,31 +192,27 @@ printBudgetStateTally term model (Cek.CekExTally costs) = do
)
builtinsAndCosts
where
allStepKinds = [minBound..maxBound] :: [Cek.StepKind]
getSpent k =
case H.lookup k costs of
Just v -> v
Nothing -> ExBudget 0 0
allNodeTags =
fmap
Cek.BStep
[Cek.BConst, Cek.BVar, Cek.BLamAbs, Cek.BApply, Cek.BDelay, Cek.BForce, Cek.BBuiltin]
totalComputeCost =
-- For unitCekCosts this will be the total number of compute steps
foldMap getSpent allNodeTags
foldMap (getSpent . Cek.BStep) allStepKinds
budgetToString (ExBudget (ExCPU cpu) (ExMemory mem)) =
case model of
-- Not %d: doesn't work when CostingInteger is SatInt.
Default -> printf "%15s %15s" (show cpu) (show mem) :: String
-- Memory usage figures are meaningless in this case
Unit -> printf "%15s" (show cpu) :: String
pbudget = budgetToString . getSpent
f l e = case e of (Cek.BBuiltinApp b, cost) -> (b, cost) : l; _ -> l
builtinsAndCosts = List.foldl f [] (H.toList costs)
builtinCosts = mconcat (map snd builtinsAndCosts)
printStepCost constr =
printf "%-10s %20s\n" (tail $ show constr) (budgetToString . getSpent $ Cek.BStep constr)
getBuiltinCost l e = case e of (Cek.BBuiltinApp b, cost) -> (b, cost) : l; _ -> l
builtinsAndCosts = List.foldl getBuiltinCost [] (H.toList costs)
totalBuiltinCosts = mconcat (map snd builtinsAndCosts)
getCPU b = let ExCPU b' = exBudgetCPU b in fromSatInt b' :: Double
totalCost = getSpent Cek.BStartup <> totalComputeCost <> builtinCosts
totalTime =
(getCPU $ getSpent Cek.BStartup) + getCPU totalComputeCost + getCPU builtinCosts
totalCost = getSpent Cek.BStartup <> totalComputeCost <> totalBuiltinCosts :: ExBudget

class PrintBudgetState cost where
printBudgetState ::
Expand Down Expand Up @@ -600,7 +590,7 @@ runPrintBuiltinSignatures :: IO ()
runPrintBuiltinSignatures = do
let builtins = enumerate @PLC.DefaultFun
mapM_
(\x -> putStr (printf "%-25s: %s\n" (show $ PP.pretty x) (show $ getSignature x)))
(\x -> putStr (printf "%-35s: %s\n" (show $ PP.pretty x) (show $ getSignature x)))
builtins
where
getSignature (PLC.toBuiltinMeaning @_ @_ @(PlcTerm ()) def -> PLC.BuiltinMeaning sch _ _) =
Expand Down

0 comments on commit b0fc9a3

Please sign in to comment.