PLT-370: NoThunks for EvaluationContext (#4734)

* NoThunks for EvaluationContext

* Modify a comment

* Update a comment

* Add test cases

* Add some comments

plutus-core/plutus-core.cabal

@@ -294,6 +294,7 @@ library
     , mmorph
     , monoidal-containers
     , mtl
+    , nothunks
     , parser-combinators          >=0.4.0
     , prettyprinter               >=1.1.0.1
     , prettyprinter-configurable

plutus-core/plutus-core/src/Data/SatInt.hs

@@ -6,6 +6,7 @@ This is not quite as fast as using 'Int' or 'Int64' directly, but we need the sa
 {-# LANGUAGE BangPatterns       #-}
 {-# LANGUAGE CPP                #-}
 {-# LANGUAGE DataKinds          #-}
+{-# LANGUAGE DeriveAnyClass     #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE MagicHash          #-}
 {-# LANGUAGE UnboxedTuples      #-}
@@ -25,13 +26,15 @@ import GHC.Integer (smallInteger)
 import GHC.Num
 import GHC.Real
 import Language.Haskell.TH.Syntax (Lift)
+import NoThunks.Class
 
 newtype SatInt = SI { unSatInt :: Int }
     deriving newtype (NFData, Bits, FiniteBits, Prim)
     deriving stock (Lift, Generic)
     deriving (FromJSON, ToJSON) via Int
     deriving FromField via Int  -- For reading cost model data from CSV input
     deriving Serialise via Int
+    deriving anyclass NoThunks
 
 instance Show SatInt where
   showsPrec p x = showsPrec p (unSatInt x)

plutus-core/plutus-core/src/PlutusCore/Builtin/Runtime.hs

@@ -1,12 +1,14 @@
 {-# LANGUAGE DataKinds                #-}
 {-# LANGUAGE GADTs                    #-}
+{-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TypeFamilies             #-}
 
 {-# LANGUAGE StrictData               #-}
 
 module PlutusCore.Builtin.Runtime where
 
+import PlutusCore.Builtin.KnownType
 import PlutusCore.Evaluation.Machine.ExBudget
 import PlutusCore.Evaluation.Machine.ExMemory
 import PlutusCore.Evaluation.Machine.Exception
@@ -16,7 +18,7 @@ import Control.Lens (ix, (^?))
 import Control.Monad.Except
 import Data.Array
 import Data.Kind qualified as GHC (Type)
-import PlutusCore.Builtin.KnownType
+import NoThunks.Class as NoThunks
 
 -- | Peano numbers. Normally called @Nat@, but that is already reserved by @base@.
 data Peano
@@ -40,6 +42,13 @@ instance NFData (RuntimeScheme n) where
         RuntimeSchemeArrow arg -> rnf arg
         RuntimeSchemeAll arg   -> rnf arg
 
+instance NoThunks (RuntimeScheme n) where
+    wNoThunks ctx = \case
+        RuntimeSchemeResult  -> pure Nothing
+        RuntimeSchemeArrow s -> noThunks ctx s
+        RuntimeSchemeAll s   -> noThunks ctx s
+    showTypeOf = const "PlutusCore.Builtin.Runtime.RuntimeScheme"
+
 -- | Compute the runtime denotation type of a builtin given the type of values and the number of
 -- arguments that the builtin takes. A \"runtime denotation type\" is different from a regular
 -- denotation type in that a regular one can have any 'ReadKnownIn' type as an argument and can
@@ -86,6 +95,32 @@ data BuiltinRuntime val =
                                           -- out what it's going to cost.
         (ToCostingType n)
 
+instance NoThunks (BuiltinRuntime val) where
+    -- Skipping `_denot` in `allNoThunks` check, since it is supposed to be lazy and
+    -- is allowed to contain thunks.
+    wNoThunks ctx (BuiltinRuntime sch _denot costing) =
+        allNoThunks
+            [ -- The order here is important: we must first check that `sch` doesn't have
+              -- thunks, before inspecting it in `noThunksInCosting`.
+              noThunks ctx sch
+            , noThunksInCosting ctx costing sch
+            ]
+
+    showTypeOf = const "PlutusCore.Builtin.Runtime.BuiltinRuntime"
+
+-- | Check whether the given `ToCostingType n` contains thunks. The `RuntimeScheme n` is used to
+-- refine `n`.
+noThunksInCosting :: NoThunks.Context -> ToCostingType n -> RuntimeScheme n -> IO (Maybe ThunkInfo)
+noThunksInCosting ctx costing = \case
+    -- @n ~ 'Z@, and @ToCostingType n ~ ExBudget@, which should not be a thunk or contain
+    -- nested thunks.
+    RuntimeSchemeResult ->
+        noThunks ctx costing
+    RuntimeSchemeArrow _ ->
+        noThunks ctx costing
+    RuntimeSchemeAll sch ->
+        noThunksInCosting ctx costing sch
+
 -- | Determines how to unlift arguments. The difference is that with 'UnliftingImmediate' unlifting
 -- is performed immediately after a builtin gets the argument and so can fail immediately too, while
 -- with deferred unlifting all arguments are unlifted upon full saturation, hence no failure can
@@ -131,6 +166,10 @@ newtype BuiltinsRuntime fun val = BuiltinsRuntime
 
 deriving newtype instance (NFData fun) => NFData (BuiltinsRuntime fun val)
 
+instance NoThunks (BuiltinsRuntime fun val) where
+    wNoThunks ctx (BuiltinsRuntime arr) = allNoThunks (noThunks ctx <$> elems arr)
+    showTypeOf = const "PlutusCore.Builtin.Runtime.BuiltinsRuntime"
+
 -- | Look up the runtime info of a built-in function during evaluation.
 lookupBuiltin
     :: (MonadError (ErrorWithCause err cause) m, AsMachineError err fun, Ix fun)

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudget.hs

@@ -144,14 +144,15 @@ module PlutusCore.Evaluation.Machine.ExBudget
     )
 where
 
+import PlutusCore.Evaluation.Machine.ExMemory
 import PlutusPrelude hiding (toList)
 
 import Codec.Serialise (Serialise (..))
 import Data.Char (toLower)
 import Data.Semigroup
 import Deriving.Aeson
 import Language.Haskell.TH.Lift (Lift)
-import PlutusCore.Evaluation.Machine.ExMemory
+import NoThunks.Class
 import Prettyprinter
 
 
@@ -175,7 +176,7 @@ instance ExBudgetBuiltin fun () where
 
 data ExBudget = ExBudget { exBudgetCPU :: ExCPU, exBudgetMemory :: ExMemory }
     deriving stock (Eq, Show, Generic, Lift)
-    deriving anyclass (PrettyBy config, NFData, Serialise)
+    deriving anyclass (PrettyBy config, NFData, NoThunks, Serialise)
     deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier LowerIntialCharacter] ExBudget
     -- LowerIntialCharacter won't actually do anything here, but let's have it in case we change the field names.
 

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExMemory.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE LambdaCase            #-}
@@ -32,6 +33,7 @@ import GHC.Integer
 import GHC.Integer.Logarithms
 import GHC.Prim
 import Language.Haskell.TH.Syntax (Lift)
+import NoThunks.Class
 import Universe
 
 {-
@@ -106,6 +108,7 @@ newtype ExMemory = ExMemory CostingInteger
   deriving (Semigroup, Monoid) via (Sum CostingInteger)
   deriving (FromJSON, ToJSON) via CostingInteger
   deriving Serialise via CostingInteger
+  deriving anyclass NoThunks
 instance Pretty ExMemory where
     pretty (ExMemory i) = pretty (toInteger i)
 instance PrettyBy config ExMemory where
@@ -119,6 +122,7 @@ newtype ExCPU = ExCPU CostingInteger
   deriving (Semigroup, Monoid) via (Sum CostingInteger)
   deriving (FromJSON, ToJSON) via CostingInteger
   deriving Serialise via CostingInteger
+  deriving anyclass NoThunks
 instance Pretty ExCPU where
     pretty (ExCPU i) = pretty (toInteger i)
 instance PrettyBy config ExCPU where

plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/MachineParameters.hs

@@ -14,6 +14,7 @@ import Control.Lens
 import GHC.Exts (inline)
 import GHC.Generics
 import GHC.Types (Type)
+import NoThunks.Class
 
 {-| We need to account for the costs of evaluator steps and also built-in function
    evaluation.  The models for these have different structures and are used in
@@ -41,7 +42,7 @@ data MachineParameters machinecosts term (uni :: Type -> Type) (fun :: Type) =
     , builtinsRuntime :: BuiltinsRuntime fun (term uni fun)
     }
     deriving stock Generic
-    deriving anyclass NFData
+    deriving anyclass (NFData, NoThunks)
 
 -- See Note [Inlining meanings of builtins].
 {-| This just uses 'toBuiltinsRuntime' function to convert a BuiltinCostModel to a BuiltinsRuntime. -}

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/CekMachineCosts.hs

@@ -16,6 +16,7 @@ import Control.DeepSeq
 import Data.Text qualified as Text
 import Deriving.Aeson
 import Language.Haskell.TH.Syntax (Lift)
+import NoThunks.Class
 
 -- | The prefix of the field names in the CekMachineCosts type, used for
 -- extracting the CekMachineCosts component of the ledger's cost model
@@ -40,7 +41,7 @@ data CekMachineCosts =
     -- happen if calling 'Error' caused the budget to be exceeded?
     }
     deriving stock (Eq, Show, Generic, Lift)
-    deriving anyclass NFData
+    deriving anyclass (NFData, NoThunks)
     deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier LowerIntialCharacter] CekMachineCosts
 
 -- Charge a unit CPU cost for AST nodes: this allows us to count the number of

plutus-ledger-api/plutus-ledger-api.cabal

@@ -93,6 +93,7 @@ library
     , flat
     , lens
     , mtl
+    , nothunks
     , plutus-core        ^>=1.0
     , plutus-tx          ^>=1.0
     , prettyprinter
@@ -134,6 +135,7 @@ test-suite plutus-ledger-api-test
     Spec.CostModelParams
     Spec.Eval
     Spec.Interval
+    Spec.NoThunks
 
   build-depends:
     , barbies
@@ -144,6 +146,7 @@ test-suite plutus-ledger-api-test
     , hedgehog
     , lens
     , mtl
+    , nothunks
     , plutus-core                ^>=1.0
     , plutus-ledger-api
     , plutus-ledger-api-testlib

plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs

@@ -31,6 +31,7 @@ import Data.ByteString.Lazy (fromStrict)
 import Data.ByteString.Short
 import Data.Text as Text
 import Data.Tuple
+import NoThunks.Class
 import Prettyprinter
 
 -- | Errors that can be thrown when evaluating a Plutus script.
@@ -101,7 +102,7 @@ data EvaluationContext = EvaluationContext
     , machineParametersDeferred  :: DefaultMachineParameters
     }
     deriving stock Generic
-    deriving anyclass NFData
+    deriving anyclass (NFData, NoThunks)
 
 {-|  Build the 'EvaluationContext'.
 

plutus-ledger-api/test/Spec.hs

@@ -5,8 +5,10 @@ import PlutusLedgerApi.Test.EvaluationContext (evalCtxForTesting)
 import PlutusLedgerApi.Test.Examples
 import PlutusLedgerApi.V1
 import Spec.Builtins qualified
+import Spec.CostModelParams qualified
 import Spec.Eval qualified
 import Spec.Interval qualified
+import Spec.NoThunks qualified
 
 import Test.Tasty
 import Test.Tasty.HUnit
@@ -15,7 +17,6 @@ import Test.Tasty.QuickCheck
 import Control.Monad (void)
 import Data.Either
 import Data.Word (Word8)
-import Spec.CostModelParams qualified
 
 main :: IO ()
 main = defaultMain tests
@@ -93,4 +94,5 @@ tests = testGroup "plutus-ledger-api" [
     , Spec.Eval.tests
     , Spec.Builtins.tests
     , Spec.CostModelParams.tests
+    , Spec.NoThunks.tests
     ]

plutus-ledger-api/test/Spec/NoThunks.hs

@@ -0,0 +1,61 @@
+{-# LANGUAGE BangPatterns     #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Spec.NoThunks (tests) where
+
+import NoThunks.Class
+
+import PlutusLedgerApi.V1 as V1
+import PlutusLedgerApi.V2 as V2
+import PlutusLedgerApi.V3 as V3
+
+import PlutusCore.Evaluation.Machine.ExBudgetingDefaults as Plutu
+import PlutusCore.Pretty
+
+import Control.Monad.Extra (whenJust)
+import Data.List.Extra (enumerate)
+import Data.Map qualified as Map
+import Data.Maybe (fromJust)
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: TestTree
+tests =
+    testGroup
+        "NoThunks"
+        [ testCase "EvaluationContext V1" evaluationContextV1
+        , testCase "EvaluationContext V2" evaluationContextV2
+        , testCase "EvaluationContext V3" evaluationContextV3
+        ]
+
+costParams :: [Integer]
+costParams = Map.elems (fromJust defaultCostModelParams)
+
+evaluationContextV1 :: Assertion
+evaluationContextV1 = do
+    let v1CostParams = take (length $ enumerate @V1.ParamName) costParams
+    !evalCtx <-
+        either (assertFailure . display) pure $
+            V1.mkEvaluationContext v1CostParams
+    failIfThunk =<< noThunks [] evalCtx
+
+evaluationContextV2 :: Assertion
+evaluationContextV2 = do
+    let v2CostParams = take (length $ enumerate @V2.ParamName) costParams
+    !evalCtx <-
+        either (assertFailure . display) pure $
+            V2.mkEvaluationContext v2CostParams
+    failIfThunk =<< noThunks [] evalCtx
+
+evaluationContextV3 :: Assertion
+evaluationContextV3 = do
+    let v3CostParams = take (length $ enumerate @V3.ParamName) costParams
+    !evalCtx <-
+        either (assertFailure . display) pure $
+            V3.mkEvaluationContext v3CostParams
+    failIfThunk =<< noThunks [] evalCtx
+
+failIfThunk :: Show a => Maybe a -> IO ()
+failIfThunk mbThunkInfo =
+    whenJust mbThunkInfo $ \thunkInfo ->
+        assertFailure $ "Unexpected thunk: " <> show thunkInfo