Use Strict in Plutus Tx

IntersectMBO · May 25, 2023 · 6186637 · 6186637
1 parent b3b258a
commit 6186637
Show file tree

Hide file tree

Showing 118 changed files with 5,632 additions and 3,355 deletions.
diff --git a/plutus-benchmark/lists/test/Sum/left-fold-built-in.budget.golden b/plutus-benchmark/lists/test/Sum/left-fold-built-in.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 160559654
-| mem: 504532})
+({cpu: 174359654
+| mem: 564532})
diff --git a/plutus-benchmark/lists/test/Sum/left-fold-data.budget.golden b/plutus-benchmark/lists/test/Sum/left-fold-data.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 378574685
-| mem: 1148162})
+({cpu: 398364389
+| mem: 1245330})
diff --git a/plutus-benchmark/lists/test/Sum/right-fold-built-in.budget.golden b/plutus-benchmark/lists/test/Sum/right-fold-built-in.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 167459654
-| mem: 534532})
+({cpu: 181259654
+| mem: 594532})
diff --git a/plutus-benchmark/lists/test/Sum/right-fold-data.budget.golden b/plutus-benchmark/lists/test/Sum/right-fold-data.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 385474685
-| mem: 1178162})
+({cpu: 405264389
+| mem: 1275330})
diff --git a/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/LastPiece.hs b/plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/LastPiece.hs
@@ -5,6 +5,8 @@
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TemplateHaskell       #-}
+{-# OPTIONS_GHC -fno-specialise #-}
+{-# OPTIONS_GHC -fno-strictness #-}
 
 {-% Last piece puzzle, adapted from nofib/spectral/last-piece.
     This is a solver for a jigsaw problem:

diff --git a/plutus-benchmark/nofib/test/Spec.hs b/plutus-benchmark/nofib/test/Spec.hs
@@ -46,7 +46,7 @@ testClausify = testGroup "clausify"
                , testCase "formula3" $ mkClausifyTest Clausify.F3
                , testCase "formula4" $ mkClausifyTest Clausify.F4
                , testCase "formula5" $ mkClausifyTest Clausify.F5
-               , Tx.fitsInto "formula1 (size)" (Clausify.mkClausifyCode Clausify.F1) 3304
+               , Tx.fitsInto "formula1 (size)" (Clausify.mkClausifyCode Clausify.F1) 3521
                , runTestNested $
                   Tx.goldenBudget "formulaBudget" $ Clausify.mkClausifyCode Clausify.F1
                ]
@@ -95,7 +95,7 @@ testQueens = testGroup "queens"
                , runTestNested    $ Tx.goldenBudget "queens5budget" $
                   Queens.mkQueensCode 5 Queens.Bt
                ]
-             , Tx.fitsInto "Bt (size)" (Queens.mkQueensCode 5 Queens.Bt) 1943
+             , Tx.fitsInto "Bt (size)" (Queens.mkQueensCode 5 Queens.Bt) 2034
              ]
 
 ---------------- Primes ----------------

diff --git a/plutus-benchmark/nofib/test/formulaBudget.budget.golden b/plutus-benchmark/nofib/test/formulaBudget.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 9146695908
-| mem: 38237448})
+({cpu: 5164038908
+| mem: 20921548})
diff --git a/plutus-benchmark/nofib/test/knightsBudget.budget.golden b/plutus-benchmark/nofib/test/knightsBudget.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 4484460298
-| mem: 15072240})
+({cpu: 6557595072
+| mem: 21801204})
diff --git a/plutus-benchmark/nofib/test/queens4budget.budget.golden b/plutus-benchmark/nofib/test/queens4budget.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 9369717305
-| mem: 33848842})
+({cpu: 9946650905
+| mem: 35910610})
diff --git a/plutus-benchmark/nofib/test/queens5budget.budget.golden b/plutus-benchmark/nofib/test/queens5budget.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 128906178648
-| mem: 453182780})
+({cpu: 138199584478
+| mem: 486584420})
diff --git a/plutus-benchmark/plutus-benchmark.cabal b/plutus-benchmark/plutus-benchmark.cabal
@@ -38,10 +38,13 @@ common lang
     ImportQualifiedPost
     ScopedTypeVariables
     StandaloneDeriving
+    Strict
 
   ghc-options:
     -fno-specialise -fno-spec-constr -fno-ignore-interface-pragmas
-    -fno-omit-interface-pragmas
+    -fno-omit-interface-pragmas -fno-strictness
+    -fno-unbox-strict-fields -fno-unbox-small-strict-fields
+    -fforce-recomp
 
   ghc-options:
     -Wall -Wnoncanonical-monad-instances -Wincomplete-uni-patterns

