|
| 1 | +{-# LANGUAGE OverloadedStrings #-} |
| 2 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 3 | +{-# LANGUAGE TemplateHaskell #-} |
| 4 | +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} |
| 5 | + |
| 6 | +-- | Standalone executable for profiling the plugin compilation functions. |
| 7 | +-- |
| 8 | +-- This test uses the exposed 'runCompiler' from Plugin.hs to compile a simple |
| 9 | +-- Core expression. This allows profiling the plugin code at runtime, including |
| 10 | +-- the SCC annotations in Plugin.hs. |
| 11 | +-- |
| 12 | +-- To run with profiling: |
| 13 | +-- cabal build plutus-tx-plugin-profile-test --enable-profiling |
| 14 | +-- cabal run plutus-tx-plugin-profile-test --enable-profiling -- +RTS -p -hc |
| 15 | +module Main where |
| 16 | + |
| 17 | +import Data.Default |
| 18 | +import Data.Foldable (fold) |
| 19 | +import PlutusCore qualified as PLC |
| 20 | +import PlutusCore.Compiler qualified as PLC |
| 21 | +import PlutusCore.Pretty as PLC |
| 22 | +import PlutusCore.Quote |
| 23 | +import PlutusCore.Quote (runQuoteT) |
| 24 | +import PlutusCore.Version qualified as PLC |
| 25 | +import PlutusIR qualified as PIR |
| 26 | +import PlutusIR.Compiler qualified as PIR |
| 27 | +import PlutusIR.Compiler.Definitions qualified as PIR |
| 28 | +import PlutusIR.Compiler.Types qualified as PIR |
| 29 | +import PlutusIR.Transform.RewriteRules |
| 30 | +import PlutusIR.Transform.RewriteRules.RemoveTrace (rewriteRuleRemoveTrace) |
| 31 | +import PlutusTx.Compiler.Builtins |
| 32 | +import PlutusTx.Compiler.Error |
| 33 | +import PlutusTx.Compiler.Types |
| 34 | +import PlutusTx.Options (PluginOptions (..), defaultPluginOptions) |
| 35 | +import PlutusTx.Plugin (runCompiler) |
| 36 | +import UntypedPlutusCore qualified as UPLC |
| 37 | + |
| 38 | +import GHC qualified as GHC |
| 39 | +import GHC.Core.FamInstEnv qualified as GHC |
| 40 | +import GHC.Core.Opt.OccurAnal qualified as GHC |
| 41 | +import GHC.Driver.Make qualified as GHC |
| 42 | +import GHC.Driver.Session qualified as GHC |
| 43 | +import GHC.Paths as GHC |
| 44 | +import GHC.Plugins qualified as GHC |
| 45 | +import GHC.Types.Literal qualified as GHC |
| 46 | + |
| 47 | +import Control.Lens |
| 48 | +import Control.Monad.Except |
| 49 | +import Control.Monad.Reader |
| 50 | +import Control.Monad.State |
| 51 | +import Control.Monad.Writer |
| 52 | + |
| 53 | +import Data.Map qualified as Map |
| 54 | +import Data.Set qualified as Set |
| 55 | +import Language.Haskell.TH.Syntax qualified as TH |
| 56 | + |
| 57 | +-- | Create a simple Core expression for testing (a literal integer) |
| 58 | +createSimpleCoreExpr :: GHC.DynFlags -> GHC.CoreExpr |
| 59 | +createSimpleCoreExpr flags = |
| 60 | + let lit = GHC.Lit (GHC.LitNumber GHC.LitNumInt 42) |
| 61 | + in lit |
| 62 | + |
| 63 | +-- | Set up a minimal CompileContext for testing |
| 64 | +setupCompileContext |
| 65 | + :: GHC.DynFlags |
| 66 | + -> GHC.FamInstEnvs |
| 67 | + -> NameInfo |
| 68 | + -> CompileContext PLC.DefaultUni PLC.DefaultFun |
| 69 | +setupCompileContext flags famEnvs nameInfo = |
| 70 | + let opts = defaultPluginOptions |
| 71 | + coverage = CoverageOpts mempty |
| 72 | + in CompileContext |
| 73 | + { ccOpts = |
| 74 | + CompileOptions |
| 75 | + { coProfile = _posProfile opts |
| 76 | + , coCoverage = coverage |
| 77 | + , coDatatypeStyle = |
| 78 | + if _posPlcTargetVersion opts < PLC.plcVersion110 |
| 79 | + then PIR.ScottEncoding |
| 80 | + else PIR._dcoStyle $ _posDatatypes opts |
| 81 | + , coRemoveTrace = _posRemoveTrace opts |
| 82 | + , coInlineFix = _posInlineFix opts |
| 83 | + } |
| 84 | + , ccFlags = flags |
| 85 | + , ccFamInstEnvs = famEnvs |
| 86 | + , ccNameInfo = nameInfo |
| 87 | + , ccScope = initialScope |
| 88 | + , ccBlackholed = mempty |
| 89 | + , ccCurDef = Nothing |
| 90 | + , ccModBreaks = Nothing |
| 91 | + , ccBuiltinsInfo = def |
| 92 | + , ccBuiltinCostModel = def |
| 93 | + , ccDebugTraceOn = _posDumpCompilationTrace opts |
| 94 | + , ccRewriteRules = makeRewriteRules opts |
| 95 | + , ccSafeToInline = False |
| 96 | + } |
| 97 | + where |
| 98 | + makeRewriteRules :: PluginOptions -> RewriteRules PLC.DefaultUni PLC.DefaultFun |
| 99 | + makeRewriteRules options = |
| 100 | + fold |
| 101 | + [ mwhen (_posRemoveTrace options) rewriteRuleRemoveTrace |
| 102 | + , defaultUniRewriteRules |
| 103 | + ] |
| 104 | + mwhen :: Monoid m => Bool -> m -> m |
| 105 | + mwhen b m = if b then m else mempty |
| 106 | + |
| 107 | +-- | Create empty NameInfo (simplified - in real usage would need proper lookups) |
| 108 | +createEmptyNameInfo :: NameInfo |
| 109 | +createEmptyNameInfo = Map.empty |
| 110 | + |
| 111 | +main :: IO () |
| 112 | +main = do |
| 113 | + putStrLn "Setting up for plugin profiling test..." |
| 114 | + |
| 115 | + -- Use GHC's API to get DynFlags |
| 116 | + GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do |
| 117 | + -- Initialize GHC session to get DynFlags |
| 118 | + GHC.runGhc (Just GHC.libdir) $ do |
| 119 | + -- Get DynFlags |
| 120 | + flags <- GHC.getSessionDynFlags |
| 121 | + |
| 122 | + -- Create a simple Core expression (literal integer) |
| 123 | + let expr = createSimpleCoreExpr flags |
| 124 | + |
| 125 | + -- Set up minimal context |
| 126 | + let famEnvs = (GHC.emptyFamInstEnv, GHC.emptyFamInstEnv) |
| 127 | + nameInfo = createEmptyNameInfo |
| 128 | + ctx = setupCompileContext flags famEnvs nameInfo |
| 129 | + opts = defaultPluginOptions |
| 130 | + st = CompileState 0 mempty |
| 131 | + moduleNameStr = "ProfileTest" |
| 132 | + -- Apply occurrence analysis like the plugin does |
| 133 | + expr' = GHC.occurAnalyseExpr expr |
| 134 | + |
| 135 | + -- Call runCompiler - this is where the SCC annotations are! |
| 136 | + _ <- |
| 137 | + runExceptT . runWriterT . runQuoteT . flip runReaderT ctx . flip evalStateT st $ |
| 138 | + runCompiler moduleNameStr opts expr' |
| 139 | + |
| 140 | + pure () |
0 commit comments