Merge branch 'master' into koz/nqueens

plutus-core/plutus-core/src/PlutusCore/Bitwise.hs

@@ -12,6 +12,7 @@ module PlutusCore.Bitwise (
   byteStringToIntegerWrapper,
   shiftByteStringWrapper,
   rotateByteStringWrapper,
+  writeBitsWrapper,
   -- * Implementation details
   IntegerToByteStringError (..),
   integerToByteStringMaximumOutputLength,
@@ -357,6 +358,12 @@ byteStringToInteger statedByteOrder input = case statedByteOrder of
 endiannessArgToByteOrder :: Bool -> ByteOrder
 endiannessArgToByteOrder b = if b then BigEndian else LittleEndian
 
+-- | Needed due to the complexities of passing lists of pairs as arguments.
+-- Effectively, we pass the second argument as required by CIP-122 in its
+-- \'unzipped\' form, truncating mismatches.
+writeBitsWrapper :: ByteString -> [Integer] -> [Bool] -> BuiltinResult ByteString
+writeBitsWrapper bs ixes = writeBits bs . zip ixes
+
 {- Note [Binary bitwise operation implementation and manual specialization]
 
    All of the 'binary' bitwise operations (namely `andByteString`,

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

@@ -1476,7 +1476,6 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
             (runCostingFunThreeArguments . paramChooseList)
 
     toBuiltinMeaning _semvar MkCons =
-
         let mkConsDenotation
                 :: SomeConstant uni a -> SomeConstant uni [a] -> BuiltinResult (Opaque val [a])
             mkConsDenotation
@@ -1922,12 +1921,12 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
             (runCostingFunTwoArguments . unimplementedCostingFun)
 
     toBuiltinMeaning _semvar WriteBits =
-        let writeBitsDenotation :: BS.ByteString -> [(Integer, Bool)] -> BuiltinResult BS.ByteString
-            writeBitsDenotation = Bitwise.writeBits
+        let writeBitsDenotation :: BS.ByteString -> [Integer] -> [Bool] -> BuiltinResult BS.ByteString
+            writeBitsDenotation = Bitwise.writeBitsWrapper
             {-# INLINE writeBitsDenotation #-}
         in makeBuiltinMeaning
             writeBitsDenotation
-            (runCostingFunTwoArguments . unimplementedCostingFun)
+            (runCostingFunThreeArguments . unimplementedCostingFun)
 
     toBuiltinMeaning _semvar ReplicateByte =
         let replicateByteDenotation :: Int -> Word8 -> BuiltinResult BS.ByteString

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

@@ -214,15 +214,25 @@ instance ExMemoryUsage BS.ByteString where
     {-# INLINE memoryUsage #-}
 
 instance ExMemoryUsage T.Text where
-    -- This is slow and inaccurate, but matches the version that was originally deployed.
-    -- We may try and improve this in future so long as the new version matches this exactly.
-    memoryUsage text = memoryUsage $ T.unpack text
+    -- This says that @Text@ allocates 1 'CostingInteger' worth of memory (i.e. 8 bytes) per
+    -- character, which is a conservative overestimate (i.e. is safe) regardless of whether @Text@
+    -- is UTF16-based (like it used to when we implemented this instance) or UTF8-based (like it is
+    -- now).
+    --
+    -- Note that the @ExMemoryUsage Char@ instance does not affect this one, this is for performance
+    -- reasons, since @T.length@ is O(1) unlike @sum . map (memoryUsage @Char) . T.unpack@. We used
+    -- to have the latter, but changed it to the former for easy performance gains.
+    --
+    -- We may want to make this a bit less of an overestimate in future just not to overcharge
+    -- users.
+    memoryUsage = singletonRose . fromIntegral . T.length
     {-# INLINE memoryUsage #-}
 
 instance ExMemoryUsage Int where
     memoryUsage _ = singletonRose 1
     {-# INLINE memoryUsage #-}
 
+-- If you ever change this, also change @ExMemoryUsage T.Text@.
 instance ExMemoryUsage Char where
     memoryUsage _ = singletonRose 1
     {-# INLINE memoryUsage #-}
@@ -231,8 +241,24 @@ instance ExMemoryUsage Bool where
     memoryUsage _ = singletonRose 1
     {-# INLINE memoryUsage #-}
 
+-- | Add two 'CostRose's. We don't make this into a 'Semigroup' instance, because there exist
+-- different ways to add two 'CostRose's (e.g. we could optimize the case when one of the roses
+-- contains only one element or we can make the function lazy in the second argument). Here we chose
+-- the version that is most efficient when the first argument is a statically known constant (we
+-- didn't do any benchmarking though, so it may not be the most efficient one) as we need this
+-- below.
+addConstantRose :: CostRose -> CostRose -> CostRose
+addConstantRose (CostRose cost1 forest1) (CostRose cost2 forest2) =
+    CostRose (cost1 + cost2) (forest1 ++ forest2)
+{-# INLINE addConstantRose #-}
+
 instance ExMemoryUsage a => ExMemoryUsage [a] where
-    memoryUsage = CostRose 0 . map memoryUsage
+    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 #-}
 
 {- Another naive traversal for size.  This accounts for the number of nodes in
@@ -253,29 +279,17 @@ instance ExMemoryUsage a => ExMemoryUsage [a] where
 -}
 instance ExMemoryUsage Data where
     memoryUsage = sizeData where
-        -- The cost of each node of the 'Data' object (in addition to the cost of its content).
-        nodeMem = singletonRose 4
-        {-# INLINE nodeMem #-}
-
-        -- Add two 'CostRose's. We don't make this into a 'Semigroup' instance, because there exist
-        -- different ways to add two 'CostRose's (e.g. we could optimize the case when one of the
-        -- roses contains only one element or we can make the function lazy in the second argument).
-        -- Here we chose the version that is most efficient when the first argument is @nodeMem@ (we
-        -- didn't do any benchmarking though, so it may not be the most efficient one) -- we don't
-        -- have any other cases.
-        combine (CostRose cost1 forest1) (CostRose cost2 forest2) =
-            CostRose (cost1 + cost2) (forest1 ++ forest2)
-        {-# INLINE combine #-}
-
-        sizeData d = combine nodeMem $ case d of
-            -- TODO: include the size of the tag, but not just yet.  See SCP-3677.
+        dataNodeRose = singletonRose 4
+        {-# INLINE dataNodeRose #-}
+
+        sizeData d = addConstantRose dataNodeRose $ case d of
+            -- TODO: include the size of the tag, but not just yet. See PLT-1176.
             Constr _ l -> CostRose 0 $ l <&> sizeData
             Map l      -> CostRose 0 $ l >>= \(d1, d2) -> [d1, d2] <&> sizeData
             List l     -> CostRose 0 $ l <&> sizeData
             I n        -> memoryUsage n
             B b        -> memoryUsage b
 
-
 {- Note [Costing constant-size types]
 The memory usage of each of the BLS12-381 types is constant, so we may be able
 to optimise things a little by ensuring that we don't re-compute the size of

plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/WriteBits.plc.golden

@@ -1 +1 @@
-bytestring -> list (pair integer bool) -> bytestring
+bytestring -> list integer -> list bool -> bytestring

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Costing.hs

@@ -428,7 +428,7 @@ test_flattenCostRoseHandlesBottom =
 test_costsAreNeverNegative :: TestTree
 test_costsAreNeverNegative =
     testProperty "costs coming from 'memoryUsage' are never negative" $
-        withMaxSuccess 500 $ \(val :: Some (ValueOf DefaultUni)) ->
+        withMaxSuccess 1000 $ \(val :: Some (ValueOf DefaultUni)) ->
             all (>= 0) . toCostList . flattenCostRose $ memoryUsage val
 
 test_costing :: TestTree

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs

@@ -65,7 +65,8 @@ getSet =
     b <- evaluateToHaskell lookupExp
     let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
           mkConstant @ByteString () bs,
-          mkConstant @[(Integer, Bool)] () [(i, b)]
+          mkConstant @[Integer] () [i],
+          mkConstant @[Bool] () [b]
           ]
     evaluatesToConstant bs lhs
 
@@ -79,7 +80,8 @@ setGet =
     b <- forAll Gen.bool
     let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [
           mkConstant @ByteString () bs,
-          mkConstant @[(Integer, Bool)] () [(i, b)]
+          mkConstant @[Integer] () [i],
+          mkConstant @[Bool] () [b]
           ]
     let lhs = mkIterAppNoAnn (builtin () PLC.ReadBit) [
           lhsInner,
@@ -97,11 +99,13 @@ setSet =
     b2 <- forAll Gen.bool
     let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
           mkConstant @ByteString () bs,
-          mkConstant @[(Integer, Bool)] () [(i, b1), (i, b2)]
+          mkConstant @[Integer] () [i, i],
+          mkConstant @[Bool] () [b1, b2]
           ]
     let rhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
           mkConstant @ByteString () bs,
-          mkConstant @[(Integer, Bool)] () [(i, b2)]
+          mkConstant @[Integer] () [i],
+          mkConstant @[Bool] () [b2]
           ]
     evaluateTheSame lhs rhs
 
@@ -122,25 +126,29 @@ writeBitsHomomorphismLaws =
         bs <- forAllByteString 1 512
         let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
               mkConstant @ByteString () bs,
-              mkConstant @[(Integer, Bool)] () []
+              mkConstant @[Integer] () [],
+              mkConstant @[Bool] () []
               ]
         evaluatesToConstant bs lhs
       compositionProp :: Property
       compositionProp = property $ do
         bs <- forAllByteString 1 512
-        changelist1 <- forAllChangelistOf bs
-        changelist2 <- forAllChangelistOf bs
+        (ixes1, bits1) <- forAllChangelistsOf bs
+        (ixes2, bits2) <- forAllChangelistsOf bs
         let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [
               mkConstant @ByteString () bs,
-              mkConstant @[(Integer, Bool)] () changelist1
+              mkConstant @[Integer] () ixes1,
+              mkConstant @[Bool] () bits1
               ]
         let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
               lhsInner,
-              mkConstant @[(Integer, Bool)] () changelist2
+              mkConstant @[Integer] () ixes2,
+              mkConstant @[Bool] () bits2
               ]
         let rhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
               mkConstant @ByteString () bs,
-              mkConstant @[(Integer, Bool)] () (changelist1 <> changelist2)
+              mkConstant @[Integer] () (ixes1 <> ixes2),
+              mkConstant @[Bool] () (bits1 <> bits2)
               ]
         evaluateTheSame lhs rhs
 
@@ -455,9 +463,12 @@ unitProp f isPadding unit = property $ do
 forAllIndexOf :: ByteString -> PropertyT IO Integer
 forAllIndexOf bs = forAll . Gen.integral . Range.linear 0 . fromIntegral $ BS.length bs * 8 - 1
 
-forAllChangelistOf :: ByteString -> PropertyT IO [(Integer, Bool)]
-forAllChangelistOf bs =
-  forAll . Gen.list (Range.linear 0 (8 * len - 1)) $ (,) <$> genIndex <*> Gen.bool
+forAllChangelistsOf :: ByteString -> PropertyT IO ([Integer], [Bool])
+forAllChangelistsOf bs = do
+  ourLen :: Int <- forAll . Gen.integral . Range.linear 0 $ 8 * len - 1
+  ixes <- forAll . Gen.list (Range.singleton ourLen) $ genIndex
+  bits <- forAll . Gen.list (Range.singleton ourLen) $ Gen.bool
+  pure (ixes, bits)
   where
     len :: Int
     len = BS.length bs

plutus-tx/src/PlutusTx/Builtins.hs

@@ -784,11 +784,28 @@ readBit ::
   Bool
 readBit bs i = fromOpaque (BI.readBit bs i)
 
--- | Given a 'BuiltinByteString' and a changelist of index-value pairs, set the _bit_ at each index
--- where the corresponding value is 'True', and clear the bit at each index where the corresponding
--- value is 'False'. Will error if any of the indexes are out-of-bounds: that is, if the index is
--- either negative, or equal to or greater than the total number of bits in the 'BuiltinByteString'
--- argument.
+-- | Given a 'BuiltinByteString', a list of indexes to change, and a list of values to change those
+-- indexes to, set the /bit/ at each of the specified index as follows:
+--
+-- * If the corresponding entry in the list of values is 'True', set that bit;
+-- * Otherwise, clear that bit.
+--
+-- Will error if any of the indexes are out-of-bounds: that is, if the index is either negative, or
+-- equal to or greater than the total number of bits in the 'BuiltinByteString' argument.
+--
+-- If the two list arguments have mismatched lengths, the longer argument will be truncated to match
+-- the length of the shorter one:
+--
+-- * @writeBits bs [0, 1, 4] [True]@ is the same as @writeBits bs [0] [True]@
+-- * @writeBits bs [0] [True, False, True]@ is the same as @writeBits bs [0] [True]@
+--
+-- = Note
+--
+-- This differs slightly from the description of the [corresponding operation in
+-- CIP-122](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#writebits); instead of a
+-- single changelist argument comprised of pairs, we instead pass two lists, one for indexes to
+-- change, and one for the values to change those indexes to. Effectively, we are passing the
+-- changelist argument \'unzipped\'.
 --
 -- = See also
 --
@@ -799,9 +816,10 @@ readBit bs i = fromOpaque (BI.readBit bs i)
 {-# INLINEABLE writeBits #-}
 writeBits ::
   BuiltinByteString ->
-  BI.BuiltinList (BI.BuiltinPair BI.BuiltinInteger BI.BuiltinBool) ->
+  [Integer] ->
+  [Bool] ->
   BuiltinByteString
-writeBits = BI.writeBits
+writeBits bs ixes bits = BI.writeBits bs (toBuiltin ixes) (toBuiltin bits)
 
 -- | Given a length (first argument) and a byte (second argument), produce a 'BuiltinByteString' of
 -- that length, with that byte in every position. Will error if given a negative length, or a second

plutus-tx/src/PlutusTx/Builtins/Internal.hs

@@ -793,15 +793,15 @@ readBit (BuiltinByteString bs) i =
 {-# NOINLINE writeBits #-}
 writeBits ::
   BuiltinByteString ->
-  BuiltinList (BuiltinPair BuiltinInteger BuiltinBool) ->
+  BuiltinList BuiltinInteger ->
+  BuiltinList BuiltinBool ->
   BuiltinByteString
-writeBits (BuiltinByteString bs) (BuiltinList xs) =
-  let unwrapped = fmap (\(BuiltinPair (i, BuiltinBool b)) -> (i, b)) xs in
-    case Bitwise.writeBits bs unwrapped of
-      BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $
-        Haskell.error "writeBits errored."
-      BuiltinSuccess bs' -> BuiltinByteString bs'
-      BuiltinSuccessWithLogs logs bs' -> traceAll logs $ BuiltinByteString bs'
+writeBits (BuiltinByteString bs) (BuiltinList ixes) (BuiltinList bits) =
+  case Bitwise.writeBitsWrapper bs ixes (fmap (\(BuiltinBool b) -> b) bits) of
+    BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $
+      Haskell.error "writeBits errored."
+    BuiltinSuccess bs' -> BuiltinByteString bs'
+    BuiltinSuccessWithLogs logs bs' -> traceAll logs $ BuiltinByteString bs'
 
 {-# NOINLINE replicateByte #-}
 replicateByte ::

plutus-tx/src/PlutusTx/Prelude.hs

@@ -66,6 +66,17 @@ module PlutusTx.Prelude (
     indexByteString,
     emptyByteString,
     decodeUtf8,
+    Builtins.andByteString,
+    Builtins.orByteString,
+    Builtins.xorByteString,
+    Builtins.complementByteString,
+    -- ** Bit operations
+    Builtins.readBit,
+    Builtins.writeBits,
+    Builtins.shiftByteString,
+    Builtins.rotateByteString,
+    Builtins.countSetBits,
+    Builtins.findFirstSetBit,
     -- * Hashes and Signatures
     sha2_256,
     sha3_256,
@@ -108,13 +119,13 @@ module PlutusTx.Prelude (
     bls12_381_millerLoop,
     bls12_381_mulMlResult,
     bls12_381_finalVerify,
-    byteStringToInteger,
-    integerToByteString,
     -- * Conversions
     fromBuiltin,
     toBuiltin,
     fromOpaque,
-    toOpaque
+    toOpaque,
+    integerToByteString,
+    byteStringToInteger
     ) where
 
 import Data.String (IsString (..))