From b012b8083a60693eb2d22064cded7a6f115eb296 Mon Sep 17 00:00:00 2001 From: Ziyang Liu Date: Fri, 7 Feb 2025 12:09:48 -0800 Subject: [PATCH] Lift `fix` from PIR/PLC into Plinth (#6825) --- plutus-tx-plugin/plutus-tx-plugin.cabal | 1 + .../src/PlutusTx/Compiler/Expr.hs | 11 ++++ plutus-tx-plugin/src/PlutusTx/Plugin.hs | 2 + .../Recursion/9.6/length-direct.budget.golden | 2 + .../Recursion/9.6/length-direct.eval.golden | 1 + .../Recursion/9.6/length-direct.pir.golden | 17 +++++ .../Recursion/9.6/length-direct.uplc.golden | 3 + .../Recursion/9.6/length-fix.budget.golden | 2 + .../test/Recursion/9.6/length-fix.eval.golden | 1 + .../test/Recursion/9.6/length-fix.pir.golden | 29 +++++++++ .../test/Recursion/9.6/length-fix.uplc.golden | 3 + plutus-tx-plugin/test/Recursion/Spec.hs | 64 +++++++++++++++++++ plutus-tx-plugin/test/Spec.hs | 2 + .../20250206_144045_unsafeFixIO_fix.md | 3 + plutus-tx/plutus-tx.cabal | 1 + plutus-tx/src/PlutusTx/Function.hs | 5 ++ plutus-tx/src/PlutusTx/Prelude.hs | 2 + 17 files changed, 149 insertions(+) create mode 100644 plutus-tx-plugin/test/Recursion/9.6/length-direct.budget.golden create mode 100644 plutus-tx-plugin/test/Recursion/9.6/length-direct.eval.golden create mode 100644 plutus-tx-plugin/test/Recursion/9.6/length-direct.pir.golden create mode 100644 plutus-tx-plugin/test/Recursion/9.6/length-direct.uplc.golden create mode 100644 plutus-tx-plugin/test/Recursion/9.6/length-fix.budget.golden create mode 100644 plutus-tx-plugin/test/Recursion/9.6/length-fix.eval.golden create mode 100644 plutus-tx-plugin/test/Recursion/9.6/length-fix.pir.golden create mode 100644 plutus-tx-plugin/test/Recursion/9.6/length-fix.uplc.golden create mode 100644 plutus-tx-plugin/test/Recursion/Spec.hs create mode 100644 plutus-tx/changelog.d/20250206_144045_unsafeFixIO_fix.md create mode 100644 plutus-tx/src/PlutusTx/Function.hs diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 2a9484c5249..2ef847d6ba8 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/plutus-tx-plugin/plutus-tx-plugin.cabal @@ -156,6 +156,7 @@ test-suite plutus-tx-plugin-tests Plugin.Strict.Spec Plugin.Typeclasses.Lib Plugin.Typeclasses.Spec + Recursion.Spec ShortCircuit.Spec ShortCircuit.WithGHCOptimisations ShortCircuit.WithoutGHCOptimisations diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 3f0e5a31609..f8d9393574e 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -48,6 +48,7 @@ import PlutusTx.Compiler.Type import PlutusTx.Compiler.Types import PlutusTx.Compiler.Utils import PlutusTx.Coverage +import PlutusTx.Function qualified import PlutusTx.PIRTypes import PlutusTx.PLCTypes (PLCType, PLCVar) @@ -67,6 +68,7 @@ import PlutusCore qualified as PLC import PlutusCore.Data qualified as PLC import PlutusCore.MkPlc qualified as PLC import PlutusCore.Pretty qualified as PP +import PlutusCore.StdLib.Data.Function qualified import PlutusCore.Subst qualified as PLC import Control.Exception (displayException) @@ -1349,6 +1351,14 @@ defineIntegerNegate = do def = PIR.Def var (body, PIR.Strict) PIR.defineTerm (LexName GHC.integerNegateName) def mempty +defineFix :: (CompilingDefault PLC.DefaultUni fun m ann) => m () +defineFix = do + ghcId <- lookupGhcId 'PlutusTx.Function.fix + var <- compileVarFresh annMayInline ghcId + let rhs = annMayInline <$ PlutusCore.StdLib.Data.Function.fix + let def = PIR.Def var (rhs, PIR.Strict) + PIR.defineTerm (LexName (GHC.getName ghcId)) def mempty + lookupIntegerNegate :: (Compiling uni fun m ann) => m (PIRTerm uni fun) lookupIntegerNegate = do ghcName <- lookupGhcName 'GHC.Num.Integer.integerNegate @@ -1365,6 +1375,7 @@ compileExprWithDefs e = do defineBuiltinTypes defineBuiltinTerms defineIntegerNegate + defineFix compileExpr e {- Note [We always need DEFAULT] diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index 2dc5f8d925c..8dad4e20f9f 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -30,6 +30,7 @@ import PlutusTx.Compiler.Trace import PlutusTx.Compiler.Types import PlutusTx.Compiler.Utils import PlutusTx.Coverage +import PlutusTx.Function qualified import PlutusTx.PIRTypes import PlutusTx.PLCTypes import PlutusTx.Plugin.Utils @@ -407,6 +408,7 @@ compileMarkedExpr locStr codeTy origE = do , 'GHC.Num.Integer.integerNegate , '(PlutusTx.Bool.&&) , '(PlutusTx.Bool.||) + , 'PlutusTx.Function.fix , 'useToOpaque , 'useFromOpaque , 'mkNilOpaque diff --git a/plutus-tx-plugin/test/Recursion/9.6/length-direct.budget.golden b/plutus-tx-plugin/test/Recursion/9.6/length-direct.budget.golden new file mode 100644 index 00000000000..b0cf873cc4e --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/9.6/length-direct.budget.golden @@ -0,0 +1,2 @@ +({cpu: 1855724 +| mem: 9806}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Recursion/9.6/length-direct.eval.golden b/plutus-tx-plugin/test/Recursion/9.6/length-direct.eval.golden new file mode 100644 index 00000000000..7ce41fb5eca --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/9.6/length-direct.eval.golden @@ -0,0 +1 @@ +(con integer 3) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Recursion/9.6/length-direct.pir.golden b/plutus-tx-plugin/test/Recursion/9.6/length-direct.pir.golden new file mode 100644 index 00000000000..06a8f865e28 --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/9.6/length-direct.pir.golden @@ -0,0 +1,17 @@ +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +letrec + !lengthDirect : List integer -> integer + = \(xs : List integer) -> + List_match + {integer} + xs + {integer} + 0 + (\(ds : integer) (ys : List integer) -> + addInteger 1 (lengthDirect ys)) +in +lengthDirect \ No newline at end of file diff --git a/plutus-tx-plugin/test/Recursion/9.6/length-direct.uplc.golden b/plutus-tx-plugin/test/Recursion/9.6/length-direct.uplc.golden new file mode 100644 index 00000000000..02f796f7b38 --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/9.6/length-direct.uplc.golden @@ -0,0 +1,3 @@ +(program + 1.1.0 + ((\s -> s s) (\s xs -> case xs [0, (\ds ys -> addInteger 1 (s s ys))]))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Recursion/9.6/length-fix.budget.golden b/plutus-tx-plugin/test/Recursion/9.6/length-fix.budget.golden new file mode 100644 index 00000000000..b0cf873cc4e --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/9.6/length-fix.budget.golden @@ -0,0 +1,2 @@ +({cpu: 1855724 +| mem: 9806}) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Recursion/9.6/length-fix.eval.golden b/plutus-tx-plugin/test/Recursion/9.6/length-fix.eval.golden new file mode 100644 index 00000000000..7ce41fb5eca --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/9.6/length-fix.eval.golden @@ -0,0 +1 @@ +(con integer 3) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Recursion/9.6/length-fix.pir.golden b/plutus-tx-plugin/test/Recursion/9.6/length-fix.pir.golden new file mode 100644 index 00000000000..368085ef848 --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/9.6/length-fix.pir.golden @@ -0,0 +1,29 @@ +letrec + data (List :: * -> *) a | List_match where + Nil : List a + Cons : a -> List a -> List a +in +(let + a = List integer + in + /\b -> + \(f : (a -> b) -> a -> b) -> + let + !s : (\a -> ifix (\(self :: * -> *) a -> self a -> a) a) (a -> b) + = iwrap + (\(self :: * -> *) a -> self a -> a) + (a -> b) + (\(s : + (\a -> ifix (\(self :: * -> *) a -> self a -> a) a) + (a -> b)) -> + f (\(x : a) -> unwrap s s x)) + in + unwrap s s) + {integer} + (\(f : List integer -> integer) (xs : List integer) -> + List_match + {integer} + xs + {integer} + 0 + (\(ds : integer) (ys : List integer) -> addInteger 1 (f ys))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Recursion/9.6/length-fix.uplc.golden b/plutus-tx-plugin/test/Recursion/9.6/length-fix.uplc.golden new file mode 100644 index 00000000000..02f796f7b38 --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/9.6/length-fix.uplc.golden @@ -0,0 +1,3 @@ +(program + 1.1.0 + ((\s -> s s) (\s xs -> case xs [0, (\ds ys -> addInteger 1 (s s ys))]))) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Recursion/Spec.hs b/plutus-tx-plugin/test/Recursion/Spec.hs new file mode 100644 index 00000000000..2c8cb77a72b --- /dev/null +++ b/plutus-tx-plugin/test/Recursion/Spec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} + +module Recursion.Spec where + +import Test.Tasty.Extras + +import PlutusTx.Code +import PlutusTx.Function (fix) +import PlutusTx.Lift (liftCodeDef) +import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Test +import PlutusTx.TH (compile) + +tests :: TestNested +tests = + testNested "Recursion" . pure $ + testNestedGhc + [ goldenUPlcReadable "length-direct" compiledLengthDirect + , goldenPirReadable "length-direct" compiledLengthDirect + , goldenEvalCekCatch + "length-direct" + [compiledLengthDirect `unsafeApplyCode` liftCodeDef [1, 2, 3]] + , goldenBudget + "length-direct" + (compiledLengthDirect `unsafeApplyCode` liftCodeDef [1, 2, 3]) + , goldenUPlcReadable "length-fix" compiledLengthFix + , goldenPirReadable "length-fix" compiledLengthFix + , goldenEvalCekCatch + "length-fix" + [compiledLengthFix `unsafeApplyCode` liftCodeDef [1, 2, 3]] + , goldenBudget + "length-fix" + (compiledLengthFix `unsafeApplyCode` liftCodeDef [1, 2, 3]) + ] + +lengthDirect :: [Integer] -> Integer +lengthDirect xs = case xs of + [] -> 0 + (_ : ys) -> 1 PlutusTx.+ lengthDirect ys + +lengthFix :: [Integer] -> Integer +lengthFix = + fix + ( \f xs -> case xs of + [] -> 0 + (_ : ys) -> 1 PlutusTx.+ f ys + ) + +compiledLengthDirect :: CompiledCode ([Integer] -> Integer) +compiledLengthDirect = $$(compile [||lengthDirect||]) + +compiledLengthFix :: CompiledCode ([Integer] -> Integer) +compiledLengthFix = $$(compile [||lengthFix||]) diff --git a/plutus-tx-plugin/test/Spec.hs b/plutus-tx-plugin/test/Spec.hs index f9b3a5acf10..9fdf9198d71 100644 --- a/plutus-tx-plugin/test/Spec.hs +++ b/plutus-tx-plugin/test/Spec.hs @@ -14,6 +14,7 @@ import Lift.Spec qualified as Lift import List.Spec qualified as List import Optimization.Spec qualified as Optimization import Plugin.Spec qualified as Plugin +import Recursion.Spec qualified as Recursion import ShortCircuit.Spec qualified as ShortCircuit import StdLib.Spec qualified as Lib import Strictness.Spec qualified as Strictness @@ -41,6 +42,7 @@ tests = , Lib.tests , Budget.tests , AsData.Budget.tests + , Recursion.tests , Optimization.tests , Strictness.tests , Blueprint.Tests.tests diff --git a/plutus-tx/changelog.d/20250206_144045_unsafeFixIO_fix.md b/plutus-tx/changelog.d/20250206_144045_unsafeFixIO_fix.md new file mode 100644 index 00000000000..f1e57a41d02 --- /dev/null +++ b/plutus-tx/changelog.d/20250206_144045_unsafeFixIO_fix.md @@ -0,0 +1,3 @@ +### Added + +- `PlutusTx.Function.fix`, Plinth's equivalent of `Data.Function.fix`. diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index 601935fa426..3f7ea7fafcc 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -84,6 +84,7 @@ library PlutusTx.Eq PlutusTx.ErrorCodes PlutusTx.Foldable + PlutusTx.Function PlutusTx.Functor PlutusTx.Integer PlutusTx.IsData diff --git a/plutus-tx/src/PlutusTx/Function.hs b/plutus-tx/src/PlutusTx/Function.hs new file mode 100644 index 00000000000..646ebd8b23b --- /dev/null +++ b/plutus-tx/src/PlutusTx/Function.hs @@ -0,0 +1,5 @@ +module PlutusTx.Function (fix) where + +fix :: forall a b. ((a -> b) -> a -> b) -> a -> b +fix f = let ~x = f x in x +{-# OPAQUE fix #-} diff --git a/plutus-tx/src/PlutusTx/Prelude.hs b/plutus-tx/src/PlutusTx/Prelude.hs index fde1ebef004..c1981f41268 100644 --- a/plutus-tx/src/PlutusTx/Prelude.hs +++ b/plutus-tx/src/PlutusTx/Prelude.hs @@ -12,6 +12,7 @@ module PlutusTx.Prelude ( module Semigroup, module Monoid, module Numeric, + module Function, module Functor, module Applicative, module Lattice, @@ -160,6 +161,7 @@ import PlutusTx.Enum as Enum import PlutusTx.Eq as Eq import PlutusTx.ErrorCodes import PlutusTx.Foldable as Foldable +import PlutusTx.Function as Function import PlutusTx.Functor as Functor import PlutusTx.IsData import PlutusTx.Lattice as Lattice