Simplify force . delay in UPLC (#2949)

This introduces a very simple simplification pass in the UPLC pipeline.
All this does is replace `force (delay t)` with `t`.

This matters because every type declaration in PIR will turn into an
immediately-instantiated type abstraction, which gets erased to a
`force/delay` pair. So this saves us ~2 AST nodes for every type
declaration, which seems like a minor but worthwhile difference.

nix/pkgs/haskell/materialized-unix/.plan.nix/plutus-core.nix

@@ -174,6 +174,7 @@
           "UntypedPlutusCore/Rename/Internal"
           "UntypedPlutusCore/Size"
           "UntypedPlutusCore/Subst"
+          "UntypedPlutusCore/Transform/Simplify"
           "Data/Aeson/THReader"
           "Data/Functor/Foldable/Monadic"
           "PlutusCore"
@@ -379,6 +380,7 @@
             "Evaluation/ApplyBuiltinName"
             "Evaluation/Golden"
             "Evaluation/Machines"
+            "Transform/Simplify"
             ];
           hsSourceDirs = [ "untyped-plutus-core/test" ];
           mainPath = [ "Spec.hs" ];

plutus-core/plutus-core.cabal

@@ -218,6 +218,7 @@ library
         UntypedPlutusCore.Rename.Internal
         UntypedPlutusCore.Size
         UntypedPlutusCore.Subst
+        UntypedPlutusCore.Transform.Simplify
 
         Data.Aeson.THReader
         Data.Functor.Foldable.Monadic
@@ -350,6 +351,7 @@ test-suite untyped-plutus-core-test
         Evaluation.ApplyBuiltinName
         Evaluation.Golden
         Evaluation.Machines
+        Transform.Simplify
     build-depends:
         plutus-core -any,
         base >=4.9 && <5,
@@ -399,7 +401,7 @@ benchmark cost-model-budgeting-bench
         filepath -any,
         hedgehog -any,
         random -any
-        
+
 
 -- This reads the CSV data generated by cost-model-budgeting-bench, builds the models
 -- using R, and saces them in cost-model/data/costModel.json

plutus-core/untyped-plutus-core/src/UntypedPlutusCore.hs

@@ -15,6 +15,7 @@ import           UntypedPlutusCore.Core.Instance.Flat as Export
 import           UntypedPlutusCore.DeBruijn           as Export
 import           UntypedPlutusCore.Size               as Export
 import           UntypedPlutusCore.Subst              as Export
+import           UntypedPlutusCore.Transform.Simplify as Export
 -- Also has some functions
 
 

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/Simplify.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE LambdaCase #-}
+-- | Very basic simplifications on UPLC.
+module UntypedPlutusCore.Transform.Simplify
+    ( simplifyTerm
+    , simplifyProgram
+    ) where
+
+import           UntypedPlutusCore.Core
+
+import           Control.Lens           (transformOf)
+
+simplifyProgram :: Program name uni fun a -> Program name uni fun a
+simplifyProgram (Program a v t) = Program a v $ simplifyTerm t
+
+simplifyTerm :: Term name uni fun a -> Term name uni fun a
+simplifyTerm = transformOf termSubterms processTerm
+
+processTerm :: Term name uni fun a -> Term name uni fun a
+processTerm = \case
+    Force _ (Delay _ t) -> t
+    t                   -> t

plutus-core/untyped-plutus-core/test/Spec.hs

@@ -3,6 +3,7 @@ module Main where
 import           Evaluation.ApplyBuiltinName (test_applyDefaultBuiltin)
 import           Evaluation.Golden           (test_golden)
 import           Evaluation.Machines
+import           Transform.Simplify          (test_simplify)
 
 import           Test.Tasty
 
@@ -14,4 +15,5 @@ main = defaultMain $ testGroup "Untyped Plutus Core"
     , test_budget
     , test_golden
     , test_tallying
+    , test_simplify
     ]

plutus-core/untyped-plutus-core/test/Transform/Simplify.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+module Transform.Simplify where
+
+import qualified PlutusCore           as PLC
+import           PlutusCore.MkPlc
+import           PlutusCore.Pretty
+import           UntypedPlutusCore
+
+import qualified Data.ByteString.Lazy as BSL
+import           Data.Coerce          (coerce)
+import           Data.Text.Encoding   (encodeUtf8)
+import           Test.Tasty
+import           Test.Tasty.Golden
+
+basic :: Term Name PLC.DefaultUni PLC.DefaultFun ()
+basic = Force () $ Delay () $ mkConstant @Integer () 1
+
+nested :: Term Name PLC.DefaultUni PLC.DefaultFun ()
+nested = Force () $ Force () $ Delay () $ Delay () $ mkConstant @Integer () 1
+
+extraDelays :: Term Name PLC.DefaultUni PLC.DefaultFun ()
+extraDelays = Force () $ Delay () $ Delay () $ mkConstant @Integer () 1
+
+interveningLambda :: Term Name PLC.DefaultUni PLC.DefaultFun ()
+interveningLambda =
+    let lam = LamAbs () (Name "" (coerce (1::Int))) $ Delay () $ mkConstant @Integer () 1
+        arg = mkConstant @Integer () 1
+    in Force () $ Apply () lam arg
+
+-- TODO Fix duplication with other golden tests, quite annoying
+goldenVsPretty :: PrettyPlc a => String -> String -> a -> TestTree
+goldenVsPretty extn name value =
+    goldenVsString name ("untyped-plutus-core/test/Transform/" ++ name ++ extn) $
+        pure . BSL.fromStrict . encodeUtf8 . render $ prettyPlcClassicDebug value
+
+goldenVsSimplified :: String -> Term Name PLC.DefaultUni PLC.DefaultFun () -> TestTree
+goldenVsSimplified name
+    = goldenVsPretty ".plc.golden" name
+    . simplifyTerm
+
+test_simplify :: TestTree
+test_simplify =
+    testGroup "simplify"
+        [ goldenVsSimplified "basic" basic
+        , goldenVsSimplified "nested" nested
+        , goldenVsSimplified "extraDelays" extraDelays
+        , goldenVsSimplified "interveningLambda" interveningLambda
+        ]

plutus-core/untyped-plutus-core/test/Transform/basic.plc.golden

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

plutus-core/untyped-plutus-core/test/Transform/extraDelays.plc.golden

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

plutus-core/untyped-plutus-core/test/Transform/interveningLambda.plc.golden

@@ -0,0 +1 @@
+(force [ (lam _1 (delay (con integer 1))) (con integer 1) ])

plutus-core/untyped-plutus-core/test/Transform/nested.plc.golden

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

plutus-tx-plugin/src/PlutusTx/Plugin.hs

@@ -335,7 +335,7 @@ runCompiler opts expr = do
     when (poDoTypecheck opts) . void $
         liftExcept $ PLC.typecheckPipeline plcTcConfig plcP
 
-    uplcP <- liftExcept $ UPLC.deBruijnProgram $ UPLC.eraseProgram plcP
+    uplcP <- liftExcept $ UPLC.deBruijnProgram $ UPLC.simplifyProgram $ UPLC.eraseProgram plcP
     pure (spirP, uplcP)
 
   where