From 596824d53dbb5f1e02925486352ba79ea2cac74f Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Thu, 16 Mar 2023 13:12:13 -0700 Subject: [PATCH] KnownApps --- .../test/Sum/left-fold-built-in.budget.golden | 2 + .../test/Sum/left-fold-data.budget.golden | 2 + .../test/Sum/left-fold-scott.budget.golden | 2 + .../Sum/right-fold-built-in.budget.golden | 2 + .../test/Sum/right-fold-data.budget.golden | 2 + .../test/Sum/right-fold-scott.budget.golden | 2 + .../nofib/src/PlutusBenchmark/NoFib/Queens.hs | 9 +- plutus-benchmark/nofib/test/Spec.hs | 6 +- .../nofib/test/formulaBudget.budget.golden | 2 + .../nofib/test/knightsBudget.budget.golden | 2 + .../nofib/test/queens4budget.budget.golden | 2 + .../nofib/test/queens5budget.budget.golden | 2 + .../src/PlutusBenchmark/ScriptContexts.hs | 5 +- ...kScriptContexEqualityData-20.budget.golden | 2 + .../test/checkScriptContext1-20.budget.golden | 2 + .../test/checkScriptContext1-4.budget.golden | 2 + .../test/checkScriptContext2-20.budget.golden | 2 + .../test/checkScriptContext2-4.budget.golden | 2 + ...ptContextEqualityOverhead-20.budget.golden | 2 + ...ScriptContextEqualityTerm-20.budget.golden | 2 + .../src/PlutusIR/Compiler/Definitions.hs | 2 +- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + .../src/PlutusTx/Compiler/Expr.hs | 98 ++++++++++++++++++- .../src/PlutusTx/Compiler/Types.hs | 59 +++++++++++ plutus-tx-plugin/src/PlutusTx/Plugin.hs | 23 +++-- 25 files changed, 214 insertions(+), 23 deletions(-) create mode 100644 plutus-benchmark/lists/test/Sum/left-fold-built-in.budget.golden create mode 100644 plutus-benchmark/lists/test/Sum/left-fold-data.budget.golden create mode 100644 plutus-benchmark/lists/test/Sum/left-fold-scott.budget.golden create mode 100644 plutus-benchmark/lists/test/Sum/right-fold-built-in.budget.golden create mode 100644 plutus-benchmark/lists/test/Sum/right-fold-data.budget.golden create mode 100644 plutus-benchmark/lists/test/Sum/right-fold-scott.budget.golden create mode 100644 plutus-benchmark/nofib/test/formulaBudget.budget.golden create mode 100644 plutus-benchmark/nofib/test/knightsBudget.budget.golden create mode 100644 plutus-benchmark/nofib/test/queens4budget.budget.golden create mode 100644 plutus-benchmark/nofib/test/queens5budget.budget.golden create mode 100644 plutus-benchmark/script-contexts/test/checkScriptContexEqualityData-20.budget.golden create mode 100644 plutus-benchmark/script-contexts/test/checkScriptContext1-20.budget.golden create mode 100644 plutus-benchmark/script-contexts/test/checkScriptContext1-4.budget.golden create mode 100644 plutus-benchmark/script-contexts/test/checkScriptContext2-20.budget.golden create mode 100644 plutus-benchmark/script-contexts/test/checkScriptContext2-4.budget.golden create mode 100644 plutus-benchmark/script-contexts/test/checkScriptContextEqualityOverhead-20.budget.golden create mode 100644 plutus-benchmark/script-contexts/test/checkScriptContextEqualityTerm-20.budget.golden diff --git a/plutus-benchmark/lists/test/Sum/left-fold-built-in.budget.golden b/plutus-benchmark/lists/test/Sum/left-fold-built-in.budget.golden new file mode 100644 index 00000000000..c3dad1d4b3f --- /dev/null +++ b/plutus-benchmark/lists/test/Sum/left-fold-built-in.budget.golden @@ -0,0 +1,2 @@ +({cpu: 160559654 +| mem: 504532}) \ No newline at end of file diff --git a/plutus-benchmark/lists/test/Sum/left-fold-data.budget.golden b/plutus-benchmark/lists/test/Sum/left-fold-data.budget.golden new file mode 100644 index 00000000000..c2101ba6379 --- /dev/null +++ b/plutus-benchmark/lists/test/Sum/left-fold-data.budget.golden @@ -0,0 +1,2 @@ +({cpu: 422780685 +| mem: 1340362}) \ No newline at end of file diff --git a/plutus-benchmark/lists/test/Sum/left-fold-scott.budget.golden b/plutus-benchmark/lists/test/Sum/left-fold-scott.budget.golden new file mode 100644 index 00000000000..0a5bd881505 --- /dev/null +++ b/plutus-benchmark/lists/test/Sum/left-fold-scott.budget.golden @@ -0,0 +1,2 @@ +({cpu: 150781800 +| mem: 566100}) \ No newline at end of file diff --git a/plutus-benchmark/lists/test/Sum/right-fold-built-in.budget.golden b/plutus-benchmark/lists/test/Sum/right-fold-built-in.budget.golden new file mode 100644 index 00000000000..ba994d8016f --- /dev/null +++ b/plutus-benchmark/lists/test/Sum/right-fold-built-in.budget.golden @@ -0,0 +1,2 @@ +({cpu: 167459654 +| mem: 534532}) \ No newline at end of file diff --git a/plutus-benchmark/lists/test/Sum/right-fold-data.budget.golden b/plutus-benchmark/lists/test/Sum/right-fold-data.budget.golden new file mode 100644 index 00000000000..2cf1c44f181 --- /dev/null +++ b/plutus-benchmark/lists/test/Sum/right-fold-data.budget.golden @@ -0,0 +1,2 @@ +({cpu: 429680685 +| mem: 1370362}) \ No newline at end of file diff --git a/plutus-benchmark/lists/test/Sum/right-fold-scott.budget.golden b/plutus-benchmark/lists/test/Sum/right-fold-scott.budget.golden new file mode 100644 index 00000000000..7e2f0e82336 --- /dev/null +++ b/plutus-benchmark/lists/test/Sum/right-fold-scott.budget.golden @@ -0,0 +1,2 @@ +({cpu: 157681800 +| mem: 596100}) \ No newline at end of file diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs index 33e38dd6079..bd845ea3d76 100644 --- a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs +++ b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs @@ -392,8 +392,8 @@ btr seed csp = bt csp . hrandom seed {-# INLINABLE random2 #-} random2 :: Integer -> Integer -random2 n = if test > 0 then test else test + 2147483647 - where test = 16807 * lo - 2836 * hi +random2 n = if test > 0 then test else test Haskell.+ 2147483647 + where test = 16807 Haskell.* lo - 2836 Haskell.* hi hi = n `Haskell.div` 127773 lo = n `Haskell.rem` 127773 @@ -403,7 +403,7 @@ randoms k = iterateN k random2 {-# INLINABLE random #-} random :: Integer -> Integer -random n = (a * n + c) -- mod m +random n = (a Haskell.* n Haskell.+ c) -- mod m where a = 994108973 c = a @@ -435,7 +435,8 @@ cacheChecks csp tbl (Node s cs) = fillTable :: State -> CSP -> Table -> Table fillTable [] csp tbl = tbl fillTable ((var' := val'):as) CSP{vars=vars,vals=vals,rel=rel} tbl = - zipWith (zipWith f) tbl [[(var,val) | val <- interval 1 vals] | var <- interval (var'+1) vars] + zipWith (zipWith f) tbl + [[(var,val) | val <- interval 1 vals] | var <- interval (var' Haskell.+ 1) vars] where f cs (var,val) = if cs == Unknown && not (rel (var' := val') (var := val)) then Known [var',var] else cs diff --git a/plutus-benchmark/nofib/test/Spec.hs b/plutus-benchmark/nofib/test/Spec.hs index 14f1128a8b0..a8ef46028ff 100644 --- a/plutus-benchmark/nofib/test/Spec.hs +++ b/plutus-benchmark/nofib/test/Spec.hs @@ -46,7 +46,7 @@ testClausify = testGroup "clausify" , testCase "formula3" $ mkClausifyTest Clausify.F3 , testCase "formula4" $ mkClausifyTest Clausify.F4 , testCase "formula5" $ mkClausifyTest Clausify.F5 - , Tx.fitsInto "formula1 (size)" (Clausify.mkClausifyCode Clausify.F1) 4901 + , Tx.fitsInto "formula1 (size)" (Clausify.mkClausifyCode Clausify.F1) 4781 , runTestNested $ Tx.goldenBudget "formulaBudget" $ Clausify.mkClausifyCode Clausify.F1 ] @@ -65,7 +65,7 @@ testKnights = testGroup "knights" -- Odd sizes call "error" because there are n , testCase "depth 100, 4x4" $ mkKnightsTest 100 4 , testCase "depth 100, 6x6" $ mkKnightsTest 100 6 , testCase "depth 100, 8x8" $ mkKnightsTest 100 8 - , Tx.fitsInto "depth 10, 4x4 (size)" (Knights.mkKnightsCode 10 4) 3516 + , Tx.fitsInto "depth 10, 4x4 (size)" (Knights.mkKnightsCode 10 4) 3494 , runTestNested $ Tx.goldenBudget "knightsBudget" $ Knights.mkKnightsCode 10 4 ] @@ -95,7 +95,7 @@ testQueens = testGroup "queens" , runTestNested $ Tx.goldenBudget "queens5budget" $ Queens.mkQueensCode 5 Queens.Bt ] - , Tx.fitsInto "Bt (size)" (Queens.mkQueensCode 5 Queens.Bt) 2759 + , Tx.fitsInto "Bt (size)" (Queens.mkQueensCode 5 Queens.Bt) 2852 ] ---------------- Primes ---------------- diff --git a/plutus-benchmark/nofib/test/formulaBudget.budget.golden b/plutus-benchmark/nofib/test/formulaBudget.budget.golden new file mode 100644 index 00000000000..06d86091336 --- /dev/null +++ b/plutus-benchmark/nofib/test/formulaBudget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 26010640908 +| mem: 111558948}) \ No newline at end of file diff --git a/plutus-benchmark/nofib/test/knightsBudget.budget.golden b/plutus-benchmark/nofib/test/knightsBudget.budget.golden new file mode 100644 index 00000000000..77388cd16ac --- /dev/null +++ b/plutus-benchmark/nofib/test/knightsBudget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 7378435298 +| mem: 27654740}) \ No newline at end of file diff --git a/plutus-benchmark/nofib/test/queens4budget.budget.golden b/plutus-benchmark/nofib/test/queens4budget.budget.golden new file mode 100644 index 00000000000..a67c36c1574 --- /dev/null +++ b/plutus-benchmark/nofib/test/queens4budget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 17033524305 +| mem: 67169742}) \ No newline at end of file diff --git a/plutus-benchmark/nofib/test/queens5budget.budget.golden b/plutus-benchmark/nofib/test/queens5budget.budget.golden new file mode 100644 index 00000000000..f4eaa9eda76 --- /dev/null +++ b/plutus-benchmark/nofib/test/queens5budget.budget.golden @@ -0,0 +1,2 @@ +({cpu: 236999646648 +| mem: 923154380}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs b/plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs index 03709efa8fa..176f5508628 100644 --- a/plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs +++ b/plutus-benchmark/script-contexts/src/PlutusBenchmark/ScriptContexts.hs @@ -11,6 +11,7 @@ import PlutusLedgerApi.V1.Value import PlutusTx qualified as PlutusTx import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.Prelude qualified as PlutusTx +import Prelude as Haskell -- | A very crude deterministic generator for 'ScriptContext's with size -- approximately proportional to the input integer. @@ -53,7 +54,7 @@ checkScriptContext1 d = let !sc = PlutusTx.unsafeFromBuiltinData d (ScriptContext txi _) = sc in - if PlutusTx.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 PlutusTx.== 0 + if PlutusTx.length (txInfoOutputs txi) `PlutusTx.modInteger` 2 Haskell.== 0 then () else PlutusTx.traceError "Odd number of outputs" @@ -74,7 +75,7 @@ checkScriptContext2 d = -- for now! in case sc of !_ -> - if 48*9900 PlutusTx.== (475200 :: Integer) + if 48*9900 Haskell.== (475200 :: Integer) then () else PlutusTx.traceError "Got my sums wrong" diff --git a/plutus-benchmark/script-contexts/test/checkScriptContexEqualityData-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContexEqualityData-20.budget.golden new file mode 100644 index 00000000000..ea5e0bcbc42 --- /dev/null +++ b/plutus-benchmark/script-contexts/test/checkScriptContexEqualityData-20.budget.golden @@ -0,0 +1,2 @@ +({cpu: 52948597 +| mem: 167402}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/checkScriptContext1-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContext1-20.budget.golden new file mode 100644 index 00000000000..d85581bfdfe --- /dev/null +++ b/plutus-benchmark/script-contexts/test/checkScriptContext1-20.budget.golden @@ -0,0 +1,2 @@ +({cpu: 460200997 +| mem: 1473069}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/checkScriptContext1-4.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContext1-4.budget.golden new file mode 100644 index 00000000000..5d0f16f0247 --- /dev/null +++ b/plutus-benchmark/script-contexts/test/checkScriptContext1-4.budget.golden @@ -0,0 +1,2 @@ +({cpu: 133868245 +| mem: 431693}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/checkScriptContext2-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContext2-20.budget.golden new file mode 100644 index 00000000000..ebcce03ed89 --- /dev/null +++ b/plutus-benchmark/script-contexts/test/checkScriptContext2-20.budget.golden @@ -0,0 +1,2 @@ +({cpu: 436044997 +| mem: 1387928}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/checkScriptContext2-4.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContext2-4.budget.golden new file mode 100644 index 00000000000..7907ba8972c --- /dev/null +++ b/plutus-benchmark/script-contexts/test/checkScriptContext2-4.budget.golden @@ -0,0 +1,2 @@ +({cpu: 126999877 +| mem: 407384}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/checkScriptContextEqualityOverhead-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContextEqualityOverhead-20.budget.golden new file mode 100644 index 00000000000..4b2267e51e5 --- /dev/null +++ b/plutus-benchmark/script-contexts/test/checkScriptContextEqualityOverhead-20.budget.golden @@ -0,0 +1,2 @@ +({cpu: 37927100 +| mem: 165000}) \ No newline at end of file diff --git a/plutus-benchmark/script-contexts/test/checkScriptContextEqualityTerm-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContextEqualityTerm-20.budget.golden new file mode 100644 index 00000000000..7a5e0553c32 --- /dev/null +++ b/plutus-benchmark/script-contexts/test/checkScriptContextEqualityTerm-20.budget.golden @@ -0,0 +1,2 @@ +({cpu: 840539251 +| mem: 3496546}) \ No newline at end of file diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Definitions.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Definitions.hs index ab07f509633..02540312f45 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Definitions.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Definitions.hs @@ -12,7 +12,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- | Support for generating PIR with global definitions with dependencies between them. -module PlutusIR.Compiler.Definitions (DefT +module PlutusIR.Compiler.Definitions (DefT (..) , MonadDefs (..) , TermDefWithStrictness , runDefT diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index c6d5988c023..87d57638312 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -80,6 +80,7 @@ library , either , extra , flat <0.5 + , ghc-prim , lens , mtl , plutus-core:{plutus-core, plutus-ir} ^>=1.3 diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 437c0a31965..9b52f41abf2 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -39,6 +39,7 @@ import PlutusTx.PIRTypes import PlutusTx.PLCTypes (PLCType, PLCVar) -- I feel like we shouldn't need this, we only need it to spot the special String type, which is annoying import PlutusTx.Builtins.Class qualified as Builtins +import PlutusTx.Builtins.Internal qualified as BI import PlutusTx.Trace import PlutusIR qualified as PIR @@ -60,11 +61,17 @@ import Data.Array qualified as Array import Data.ByteString qualified as BS import Data.List (elemIndex) import Data.List.NonEmpty qualified as NE +import Data.Map (Map) import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.Traversable +import Data.Tuple.Extra +import GHC.Classes qualified +import GHC.Num qualified +import GHC.Real qualified +import Language.Haskell.TH qualified as TH {- Note [System FC and System FW] Haskell uses system FC, which includes type equalities and coercions. @@ -744,7 +751,8 @@ compileExpr e = withContextM 2 (sdToTxt $ "Compiling expr:" GHC.<+> GHC.ppr e) $ "Variable" GHC.<+> GHC.ppr n GHC.$+$ (GHC.ppr $ GHC.idDetails n) GHC.$+$ (GHC.ppr $ GHC.realIdUnfolding n) - + ((bimap strip (fmap strip) . GHC.collectArgs) -> (GHC.Var n, args)) + | Just action <- isKnownApp n args -> action -- ignoring applications to types of 'RuntimeRep' kind, see Note [Unboxed tuples] l `GHC.App` GHC.Type t | GHC.isRuntimeRepKindedTy t -> compileExpr l -- arg can be a type here, in which case it's a type instantiation @@ -848,6 +856,94 @@ compileExpr e = withContextM 2 (sdToTxt $ "Compiling expr:" GHC.<+> GHC.ppr e) $ GHC.Type _ -> throwPlain $ UnsupportedError "Types as standalone expressions" GHC.Coercion _ -> throwPlain $ UnsupportedError "Coercions as expressions" +isKnownApp :: + CompilingDefault uni fun m ann => + GHC.Var -> + [GHC.CoreExpr] -> + Maybe (m (PIRTerm uni fun)) +isKnownApp fun args = Map.lookup (splitNameString (GHC.varName fun)) knownApps >>= ($ args) + +knownApps :: + CompilingDefault uni fun m ann => + Map (Maybe String, String) ([GHC.CoreExpr] -> Maybe (m (PIRTerm uni fun))) +knownApps = + Map.fromListWithKey (\n -> error ("knownApps: key defined more than once: " <> show n)) + . fmap (first (TH.nameModule &&& TH.nameBase)) + $ [ + ( '(GHC.Classes.==) + , \case + [GHC.Type ty, _numDict, GHC.Lit (GHC.LitNumber _ i), GHC.Lit (GHC.LitNumber _ j)] + | ty `GHC.eqType` GHC.integerTy -> Just $ do + res <- lookupDataCon =<< thNameToGhcNameOrFail (if i == j then 'True else 'False) + compileDataConRef $ res + [GHC.Type ty, _eqDict] + | ty `GHC.eqType` GHC.integerTy -> + Just $ + compileExpr . GHC.Var =<< lookupId =<< thNameToGhcNameOrFail 'Builtins.equalsInteger + _ -> Nothing + ) + , + ( '(GHC.Num.+) + , \case + [GHC.Type ty, _numDict, GHC.Lit (GHC.LitNumber numTy i), GHC.Lit (GHC.LitNumber _numTy j)] + | ty `GHC.eqType` GHC.integerTy -> + Just . compileExpr . GHC.Lit $ GHC.LitNumber numTy (i + j) + [GHC.Type ty, _numDict] + | ty `GHC.eqType` GHC.integerTy -> + Just $ + compileExpr . GHC.Var =<< lookupId =<< thNameToGhcNameOrFail 'BI.addInteger + _ -> Nothing + ) + , + ( '(GHC.Num.*) + , \case + [GHC.Type ty, _numDict, GHC.Lit (GHC.LitNumber numTy i), GHC.Lit (GHC.LitNumber _numTy j)] + | ty `GHC.eqType` GHC.integerTy -> + Just . compileExpr . GHC.Lit $ GHC.LitNumber numTy (i * j) + [GHC.Type ty, _numDict] + | ty `GHC.eqType` GHC.integerTy -> + Just $ + compileExpr . GHC.Var =<< lookupId =<< thNameToGhcNameOrFail 'BI.multiplyInteger + _ -> Nothing + ) + , + ( 'GHC.Num.fromInteger + , \case + [GHC.Type ty, _numDict, arg] + | ty `GHC.eqType` GHC.integerTy -> Just $ compileExpr arg + [GHC.Type ty, _numDict] + | ty `GHC.eqType` GHC.integerTy -> Just $ do + idId <- lookupId =<< thNameToGhcNameOrFail 'id + compileExpr $ GHC.mkCoreApps (GHC.Var idId) [GHC.Type GHC.integerTy] + _ -> Nothing + ) + , + ( 'GHC.Num.negate + , \case + [GHC.Type ty, _numDict, GHC.Lit (GHC.LitNumber numTy i)] + | ty `GHC.eqType` GHC.integerTy -> + Just . compileExpr . GHC.Lit $ GHC.LitNumber numTy (-i) + _ -> Nothing + ) + , + ( 'GHC.Real.toInteger + , \case + [GHC.Type ty, _numDict, arg] + | ty `GHC.eqType` GHC.integerTy -> Just $ compileExpr arg + [GHC.Type ty, _integralDict] + | ty `GHC.eqType` GHC.integerTy -> Just $ do + idId <- lookupId =<< thNameToGhcNameOrFail 'id + compileExpr $ GHC.mkCoreApps (GHC.Var idId) [GHC.Type GHC.integerTy] + _ -> Nothing + ) + ] + +splitNameString :: GHC.Name -> (Maybe String, String) +splitNameString name = (modu, occ) + where + modu = fmap (GHC.moduleNameString . GHC.moduleName) (GHC.nameModule_maybe name) + occ = GHC.occNameString (GHC.nameOccName name) + {- Note [What source locations to cover] We try to get as much coverage information as we can out of GHC. This means that anything we find in the GHC Core code that hints at a source location will be diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs index 0596cebb405..238b0ca30ee 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs @@ -22,13 +22,16 @@ import PlutusCore.Annotation import PlutusCore.Builtin qualified as PLC import PlutusCore.Default qualified as PLC import PlutusCore.Quote +import PlutusIR.Compiler.Definitions qualified as PIR import GHC qualified import GHC.Core.FamInstEnv qualified as GHC import GHC.Plugins qualified as GHC +import GHC.Types.TyThing qualified as GHC import Control.Monad.Except import Control.Monad.Reader +import Control.Monad.State import Control.Monad.Writer import Data.List.NonEmpty qualified as NE @@ -174,6 +177,61 @@ stableModuleCmp m1 m2 = -- See Note [Stable name comparisons] (GHC.moduleUnit m1 `GHC.stableUnitCmp` GHC.moduleUnit m2) +class Monad m => MonadCoreM m where + lookupId :: GHC.Name -> m GHC.Id + lookupDataCon :: GHC.Name -> m GHC.DataCon + lookupTyCon :: GHC.Name -> m GHC.TyCon + thNameToGhcName :: TH.Name -> m (Maybe GHC.Name) + +instance MonadCoreM GHC.CoreM where + lookupId = GHC.lookupId + lookupDataCon = GHC.lookupDataCon + lookupTyCon = GHC.lookupTyCon + thNameToGhcName = GHC.thNameToGhcName + +instance MonadCoreM m => MonadCoreM (ReaderT r m) where + lookupId = lift . lookupId + lookupDataCon = lift . lookupDataCon + lookupTyCon = lift . lookupTyCon + thNameToGhcName = lift . thNameToGhcName + +instance (MonadCoreM m, Monoid w) => MonadCoreM (WriterT w m) where + lookupId = lift . lookupId + lookupDataCon = lift . lookupDataCon + lookupTyCon = lift . lookupTyCon + thNameToGhcName = lift . thNameToGhcName + +instance MonadCoreM m => MonadCoreM (StateT s m) where + lookupId = lift . lookupId + lookupDataCon = lift . lookupDataCon + lookupTyCon = lift . lookupTyCon + thNameToGhcName = lift . thNameToGhcName + +instance MonadCoreM m => MonadCoreM (QuoteT m) where + lookupId = lift . lookupId + lookupDataCon = lift . lookupDataCon + lookupTyCon = lift . lookupTyCon + thNameToGhcName = lift . thNameToGhcName + +instance MonadCoreM m => MonadCoreM (ExceptT s m) where + lookupId = lift . lookupId + lookupDataCon = lift . lookupDataCon + lookupTyCon = lift . lookupTyCon + thNameToGhcName = lift . thNameToGhcName + +deriving newtype instance MonadCoreM m => MonadCoreM (PIR.DefT key uni fun ann m) + +-- | Get the 'GHC.Name' corresponding to the given 'TH.Name', or throw an error if we can't get it. +thNameToGhcNameOrFail :: + (MonadCoreM m, MonadError (CompileError uni fun ann) m) => + TH.Name -> + m GHC.Name +thNameToGhcNameOrFail name = do + maybeName <- thNameToGhcName name + case maybeName of + Just n -> pure n + Nothing -> throwError . NoContext $ CoreNameLookupError name + -- See Note [Scopes] type Compiling uni fun m ann = ( MonadError (CompileError uni fun ann) m @@ -181,6 +239,7 @@ type Compiling uni fun m ann = , MonadReader (CompileContext uni fun) m , MonadDefs LexName uni fun Ann m , MonadWriter CoverageIndex m + , MonadCoreM m ) -- Packing up equality constraints gives us a nice way of writing type signatures as this way diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index c130359c218..a14dee321b7 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -369,6 +369,7 @@ runCompiler :: , MonadQuote m , MonadError (CompileError uni fun Ann) m , MonadIO m + , MonadCoreM m ) => String -> PluginOptions -> @@ -455,16 +456,14 @@ runCompiler moduleName opts expr = do getSrcSpans :: PIR.Provenance Ann -> SrcSpans getSrcSpans = SrcSpans . Set.unions . fmap (unSrcSpans . annSrcSpans) . toList --- | Get the 'GHC.Name' corresponding to the given 'TH.Name', or throw an error if we can't get it. -thNameToGhcNameOrFail :: TH.Name -> PluginM uni fun GHC.Name -thNameToGhcNameOrFail name = do - maybeName <- lift . lift $ GHC.thNameToGhcName name - case maybeName of - Just n -> pure n - Nothing -> throwError . NoContext $ CoreNameLookupError name - -- | Create a GHC Core expression that will evaluate to the given ByteString at runtime. -makeByteStringLiteral :: BS.ByteString -> PluginM uni fun GHC.CoreExpr +makeByteStringLiteral :: + ( MonadCoreM m + , MonadError (CompileError uni fun ann) m + , GHC.HasDynFlags m + ) => + BS.ByteString -> + m GHC.CoreExpr makeByteStringLiteral bs = do flags <- GHC.getDynFlags @@ -476,9 +475,9 @@ makeByteStringLiteral bs = do -} -- Get the names of functions/types that we need for our expression - upio <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'unsafePerformIO - bsTc <- lift . lift . GHC.lookupTyCon =<< thNameToGhcNameOrFail ''BS.ByteString - upal <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'BSUnsafe.unsafePackAddressLen + upio <- lookupId =<< thNameToGhcNameOrFail 'unsafePerformIO + bsTc <- lookupTyCon =<< thNameToGhcNameOrFail ''BS.ByteString + upal <- lookupId =<< thNameToGhcNameOrFail 'BSUnsafe.unsafePackAddressLen -- We construct the following expression: -- unsafePerformIO $ unsafePackAddressLen