Skip to content

Commit

Permalink
WIP wrap PIR terms in trace.
Browse files Browse the repository at this point in the history
  • Loading branch information
thealmarty committed Sep 14, 2021
1 parent 386acbb commit 57535bf
Show file tree
Hide file tree
Showing 7 changed files with 229 additions and 13 deletions.
2 changes: 1 addition & 1 deletion plutus-core/plutus-core/src/PlutusCore/Constant/Typed.hs
Original file line number Diff line number Diff line change
Expand Up @@ -395,7 +395,7 @@ data family TyAppRep (fun :: dom -> cod) (arg :: dom) :: cod
data family TyForallRep (var :: TyNameRep kind) (a :: GHC.Type) :: GHC.Type

-- See Note [Motivation for polymorphic built-in functions].
-- See Note [Implemetation of polymorphic built-in functions].
-- See Note [Implementation of polymorphic built-in functions].
-- See Note [Pattern matching on built-in types].
-- | The denotation of a term whose PLC type is encoded in @rep@ (for example a type variable or
-- an application of a type variable). I.e. the denotation of such a term is the term itself.
Expand Down
3 changes: 2 additions & 1 deletion plutus-core/plutus-ir/src/PlutusIR/Compiler.hs
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,7 @@ module PlutusIR.Compiler (
coDoSimplifierUnwrapCancel,
coDoSimplifierBeta,
coDoSimplifierInline,
coProfile,
defaultCompilationOpts,
CompilationCtx,
ccOpts,
Expand Down Expand Up @@ -165,7 +166,7 @@ compileToReadable =
>=> through check

-- | The 2nd half of the PIR compiler pipeline.
-- Compiles a 'Term' into a PLC Term, by removing/translating step-by-step the PIR's language construsts to PLC.
-- Compiles a 'Term' into a PLC Term, by removing/translating step-by-step the PIR's language constructs to PLC.
-- Note: the result *does* have globally unique names.
compileReadableToPlc :: (Compiling m e uni fun a, b ~ Provenance a) => Term TyName Name uni fun b -> m (PLCTerm uni fun a)
compileReadableToPlc =
Expand Down
3 changes: 2 additions & 1 deletion plutus-core/plutus-ir/src/PlutusIR/Compiler/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -51,12 +51,13 @@ data CompilationOpts = CompilationOpts {
, _coDoSimplifierUnwrapCancel :: Bool
, _coDoSimplifierBeta :: Bool
, _coDoSimplifierInline :: Bool
, _coProfile :: Bool
} deriving (Eq, Show)

makeLenses ''CompilationOpts

defaultCompilationOpts :: CompilationOpts
defaultCompilationOpts = CompilationOpts True False False False 8 True True True
defaultCompilationOpts = CompilationOpts True False False False 8 True True True False

data CompilationCtx uni fun a = CompilationCtx {
_ccOpts :: CompilationOpts
Expand Down
13 changes: 9 additions & 4 deletions plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@
-- | Functions for compiling GHC Core expressions into Plutus Core terms.
module PlutusTx.Compiler.Expr (compileExpr, compileExprWithDefs, compileDataConRef) where

import qualified PlutusTx.Builtins as Builtins
import PlutusTx.Compiler.Binders
import PlutusTx.Compiler.Builtins
import PlutusTx.Compiler.Error
Expand All @@ -20,8 +21,6 @@ import PlutusTx.Compiler.Type
import PlutusTx.Compiler.Types
import PlutusTx.Compiler.Utils
import PlutusTx.PIRTypes

import qualified PlutusTx.Builtins as Builtins
-- I feel like we shouldn't need this, we only need it to spot the special String type, which is annoying
import qualified PlutusTx.Builtins.Class as Builtins

Expand Down Expand Up @@ -405,7 +404,13 @@ hoistExpr var t =
(PIR.Def var' (PIR.mkVar () var', PIR.Strict))
mempty

t' <- compileExpr t
CompileContext {ccOpts=profileOpts} <- ask
t' <-
if coProfile profileOpts==All then do
t'' <- compileExpr t
return $ Builtins.trace "entering x" (\() -> Builtins.trace "exiting x" t'') ()
else compileExpr t
-- TODO add Some option

-- See Note [Non-strict let-bindings]
let strict = PIR.isPure (const PIR.NonStrict) t'
Expand Down Expand Up @@ -540,7 +545,7 @@ compileExpr e = withContextM 2 (sdToTxt $ "Compiling expr:" GHC.<+> GHC.ppr e) $
l `GHC.App` arg -> PIR.Apply () <$> compileExpr l <*> compileExpr arg
-- if we're biding a type variable it's a type abstraction
GHC.Lam b@(GHC.isTyVar -> True) body -> mkTyAbsScoped b $ compileExpr body
-- othewise it's a normal lambda
-- otherwise it's a normal lambda
GHC.Lam b body -> mkLamAbsScoped b $ compileExpr body

GHC.Let (GHC.NonRec b arg) body -> do
Expand Down
13 changes: 11 additions & 2 deletions plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -31,8 +31,10 @@ import qualified Language.Haskell.TH.Syntax as TH

type BuiltinNameInfo = Map.Map TH.Name GHC.TyThing

-- | Compilation options. Empty currently.
data CompileOptions = CompileOptions {}
-- | Compilation options.
newtype CompileOptions = CompileOptions {
coProfile :: ProfileOpts
}

data CompileContext uni fun = CompileContext {
ccOpts :: CompileOptions,
Expand All @@ -43,6 +45,13 @@ data CompileContext uni fun = CompileContext {
ccBlackholed :: Set.Set GHC.Name
}

-- | Profiling options. @All@ profiles everything. @None@ turns off profiling. @Some@ turns on profiling for selected terms.
data ProfileOpts =
All
| None
| Some [String]
deriving (Eq)

-- | A wrapper around 'GHC.Name' with a stable 'Ord' instance. Use this where the ordering
-- will affect the output of the compiler, i.e. when sorting or so on. It's fine to use
-- 'GHC.Name' if we're just putting them in a 'Set.Set', for example.
Expand Down
14 changes: 10 additions & 4 deletions plutus-tx-plugin/src/PlutusTx/Plugin.hs
Original file line number Diff line number Diff line change
Expand Up @@ -48,7 +48,7 @@ import Data.List (isPrefixOf)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
import qualified Data.Text.Prettyprint.Doc as PP
import Data.Traversable
import Data.Traversable (for)
import ErrorCode
import qualified FamInstEnv as GHC
import Text.Read (readMaybe)
Expand All @@ -71,6 +71,7 @@ data PluginOptions = PluginOptions {
, poDoSimplifierBeta :: Bool
, poDoSimplifierInline :: Bool
, poDoSimplifierRemoveDeadBindings :: Bool
, poProfile :: ProfileOpts
}

data PluginCtx = PluginCtx
Expand Down Expand Up @@ -148,6 +149,12 @@ parsePluginArgs args = do
, poDoSimplifierBeta = notElem' "no-simplifier-beta"
, poDoSimplifierInline = notElem' "no-simplifier-inline"
, poDoSimplifierRemoveDeadBindings = notElem' "no-simplifier-remove-dead-bindings"
-- profiling: profiling-on turns on profiling for everything
, poProfile =
if elem' "profile-all" then All
else None
-- TODO add a few options for
-- else if elem' "profile=" then Some
}
-- TODO: better parsing with failures
pure opts
Expand Down Expand Up @@ -281,7 +288,7 @@ compileMarkedExprs expr = do

-- | Behaves the same as 'compileMarkedExpr', unless a compilation error occurs ;
-- if a compilation error happens and the 'defer-errors' option is turned on,
-- the compilation error is supressed and the original hs expression is replaced with a
-- the compilation error is suppressed and the original hs expression is replaced with a
-- haskell runtime-error expression.
compileMarkedExprOrDefer :: String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr
compileMarkedExprOrDefer locStr codeTy origE = do
Expand Down Expand Up @@ -316,7 +323,7 @@ compileMarkedExpr locStr codeTy origE = do
-- We need to do this out here, since it has to run in CoreM
nameInfo <- makePrimitiveNameInfo builtinNames
let ctx = CompileContext {
ccOpts = CompileOptions {},
ccOpts = CompileOptions {coProfile =poProfile opts},
ccFlags = flags,
ccFamInstEnvs = famEnvs,
ccBuiltinNameInfo = nameInfo,
Expand Down Expand Up @@ -368,7 +375,6 @@ runCompiler moduleName opts expr = do
& set (PIR.ccOpts . PIR.coDoSimplifierBeta) (poDoSimplifierBeta opts)
& set (PIR.ccOpts . PIR.coDoSimplifierInline) (poDoSimplifierInline opts)


-- GHC.Core -> Pir translation.
pirT <- PIR.runDefT () $ compileExprWithDefs expr
when (poDumpPir opts) . liftIO $ dumpFlat (PIR.Program () pirT) "initial PIR program" (moduleName ++ ".pir-initial.flat")
Expand Down
194 changes: 194 additions & 0 deletions plutus-tx-plugin/test/Plugin/Primitives/Profiling.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,194 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:debug-context #-}
{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:profile-all #-}

module Plugin.Primitives.Profiling where

import Common
import Lib
import PlcTestUtils
import Plugin.Lib

import qualified PlutusTx.Builtins as Builtins
import qualified PlutusTx.Builtins.Class as Builtins
import qualified PlutusTx.Builtins.Internal as BI
import PlutusTx.Code
import PlutusTx.IsData
import PlutusTx.Lift
import PlutusTx.Plugin
import qualified PlutusTx.Prelude as P

import qualified PlutusCore as PLC
import qualified PlutusCore.Default as PLC

import Data.Proxy
import Data.Text (Text)

import GHC.Magic

primitives :: TestNested
primitives = testNested "Primitives" [
goldenPir "string" string
, goldenPir "int" int
, goldenPir "int2" int2
, goldenPir "bool" bool
, goldenPir "and" andPlc
, goldenUEval "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 ]
, goldenPir "intCompare" intCompare
, goldenPir "intEq" intEq
, goldenUEval "intEqApply" [ toUPlc intEq, toUPlc int, toUPlc int ]
, goldenPir "void" void
, goldenPir "intPlus" intPlus
, goldenPir "intDiv" intDiv
, goldenUEval "intPlusApply" [ toUPlc intPlus, toUPlc int, toUPlc int2 ]
, goldenPir "error" errorPlc
, goldenPir "ifThenElse" ifThenElse
, goldenUEval "ifThenElseApply" [ toUPlc ifThenElse, toUPlc int, toUPlc int2 ]
, goldenPir "emptyByteString" emptyByteString
, goldenUEval "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)]
, goldenPir "verify" verify
, goldenPir "trace" trace
, goldenPir "traceComplex" traceComplex
, goldenPir "stringLiteral" stringLiteral
, goldenUEval "equalsString" [ getPlc stringEquals, liftProgram ("hello" :: Builtins.BuiltinString), liftProgram ("hello" :: Builtins.BuiltinString)]
, goldenPir "encodeUtf8" stringEncode
, goldenUEval "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 ]
, goldenPir "deconstructorData2" deconstructData2
, goldenUEval "deconstructData2" [ toUPlc deconstructData2, toUPlc constructData2 ]
, goldenUEval "deconstructData3" [ toUPlc deconstructData3, toUPlc constructData3 ]
]

string :: CompiledCode Builtins.BuiltinString
string = plc (Proxy @"text") "text"

int :: CompiledCode Integer
int = plc (Proxy @"int") (1::Integer)

int2 :: CompiledCode Integer
int2 = plc (Proxy @"int2") (2::Integer)

emptyBS :: CompiledCode Builtins.BuiltinByteString
emptyBS = plc (Proxy @"emptyBS") Builtins.emptyByteString

bool :: CompiledCode Bool
bool = plc (Proxy @"bool") True

andPlc :: CompiledCode (Bool -> Bool -> Bool)
andPlc = plc (Proxy @"andPlc") (\(x::Bool) (y::Bool) -> if x then (if y then True else False) else False)

tuple :: CompiledCode (Integer, Integer)
tuple = plc (Proxy @"tuple") (1::Integer, 2::Integer)

tupleMatch :: CompiledCode ((Integer, Integer) -> Integer)
tupleMatch = plc (Proxy @"tupleMatch") (\(x:: (Integer, Integer)) -> let (a, b) = x in a)

intCompare :: CompiledCode (Integer -> Integer -> Bool)
intCompare = plc (Proxy @"intCompare") (\(x::Integer) (y::Integer) -> Builtins.lessThanInteger x y)

intEq :: CompiledCode (Integer -> Integer -> Bool)
intEq = plc (Proxy @"intEq") (\(x::Integer) (y::Integer) -> Builtins.equalsInteger x y)

-- Has a Void in it
void :: CompiledCode (Integer -> Integer -> Bool)
void = plc (Proxy @"void") (\(x::Integer) (y::Integer) -> let a x' y' = case (x', y') of { (True, True) -> True; _ -> False; } in Builtins.equalsInteger x y `a` Builtins.equalsInteger y x)

intPlus :: CompiledCode (Integer -> Integer -> Integer)
intPlus = plc (Proxy @"intPlus") (\(x::Integer) (y::Integer) -> Builtins.addInteger x y)

intDiv :: CompiledCode (Integer -> Integer -> Integer)
intDiv = plc (Proxy @"intDiv") (\(x::Integer) (y::Integer) -> Builtins.divideInteger x y)

errorPlc :: CompiledCode (() -> Integer)
errorPlc = plc (Proxy @"errorPlc") (Builtins.error @Integer)

ifThenElse :: CompiledCode (Integer -> Integer -> Integer)
ifThenElse = plc (Proxy @"ifThenElse") (\(x::Integer) (y::Integer) -> if Builtins.equalsInteger x y then x else y)

emptyByteString :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString)
emptyByteString = plc (Proxy @"emptyByteString") (\(x :: Builtins.BuiltinByteString) -> x)

bytestring :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString)
bytestring = plc (Proxy @"bytestring") (\(x::Builtins.BuiltinByteString) -> x)

sha2 :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString)
sha2 = plc (Proxy @"sha2") (\(x :: Builtins.BuiltinByteString) -> Builtins.sha2_256 x)

