Fix memory usage for polymorphic types.

plutus-conformance/agda/Spec.hs

@@ -147,42 +147,11 @@ failingEvaluationTests =
 -}
 failingBudgetTests :: [FilePath]
 failingBudgetTests =
-  -- These currently fail because the Agda code doesn't know about alternative
-  -- size measures used by `replicateByte`, `writeBits`, and `dropList`: see
-  -- https://github.com/IntersectMBO/plutus/pull/6368.  Some of the budget tests
-  -- do pass, either because evaluation fails or because two different size
-  -- measures happen to be the same for small inputs.
+  -- These currently fail because (a) the Agda code doesn't know about the
+  -- IntegerCostedLiterally size measure used by `replicateByte`, and (b)
+  -- GHC 8.0 can't deal with `dropList`.
   [ "test-cases/uplc/evaluation/builtin/semantics/replicateByte/case-07"
   , "test-cases/uplc/evaluation/builtin/semantics/replicateByte/case-09"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-11"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-12"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-13"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-14"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-15"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-16"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-17"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-18"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-20"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-21"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-22"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-23"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-24"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-25"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-26"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-27"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-29"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-30"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-31"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-32"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-33"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-34"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-35"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-36"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-37"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-38"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-39"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-40"
-  , "test-cases/uplc/evaluation/builtin/semantics/writeBits/case-41"
   , "test-cases/uplc/evaluation/builtin/semantics/dropList/dropList-01"
   , "test-cases/uplc/evaluation/builtin/semantics/dropList/dropList-02"
   , "test-cases/uplc/evaluation/builtin/semantics/dropList/dropList-03"

plutus-core/cost-model/budgeting-bench/Benchmarks/Bitwise.hs

@@ -7,7 +7,6 @@ import Generators
 import PlutusCore
 import PlutusCore.Evaluation.Machine.CostStream (sumCostStream)
 import PlutusCore.Evaluation.Machine.ExMemoryUsage (ExMemoryUsage, IntegerCostedLiterally (..),
-                                                    ListCostedByLength (..),
                                                     NumBytesCostedAsNumWords (..), flattenCostRose,
                                                     memoryUsage)
 
@@ -140,14 +139,7 @@ benchWriteBits =
       -- Given an integer k, return a list of updates which write a bit 10*k
       -- times.  Here k will range from 1 to numSamples, which is 150.
       inputs = zip3 xs positions (replicate numSamples True)
-  in createThreeTermBuiltinBenchElementwiseWithWrappers
-       (id, ListCostedByLength, id)
-       WriteBits [] inputs
-  {- This is like createThreeTermBuiltinBenchElementwise except that the benchmark
-   name contains the length of the list of updates, not the memory usage.  The
-   denotation of WriteBits in Default.Builtins must wrap its second and third
-   arguments in ListCostedByLength to make sure that the correct ExMemoryUsage
-   instance is called for costing. -}
+  in createThreeTermBuiltinBenchElementwise  WriteBits [] inputs
 
 {- For small inputs `replicateByte` looks constant-time.  For larger inputs it's
    linear.  We're limiting the output to 8192 bytes (size 1024), so we may as

plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs

@@ -28,7 +28,6 @@ import PlutusCore.Default.Universe
 import PlutusCore.Evaluation.Machine.BuiltinCostModel
 import PlutusCore.Evaluation.Machine.ExBudgetStream (ExBudgetStream)
 import PlutusCore.Evaluation.Machine.ExMemoryUsage (ExMemoryUsage, IntegerCostedLiterally (..),
-                                                    ListCostedByLength (..),
                                                     NumBytesCostedAsNumWords (..), memoryUsage,
                                                     singletonRose)
 import PlutusCore.Pretty (PrettyConfigPlc)
@@ -1967,10 +1966,10 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
     toBuiltinMeaning _semvar WriteBits =
         let writeBitsDenotation
               :: BS.ByteString
-              -> ListCostedByLength Integer
+              -> [Integer]
               -> Bool
               -> BuiltinResult BS.ByteString
-            writeBitsDenotation s (ListCostedByLength ixs) = Bitwise.writeBits s ixs
+            writeBitsDenotation s ixs = Bitwise.writeBits s ixs
             {-# INLINE writeBitsDenotation #-}
         in makeBuiltinMeaning
             writeBitsDenotation

plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs

@@ -47,9 +47,7 @@ import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1
 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2
 import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing
 import PlutusCore.Data (Data)
-import PlutusCore.Evaluation.Machine.ExMemoryUsage (ArrayCostedByLength (..),
-                                                    IntegerCostedLiterally (..),
-                                                    ListCostedByLength (..),
+import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally (..),
                                                     NumBytesCostedAsNumWords (..))
 import PlutusCore.Pretty.Extra (juxtRenderContext)
 
@@ -499,20 +497,6 @@ deriving newtype instance KnownBuiltinTypeIn DefaultUni term Integer =>
 deriving newtype instance KnownBuiltinTypeIn DefaultUni term Integer =>
     ReadKnownIn DefaultUni term IntegerCostedLiterally
 
-deriving newtype instance KnownTypeAst tyname DefaultUni a =>
-    KnownTypeAst tyname DefaultUni (ListCostedByLength a)
-deriving newtype instance KnownBuiltinTypeIn DefaultUni term [a] =>
-    MakeKnownIn DefaultUni term (ListCostedByLength a)
-deriving newtype instance KnownBuiltinTypeIn DefaultUni term [a] =>
-    ReadKnownIn DefaultUni term (ListCostedByLength a)
-
-deriving newtype instance KnownTypeAst tyname DefaultUni a =>
-    KnownTypeAst tyname DefaultUni (ArrayCostedByLength a)
-deriving newtype instance KnownBuiltinTypeIn DefaultUni term (Vector a) =>
-    MakeKnownIn DefaultUni term (ArrayCostedByLength a)
-deriving newtype instance KnownBuiltinTypeIn DefaultUni term (Vector a) =>
-    ReadKnownIn DefaultUni term (ArrayCostedByLength a)
-
 deriving via AsInteger Natural instance
     KnownTypeAst tyname DefaultUni Natural
 deriving via AsInteger Natural instance KnownBuiltinTypeIn DefaultUni term Integer =>

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

@@ -12,8 +12,6 @@ module PlutusCore.Evaluation.Machine.ExMemoryUsage
     , flattenCostRose
     , NumBytesCostedAsNumWords(..)
     , IntegerCostedLiterally(..)
-    , ListCostedByLength(..)
-    , ArrayCostedByLength(..)
     ) where
 
 import PlutusCore.Crypto.BLS12_381.G1 as BLS12_381.G1
@@ -158,8 +156,66 @@ class ExMemoryUsage a where
     -- Inlining the implementations of this method gave us a 1-2% speedup.
     memoryUsage :: a -> CostRose
 
-instance (ExMemoryUsage a, ExMemoryUsage b) => ExMemoryUsage (a, b) where
-    memoryUsage (a, b) = CostRose 1 [memoryUsage a, memoryUsage b]
+{- Note [Alternative memory usage instances].  The `memoryUsage` function provides
+ a measure of the size of an object for costing purposes, the idea being that
+ the time taken to execute a builtin, and the memory used to contain its result,
+ will depend on the size of the inputs.  The name `memoryUsage` is perhaps a
+ misnomer: it was originally supposed to measure (in 64-bit words) the heap
+ space required to store an object, but this is not always the correct measure
+ to use.  For example, the time taken by `AddInteger` or `MultiplyInteger` will
+ depend on the logarithms of the inputs (and the logarithm is proportional to
+ the memory occupied by the inputs), and the memory occupied by the result will
+ be some function of the memory occupied by the inputs, so for these functions
+ the actual memory usage is a sensible size measure.  However, calling
+ `replicateByte n b` function allocates a number of bytes which is equal to the
+ actual value of `n`, which will be exponentially greater than the memory
+ occupied by `n`, so this case the memory usage is not a sensible size measure.
+ In most cases the default `memoryUsage` function returns the actual memory
+ usage, but to deal with cases like `replicateByte` we occasionally use newtype
+ wrappers which define a different size measure (see `IntegerCostedLiterally`
+ below).  Polymorphic types require some care though: see Note [ExMemoryUsage
+ for polymorphic types].
+-}
+
+{- Note [ExMemoryUsage for polymorphic types].  For polymorphic types such as
+ `pair, `list`, and `array` DO NOT use newtype wrappers to define alternative
+ size measures.  The denotations of functions which take polymorphic arguments
+ use `SomeConstant` and this will ignore newtype wrappers and will only use the
+ default `memoryUsage` function, which could lead to unexpected results.
+ Furthermore, actual memory usage is typically not a good size measure for
+ polymorphic arguments: the time taken to process a list, for example, will
+ typically depend only on the length of the list and not the size of the
+ contents.  Currently all such functions are parametrically polymorphic and only
+ manipulate pointers without inspecting the contents of their polymorphic
+ arguments, so it is reasonable to use size measures which depend only on the
+ surface structure of polymorphic objects. -}
+
+{- We expect that all builtins which involve pairs will be constant cost and so
+   their memory usage will never be involved in any computations.  The memory
+   usage is set to maxBound so that we'll notice if this assumption is ever
+   violated -}
+instance ExMemoryUsage (a, b) where
+    memoryUsage _ = singletonRose maxBound
+    {-# INLINE memoryUsage #-}
+
+{- Note the the `memoryUsage` of an empty list is zero.  This shouldn't cause any
+ problems, but be sure to check that no costing function involving lists can
+ return zero for an empty list (or any other input).
+-}
+{- Calculating the memory usage by processing the entire spine of the list eagerly
+ is safe because there's no way to cheaply construct a long list: you either
+ make one using repeated mkCons, which is expensive, or return one from a
+ builtin, which has to be appropriately expensive too. -}
+instance ExMemoryUsage [a] where
+  memoryUsage l = singletonRose . fromIntegral $ length l
+  {-# INLINE memoryUsage #-}
+
+{- Note the the `memoryUsage` of an empty array is zero.  This shouldn't cause any
+ problems, but be sure to check that no costing function involving arrays can
+ return zero for an empty array (or any other input).
+-}
+instance ExMemoryUsage (Vector a) where
+    memoryUsage l = singletonRose . fromIntegral $ Vector.length l
     {-# INLINE memoryUsage #-}
 
 instance (Closed uni, uni `Everywhere` ExMemoryUsage) => ExMemoryUsage (Some (ValueOf uni)) where
@@ -208,28 +264,6 @@ instance ExMemoryUsage IntegerCostedLiterally where
     -- realistic input should be that large; however if you're going to use this then be
     -- sure to convince yourself that it's safe.
 
-{- | A wrappper for lists whose "memory usage" for costing purposes is just the
-   length of the list, ignoring the sizes of the elements. If this is used to
-   wrap an argument in the denotation of a builtin then it *MUST* also be used
-   to wrap the same argument in the relevant budgeting benchmark. -}
-newtype ListCostedByLength a = ListCostedByLength { unListCostedByLength :: [a] }
-instance ExMemoryUsage (ListCostedByLength a) where
-    memoryUsage (ListCostedByLength l) = singletonRose . fromIntegral $ length l
-    {-# INLINE memoryUsage #-}
-    -- Note that this uses `fromIntegral`, which will narrow large values to
-    -- maxBound::SatInt = 2^63-1.  This shouldn't be a problem for costing because no
-    -- realistic input should be that large; however if you're going to use this then be
-    -- sure to convince yourself that it's safe.
-
-newtype ArrayCostedByLength a = ArrayCostedByLength { unArrayCostedByLength :: Vector a }
-instance ExMemoryUsage (ArrayCostedByLength a) where
-    memoryUsage (ArrayCostedByLength l) = singletonRose . fromIntegral $ Vector.length l
-    {-# INLINE memoryUsage #-}
-    -- Note that this uses `fromIntegral`, which will narrow large values to
-    -- maxBound::SatInt = 2^63-1.  This shouldn't be a problem for costing because no
-    -- realistic input should be that large; however if you're going to use this then be
-    -- sure to convince yourself that it's safe.
-
 -- | Calculate a 'CostingInteger' for the given 'Integer'.
 memoryUsageInteger :: Integer -> CostingInteger
 -- integerLog2# is unspecified for 0 (but in practice returns -1)
@@ -304,40 +338,20 @@ addConstantRose (CostRose cost1 forest1) (CostRose cost2 forest2) =
     CostRose (cost1 + cost2) (forest1 ++ forest2)
 {-# INLINE addConstantRose #-}
 
-instance ExMemoryUsage a => ExMemoryUsage [a] where
-    -- sizeof([a]) = (1 + 3N) words + N * sizeof(v)
-    memoryUsage = CostRose nilCost . map (addConstantRose consRose . memoryUsage) where
-        -- As per https://wiki.haskell.org/GHC/Memory_Footprint
-        nilCost = 1
-        {-# INLINE nilCost #-}
-        consRose = singletonRose 3
-        {-# INLINE consRose #-}
-    {-# INLINE memoryUsage #-}
-
-instance ExMemoryUsage a => ExMemoryUsage (Vector a) where
-    -- sizeof(Vector v) = (7 + N) words + N * sizeof(v)
-    memoryUsage v = CostRose arrayCost [ memoryUsage a | a <- Vector.toList v ]
-      where
-        arrayCost :: SatInt
-        arrayCost = 7 + fromIntegral (Vector.length v)
-        {-# INLINE arrayCost #-}
-    {-# INLINE memoryUsage #-}
-
-{- Another naive traversal for size.  This accounts for the number of nodes in
-   a Data object, and also the sizes of the contents of the nodes.  This is not
-   ideal, but it seems to be the best we can do.  At present this only comes
-   into play for 'equalsData', which is implemented using the derived
-   implementation of '==' (fortunately the costing functions are lazy, so this
-   won't be called for things like 'unBData' which have constant costing
-   functions because they only have to look at the top node).  The problem is
-   that when we call 'equalsData' the comparison will take place entirely in
-   Haskell, so the costing functions for the contents of 'I' and 'B' nodes
-   won't be called.  Thus if we just counted the number of nodes the sizes of
-   'I 2' and 'B <huge bytestring>' would be the same but they'd take different
-   amounts of time to compare.  It's not clear how to trade off the costs of
-   processing a node and processing the contents of nodes: the implementation
-   below compromises by charging four units per node, but we may wish to revise
-   this after experimentation.
+{- A naive traversal for size.  This accounts for the number of nodes in a Data
+   object and also the sizes of the contents of the nodes.  This is not ideal,
+   but it seems to be the best we can do.  At present this only comes into play
+   for 'equalsData', which is implemented using the derived implementation of
+   '==' (fortunately the costing functions are lazy, so this won't be called for
+   things like 'unBData' which have constant costing functions because they only
+   have to look at the top node).  The problem is that when we call 'equalsData'
+   the comparison will take place entirely in Haskell, so the costing functions
+   for the contents of 'I' and 'B' nodes won't be called.  Thus if we just
+   counted the number of nodes the sizes of 'I 2' and 'B <huge bytestring>'
+   would be the same but they'd take different amounts of time to compare.  It's
+   not clear how to trade off the costs of processing a node and processing the
+   contents of nodes: the implementation below compromises by charging four
+   units per node, but we may wish to revise this after experimentation.
 -}
 instance ExMemoryUsage Data where
     memoryUsage = sizeData where

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

@@ -37,7 +37,7 @@ import PlutusCore.Evaluation.Machine.BuiltinCostModel (BuiltinCostModel)
 import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (ExBudget))
 import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (cekCostModelForVariant)
 import PlutusCore.Evaluation.Machine.ExBudgetStream (sumExBudgetStream)
-import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally, ListCostedByLength,
+import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally,
                                                     NumBytesCostedAsNumWords)
 import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (..))
 import UntypedPlutusCore.Evaluation.Machine.Cek.CekMachineCosts (CekMachineCosts,
@@ -135,10 +135,6 @@ smallConstant tr
     , Just HRefl <- eqTypeRep trList (typeRep @[]) =
         case smallConstant trElem of
           SomeConst c -> SomeConst ([] `asTypeOf` [c])
-    | trList' `App` trElem <- tr
-    , Just HRefl <- eqTypeRep trList' (typeRep @ListCostedByLength) =
-        case smallConstant trElem of
-          SomeConst c -> SomeConst ([] `asTypeOf` [c])
     | trArray `App` trElem <- tr
     , Just HRefl <- eqTypeRep trArray (typeRep @Vector) =
         case smallConstant trElem of

plutus-core/plutus-core/test/TypeSynthesis/Golden/Signatures/DefaultFun/WriteBits.sig.golden

@@ -1 +1 @@
-ByteString -> ListCostedByLength Integer -> Bool -> BuiltinResult ByteString
+ByteString -> [Integer] -> Bool -> BuiltinResult ByteString

plutus-core/testlib/PlutusCore/Generators/Hedgehog/Builtin.hs

@@ -17,7 +17,7 @@ import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1
 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2
 import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing
 import PlutusCore.Data (Data (..))
-import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally, ListCostedByLength,
+import PlutusCore.Evaluation.Machine.ExMemoryUsage (IntegerCostedLiterally,
                                                     NumBytesCostedAsNumWords)
 import PlutusCore.Generators.Hedgehog.AST hiding (genConstant)
 import PlutusCore.Generators.QuickCheck.Builtin
@@ -116,10 +116,6 @@ genConstant tr
     , Just HRefl <- eqTypeRep trList (typeRep @[]) =
         case genConstant trElem of
             SomeGen genElem -> SomeGen $ Gen.list (Range.linear 0 10) genElem
-    | trList' `App` trElem <- tr
-    , Just HRefl <- eqTypeRep trList' (typeRep @ListCostedByLength) =
-        case genConstant trElem of
-          SomeGen genElem -> SomeGen $ Gen.list (Range.linear 0 10) genElem
     | trArray `App` trElem <- tr
     , Just HRefl <- eqTypeRep trArray (typeRep @Vector) =
         case genConstant trElem of