diff --git a/plutus-tx-plugin/app/GeneratePrecompiledTerms.hs b/plutus-tx-plugin/app/GeneratePrecompiledTerms.hs new file mode 100644 index 00000000000..74e07ae2595 --- /dev/null +++ b/plutus-tx-plugin/app/GeneratePrecompiledTerms.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=10 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=10 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=10 #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +{-# OPTIONS_GHC -fforce-recomp #-} + +module Main (main) where + +import Prelude + +import PlutusTx.Compiler.Precompiled + +main :: IO () +main = $(precompileMain) diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index b4180359ca9..245144d2d04 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -13,6 +13,7 @@ description: The Plutus Tx compiler and GHC plugin. category: Language build-type: Simple extra-doc-files: README.md +data-files: precompiled/* source-repository head type: git @@ -55,6 +56,7 @@ library hs-source-dirs: src exposed-modules: PlutusTx.Compiler.Error + PlutusTx.Compiler.Precompiled PlutusTx.Options PlutusTx.Plugin @@ -80,6 +82,8 @@ library , containers , either , extra + , file-embed + , filepath , flat ^>=0.6 , ghc , lens @@ -109,6 +113,21 @@ executable gen-plugin-opts-doc default-language: Haskell2010 +executable gen-precompiled-terms + import: lang, ghc-version-support, os-support + main-is: GeneratePrecompiledTerms.hs + hs-source-dirs: app + build-depends: + , base >=4.7 && <5 + , plutus-tx-plugin ^>=1.45 + + default-language: Haskell2010 + default-extensions: Strict + ghc-options: + -threaded -rtsopts -with-rtsopts=-N -g -fno-strictness + -fno-unbox-strict-fields -fno-unbox-small-strict-fields + -fno-full-laziness + test-suite plutus-tx-plugin-tests import: lang, ghc-version-support, os-support type: exitcode-stdio-1.0 diff --git a/plutus-tx-plugin/precompiled/PlutusTx.Builtins.equalsInteger b/plutus-tx-plugin/precompiled/PlutusTx.Builtins.equalsInteger new file mode 100644 index 00000000000..13e61a684f1 Binary files /dev/null and b/plutus-tx-plugin/precompiled/PlutusTx.Builtins.equalsInteger differ diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index eeb09503397..8ecb7797b66 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -18,6 +18,7 @@ module PlutusTx.Compiler.Builtins ( , lookupBuiltinType , errorFunc) where +import PlutusTx.Builtins qualified as PTxBuiltins import PlutusTx.Builtins.HasOpaque qualified as Builtins import PlutusTx.Builtins.Internal qualified as Builtins @@ -200,6 +201,7 @@ builtinNames = [ , 'Builtins.lessThanInteger , 'Builtins.lessThanEqualsInteger , 'Builtins.equalsInteger + , 'PTxBuiltins.equalsInteger , 'Builtins.error diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index f8b0a10fe14..37c0f8aa858 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -40,6 +41,7 @@ import PlutusTx.Compiler.Builtins import PlutusTx.Compiler.Error import PlutusTx.Compiler.Laziness import PlutusTx.Compiler.Names +import PlutusTx.Compiler.Precompiled import PlutusTx.Compiler.Trace import PlutusTx.Compiler.Type import PlutusTx.Compiler.Types @@ -848,6 +850,7 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do boolOperatorOr <- lookupGhcName '(PlutusTx.Bool.||) boolOperatorAnd <- lookupGhcName '(PlutusTx.Bool.&&) inlineName <- lookupGhcName 'PlutusTx.Optimize.Inline.inline + builtinEqualsInteger <- lookupGhcName 'Builtins.equalsInteger case e of {- Note [Lazy boolean operators] @@ -1006,7 +1009,7 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do throwPlain $ UnsupportedError "Use of == from the Haskell Eq typeclass" GHC.Var n | isProbablyIntegerEq n -> - throwPlain $ UnsupportedError "Use of Haskell Integer equality, possibly via the Haskell Eq typeclass" + foo GHC.Var n | isProbablyBytestringEq n -> throwPlain $ UnsupportedError "Use of Haskell ByteString equality, possibly via the Haskell Eq typeclass" @@ -1469,6 +1472,13 @@ defineIntegerNegate = do def = PIR.Def var (body, PIR.Strict) PIR.defineTerm (LexName GHC.integerNegateName) def mempty +-- defineIntegerEq :: (CompilingDefault PLC.DefaultUni fun m ann) => m () +-- defineIntegerEq = do +-- ghcId <- lookupGhcId 'GHC.Num.Integer.integerEq +-- var <- compileVarFresh annAlwaysInline ghcId +-- let def = PIR.Def var (, PIR.Strict) +-- PIR.defineTerm (LexName (GHC.getName ghcId)) def mempty + defineFix :: (CompilingDefault PLC.DefaultUni fun m ann) => m () defineFix = do inlineFix <- asks (coInlineFix . ccOpts) @@ -1486,6 +1496,14 @@ lookupIntegerNegate = do Nothing -> throwPlain $ CompilationError "Cannot find the definition of integerNegate. Please file a bug report." +foo :: (Compiling uni fun m ann) => m (PIRTerm uni fun) +foo = do + ghcName <- lookupGhcName 'Builtins.equalsInteger + PIR.lookupTerm (LexName ghcName) >>= \case + Just t -> pure t + Nothing -> throwPlain $ + CompilationError "Cannot find the definition of integerNegate. Please file a bug report." + compileExprWithDefs :: (CompilingDefault uni fun m ann) => GHC.CoreExpr -> @@ -1495,6 +1513,7 @@ compileExprWithDefs e = do defineBuiltinTerms defineIntegerNegate defineFix + $(definePrecompiledTerms) compileExpr e {- Note [We always need DEFAULT] diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Precompiled.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Precompiled.hs new file mode 100644 index 00000000000..fb6b4882077 --- /dev/null +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Precompiled.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +module PlutusTx.Compiler.Precompiled where + +import Debug.Trace +import PlutusCore.Pretty + +import Data.ByteString qualified as BS +import Data.FileEmbed +import Flat +import Language.Haskell.TH.Lib qualified as TH +import Language.Haskell.TH.Syntax qualified as TH +import System.FilePath + +import GHC.Types.Name qualified as GHC + +import PlutusIR qualified as PIR +import PlutusIR.Compiler.Definitions qualified as PIR +import PlutusIR.MkPir qualified as PIR +import PlutusTx +import PlutusTx.Builtins qualified +import PlutusTx.Code qualified as PlutusTx +import PlutusTx.Compiler.Types +import PlutusTx.Compiler.Utils + +precompiledTermsPath :: FilePath +precompiledTermsPath = "precompiled" + +preCompiledTerms :: [TH.Name] +preCompiledTerms = + [ 'PlutusTx.Builtins.equalsInteger + ] + +-- test :: () +-- test = +-- let +-- foo = [||PlutusTx.Builtins.equalsInteger||] +-- in () + +precompile :: TH.Name -> TH.Q TH.Exp +precompile name = do + let + fileName = precompiledTermsPath Prelude.show name + foo :: TH.Code TH.Q (Integer -> Integer -> Bool) + foo = (TH.Code $ pure $ TH.TExp $ TH.VarE name) + compiled = TH.unType <$> (TH.examineCode $ PlutusTx.compile foo) + + [| case $(compiled) of + PlutusTx.SerializedCode _ (Just pir) _ -> do + BS.writeFile $(TH.lift fileName) pir + _ -> putStrLn $ "Compilation result of " <> $(TH.lift $ show name) <> "does not have PIR" + |] + +precompileMain :: TH.Q TH.Exp +precompileMain = TH.doE $ TH.noBindS . precompile <$> preCompiledTerms + +definePrecompiledTerm :: TH.Name -> TH.Q TH.Exp +definePrecompiledTerm name = do + let + filePath = precompiledTermsPath Prelude.show name + pirRaw = embedFileIfExists filePath + + [| case ($pirRaw :: Maybe BS.ByteString) of + Nothing -> pure () + Just pirRaw' -> + case unflat @(PIR.Program _ _ _ _ SrcSpans) pirRaw' of + Left _ -> pure () + Right pir -> do + ghcId <- lookupGhcId name + var <- compileVarFresh annMayInline ghcId + PIR.defineTerm + (LexName (GHC.getName ghcId)) + (PIR.Def + var + ((annMayInline <$ pir) ^. PIR.progTerm, PIR.Strict)) + mempty + |] + +definePrecompiledTerms :: TH.Q TH.Exp +definePrecompiledTerms = TH.doE $ TH.noBindS . definePrecompiledTerm <$> preCompiledTerms diff --git a/plutus-tx-plugin/test/Plugin/Errors/Spec.hs b/plutus-tx-plugin/test/Plugin/Errors/Spec.hs index 526bc5bd92c..f41b7a1d9c7 100644 --- a/plutus-tx-plugin/test/Plugin/Errors/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Errors/Spec.hs @@ -15,6 +15,8 @@ module Plugin.Errors.Spec where +import Prelude as Haskell + import Test.Tasty.Extras import PlutusCore.Test (goldenUPlc) @@ -83,8 +85,8 @@ oddDirectLocal n = if Builtins.equalsInteger n 0 then False else evenDirectLocal mutualRecursionUnfoldingsLocal :: CompiledCode Bool mutualRecursionUnfoldingsLocal = plc (Proxy @"mutualRecursionUnfoldingsLocal") (evenDirectLocal 4) -literalCaseInt :: CompiledCode (Integer -> Integer) -literalCaseInt = plc (Proxy @"literalCaseInt") (\case { 1 -> 2; x -> x}) +literalCaseInt :: CompiledCode (Integer -> Bool) +literalCaseInt = plc (Proxy @"literalCaseInt") (\x -> x == 1) literalCaseBs :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString) literalCaseBs = plc (Proxy @"literalCaseBs") (\x -> case x of { "abc" -> ""; x -> x}) diff --git a/plutus-tx-plugin/test/TH/9.6/baseIntegerEq.eval-cek.golden b/plutus-tx-plugin/test/TH/9.6/baseIntegerEq.eval-cek.golden new file mode 100644 index 00000000000..85753ab4050 --- /dev/null +++ b/plutus-tx-plugin/test/TH/9.6/baseIntegerEq.eval-cek.golden @@ -0,0 +1,109 @@ +(lam + x + [ + (lam + x + [ + [ + [ + [ + [ + (force + (delay + (lam + True + (lam + False + (lam + Bool_match + [ + (force + [ + (lam `==` (force `==`)) + (delay (delay (lam v v))) + ] + ) + [ + (lam + ifThenElse + [ + (lam + equalsInteger + [ + (lam + equalsInteger + [ + (lam + `$fEqInteger` (force `$fEqInteger`) + ) + (delay (force equalsInteger)) + ] + ) + (delay + (lam + x + [ + (lam + x + (lam + y + [ + (lam + y + [ + (lam + b + [ + [ + [ + (force ifThenElse) + b + ] + True + ] + False + ] + ) + [ [ equalsInteger x ] y ] + ] + ) + y + ] + ) + ) + x + ] + ) + ) + ] + ) + (builtin equalsInteger) + ] + ) + (builtin ifThenElse) + ] + ] + ) + ) + ) + ) + ) + (constr 0) + ] + (constr 1) + ] + (lam + x + (delay + (lam case_True (lam case_False (case x case_True case_False))) + ) + ) + ] + x + ] + (con integer 42) + ] + ) + x + ] +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/TH/9.6/baseIntegerEq.pir.golden b/plutus-tx-plugin/test/TH/9.6/baseIntegerEq.pir.golden new file mode 100644 index 00000000000..2717445c79d --- /dev/null +++ b/plutus-tx-plugin/test/TH/9.6/baseIntegerEq.pir.golden @@ -0,0 +1,68 @@ +(program + 1.1.0 + (let + (nonrec) + (datatypebind + (datatype + (tyvardecl Bool (type)) + + Bool_match + (vardecl True Bool) (vardecl False Bool) + ) + ) + (termbind + (strict) + (vardecl equalsInteger (fun (con integer) (fun (con integer) (con bool)))) + (builtin equalsInteger) + ) + (termbind + (strict) + (vardecl ifThenElse (all a (type) (fun (con bool) (fun a (fun a a))))) + (builtin ifThenElse) + ) + (termbind + (nonstrict) + (vardecl equalsInteger (fun (con integer) (fun (con integer) Bool))) + (lam + x + (con integer) + (let + (nonrec) + (termbind (strict) (vardecl x (con integer)) x) + (lam + y + (con integer) + (let + (nonrec) + (termbind (strict) (vardecl y (con integer)) y) + (termbind + (strict) (vardecl b (con bool)) [ [ equalsInteger x ] y ] + ) + [ [ [ { ifThenElse Bool } b ] True ] False ] + ) + ) + ) + ) + ) + (termbind + (nonstrict) + (vardecl + `$fEqInteger` [ (lam a (type) (fun a (fun a Bool))) (con integer) ] + ) + equalsInteger + ) + (termbind + (nonstrict) + (vardecl + `==` + (all + a + (type) + (fun [ (lam a (type) (fun a (fun a Bool))) a ] (fun a (fun a Bool))) + ) + ) + (abs a (type) (lam v [ (lam a (type) (fun a (fun a Bool))) a ] v)) + ) + [ { `==` (con integer) } `$fEqInteger` ] + ) +) \ No newline at end of file diff --git a/plutus-tx-plugin/test/TH/Spec.hs b/plutus-tx-plugin/test/TH/Spec.hs index 10bbbb0bedd..66746c06cec 100644 --- a/plutus-tx-plugin/test/TH/Spec.hs +++ b/plutus-tx-plugin/test/TH/Spec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} @@ -11,6 +12,8 @@ {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -fforce-recomp #-} + module TH.Spec (tests) where import Test.Tasty.Extras @@ -48,6 +51,8 @@ tests = testNested "TH" . pure $ testNestedGhc , goldenEvalCekLog "traceRepeatedly" [traceRepeatedly] -- want to see the raw structure, so using Show , nestedGoldenVsDoc "someData" "" (pretty $ Haskell.show someData) + + , goldenPir "baseIntegerEq" baseIntegerEq ] simple :: CompiledCode (Bool -> Integer) @@ -80,3 +85,9 @@ traceRepeatedly = $$(compile i3 = trace ("Adding them up: " <> show (i1 + i2)) (i1 + i2) in i3 ||]) + +baseIntegerEq :: CompiledCode (Bool) +baseIntegerEq = $$(compile + [|| + (1 Haskell.== (2 :: Integer)) + ||])