diff --git a/plutus-benchmark/script-contexts/test/checkScriptContexEqualityData-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContexEqualityData-20.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 60584597
-| mem: 200602})
+({cpu: 60653597
+| mem: 200902})
diff --git a/plutus-benchmark/script-contexts/test/checkScriptContext1-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContext1-20.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 424297997
-| mem: 1316969})
+({cpu: 32842097
+| mem: 104340})
diff --git a/plutus-benchmark/script-contexts/test/checkScriptContext1-4.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContext1-4.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 124093245
-| mem: 389193})
+({cpu: 32842097
+| mem: 104340})
diff --git a/plutus-benchmark/script-contexts/test/checkScriptContext2-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContext2-20.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 405027508
-| mem: 1254326})
+({cpu: 32842097
+| mem: 104340})
diff --git a/plutus-benchmark/script-contexts/test/checkScriptContext2-4.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContext2-4.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 118430388
-| mem: 371382})
+({cpu: 32842097
+| mem: 104340})
diff --git a/plutus-benchmark/script-contexts/test/checkScriptContextEqualityTerm-20.budget.golden b/plutus-benchmark/script-contexts/test/checkScriptContextEqualityTerm-20.budget.golden
@@ -1,2 +1,2 @@
-({cpu: 573072251
-| mem: 2333646})
+({cpu: 608860251
+| mem: 2489246})
diff --git a/plutus-core/plutus-ir/src/PlutusIR/Purity.hs b/plutus-core/plutus-ir/src/PlutusIR/Purity.hs
@@ -5,17 +5,20 @@
 
 module PlutusIR.Purity
     ( isPure
+    , FirstEffectfulTerm (..)
     , firstEffectfulTerm
+    , firstEffectfulTerm2
     , asBuiltinApp
     , isSaturated
     , BuiltinApp (..)
     , Arg (..)
     ) where
 
+import PlutusCore.Builtin
 import PlutusIR
 
+import Control.Applicative
 import Data.List.NonEmpty qualified as NE
-import PlutusCore.Builtin
 
 -- | An argument taken by a builtin: could be a term of a type.
 data Arg tyname name uni fun a = TypeArg (Type tyname uni a) | TermArg (Term tyname name uni fun a)
@@ -127,6 +130,53 @@ isPure ver varStrictness = go
             TermBind _ Strict _ rhs -> go rhs
             _                       -> True
 