bsEquals :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool)
bsEquals = plc (Proxy @"bs32Equals") (\(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.equalsByteString x y)

bsLength :: CompiledCode (Builtins.BuiltinByteString -> Integer)
bsLength = plc (Proxy @"bs32Length") (\(x :: Builtins.BuiltinByteString) -> Builtins.lengthOfByteString x)

bsIndex :: CompiledCode (Builtins.BuiltinByteString -> Integer -> Integer)
bsIndex = plc (Proxy @"bs32Index") (\(x :: Builtins.BuiltinByteString) (n :: Integer) -> Builtins.indexByteString x n)

bsCons :: CompiledCode (Integer -> Builtins.BuiltinByteString -> Builtins.BuiltinByteString)
bsCons = plc (Proxy @"bs32Cons") (\(n :: Integer) (x :: Builtins.BuiltinByteString) -> Builtins.consByteString n x)

bsLt :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool)
bsLt = plc (Proxy @"bsLt") (\(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.lessThanByteString x y)

bsDecode :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinString)
bsDecode = plc (Proxy @"bsDecode") (\(x :: Builtins.BuiltinByteString) -> Builtins.decodeUtf8 x)

verify :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool)
verify = plc (Proxy @"verify") (\(x::Builtins.BuiltinByteString) (y::Builtins.BuiltinByteString) (z::Builtins.BuiltinByteString) -> Builtins.verifySignature x y z)

