Add support for base integer comparison

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)

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

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
 

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]

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

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})

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
+  ]
+)