+data FirstEffectfulTerm tyname name uni fun a
+  = FirstEffectfulTerm (Term tyname name uni fun a)
+  | Uncertain
+
+{- |
+Try to identify the first sub term which will be evaluated in the given term and
+which could have an effect. 'Nothing' indicates that there's no term to evaluate.
+-}
+firstEffectfulTerm2 ::
+  forall tyname name uni fun a.
+  Term tyname name uni fun a ->
+  Maybe (FirstEffectfulTerm tyname name uni fun a)
+firstEffectfulTerm2 = goTerm
+    where
+      goTerm :: Term tyname name uni fun a -> Maybe (FirstEffectfulTerm tyname name uni fun a)
+      goTerm = \case
+        Let _ NonRec bs b -> goBindings (NE.toList bs) <|> goTerm b
+
+        Apply _ fun args  -> goTerm fun <|> goTerm args
+        TyInst _ t _      -> goTerm t
+        IWrap _ _ _ t     -> goTerm t
+        Unwrap _ t        -> goTerm t
+        Constr _ _ _ []   -> Nothing
+        Constr _ _ _ ts   -> asum $ goTerm <$> ts
+        Case _ _ t _      -> goTerm t
+
+        t@Var{}           -> Just (FirstEffectfulTerm t)
+        t@Error{}         -> Just (FirstEffectfulTerm t)
+        Builtin{}         -> Nothing
+
+        -- Hard to know what gets evaluated first in a recursive let-binding,
+        -- just give up and return `Uncertain`
+        (Let _ Rec _ _)   -> Just Uncertain
+        TyAbs{}           -> Nothing
+        LamAbs{}          -> Nothing
+        Constant{}        -> Nothing
+
+      goBindings ::
+        [Binding tyname name uni fun a] ->
+        Maybe (FirstEffectfulTerm tyname name uni fun a)
+      goBindings [] = Nothing
+      goBindings (b:bs) = case b of
+        -- Only strict term bindings can cause effects
+        TermBind _ Strict _ rhs -> goTerm rhs
+        _                       -> goBindings bs
+
+
 {- |
 Try to identify the first sub term which will be evaluated in the given term and
 which could have an effect. 'Nothing' indicates that we don't know, this function

diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs
@@ -18,7 +18,7 @@ import PlutusCore.Subst (typeSubstTyNamesM)
 import PlutusIR
 import PlutusIR.Analysis.Dependencies qualified as Deps
 import PlutusIR.Analysis.Usages qualified as Usages
-import PlutusIR.Purity (firstEffectfulTerm, isPure)
+import PlutusIR.Purity (FirstEffectfulTerm (..), firstEffectfulTerm2, isPure)
 import PlutusIR.Transform.Rename ()
 import PlutusPrelude
 
@@ -300,9 +300,9 @@ effectSafe body s n purity = do
     -- This can in the worst case traverse a lot of the term, which could lead to us
     -- doing ~quadratic work as we process the program. However in practice most term
     -- types will make it give up, so it's not too bad.
-    let immediatelyEvaluated = case firstEffectfulTerm body of
-            Just (Var _ n') -> n == n'
-            _               -> False
+    let immediatelyEvaluated = case firstEffectfulTerm2 body of
+            Just (FirstEffectfulTerm (Var _ n')) -> n == n'
+            _                                    -> False
     pure $ case s of
         Strict    -> purity || immediatelyEvaluated
         NonStrict -> True

diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal
@@ -44,6 +44,7 @@ common lang
     -Wincomplete-record-updates -Wredundant-constraints -Widentities
     -Wunused-packages -Wmissing-deriving-strategies -fobject-code
     -fno-ignore-interface-pragmas -fno-omit-interface-pragmas
+    -fno-strictness
 
 library
   import:           lang

diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal
@@ -40,6 +40,7 @@ common lang
     -Wincomplete-record-updates -Wredundant-constraints -Widentities
     -Wunused-packages -Wmissing-deriving-strategies -fobject-code
     -fno-ignore-interface-pragmas -fno-omit-interface-pragmas
+    -fforce-recomp
 
 common ghc-version-support
   -- See the section on GHC versions in CONTRIBUTING
@@ -115,7 +116,7 @@ executable gen-plugin-opts-doc
   default-language: Haskell2010
 
 test-suite plutus-tx-tests
-  import:         lang, ghc-version-support
+  import:             lang, ghc-version-support
 
   -- test output changes after 9.2, bad for golden tests
   if impl(ghc >=9.3)
@@ -124,9 +125,9 @@ test-suite plutus-tx-tests
   if flag(use-ghc-stub)
     buildable: False
 
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        Spec.hs
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  main-is:            Spec.hs
   other-modules:
     Budget.Spec
     IsData.Spec
@@ -169,20 +170,29 @@ test-suite plutus-tx-tests
     , template-haskell
     , text
 
+  default-extensions: Strict
+
   -- NOTE: -g makes the plugin give better errors
-  ghc-options:    -g
+  ghc-options:
+    -g -fno-strictness -fno-unbox-strict-fields
+    -fno-unbox-small-strict-fields
 
 test-suite size
-  import:         lang, ghc-version-support
+  import:             lang, ghc-version-support
 
   -- needs plutus-tx-plugin but it looks unused
-  ghc-options:    -Wno-unused-packages
-  type:           exitcode-stdio-1.0
-  main-is:        Main.hs
-  hs-source-dirs: test/size
+  ghc-options:        -Wno-unused-packages
+  type:               exitcode-stdio-1.0
+  main-is:            Main.hs
+  hs-source-dirs:     test/size
   build-depends:
     , base                                      >=4.9 && <5.0
     , plutus-tx-plugin                          ^>=1.7
     , plutus-tx:{plutus-tx, plutus-tx-testlib}  ^>=1.7
     , tagged
     , tasty
+
+  default-extensions: Strict
+  ghc-options:
+    -fno-strictness -fno-unbox-strict-fields
+    -fno-unbox-small-strict-fields
diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs
@@ -280,7 +280,7 @@ mkConstructorType dc =
             pure $ PIR.mkIterTyFun annMayInline args resultType
 
 ghcStrictnessNote :: GHC.SDoc
-ghcStrictnessNote = "Note: GHC can generate these unexpectedly, you may need '-fno-strictness', '-fno-specialise', or '-fno-spec-constr'"
+ghcStrictnessNote = "Note: GHC can generate these unexpectedly, you may need '-fno-strictness', '-fno-specialise', '-fno-spec-constr', '-fno-unbox-strict-fields', or '-fno-unbox-small-strict-fields'."
 
 -- | Get the constructors of the given 'TyCon' as PLC terms.
 getConstructors :: CompilingDefault uni fun m ann => GHC.TyCon -> m [PIRTerm uni fun]

diff --git a/plutus-tx-plugin/test/Budget/Spec.hs b/plutus-tx-plugin/test/Budget/Spec.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE ScopedTypeVariables   #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeApplications      #-}
+{-# OPTIONS_GHC -fforce-recomp #-}
 {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-}
 {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-}

diff --git a/plutus-tx-plugin/test/Budget/andCheap.pir-readable.golden b/plutus-tx-plugin/test/Budget/andCheap.pir-readable.golden
@@ -27,20 +27,23 @@ letrec
                  {all dead. dead})
           {all dead. dead}
 in
-and
-  ((let
-       a = List Bool
-     in
-     \(c : Bool -> a -> a)
-      (n : a) ->
-       c
-         False
-         (c
-            True
+let
+  !ls : List Bool
+    = (let
+          a = List Bool
+        in
+        \(c : Bool -> a -> a)
+         (n : a) ->
+          c
+            False
             (c
                True
                (c
                   True
-                  (c True (c True (c True (c True (c True (c True n))))))))))
-     (\(ds : Bool) (ds : List Bool) -> Cons {Bool} ds ds)
-     (Nil {Bool}))
+                  (c
+                     True
+                     (c True (c True (c True (c True (c True (c True n))))))))))
+        (\(ds : Bool) (ds : List Bool) -> Cons {Bool} ds ds)
+        (Nil {Bool})
+in
+and ls