trace :: CompiledCode (Builtins.BuiltinString -> ())
trace = plc (Proxy @"trace") (\(x :: Builtins.BuiltinString) -> Builtins.trace x ())

traceComplex :: CompiledCode (Bool -> ())
traceComplex = plc (Proxy @"traceComplex") (\(b :: Bool) -> if b then P.trace "yes" () else P.traceError "no")

stringLiteral :: CompiledCode (Builtins.BuiltinString)
stringLiteral = plc (Proxy @"stringLiteral") ("abc"::Builtins.BuiltinString)

stringEquals :: CompiledCode (Builtins.BuiltinString -> Builtins.BuiltinString -> Bool)
stringEquals = plc (Proxy @"string32Equals") (\(x :: Builtins.BuiltinString) (y :: Builtins.BuiltinString) -> Builtins.equalsString x y)

stringEncode :: CompiledCode (Builtins.BuiltinByteString)
stringEncode = plc (Proxy @"stringEncode") (Builtins.encodeUtf8 "abc")

constructData1 :: CompiledCode (Builtins.BuiltinData)
constructData1 = plc (Proxy @"constructData1") (Builtins.mkI 1)

deconstructData1 :: CompiledCode (Builtins.BuiltinData -> Integer)
deconstructData1 = plc (Proxy @"deconstructData1") (\(d :: Builtins.BuiltinData) -> Builtins.unsafeDataAsI d)

