Builtin Array type backed by Vector

+ LengthArray and ListToArray functions.
IntersectMBO · Dec 3, 2024 · acdd3ef · acdd3ef
1 parent 5903f1f
commit acdd3ef
Show file tree

Hide file tree

Showing 28 changed files with 245 additions and 13 deletions.
diff --git a/plutus-core/cost-model/create-cost-model/BuiltinMemoryModels.hs b/plutus-core/cost-model/create-cost-model/BuiltinMemoryModels.hs
@@ -110,6 +110,8 @@ builtinMemoryModels = BuiltinCostModelBase
   , paramHeadList                        = Id $ ModelOneArgumentConstantCost    32
   , paramTailList                        = Id $ ModelOneArgumentConstantCost    32
   , paramNullList                        = Id $ ModelOneArgumentConstantCost    32
+  , paramLengthArray                     = Id $ ModelOneArgumentConstantCost    99
+  , paramListToArray                     = Id $ ModelOneArgumentConstantCost    99
   , paramChooseData                      = Id $ ModelSixArgumentsConstantCost   32
   , paramConstrData                      = Id $ ModelTwoArgumentsConstantCost   32
   , paramMapData                         = Id $ ModelOneArgumentConstantCost    32

diff --git a/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs b/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs
@@ -75,6 +75,8 @@ builtinCostModelNames = BuiltinCostModelBase
   , paramHeadList                        = "headListModel"
   , paramTailList                        = "tailListModel"
   , paramNullList                        = "nullListModel"
+  , paramLengthArray                     = "lengthArrayModel"
+  , paramListToArray                     = "listToArrayModel"
   , paramChooseData                      = "chooseDataModel"
   , paramConstrData                      = "constrDataModel"
   , paramMapData                         = "mapDataModel"
@@ -209,6 +211,9 @@ createBuiltinCostModel bmfile rfile = do
   paramHeadList                        <- getParams readCF1 paramHeadList
   paramTailList                        <- getParams readCF1 paramTailList
   paramNullList                        <- getParams readCF1 paramNullList
+  -- Arrays
+  paramLengthArray                     <- getParams readCF1 paramLengthArray
+  paramListToArray                     <- getParams readCF1 paramListToArray
   -- Data
   paramChooseData                      <- getParams readCF6 paramChooseData
   paramConstrData                      <- getParams readCF2 paramConstrData

diff --git a/plutus-core/cost-model/data/builtinCostModelA.json b/plutus-core/cost-model/data/builtinCostModelA.json
@@ -698,6 +698,26 @@
             "type": "constant_cost"
         }
     },
