Merge branch 'master' into ramsay-t/translation-efficiency-2

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

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]

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

plutus-tx-plugin/test/Recursion/9.6/length-direct.budget.golden

@@ -0,0 +1,2 @@
+({cpu: 1855724
+| mem: 9806})

plutus-tx-plugin/test/Recursion/9.6/length-direct.eval.golden

@@ -0,0 +1 @@
+(con integer 3)

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

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

plutus-tx-plugin/test/Recursion/9.6/length-fix.budget.golden

@@ -0,0 +1,2 @@
+({cpu: 1855724
+| mem: 9806})

plutus-tx-plugin/test/Recursion/9.6/length-fix.eval.golden

@@ -0,0 +1 @@
+(con integer 3)

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

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

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

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

plutus-tx/changelog.d/20250206_144045_unsafeFixIO_fix.md

@@ -0,0 +1,3 @@
+### Added
+
+- `PlutusTx.Function.fix`, Plinth's equivalent of `Data.Function.fix`.

plutus-tx/plutus-tx.cabal

@@ -84,6 +84,7 @@ library
     PlutusTx.Eq
     PlutusTx.ErrorCodes
     PlutusTx.Foldable
+    PlutusTx.Function
     PlutusTx.Functor
     PlutusTx.Integer
     PlutusTx.IsData

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

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