constructData2 :: CompiledCode (Builtins.BuiltinData)
constructData2 = plc (Proxy @"constructData2") (Builtins.mkConstr 1 [Builtins.mkI 2, Builtins.mkI 3])

deconstructData2 :: CompiledCode (Builtins.BuiltinData -> (Integer, [Integer]))
deconstructData2 = plc (Proxy @"deconstructData2") (\(d :: Builtins.BuiltinData) -> (P.fmap . P.fmap) Builtins.unsafeDataAsI (Builtins.unsafeDataAsConstr d))

constructData3 :: CompiledCode (Builtins.BuiltinData)
constructData3 = plc (Proxy @"constructData2") (Builtins.mkList [Builtins.mkI 2, Builtins.mkI 3])

deconstructData3 :: CompiledCode (Builtins.BuiltinData -> [Builtins.BuiltinData])
deconstructData3 = plc (Proxy @"deconstructData2") (\(d :: Builtins.BuiltinData) -> (Builtins.unsafeDataAsList d))

matchData1 :: CompiledCode (Builtins.BuiltinData -> Maybe Integer)
matchData1 = plc (Proxy @"matchData1") (\(d :: Builtins.BuiltinData) -> (Builtins.matchData d (\_ _ -> Nothing) (const Nothing) (const Nothing) (Just) (const Nothing)))

0 comments on commit 57535bf

Please sign in to comment.