+    "lengthArray" : {
+        "cpu": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        }
+    },
+    "listToArray": {
+        "cpu": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        }
+    },
     "quotientInteger": {
         "cpu": {
             "arguments": {

diff --git a/plutus-core/cost-model/data/builtinCostModelB.json b/plutus-core/cost-model/data/builtinCostModelB.json
@@ -698,6 +698,26 @@
             "type": "constant_cost"
         }
     },
+    "lengthArray" : {
+        "cpu": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        }
+    },
+    "listToArray": {
+        "cpu": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        }
+    },
     "quotientInteger": {
         "cpu": {
             "arguments": {

diff --git a/plutus-core/cost-model/data/builtinCostModelC.json b/plutus-core/cost-model/data/builtinCostModelC.json
@@ -707,6 +707,26 @@
             "type": "constant_cost"
         }
     },
+    "lengthArray" : {
+        "cpu": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        }
+    },
+    "listToArray": {
+        "cpu": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        },
+        "memory": {
+            "arguments": 99999999999999,
+            "type": "constant_cost"
+        }
+    },
     "quotientInteger": {
         "cpu": {
             "arguments": {

diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal
@@ -217,6 +217,7 @@ library
   other-modules:
     Data.Aeson.Flatten
     Data.Functor.Foldable.Monadic
+    Data.Vector.Orphans
     PlutusCore.Builtin.HasConstant
     PlutusCore.Builtin.KnownKind
     PlutusCore.Builtin.KnownType
@@ -341,7 +342,7 @@ library
     , time
     , transformers
     , unordered-containers
-    , vector
+    , vector                      ^>=0.13.2
     , witherable
 
   if impl(ghc <9.0)
@@ -376,7 +377,7 @@ test-suite plutus-core-test
   default-language: Haskell2010
   build-depends:
     , aeson
-    , base                             >=4.9   && <5
+    , base                             >=4.9     && <5
     , bytestring
     , containers
     , data-default-class
@@ -400,6 +401,7 @@ test-suite plutus-core-test
     , text
     , th-lift-instances
     , th-utilities
+    , vector                           ^>=0.13.2
 
 test-suite untyped-plutus-core-test
   import:         lang
@@ -815,6 +817,7 @@ library plutus-core-testlib
     , tasty-hedgehog
     , tasty-hunit
     , text
+    , vector
 
 -- This wraps up the use of the certifier library
 -- so we can present a consistent inteface whether we

diff --git a/plutus-core/plutus-core/src/Data/Vector/Orphans.hs b/plutus-core/plutus-core/src/Data/Vector/Orphans.hs
@@ -0,0 +1,16 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Data.Vector.Orphans () where
+
+import Data.Hashable (Hashable (hashWithSalt))
+import Data.Vector.Strict qualified as Strict
+import Flat (Flat (..))
+import Flat.Instances.Vector ()
+
+instance (Hashable a) => Hashable (Strict.Vector a) where
+  hashWithSalt = Strict.foldl' hashWithSalt
+
+instance (Flat a) => Flat (Strict.Vector a) where
+  size = size . Strict.toLazy -- Strict to Lazy is O(1)
+  encode = encode . Strict.toLazy
+  decode = Strict.fromLazy <$> decode -- Strict from Lazy is O(1)
diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs
@@ -43,6 +43,8 @@ import Data.ByteString.Lazy qualified as BSL
 import Data.Ix (Ix)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8', encodeUtf8)
+import Data.Vector.Strict (Vector)
+import Data.Vector.Strict qualified as Vector
 import Flat hiding (from, to)
 import Flat.Decoder (Get, dBEBits8)
 import Flat.Encoder as Flat (Encoding, NumBits, eBits)
@@ -104,6 +106,9 @@ data DefaultFun
     | HeadList
     | TailList
     | NullList
+    -- Arrays
+    | LengthArray
+    | ListToArray
     -- Data
     -- See Note [Pattern matching on built-in types].
     -- It is convenient to have a "choosing" function for a data type that has more than two
@@ -1554,6 +1559,24 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
             nullListDenotation
             (runCostingFunOneArgument . paramNullList)
 
+    toBuiltinMeaning _semvar LengthArray =
+      let lengthArrayDenotation :: SomeConstant uni (Vector a) -> BuiltinResult Int
+          lengthArrayDenotation (SomeConstant (Some (ValueOf uni vec))) =
+            case uni of
+              DefaultUniArray _argUni -> pure $ Vector.length vec
+              _ -> throwing _StructuralUnliftingError "Expected an array but got something else"
+          {-# INLINE lengthArrayDenotation #-}
+        in makeBuiltinMeaning lengthArrayDenotation (runCostingFunOneArgument . paramLengthArray)
+
+    toBuiltinMeaning _semvar ListToArray =
+      let listToArrayDenotation :: SomeConstant uni [a] -> BuiltinResult (Opaque val (Vector a))
+          listToArrayDenotation (SomeConstant (Some (ValueOf uniListA xs))) =
+            case uniListA of
+              DefaultUniList arg -> pure $ fromValueOf (DefaultUniArray arg) $ Vector.fromList xs
+              _ -> throwing _StructuralUnliftingError  "Expected an array but got something else"
+          {-# INLINE listToArrayDenotation #-}
+        in makeBuiltinMeaning listToArrayDenotation (runCostingFunOneArgument . paramListToArray)
+
     -- Data
     toBuiltinMeaning _semvar ChooseData =
         let chooseDataDenotation :: Data -> a -> a -> a -> a -> a -> a
@@ -2183,6 +2206,9 @@ instance Flat DefaultFun where
               CaseList                        -> 88
               CaseData                        -> 89
 
+              LengthArray                     -> 90
+              ListToArray                     -> 91
+
     decode = go =<< decodeBuiltin
         where go 0  = pure AddInteger
               go 1  = pure SubtractInteger
@@ -2274,6 +2300,8 @@ instance Flat DefaultFun where
               go 87 = pure ExpModInteger
               go 88 = pure CaseList
               go 89 = pure CaseData
+              go 90 = pure LengthArray
+              go 91 = pure ListToArray
               go t  = fail $ "Failed to decode builtin tag, got: " ++ show t
 
     size _ n = n + builtinTagWidth

diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Universe.hs
@@ -34,6 +34,7 @@
 module PlutusCore.Default.Universe
     ( DefaultUni (..)
     , pattern DefaultUniList
+    , pattern DefaultUniArray
     , pattern DefaultUniPair
     , noMoreTypeFunctions
     , module Export  -- Re-exporting universes infrastructure for convenience.
@@ -46,7 +47,8 @@ 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 (..),
+import PlutusCore.Evaluation.Machine.ExMemoryUsage (ArrayCostedByLength (..),
+                                                    IntegerCostedLiterally (..),
                                                     ListCostedByLength (..),
                                                     NumBytesCostedAsNumWords (..))
 import PlutusCore.Pretty.Extra (juxtRenderContext)
@@ -57,6 +59,7 @@ import Data.Proxy (Proxy (Proxy))
 import Data.Text (Text)
 import Data.Text qualified as Text
 import Data.Typeable (typeRep)
+import Data.Vector.Strict (Vector)
 import Data.Word (Word16, Word32, Word64)
 import GHC.Exts (inline, oneShot)
 import Text.PrettyBy.Fixity (RenderContext, inContextM, juxtPrettyM)
@@ -104,6 +107,7 @@ data DefaultUni a where
     DefaultUniString :: DefaultUni (Esc Text)
     DefaultUniUnit :: DefaultUni (Esc ())
     DefaultUniBool :: DefaultUni (Esc Bool)
+    DefaultUniProtoArray :: DefaultUni (Esc Vector)
     DefaultUniProtoList :: DefaultUni (Esc [])
     DefaultUniProtoPair :: DefaultUni (Esc (,))
     DefaultUniApply :: !(DefaultUni (Esc f)) -> !(DefaultUni (Esc a)) -> DefaultUni (Esc (f a))
@@ -116,6 +120,8 @@ data DefaultUni a where
 -- so we just leave GHC with its craziness.
 pattern DefaultUniList uniA =
     DefaultUniProtoList `DefaultUniApply` uniA
+pattern DefaultUniArray uniA =
+    DefaultUniProtoArray `DefaultUniApply` uniA
 pattern DefaultUniPair uniA uniB =
     DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB
 
@@ -150,6 +156,9 @@ instance GEq DefaultUni where
         geqStep DefaultUniProtoList a2 = do
             DefaultUniProtoList <- Just a2
             Just Refl
+        geqStep DefaultUniProtoArray a2 = do
+            DefaultUniProtoArray <- Just a2
+            Just Refl
         geqStep DefaultUniProtoPair a2 = do
             DefaultUniProtoPair <- Just a2
             Just Refl
@@ -187,6 +196,7 @@ instance ToKind DefaultUni where
     toSingKind DefaultUniUnit                 = knownKind
     toSingKind DefaultUniBool                 = knownKind
     toSingKind DefaultUniProtoList            = knownKind
+    toSingKind DefaultUniProtoArray           = knownKind
     toSingKind DefaultUniProtoPair            = knownKind
     toSingKind (DefaultUniApply uniF _)       = case toSingKind uniF of _ `SingKindArrow` cod -> cod
     toSingKind DefaultUniData                 = knownKind
@@ -211,6 +221,7 @@ instance PrettyBy RenderContext (DefaultUni a) where
         DefaultUniUnit                 -> "unit"
         DefaultUniBool                 -> "bool"
         DefaultUniProtoList            -> "list"
+        DefaultUniProtoArray           -> "array"
         DefaultUniProtoPair            -> "pair"
         DefaultUniApply uniF uniA      -> uniF `juxtPrettyM` uniA
         DefaultUniData                 -> "data"
@@ -251,6 +262,8 @@ instance DefaultUni `Contains` Bool where
     knownUni = DefaultUniBool
 instance DefaultUni `Contains` [] where
     knownUni = DefaultUniProtoList
+instance DefaultUni `Contains` Vector where
+    knownUni = DefaultUniProtoArray
 instance DefaultUni `Contains` (,) where
     knownUni = DefaultUniProtoPair
 instance DefaultUni `Contains` Data where
@@ -274,6 +287,8 @@ instance KnownBuiltinTypeAst tyname DefaultUni Bool =>
     KnownTypeAst tyname DefaultUni Bool
 instance KnownBuiltinTypeAst tyname DefaultUni [a] =>
     KnownTypeAst tyname DefaultUni [a]
+instance KnownBuiltinTypeAst tyname DefaultUni (Vector a) =>
+    KnownTypeAst tyname DefaultUni (Vector a)
 instance KnownBuiltinTypeAst tyname DefaultUni (a, b) =>
     KnownTypeAst tyname DefaultUni (a, b)
 instance KnownBuiltinTypeAst tyname DefaultUni Data =>
@@ -299,6 +314,8 @@ instance KnownBuiltinTypeIn DefaultUni term Data =>
     ReadKnownIn DefaultUni term Data
 instance KnownBuiltinTypeIn DefaultUni term [a] =>
     ReadKnownIn DefaultUni term [a]
+instance KnownBuiltinTypeIn DefaultUni term (Vector a) =>
+    ReadKnownIn DefaultUni term (Vector a)
 instance KnownBuiltinTypeIn DefaultUni term (a, b) =>
     ReadKnownIn DefaultUni term (a, b)
 instance KnownBuiltinTypeIn DefaultUni term BLS12_381.G1.Element =>
@@ -322,6 +339,8 @@ instance KnownBuiltinTypeIn DefaultUni term Data =>
     MakeKnownIn DefaultUni term Data
 instance KnownBuiltinTypeIn DefaultUni term [a] =>
     MakeKnownIn DefaultUni term [a]
+instance KnownBuiltinTypeIn DefaultUni term (Vector a) =>
+    MakeKnownIn DefaultUni term (Vector a)
 instance KnownBuiltinTypeIn DefaultUni term (a, b) =>
     MakeKnownIn DefaultUni term (a, b)
 instance KnownBuiltinTypeIn DefaultUni term BLS12_381.G1.Element =>
@@ -487,6 +506,13 @@ deriving newtype instance KnownBuiltinTypeIn DefaultUni term [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 =>
@@ -523,6 +549,7 @@ instance Closed DefaultUni where
         , constr `Permits` ()
         , constr `Permits` Bool
         , constr `Permits` []
+        , constr `Permits` Vector
         , constr `Permits` (,)
         , constr `Permits` Data
         , constr `Permits` BLS12_381.G1.Element
@@ -544,6 +571,7 @@ instance Closed DefaultUni where
     encodeUni DefaultUniBLS12_381_G1_Element = [9]
     encodeUni DefaultUniBLS12_381_G2_Element = [10]
     encodeUni DefaultUniBLS12_381_MlResult   = [11]
+    encodeUni DefaultUniProtoArray           = [12]
 
     -- See Note [Decoding universes].
     -- See Note [Stable encoding of tags].
@@ -564,6 +592,7 @@ instance Closed DefaultUni where
         9  -> k DefaultUniBLS12_381_G1_Element
         10 -> k DefaultUniBLS12_381_G2_Element
         11 -> k DefaultUniBLS12_381_MlResult
+        12 -> k DefaultUniProtoArray
         _  -> empty
 
     bring
@@ -576,6 +605,8 @@ instance Closed DefaultUni where
     bring _ DefaultUniBool r = r
     bring p (DefaultUniProtoList `DefaultUniApply` uniA) r =
         bring p uniA r
+    bring p (DefaultUniProtoArray `DefaultUniApply` uniA) r =
+        bring p uniA r
     bring p (DefaultUniProtoPair `DefaultUniApply` uniA `DefaultUniApply` uniB) r =
         bring p uniA $ bring p uniB r
     bring _ (f `DefaultUniApply` _ `DefaultUniApply` _ `DefaultUniApply` _) _ =

diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs
@@ -127,6 +127,9 @@ data BuiltinCostModelBase f =
     , paramHeadList                        :: f ModelOneArgument
     , paramTailList                        :: f ModelOneArgument
     , paramNullList                        :: f ModelOneArgument
+    -- Arrays
+    , paramLengthArray                     :: f ModelOneArgument
+    , paramListToArray                     :: f ModelOneArgument
     -- Data
     , paramChooseData                      :: f ModelSixArguments
     , paramConstrData                      :: f ModelTwoArguments