From 50081f009f468a66d8810451b929007e12ccdb36 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 7 May 2024 11:57:43 +1200 Subject: [PATCH 01/16] Initial port of logical ops --- plutus-core/plutus-core.cabal | 1 + .../src/PlutusCore/Bitwise/Logical.hs | 468 ++++++++++++++++++ .../src/PlutusCore/Default/Builtins.hs | 75 +++ 3 files changed, 544 insertions(+) create mode 100644 plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index af8cf84b0c3..3f04eebe9b4 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -89,6 +89,7 @@ library PlutusCore.Annotation PlutusCore.Arity PlutusCore.Bitwise.Convert + PlutusCore.Bitwise.Logical PlutusCore.Builtin PlutusCore.Builtin.Debug PlutusCore.Builtin.Elaborate diff --git a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs new file mode 100644 index 00000000000..8c57cd23c7a --- /dev/null +++ b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs @@ -0,0 +1,468 @@ +-- editorconfig-checker-disable-file + +{-# LANGUAGE OverloadedStrings #-} + +-- | Implementations of bitwise logical primops. +module PlutusCore.Bitwise.Logical ( + bitwiseLogicalAnd, + bitwiseLogicalOr, + bitwiseLogicalXor, + bitwiseLogicalComplement, + readBit, + writeBits, + byteStringReplicate, + ) where + +import Control.Exception (Exception, throw, try) +import Data.Bits qualified as Bits +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Internal qualified as BSI +import Data.Foldable (for_, traverse_) +import Data.Text (pack) +import Data.Word (Word64, Word8) +import Foreign.Marshal.Utils (copyBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (peekByteOff, peekElemOff, pokeByteOff, pokeElemOff) +import PlutusCore.Builtin (BuiltinResult, emit) +import PlutusCore.Evaluation.Result (evaluationFailure) +import System.IO.Unsafe (unsafeDupablePerformIO) + +{- Note [Binary bitwise operation implementation and manual specialization] + + All of the 'binary' bitwise operations (namely `bitwiseLogicalAnd`, + `bitwiseLogicalOr` and `bitwiseLogicalXor`) operate similarly: + + 1. Decide which of their two `ByteString` arguments determines the length + of the result. For padding semantics, this is the _longer_ argument, + whereas for truncation semantics, it's the _shorter_ one. If both + `ByteString` arguments have identical length, it doesn't matter which we + choose. + 2. Copy the choice made in step 1 into a fresh mutable buffer. + 3. Traverse over each byte of the argument _not_ chosen in step 1, and + combine each of those bytes with the byte at the corresponding index of + the fresh mutable buffer from step 2 (`.&.` for `bitwiseLogicalAnd`, + `.|.` for `bitwiseLogicalOr`, `xor` for `bitwiseLogicalXor`). + + We also make use of loop sectioning to optimize this operation: see Note + [Loop sectioning] explaining why we do this. Fundamentally, this doesn't + change the logic of the operation, but means that step 3 is split into + two smaller sub-steps: we first word 8 bytes at a time, then one byte at a + time to finish up if necessary. Other than the choice of 'combining + operation', the structure of the computation is the same, which suggests that + we want a helper function with a signature like + + helper1 :: + (Word64 -> Word64 -> Word64) -> + (Word8 -> Word8 -> Word8) -> + ByteString -> + ByteString -> + Int -> + ByteString + + or possibly (to avoid duplicate argument passing) like + + helper2 :: + (forall (a :: Type) . Bits a => a -> a -> a) -> + ByteString -> + ByteString -> + Int -> + ByteString + + This would allow us to share all this logic, and have each of the 'top-level' + operations just dispatch to either of the helpers with the appropriate + function argument(s). Instead, we chose to write a manual copy of this logic + for each of the 'top-level' operations, substituting only the 'combining + operation'. + + We made this choice as any design based on either `helper1` or `helper2` is + significantly slower (at least 50% worse, and the penalty _percentage_ grows + with argument size). While `helper2` is significantly more penalizing than + `helper1`, even `helper1` reaches an almost threefold slowdown at the higher + input sizes we are interested in relative the manual version we use here. + Due to the 'low-level' nature of Plutus Core primops, we consider these costs + unacceptable relative the (small) benefits to code clarity and maintainability + any solution using either style of helper would provide. + + The reason for `helper2` under-performing is unsurprising: any argument whose + type is rank-2 polymorphic with a dictionary constraint essentially acts as + a 'program template', which gets interpreted at runtime given some dictionary + for a `Bits` instance. GHC can do practically nothing to optimize this, as + there is no way to tell, for any given argument, _which_ definitions of an + instance would be required here, even if the set of operations we use is + finite, since any instance can make use of the full power of Haskell, which + essentially lands us in Rice's Theorem territory. For `helper1`, the reasons + are similar: it _must_ be able to work regardless of what functions (assuming + appropriate types) it is given, which means in general, GHC is forced to + compile mother-may-I-style code involving pointer chasing those arguments at + runtime. This explains why the 'blowup' becomes worse with argument length. + + While in theory inlining could help with at least the `helper1` case ( + `helper2` is beyond that technique), it doesn't seem like GHC is able to + figure this out, even with `INLINE` is placed on `helper1`. + -} + +-- | Bitwise logical AND, as per [the relevant +-- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +bitwiseLogicalAnd :: Bool -> ByteString -> ByteString -> ByteString +bitwiseLogicalAnd shouldPad bs1 bs2 = + let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) + (toCopy, toTraverse) = if shouldPad then (longer, shorter) else (shorter, longer) + in go toCopy toTraverse (BS.length shorter) + where + go :: ByteString -> ByteString -> Int -> ByteString + go toCopy toTraverse traverseLen = + unsafeDupablePerformIO . BS.useAsCStringLen toCopy $ \(copyPtr, copyLen) -> + BS.useAsCString toTraverse $ \traversePtr -> do + BSI.create copyLen $ \dstPtr -> do + copyBytes dstPtr (castPtr copyPtr) copyLen + let (bigStrides, littleStrides) = traverseLen `quotRem` 8 + let offset = bigStrides * 8 + let bigDstPtr :: Ptr Word64 = castPtr dstPtr + let bigTraversePtr :: Ptr Word64 = castPtr traversePtr + for_ [0 .. bigStrides - 1] $ \i -> do + w64_1 <- peekElemOff bigDstPtr i + w64_2 <- peekElemOff bigTraversePtr i + pokeElemOff bigDstPtr i $ w64_1 Bits..&. w64_2 + let smallDstPtr :: Ptr Word8 = plusPtr dstPtr offset + let smallTraversePtr :: Ptr Word8 = plusPtr traversePtr offset + for_ [0 .. littleStrides - 1] $ \i -> do + w8_1 <- peekElemOff smallDstPtr i + w8_2 <- peekElemOff smallTraversePtr i + pokeElemOff smallDstPtr i $ w8_1 Bits..&. w8_2 + +-- | Bitwise logical OR, as per [the relevant +-- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +bitwiseLogicalOr :: Bool -> ByteString -> ByteString -> ByteString +bitwiseLogicalOr shouldPad bs1 bs2 = + let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) + (toCopy, toTraverse) = if shouldPad then (longer, shorter) else (shorter, longer) + in go toCopy toTraverse (BS.length shorter) + where + go :: ByteString -> ByteString -> Int -> ByteString + go toCopy toTraverse traverseLen = + unsafeDupablePerformIO . BS.useAsCStringLen toCopy $ \(copyPtr, copyLen) -> + BS.useAsCString toTraverse $ \traversePtr -> do + BSI.create copyLen $ \dstPtr -> do + copyBytes dstPtr (castPtr copyPtr) copyLen + let (bigStrides, littleStrides) = traverseLen `quotRem` 8 + let offset = bigStrides * 8 + let bigDstPtr :: Ptr Word64 = castPtr dstPtr + let bigTraversePtr :: Ptr Word64 = castPtr traversePtr + for_ [0 .. bigStrides - 1] $ \i -> do + w64_1 <- peekElemOff bigDstPtr i + w64_2 <- peekElemOff bigTraversePtr i + pokeElemOff bigDstPtr i $ w64_1 Bits..|. w64_2 + let smallDstPtr :: Ptr Word8 = plusPtr dstPtr offset + let smallTraversePtr :: Ptr Word8 = plusPtr traversePtr offset + for_ [0 .. littleStrides - 1] $ \i -> do + w8_1 <- peekElemOff smallDstPtr i + w8_2 <- peekElemOff smallTraversePtr i + pokeElemOff smallDstPtr i $ w8_1 Bits..|. w8_2 + +-- | Bitwise logical XOR, as per [the relevant +-- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +bitwiseLogicalXor :: Bool -> ByteString -> ByteString -> ByteString +bitwiseLogicalXor shouldPad bs1 bs2 = + let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) + (toCopy, toTraverse) = if shouldPad then (longer, shorter) else (shorter, longer) + in go toCopy toTraverse (BS.length shorter) + where + go :: ByteString -> ByteString -> Int -> ByteString + go toCopy toTraverse traverseLen = + unsafeDupablePerformIO . BS.useAsCStringLen toCopy $ \(copyPtr, copyLen) -> + BS.useAsCString toTraverse $ \traversePtr -> do + BSI.create copyLen $ \dstPtr -> do + copyBytes dstPtr (castPtr copyPtr) copyLen + let (bigStrides, littleStrides) = traverseLen `quotRem` 8 + let offset = bigStrides * 8 + let bigDstPtr :: Ptr Word64 = castPtr dstPtr + let bigTraversePtr :: Ptr Word64 = castPtr traversePtr + for_ [0 .. bigStrides - 1] $ \i -> do + w64_1 <- peekElemOff bigDstPtr i + w64_2 <- peekElemOff bigTraversePtr i + pokeElemOff bigDstPtr i $ Bits.xor w64_1 w64_2 + let smallDstPtr :: Ptr Word8 = plusPtr dstPtr offset + let smallTraversePtr :: Ptr Word8 = plusPtr traversePtr offset + for_ [0 .. littleStrides - 1] $ \i -> do + w8_1 <- peekElemOff smallDstPtr i + w8_2 <- peekElemOff smallTraversePtr i + pokeElemOff smallDstPtr i $ Bits.xor w8_1 w8_2 + +-- | Bitwise logical complement, as per [the relevant +-- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +{-# INLINEABLE bitwiseLogicalComplement #-} +bitwiseLogicalComplement :: ByteString -> ByteString +bitwiseLogicalComplement bs = unsafeDupablePerformIO . BS.useAsCStringLen bs $ \(srcPtr, len) -> do + -- We use loop sectioning here; see Note [Loop sectioning] as to why we do this + let (bigStrides, littleStrides) = len `quotRem` 8 + let offset = bigStrides * 8 + BSI.create len $ \dstPtr -> do + let bigSrcPtr :: Ptr Word64 = castPtr srcPtr + let bigDstPtr :: Ptr Word64 = castPtr dstPtr + for_ [0 .. bigStrides - 1] $ \i -> do + w64 <- peekElemOff bigSrcPtr i + pokeElemOff bigDstPtr i . Bits.complement $ w64 + let smallSrcPtr :: Ptr Word8 = plusPtr srcPtr offset + let smallDstPtr :: Ptr Word8 = plusPtr dstPtr offset + for_ [0 .. littleStrides - 1] $ \i -> do + w8 <- peekElemOff smallSrcPtr i + pokeElemOff smallDstPtr i . Bits.complement $ w8 + +-- | Bit read at index, as per [the relevant +-- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md) +{-# INLINEABLE readBit #-} +readBit :: ByteString -> Int -> BuiltinResult Bool +readBit bs ix + | ix < 0 = do + emit "readBit: index out of bounds" + emit $ "Index: " <> (pack . show $ ix) + evaluationFailure + | ix >= (len * 8) - 1 = do + emit "readBit: index out of bounds" + emit $ "Index: " <> (pack . show $ ix) + evaluationFailure + | otherwise = do + let (bigIx, littleIx) = ix `quotRem` 8 + let flipIx = len - bigIx - 1 + pure $ Bits.testBit (BS.index bs flipIx) littleIx + where + len :: Int + len = BS.length bs + +-- | Bulk bit write, as per [the relevant +-- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md) +{-# INLINEABLE writeBits #-} +writeBits :: ByteString -> [(Integer, Bool)] -> BuiltinResult ByteString +writeBits bs changelist = case unsafeDupablePerformIO . try $ go of + Left (WriteBitsException i) -> do + emit "writeBits: index out of bounds" + emit $ "Index: " <> (pack . show $ i) + evaluationFailure + Right result -> pure result + where + -- This is written in a somewhat strange way. See Note [writeBits and + -- exceptions], which covers why we did this. + go :: IO ByteString + go = BS.useAsCString bs $ \srcPtr -> + BSI.create len $ \dstPtr -> do + copyBytes dstPtr (castPtr srcPtr) len + traverse_ (setAtIx dstPtr) changelist + len :: Int + len = BS.length bs + bitLen :: Integer + bitLen = fromIntegral len * 8 + setAtIx :: Ptr Word8 -> (Integer, Bool) -> IO () + setAtIx ptr (i, b) + | i < 0 = throw $ WriteBitsException i + | i >= bitLen - 1 = throw $ WriteBitsException i + | otherwise = do + let (bigIx, littleIx) = i `quotRem` 8 + let flipIx = len - fromIntegral bigIx - 1 + w8 :: Word8 <- peekByteOff ptr flipIx + let toWrite = if b + then Bits.setBit w8 . fromIntegral $ littleIx + else Bits.clearBit w8 . fromIntegral $ littleIx + pokeByteOff ptr flipIx toWrite + +-- | Byte replication, as per [the relevant +-- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md) +byteStringReplicate :: Int -> Word8 -> BuiltinResult ByteString +byteStringReplicate len w8 + | len < 0 = do + emit "byteStringReplicate: negative length requested" + evaluationFailure + | otherwise = pure . BS.replicate len $ w8 + +-- Helpers + +{- Note [writeBits and exceptions] + + As `writeBits` allows us to pass a changelist argument of any length, we + potentially could have an out-of-bounds index anywhere in the list. As we + have to fail on such cases (and report them appropriately), we end up needing + _both_ IO (to do mutable things) as well as a way to signal errors. We can + do this in two ways: + + 1. Pre-scan the changelist for any out-of-bounds indexes, fail if we see any, + then apply the necessary changes if no out-of-bounds indexes are found. + 2. Speculatively allocate the new `ByteString`, then do the changes in the + changelist argument one at a time, failing as soon as we see an out-of-bounds + index. + + Option 1 would require traversing the changelist argument twice, which is + undesirable, which means that option 2 is the more efficient choice. The + natural choice for option 2 would be something similar to `ExceptT Int IO` + (with the `Int` being an out-of-bounds index). However, we aren't able to do + this, as ultimately, `ByteString`s are implemented as `ForeignPtr`s, forcing + us to use the following function to interact with them, directly or not: + + withForeignPtr :: forall (a :: Type) . ForeignPtr a -> (Ptr a -> IO b) -> IO b + + Notably, the function argument produces a result of `IO b`, whereas we would + need `MonadIO m => m b` instead. This means that our _only_ choice is to + use the exception mechanism, either directly or via some wrappers like + `MonadUnliftIO`. While this is unusual, and arguably against the spirit of + the use of `IO` relative `ByteString` construction, we don't have any other + choice. We decided to use the exception mechanism directly, as while + `MonadUnliftIO` is a bit cleaner, it ultimately ends up doing the same thing + anyway, and this method at least makes it clear what we're doing. + + This doesn't pose any problems from the point of view of Plutus Core, as this + exception cannot 'leak'; we handle it entirely within `writeBits`, and no + other Plutus Core code can ever see it. +-} +newtype WriteBitsException = WriteBitsException Integer + deriving stock (Eq, Show) + +instance Exception WriteBitsException + +{- Note [Loop sectioning] + +Several operations in this module effectively function as loops over bytes, +which have to be read, written, or both. Furthermore, we usually need to +process these bytes somehow, typically using fixed-width bitwise operations +from the Haskell side, thus allowing us to 'translate' these same operations +to the variable-width `ByteString` arguments we are dealing with. This involves +significant trafficking of data between memory and machine registers (as +`ByteString`s are wrapped counted arrays), as well as the overheads of looping +(involving comparisons and branches). This trafficking is necessary not only +to move the memory around, but also to process it, as on modern architectures, +data must first be moved into a register in order to do anything with it. + +On all architectures of interest (essentially, 64-bit Tier 1), general-purpose +registers (GPRs henceforth) are 64 bits (or 8 bytes) wide. Furthermore, the +primary cost of moving data between memory and registers is having to overcome +the 'memory wall': the exact amount of data being moved doesn't affect this +much. In addition to this, when we operate on single bytes, the remaining 56 +bits of the GPR holding that data are essentially 'wasted'. In the situation +we are in (namely, operating over arrays, whose data is adjacent in memory), +we thus get two sources of inefficiency: + +* Despite paying the cost for a memory transfer, we move only one-eighth of + the data we could; and +* Despite transferring data from memory to registers, we use these registers + only at one-eighth capacity. + +In short, we do _eight times_ more rotations of the loop, and memory moves, +than we need to! + +To avoid this, we use a technique called _loop sectioning_. Effectively, this +transforms our homogenous loop (that always works one byte at a time) into a +heterogenous loop: first, we operate on a larger section (called a _stride_) +until we can no longer do this, and then we finish up using byte at a time +processing. Essentially, given an input like this: + +[ b1, b2, b3, b4, b5, b6, b7, b8, b9, b10 ] + +the homogeous byte-at-a-time approach would process it like so: + + _ _ _ _ _ _ _ _ _ _ +[ b1, b2, b3, b4, b5, b6, b7, b8, b9, b10 ] + +for a total of 10 memory transfers and 10 loop spins, whereas a loop-sectioned +approach with a stride of 8 would instead process like so: + + ______________________________ _ _ +[ b1, b2, b3, b4, b5, b6, b7, b8, b9, b10 ] + +This gives us only _three_ memory transfers and _three_ loop spins instead. This +effectively reduces our work by a factor of 8. In our cases, this is significant. + +This technique only benefits us because counted arrays are cache-friendly: see +Note [Superscalarity and caching] for a longer explanation of this and why it +matters. + +Further information: + +- Tier 1 GHC platform list: + https://gitlab.haskell.org/ghc/ghc/-/wikis/platforms#tier-1-platforms +- Memory wall: + https://link.springer.com/referenceworkentry/10.1007/978-0-387-09766-4_234 +- Loop sectioning in more detail: + http://physics.ujep.cz/~zmoravec/prga/main_for/mergedProjects/optaps_for/common/optaps_vec_mine.htm +-} + +{- Note [Superscalarity and caching] +On modern architectures, in order to process data, it must first be moved from +memory into a register. This operation has some cost (known as the 'memory wall'), +which is largely independent of how much data gets moved (assuming the register +can hold it): moving one byte, or a whole register's worth, costs about the same. +To reduce this cost, CPU manufacturers have introduced _cache hierarchies_, +which are designed to limit the cost of the wall, as long as the data access +matches the cache's optimal usage pattern. Thus, while an idealized view of +the memory hierachy is this: + +Registers +--------- +Memory + +in reality, the view is more like this: + +Registers +--------- +L1 cache +--------- +L2 cache +--------- +L3 cache (on some platforms) +--------- +Memory + +Each 'higher' cache in the hierarchy is smaller, but faster, and when a memory +fetch is requested in code, in addition to moving the requested data to a +register, that data (plus some more) is moved into caches as well. The amount +of data moved into cache (a _cache line_) is typically eight machine words on +modern architectures (and definitely is the case for all Tier 1 GHC platforms): +for the cases concerning Plutus, that is 64 bytes. Therefore, if data we need +soon after a fetch is _physically_ nearby, it won't need to be fetched from +memory: instead, it would come from a cache, which is faster (by a considerable +margin). + +To see how this can matter, consider the following ByteString: + +[ b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11 ] + +The ByteString (being a counted array) has all of its data physically adjacent +to each other. Suppose we wanted to fetch the byte at index 1 (second position). +The naive view of what happens is like this: + +Registers: [b2] [ ] [ ] .... [ ] +Memory: [ b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11 ] + +Thus, it would appear that, if we wanted a different position's value, we would +need to fetch from memory again. However, what _actually_ happens is more like this: + +Registers: [b2] [ ] [ ] .... [ ] +L1 cache: [ b2, b3, b4, b5, b6, b7, b8, b9, b10, b11 ] +Memory: [ b1, b2, b3, b4, b5, b6, b7, b8, b9, b10, b11 ] + +We note that b2, as well as its adjacent elements, were _all_ pulled into the L1 +cache. This can only work because all these elements are physically adjacent in +memory. The improvement in performance from this cache use is _very_ non-trivial: +an L1 cache is about 200 times faster than a memory access, and an L2 cache about +20 times faster. + +To take further advantage of this, modern CPUs (and all Tier 1 GHC platforms have +this capability) are _superscalar_. To explain what this means, let's consider the +naive view of how CPUs execute instructions: namely, it is one-at-a-time, and +synchronous. While CPUs must give the _appearance_ that they behave this way, in +practice, CPU execution is very much asynchronous: due to the proliferation of ALUs +on a single chip, having twice as many processing units is much cheaper than having +processing units run twice as fast. Thus, if there are no data dependencies +between instructions, CPUs can (and do!) execute them simultaneously, stalling to +await results if a data dependency is detected. This can be done automatically +using Tomasulo's algorithm, which ensures no conflicts with maximum throughput. + +Superscalarity interacts well with the cache hierarchy, as it makes data more +easily available for processing, provided there is enough 'work to do', and no +data dependencies. In our situation, most of what we do is data _movement_ from +one memory location to another, which by its very nature lacks any data +dependencies. + +Further references: + +- Numbers for cache and memory transfers: https://gist.github.com/jboner/2841832 +- Superscalarity: https://en.wikipedia.org/wiki/Superscalar_processor +- Tomasulo's algorithm: https://en.wikipedia.org/wiki/Tomasulo%27s_algorithm +-} diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 33c46234256..8acdac375ec 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -27,6 +27,7 @@ import PlutusCore.Evaluation.Result (EvaluationResult (..)) import PlutusCore.Pretty (PrettyConfigPlc) import PlutusCore.Bitwise.Convert as Convert +import PlutusCore.Bitwise.Logical as Logical 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 @@ -152,6 +153,14 @@ data DefaultFun -- Conversions | IntegerToByteString | ByteStringToInteger + -- Logical + | BitwiseLogicalAnd + | BitwiseLogicalOr + | BitwiseLogicalXor + | BitwiseLogicalComplement + | ReadBit + | WriteBits + | ByteStringReplicate deriving stock (Show, Eq, Ord, Enum, Bounded, Generic, Ix) deriving anyclass (NFData, Hashable, PrettyBy PrettyConfigPlc) @@ -1820,6 +1829,57 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where in makeBuiltinMeaning byteStringToIntegerDenotation (runCostingFunTwoArguments . paramByteStringToInteger) + -- Logical + toBuiltinMeaning _semvar BitwiseLogicalAnd = + let bitwiseLogicalAndDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + bitwiseLogicalAndDenotation = Logical.bitwiseLogicalAnd + {-# INLINE bitwiseLogicalAndDenotation #-} + in makeBuiltinMeaning + bitwiseLogicalAndDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar BitwiseLogicalOr = + let bitwiseLogicalOrDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + bitwiseLogicalOrDenotation = Logical.bitwiseLogicalOr + {-# INLINE bitwiseLogicalOrDenotation #-} + in makeBuiltinMeaning + bitwiseLogicalOrDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar BitwiseLogicalXor = + let bitwiseLogicalXorDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + bitwiseLogicalXorDenotation = Logical.bitwiseLogicalXor + {-# INLINE bitwiseLogicalXorDenotation #-} + in makeBuiltinMeaning + bitwiseLogicalXorDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar BitwiseLogicalComplement = + let bitwiseLogicalComplementDenotation :: BS.ByteString -> BS.ByteString + bitwiseLogicalComplementDenotation = Logical.bitwiseLogicalComplement + {-# INLINE bitwiseLogicalComplementDenotation #-} + in makeBuiltinMeaning + bitwiseLogicalComplementDenotation + (runCostingFunOneArgument . unimplementedCostingFun) + toBuiltinMeaning _semvar ReadBit = + let readBitDenotation :: BS.ByteString -> Int -> BuiltinResult Bool + readBitDenotation = Logical.readBit + {-# INLINE readBitDenotation #-} + in makeBuiltinMeaning + readBitDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar WriteBits = + let writeBitsDenotation :: BS.ByteString -> [(Integer, Bool)] -> BuiltinResult BS.ByteString + writeBitsDenotation = Logical.writeBits + {-# INLINE writeBitsDenotation #-} + in makeBuiltinMeaning + writeBitsDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar ByteStringReplicate = + let byteStringReplicateDenotation :: Int -> Word8 -> BuiltinResult BS.ByteString + byteStringReplicateDenotation = Logical.byteStringReplicate + {-# INLINE byteStringReplicateDenotation #-} + in makeBuiltinMeaning + byteStringReplicateDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + -- See Note [Inlining meanings of builtins]. {-# INLINE toBuiltinMeaning #-} @@ -1947,6 +2007,14 @@ instance Flat DefaultFun where IntegerToByteString -> 73 ByteStringToInteger -> 74 + BitwiseLogicalAnd -> 75 + BitwiseLogicalOr -> 76 + BitwiseLogicalXor -> 77 + BitwiseLogicalComplement -> 78 + ReadBit -> 79 + WriteBits -> 80 + ByteStringReplicate -> 81 + decode = go =<< decodeBuiltin where go 0 = pure AddInteger go 1 = pure SubtractInteger @@ -2023,6 +2091,13 @@ instance Flat DefaultFun where go 72 = pure Blake2b_224 go 73 = pure IntegerToByteString go 74 = pure ByteStringToInteger + go 75 = pure BitwiseLogicalAnd + go 76 = pure BitwiseLogicalOr + go 77 = pure BitwiseLogicalXor + go 78 = pure BitwiseLogicalComplement + go 79 = pure ReadBit + go 80 = pure WriteBits + go 81 = pure ByteStringReplicate go t = fail $ "Failed to decode builtin tag, got: " ++ show t size _ n = n + builtinTagWidth From 62d1e1a6224fcee80981fbfa3d18bb10fabb5195 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 8 May 2024 10:23:57 +1200 Subject: [PATCH 02/16] Add PlutusTx correspondents to the new builtins --- plutus-tx/src/PlutusTx/Builtins.hs | 137 ++++++++++++++++++++ plutus-tx/src/PlutusTx/Builtins/Internal.hs | 76 +++++++++++ 2 files changed, 213 insertions(+) diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 775d24c9bfc..23a5b34d71d 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -106,8 +106,17 @@ module PlutusTx.Builtins ( , toBuiltin , integerToByteString , byteStringToInteger + -- * Logical + , bitwiseLogicalAnd + , bitwiseLogicalOr + , bitwiseLogicalXor + , bitwiseLogicalComplement + , readBit + , writeBits + , byteStringReplicate ) where +import Data.Functor (fmap) import Data.Maybe import PlutusTx.Base (const, uncurry) import PlutusTx.Bool (Bool (..)) @@ -637,3 +646,131 @@ integerToByteString endianness = BI.integerToByteString (toBuiltin (byteOrderToB byteStringToInteger :: ByteOrder -> BuiltinByteString -> Integer byteStringToInteger endianness = BI.byteStringToInteger (toBuiltin (byteOrderToBool endianness)) + +-- Logical operations + +-- | Perform logical AND on two 'BuiltinByteString' arguments, as described +-- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinlogicaland). +-- +-- The first argument indicates whether padding semantics should be used or not; +-- if 'False', truncation semantics will be used instead. +-- +-- = See also +-- +-- * [Padding and truncation +-- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#padding-versus-truncation-semantics) +-- * [Bit indexing +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +{-# INLINEABLE bitwiseLogicalAnd #-} +bitwiseLogicalAnd :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +bitwiseLogicalAnd b = BI.bitwiseLogicalAnd (toBuiltin b) + +-- | Perform logical OR on two 'BuiltinByteString' arguments, as described +-- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinlogicalor). +-- +-- The first argument indicates whether padding semantics should be used or not; +-- if 'False', truncation semantics will be used instead. +-- +-- = See also +-- +-- * [Padding and truncation +-- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#padding-versus-truncation-semantics) +-- * [Bit indexing +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +{-# INLINEABLE bitwiseLogicalOr #-} +bitwiseLogicalOr :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +bitwiseLogicalOr b = BI.bitwiseLogicalOr (toBuiltin b) + +-- | Perform logical XOR on two 'BuiltinByteString' arguments, as described +-- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinlogicalxor). +-- +-- The first argument indicates whether padding semantics should be used or not; +-- if 'False', truncation semantics will be used instead. +-- +-- = See also +-- +-- * [Padding and truncation +-- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#padding-versus-truncation-semantics) +-- * [Bit indexing +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +{-# INLINEABLE bitwiseLogicalXor #-} +bitwiseLogicalXor :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +bitwiseLogicalXor b = BI.bitwiseLogicalXor (toBuiltin b) + +-- | Perform logical complement on a 'BuiltinByteString', as described +-- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinlogicalcomplement). +-- +-- = See also +-- +-- * [Bit indexing +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +{-# INLINEABLE bitwiseLogicalComplement #-} +bitwiseLogicalComplement :: + BuiltinByteString -> + BuiltinByteString +bitwiseLogicalComplement = BI.bitwiseLogicalComplement + +-- | Read a bit at the _bit_ index given by the 'Integer' argument in the +-- 'BuiltinByteString' argument. The result will be 'True' if the corresponding bit is set, and +-- 'False' if it is clear. Will error if given an out-of-bounds index argument; that is, if the +-- index is either negative, or equal to or greater than the total number of bits in the +-- 'BuiltinByteString' argument. +-- +-- = See also +-- +-- * [Bit indexing +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +-- * [Operation +-- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinreadbit) +{-# INLINEABLE readBit #-} +readBit :: + BuiltinByteString -> + Integer -> + Bool +readBit bs i = fromBuiltin (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. +-- +-- = See also +-- +-- * [Bit indexing +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +-- * [Operation +-- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinsetbits) +{-# INLINEABLE writeBits #-} +writeBits :: + BuiltinByteString -> + BI.BuiltinList (BI.BuiltinPair BI.BuiltinInteger BI.BuiltinBool) -> + BuiltinByteString +writeBits = BI.writeBits + +-- | 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 +-- argument that isn't a byte (less than 0, greater than 255). +-- +-- = See also +-- +-- * [Operation +-- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinreplicate) +{-# INLINEABLE byteStringReplicate #-} +byteStringReplicate :: + Integer -> + Integer -> + BuiltinByteString +byteStringReplicate = BI.byteStringReplicate diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 843b63ccc4c..ab6d428a06c 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -33,6 +33,7 @@ import Data.Text as Text (Text, empty) import Data.Text.Encoding as Text (decodeUtf8, encodeUtf8) import GHC.Generics (Generic) import PlutusCore.Bitwise.Convert qualified as Convert +import PlutusCore.Bitwise.Logical qualified as Logical import PlutusCore.Builtin (BuiltinResult (..)) import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 @@ -706,3 +707,78 @@ byteStringToInteger -> BuiltinInteger byteStringToInteger (BuiltinBool statedEndianness) (BuiltinByteString input) = Convert.byteStringToIntegerWrapper statedEndianness input + +{- +LOGICAL +-} + +{-# NOINLINE bitwiseLogicalAnd #-} +bitwiseLogicalAnd :: + BuiltinBool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +bitwiseLogicalAnd (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.bitwiseLogicalAnd isPaddingSemantics data1 $ data2 + +{-# NOINLINE bitwiseLogicalOr #-} +bitwiseLogicalOr :: + BuiltinBool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +bitwiseLogicalOr (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.bitwiseLogicalOr isPaddingSemantics data1 $ data2 + +{-# NOINLINE bitwiseLogicalXor #-} +bitwiseLogicalXor :: + BuiltinBool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +bitwiseLogicalXor (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.bitwiseLogicalXor isPaddingSemantics data1 $ data2 + +{-# NOINLINE bitwiseLogicalComplement #-} +bitwiseLogicalComplement :: + BuiltinByteString -> + BuiltinByteString +bitwiseLogicalComplement (BuiltinByteString bs) = + BuiltinByteString . Logical.bitwiseLogicalComplement $ bs + +{-# NOINLINE readBit #-} +readBit :: + BuiltinByteString -> + BuiltinInteger -> + BuiltinBool +readBit (BuiltinByteString bs) i = + case Logical.readBit bs (fromIntegral i) of + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + Haskell.error "readBit errored." + BuiltinSuccess b -> BuiltinBool b + BuiltinSuccessWithLogs logs b -> traceAll logs $ BuiltinBool b + +{-# NOINLINE writeBits #-} +writeBits :: + BuiltinByteString -> + BuiltinList (BuiltinPair BuiltinInteger BuiltinBool) -> + BuiltinByteString +writeBits (BuiltinByteString bs) (BuiltinList xs) = + let unwrapped = fmap (\(BuiltinPair (i, BuiltinBool b)) -> (i, b)) xs in + case Logical.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' + +{-# NOINLINE byteStringReplicate #-} +byteStringReplicate :: + BuiltinInteger -> + BuiltinInteger -> + BuiltinByteString +byteStringReplicate n w8 = + case Logical.byteStringReplicate (fromIntegral n) (fromIntegral w8) of + BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ + Haskell.error "byteStringReplicate errored." + BuiltinSuccess bs -> BuiltinByteString bs + BuiltinSuccessWithLogs logs bs -> traceAll logs $ BuiltinByteString bs From 119f162239521c4b3f0a599d73a21b83cb8a44f0 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 8 May 2024 14:18:53 +1200 Subject: [PATCH 03/16] Tests for logical operations --- plutus-core/plutus-core.cabal | 1 + .../test/Evaluation/Builtins/Definition.hs | 43 +++ .../test/Evaluation/Builtins/Laws.hs | 283 ++++++++++++++++++ 3 files changed, 327 insertions(+) create mode 100644 plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 754bccba715..afec0afdf7c 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -419,6 +419,7 @@ test-suite untyped-plutus-core-test Evaluation.Builtins.Conversion Evaluation.Builtins.Costing Evaluation.Builtins.Definition + Evaluation.Builtins.Laws Evaluation.Builtins.MakeRead Evaluation.Builtins.SignatureVerification Evaluation.Debug diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index c7d6eb915e8..a0e0caa705a 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -27,6 +27,7 @@ import PlutusCore.Pretty import PlutusPrelude import UntypedPlutusCore.Evaluation.Machine.Cek +import PlutusCore qualified as PLC import PlutusCore.Examples.Builtins import PlutusCore.Examples.Data.Data import PlutusCore.StdLib.Data.Bool @@ -42,6 +43,7 @@ import PlutusCore.StdLib.Data.Unit import Evaluation.Builtins.BLS12_381 (test_BLS12_381) import Evaluation.Builtins.Common import Evaluation.Builtins.Conversion qualified as Conversion +import Evaluation.Builtins.Laws qualified as Laws import Evaluation.Builtins.SignatureVerification (ecdsaSecp256k1Prop, ed25519_Variant0Prop, ed25519_Variant1Prop, ed25519_Variant2Prop, schnorrSecp256k1Prop) @@ -874,6 +876,46 @@ test_Conversion = ] ] +-- Tests that the logical builtins are behaving correctly +test_Logical :: TestTree +test_Logical = + adjustOption (\x -> max x . HedgehogTestLimit . Just $ 4000) . + testGroup "Logical" $ [ + testGroup "bitwiseLogicalAnd" [ + Laws.abelianSemigroupLaws "truncation" PLC.BitwiseLogicalAnd False, + Laws.idempotenceLaw "truncation" PLC.BitwiseLogicalAnd False, + Laws.absorbtionLaw "truncation" PLC.BitwiseLogicalAnd False "", + Laws.leftDistributiveLaw "truncation" "itself" PLC.BitwiseLogicalAnd PLC.BitwiseLogicalAnd False, + Laws.leftDistributiveLaw "truncation" "OR" PLC.BitwiseLogicalAnd PLC.BitwiseLogicalOr False, + Laws.leftDistributiveLaw "truncation" "XOR" PLC.BitwiseLogicalAnd PLC.BitwiseLogicalXor False, + Laws.abelianMonoidLaws "padding" PLC.BitwiseLogicalAnd True "", + Laws.distributiveLaws "padding" PLC.BitwiseLogicalAnd True + ], + testGroup "bitwiseLogicalOr" [ + Laws.abelianSemigroupLaws "truncation" PLC.BitwiseLogicalOr False, + Laws.idempotenceLaw "truncation" PLC.BitwiseLogicalOr False, + Laws.absorbtionLaw "truncation" PLC.BitwiseLogicalOr False "", + Laws.leftDistributiveLaw "truncation" "itself" PLC.BitwiseLogicalOr PLC.BitwiseLogicalOr False, + Laws.leftDistributiveLaw "truncation" "AND" PLC.BitwiseLogicalOr PLC.BitwiseLogicalAnd False, + Laws.abelianMonoidLaws "padding" PLC.BitwiseLogicalOr True "", + Laws.distributiveLaws "padding" PLC.BitwiseLogicalOr True + ], + testGroup "bitwiseLogicalXor" [ + Laws.abelianSemigroupLaws "truncation" PLC.BitwiseLogicalXor False, + Laws.absorbtionLaw "truncation" PLC.BitwiseLogicalXor False "", + Laws.xorInvoluteLaw, + Laws.abelianMonoidLaws "padding" PLC.BitwiseLogicalXor True "" + ] + {- + testGroup "bitwiseLogicalComplement" [ + Laws.complementSelfInverse, + Laws.deMorgan + ], + testGroup "bit reading and modification" _, + testGroup "byteStringReplicate" _ + -} + ] + test_definition :: TestTree test_definition = testGroup "definition" @@ -909,4 +951,5 @@ test_definition = , test_Version , test_ConsByteString , test_Conversion + , test_Logical ] diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs new file mode 100644 index 00000000000..09315638e02 --- /dev/null +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Evaluation.Builtins.Laws ( + abelianSemigroupLaws, + abelianMonoidLaws, + idempotenceLaw, + absorbtionLaw, + leftDistributiveLaw, + distributiveLaws, + xorInvoluteLaw + ) where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Evaluation.Builtins.Common (typecheckEvaluateCek) +import GHC.Exts (fromString) +import Hedgehog (Property, PropertyT, annotateShow, failure, forAllWith, property, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Numeric (showHex) +import PlutusCore qualified as PLC +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModel) +import PlutusCore.MkPlc (builtin, mkConstant, mkIterAppNoAnn) +import PlutusPrelude (Word8, def) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Hedgehog (testPropertyNamed) +import UntypedPlutusCore qualified as UPLC + +xorInvoluteLaw :: TestTree +xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" . property $ do + bs <- forAllByteString + semantics <- forAllWith showSemantics Gen.bool + let lhsInner = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalXor) [ + mkConstant @Bool () semantics, + mkConstant @ByteString () bs, + mkConstant @ByteString () bs + ] + let lhs = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalXor) [ + mkConstant @Bool () semantics, + mkConstant @ByteString () bs, + lhsInner + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () bs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + where + showSemantics :: Bool -> String + showSemantics b = if b + then "padding semantics" + else "truncation semantics" + +leftDistributiveLaw :: String -> String -> UPLC.DefaultFun -> UPLC.DefaultFun -> Bool -> TestTree +leftDistributiveLaw name distOpName f distOp isPadding = + testPropertyNamed ("left distribution (" <> name <> ") over " <> distOpName) + ("left_distribution_" <> fromString name <> "_" <> fromString distOpName) + (leftDistProp f distOp isPadding) + +distributiveLaws :: String -> UPLC.DefaultFun -> Bool -> TestTree +distributiveLaws name f isPadding = + testGroup ("distributivity over itself (" <> name <> ")") [ + testPropertyNamed "left distribution" "left_distribution" (leftDistProp f f isPadding), + testPropertyNamed "right distribution" "right_distribution" (rightDistProp f isPadding) + ] + +abelianSemigroupLaws :: String -> UPLC.DefaultFun -> Bool -> TestTree +abelianSemigroupLaws name f isPadding = + testGroup ("abelian semigroup (" <> name <> ")") [ + testPropertyNamed "commutativity" "commutativity" (commProp f isPadding), + testPropertyNamed "associativity" "associativity" (assocProp f isPadding) + ] + +abelianMonoidLaws :: String -> UPLC.DefaultFun -> Bool -> ByteString -> TestTree +abelianMonoidLaws name f isPadding unit = + testGroup ("abelian monoid (" <> name <> ")") [ + testPropertyNamed "commutativity" "commutativity" (commProp f isPadding), + testPropertyNamed "associativity" "associativity" (assocProp f isPadding), + testPropertyNamed "unit" "unit" (unitProp f isPadding unit) + ] + +idempotenceLaw :: String -> UPLC.DefaultFun -> Bool -> TestTree +idempotenceLaw name f isPadding = + testPropertyNamed ("idempotence (" <> name <> ")") + ("idempotence_" <> fromString name) + idempProp + where + idempProp :: Property + idempProp = property $ do + bs <- forAllByteString + let lhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () bs, + mkConstant @ByteString () bs + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () bs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +absorbtionLaw :: String -> UPLC.DefaultFun -> Bool -> ByteString -> TestTree +absorbtionLaw name f isPadding absorber = + testPropertyNamed ("absorbing element (" <> name <> ")") + ("absorbing_element_" <> fromString name) + absorbProp + where + absorbProp :: Property + absorbProp = property $ do + bs <- forAllByteString + let lhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () bs, + mkConstant @ByteString () absorber + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + mkConstant @ByteString () absorber, + lhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +-- Helpers + +leftDistProp :: UPLC.DefaultFun -> UPLC.DefaultFun -> Bool -> Property +leftDistProp f distOp isPadding = property $ do + x <- forAllByteString + y <- forAllByteString + z <- forAllByteString + let distLhs = mkIterAppNoAnn (builtin () distOp) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () y, + mkConstant @ByteString () z + ] + let lhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () x, + distLhs + ] + let distRhs1 = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () x, + mkConstant @ByteString () y + ] + let distRhs2 = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () x, + mkConstant @ByteString () z + ] + let rhs = mkIterAppNoAnn (builtin () distOp) [ + mkConstant @Bool () isPadding, + distRhs1, + distRhs2 + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +rightDistProp :: UPLC.DefaultFun -> Bool -> Property +rightDistProp f isPadding = property $ do + x <- forAllByteString + y <- forAllByteString + z <- forAllByteString + let lhsInner = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () x, + mkConstant @ByteString () y + ] + let lhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + lhsInner, + mkConstant @ByteString () z + ] + let rhsInner1 = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () x, + mkConstant @ByteString () z + ] + let rhsInner2 = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () y, + mkConstant @ByteString () z + ] + let rhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + rhsInner1, + rhsInner2 + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +commProp :: UPLC.DefaultFun -> Bool -> Property +commProp f isPadding = property $ do + data1 <- forAllByteString + data2 <- forAllByteString + let lhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () data1, + mkConstant @ByteString () data2 + ] + let rhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () data2, + mkConstant @ByteString () data1 + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +assocProp :: UPLC.DefaultFun -> Bool -> Property +assocProp f isPadding = property $ do + data1 <- forAllByteString + data2 <- forAllByteString + data3 <- forAllByteString + let data12 = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () data1, + mkConstant @ByteString () data2 + ] + let lhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + data12, + mkConstant @ByteString () data3 + ] + let data23 = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () data2, + mkConstant @ByteString () data3 + ] + let rhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () data1, + data23 + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +unitProp :: UPLC.DefaultFun -> Bool -> ByteString -> Property +unitProp f isPadding unit = property $ do + bs <- forAllByteString + let lhs = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () isPadding, + mkConstant @ByteString () bs, + mkConstant @ByteString () unit + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () bs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +forAllByteString :: PropertyT IO ByteString +forAllByteString = forAllWith hexShow . Gen.bytes . Range.linear 0 $ 1024 + +hexShow :: ByteString -> String +hexShow = ("0x" <>) . BS.foldl' (\acc w8 -> acc <> byteToHex w8) "" + where + byteToHex :: Word8 -> String + byteToHex w8 + | w8 < 128 = "0" <> showHex w8 "" + | otherwise = showHex w8 "" + +evaluateAndVerify :: + UPLC.Term UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> + PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> + PropertyT IO () +evaluateAndVerify expected actual = + case typecheckEvaluateCek def defaultBuiltinCostModel actual of + Left x -> annotateShow x >> failure + Right (res, logs) -> case res of + PLC.EvaluationFailure -> annotateShow logs >> failure + PLC.EvaluationSuccess r -> r === expected + From 5bc7e1e4ed4856e763001032df71b866af87f0e6 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 9 May 2024 13:42:57 +1200 Subject: [PATCH 04/16] Rest of tests --- .../src/PlutusCore/Bitwise/Logical.hs | 4 +- .../test/Evaluation/Builtins/Definition.hs | 16 +- .../test/Evaluation/Builtins/Laws.hs | 260 +++++++++++++++++- 3 files changed, 265 insertions(+), 15 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs index 8c57cd23c7a..d399984c858 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs @@ -218,7 +218,7 @@ readBit bs ix emit "readBit: index out of bounds" emit $ "Index: " <> (pack . show $ ix) evaluationFailure - | ix >= (len * 8) - 1 = do + | ix >= len * 8 = do emit "readBit: index out of bounds" emit $ "Index: " <> (pack . show $ ix) evaluationFailure @@ -255,7 +255,7 @@ writeBits bs changelist = case unsafeDupablePerformIO . try $ go of setAtIx :: Ptr Word8 -> (Integer, Bool) -> IO () setAtIx ptr (i, b) | i < 0 = throw $ WriteBitsException i - | i >= bitLen - 1 = throw $ WriteBitsException i + | i >= bitLen = throw $ WriteBitsException i | otherwise = do let (bigIx, littleIx) = i `quotRem` 8 let flipIx = len - fromIntegral bigIx - 1 diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index a0e0caa705a..1b923a32618 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -905,15 +905,21 @@ test_Logical = Laws.absorbtionLaw "truncation" PLC.BitwiseLogicalXor False "", Laws.xorInvoluteLaw, Laws.abelianMonoidLaws "padding" PLC.BitwiseLogicalXor True "" - ] - {- + ], testGroup "bitwiseLogicalComplement" [ Laws.complementSelfInverse, Laws.deMorgan ], - testGroup "bit reading and modification" _, - testGroup "byteStringReplicate" _ - -} + testGroup "bit reading and modification" [ + Laws.getSet, + Laws.setGet, + Laws.setSet, + Laws.writeBitsHomomorphismLaws + ], + testGroup "byteStringReplicate" [ + Laws.replicateHomomorphismLaws, + Laws.replicateIndex + ] ] test_definition :: TestTree diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs index 09315638e02..cbaa7bb6d61 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs @@ -1,3 +1,4 @@ +-- editorconfig-checker-disable-file {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -8,14 +9,23 @@ module Evaluation.Builtins.Laws ( absorbtionLaw, leftDistributiveLaw, distributiveLaws, - xorInvoluteLaw + xorInvoluteLaw, + complementSelfInverse, + deMorgan, + getSet, + setGet, + setSet, + writeBitsHomomorphismLaws, + replicateHomomorphismLaws, + replicateIndex ) where import Data.ByteString (ByteString) import Data.ByteString qualified as BS -import Evaluation.Builtins.Common (typecheckEvaluateCek) +import Evaluation.Builtins.Common (typecheckEvaluateCek, typecheckReadKnownCek) import GHC.Exts (fromString) -import Hedgehog (Property, PropertyT, annotateShow, failure, forAllWith, property, (===)) +import Hedgehog (Gen, Property, PropertyT, annotateShow, failure, forAll, forAllWith, property, + (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Numeric (showHex) @@ -27,6 +37,225 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testPropertyNamed) import UntypedPlutusCore qualified as UPLC +replicateIndex :: TestTree +replicateIndex = testPropertyNamed "every byte is the same" "replicate_all_match" . property $ do + n <- forAll . Gen.integral . Range.linear 1 $ 1024 + b <- forAll . Gen.integral . Range.constant 0 $ 255 + i <- forAll . Gen.integral . Range.linear 0 $ n - 1 + let lhsInner = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + mkConstant @Integer () n, + mkConstant @Integer () b + ] + let lhs = mkIterAppNoAnn (builtin () PLC.IndexByteString) [ + lhsInner, + mkConstant @Integer () i + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsInteger) [ + lhs, + mkConstant @Integer () b + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +getSet :: TestTree +getSet = + testPropertyNamed "get-set" "get_set" . property $ do + bs <- forAllByteString1 + i <- forAllIndexOf bs + let lookupExp = mkIterAppNoAnn (builtin () PLC.ReadBit) [ + mkConstant @ByteString () bs, + mkConstant @Integer () i + ] + case typecheckReadKnownCek def defaultBuiltinCostModel lookupExp of + Left err -> annotateShow err >> failure + Right (Left err) -> annotateShow err >> failure + Right (Right b) -> do + let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ + mkConstant @ByteString () bs, + mkConstant @[(Integer, Bool)] () [(i, b)] + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () bs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +setGet :: TestTree +setGet = + testPropertyNamed "set-get" "set_get" . property $ do + bs <- forAllByteString1 + i <- forAllIndexOf bs + b <- forAll Gen.bool + let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [ + mkConstant @ByteString () bs, + mkConstant @[(Integer, Bool)] () [(i, b)] + ] + let lhs = mkIterAppNoAnn (builtin () PLC.ReadBit) [ + lhsInner, + mkConstant @Integer () i + ] + evaluateAndVerify (mkConstant @Bool () b) lhs + +setSet :: TestTree +setSet = + testPropertyNamed "set-set" "set_set" . property $ do + bs <- forAllByteString1 + i <- forAllIndexOf bs + b1 <- forAll Gen.bool + b2 <- forAll Gen.bool + let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ + mkConstant @ByteString () bs, + mkConstant @[(Integer, Bool)] () [(i, b1), (i, b2)] + ] + let rhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ + mkConstant @ByteString () bs, + mkConstant @[(Integer, Bool)] () [(i, b2)] + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +writeBitsHomomorphismLaws :: TestTree +writeBitsHomomorphismLaws = + testGroup "homomorphism to lists" [ + testPropertyNamed "identity -> []" "write_bits_h_1" identityProp, + testPropertyNamed "composition -> concatenation" "write_bits_h_2" compositionProp + ] + where + identityProp :: Property + identityProp = property $ do + bs <- forAllByteString1 + let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ + mkConstant @ByteString () bs, + mkConstant @[(Integer, Bool)] () [] + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () bs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + compositionProp :: Property + compositionProp = property $ do + bs <- forAllByteString1 + changelist1 <- forAllChangelistOf bs + changelist2 <- forAllChangelistOf bs + let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [ + mkConstant @ByteString () bs, + mkConstant @[(Integer, Bool)] () changelist1 + ] + let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ + lhsInner, + mkConstant @[(Integer, Bool)] () changelist2 + ] + let rhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [ + mkConstant @ByteString () bs, + mkConstant @[(Integer, Bool)] () (changelist1 <> changelist2) + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +replicateHomomorphismLaws :: TestTree +replicateHomomorphismLaws = + testGroup "homomorphism" [ + testPropertyNamed "0 -> empty" "replicate_h_1" identityProp, + testPropertyNamed "+ -> concat" "replicate_h_2" compositionProp + ] + where + identityProp :: Property + identityProp = property $ do + b <- forAll . Gen.integral . Range.constant 0 $ 255 + let lhs = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + mkConstant @Integer () 0, + mkConstant @Integer () b + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () "" + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + compositionProp :: Property + compositionProp = property $ do + b <- forAll . Gen.integral . Range.constant 0 $ 255 + n1 <- forAll . Gen.integral . Range.linear 0 $ 512 + n2 <- forAll . Gen.integral . Range.linear 0 $ 512 + let lhsInner1 = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + mkConstant @Integer () n1, + mkConstant @Integer () b + ] + let lhsInner2 = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + mkConstant @Integer () n2, + mkConstant @Integer () b + ] + let lhs = mkIterAppNoAnn (builtin () PLC.AppendByteString) [ + lhsInner1, + lhsInner2 + ] + let rhs = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + mkConstant @Integer () (n1 + n2), + mkConstant @Integer () b + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +complementSelfInverse :: TestTree +complementSelfInverse = + testPropertyNamed "self-inverse" "self_inverse" . property $ do + bs <- forAllByteString + let lhsInner = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + mkConstant @ByteString () bs + ] + let lhs = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + lhsInner + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () bs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +deMorgan :: TestTree +deMorgan = testGroup "De Morgan's laws" [ + testPropertyNamed "NOT AND -> OR" "demorgan_and" . go PLC.BitwiseLogicalAnd $ PLC.BitwiseLogicalOr, + testPropertyNamed "NOT OR -> AND" "demorgan_or" . go PLC.BitwiseLogicalOr $ PLC.BitwiseLogicalAnd + ] + where + go :: UPLC.DefaultFun -> UPLC.DefaultFun -> Property + go f g = property $ do + semantics <- forAllWith showSemantics Gen.bool + bs1 <- forAllByteString + bs2 <- forAllByteString + let lhsInner = mkIterAppNoAnn (builtin () f) [ + mkConstant @Bool () semantics, + mkConstant @ByteString () bs1, + mkConstant @ByteString () bs2 + ] + let lhs = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + lhsInner + ] + let rhsInner1 = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + mkConstant @ByteString () bs1 + ] + let rhsInner2 = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + mkConstant @ByteString () bs2 + ] + let rhs = mkIterAppNoAnn (builtin () g) [ + mkConstant @Bool () semantics, + rhsInner1, + rhsInner2 + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + xorInvoluteLaw :: TestTree xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" . property $ do bs <- forAllByteString @@ -46,11 +275,6 @@ xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" . property mkConstant @ByteString () bs ] evaluateAndVerify (mkConstant @Bool () True) compareExp - where - showSemantics :: Bool -> String - showSemantics b = if b - then "padding semantics" - else "truncation semantics" leftDistributiveLaw :: String -> String -> UPLC.DefaultFun -> UPLC.DefaultFun -> Bool -> TestTree leftDistributiveLaw name distOpName f distOp isPadding = @@ -122,6 +346,11 @@ absorbtionLaw name f isPadding absorber = -- Helpers +showSemantics :: Bool -> String +showSemantics b = if b + then "padding semantics" + else "truncation semantics" + leftDistProp :: UPLC.DefaultFun -> UPLC.DefaultFun -> Bool -> Property leftDistProp f distOp isPadding = property $ do x <- forAllByteString @@ -262,6 +491,21 @@ unitProp f isPadding unit = property $ do forAllByteString :: PropertyT IO ByteString forAllByteString = forAllWith hexShow . Gen.bytes . Range.linear 0 $ 1024 +forAllByteString1 :: PropertyT IO ByteString +forAllByteString1 = forAllWith hexShow . Gen.bytes . Range.linear 1 $ 1024 + +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 + where + len :: Int + len = BS.length bs + genIndex :: Gen Integer + genIndex = Gen.integral . Range.linear 0 . fromIntegral $ len * 8 - 1 + hexShow :: ByteString -> String hexShow = ("0x" <>) . BS.foldl' (\acc w8 -> acc <> byteToHex w8) "" where From 76b6fc5ee83b3655fc5f5718018df28c00aa0beb Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 10 May 2024 09:51:12 +1200 Subject: [PATCH 05/16] Formatting of denotations --- .../src/PlutusCore/Default/Builtins.hs | 88 ++++++++++--------- 1 file changed, 48 insertions(+), 40 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 8acdac375ec..f348193975d 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1814,68 +1814,76 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where -- Conversions {- See Note [Input length limitation for IntegerToByteString] -} toBuiltinMeaning _semvar IntegerToByteString = - let integerToByteStringDenotation :: Bool -> LiteralByteSize -> Integer -> BuiltinResult BS.ByteString - {- The second argument is wrapped in a LiteralByteSize to allow us to interpret it as a size during - costing. It appears as an integer in UPLC: see Note [Integral types as Integer]. -} - integerToByteStringDenotation b (LiteralByteSize w) n = integerToByteStringWrapper b w n - {-# INLINE integerToByteStringDenotation #-} - in makeBuiltinMeaning - integerToByteStringDenotation - (runCostingFunThreeArguments . paramIntegerToByteString) + let integerToByteStringDenotation :: Bool -> LiteralByteSize -> Integer -> BuiltinResult BS.ByteString + {- The second argument is wrapped in a LiteralByteSize to allow us to interpret it as a size during + costing. It appears as an integer in UPLC: see Note [Integral types as Integer]. -} + integerToByteStringDenotation b (LiteralByteSize w) n = integerToByteStringWrapper b w n + {-# INLINE integerToByteStringDenotation #-} + in makeBuiltinMeaning + integerToByteStringDenotation + (runCostingFunThreeArguments . paramIntegerToByteString) + toBuiltinMeaning _semvar ByteStringToInteger = - let byteStringToIntegerDenotation :: Bool -> BS.ByteString -> Integer - byteStringToIntegerDenotation = byteStringToIntegerWrapper - {-# INLINE byteStringToIntegerDenotation #-} + let byteStringToIntegerDenotation :: Bool -> BS.ByteString -> Integer + byteStringToIntegerDenotation = byteStringToIntegerWrapper + {-# INLINE byteStringToIntegerDenotation #-} in makeBuiltinMeaning byteStringToIntegerDenotation (runCostingFunTwoArguments . paramByteStringToInteger) + -- Logical toBuiltinMeaning _semvar BitwiseLogicalAnd = - let bitwiseLogicalAndDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - bitwiseLogicalAndDenotation = Logical.bitwiseLogicalAnd - {-# INLINE bitwiseLogicalAndDenotation #-} + let bitwiseLogicalAndDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + bitwiseLogicalAndDenotation = Logical.bitwiseLogicalAnd + {-# INLINE bitwiseLogicalAndDenotation #-} in makeBuiltinMeaning bitwiseLogicalAndDenotation (runCostingFunThreeArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar BitwiseLogicalOr = - let bitwiseLogicalOrDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - bitwiseLogicalOrDenotation = Logical.bitwiseLogicalOr - {-# INLINE bitwiseLogicalOrDenotation #-} + let bitwiseLogicalOrDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + bitwiseLogicalOrDenotation = Logical.bitwiseLogicalOr + {-# INLINE bitwiseLogicalOrDenotation #-} in makeBuiltinMeaning - bitwiseLogicalOrDenotation - (runCostingFunThreeArguments . unimplementedCostingFun) + bitwiseLogicalOrDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar BitwiseLogicalXor = - let bitwiseLogicalXorDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - bitwiseLogicalXorDenotation = Logical.bitwiseLogicalXor - {-# INLINE bitwiseLogicalXorDenotation #-} + let bitwiseLogicalXorDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + bitwiseLogicalXorDenotation = Logical.bitwiseLogicalXor + {-# INLINE bitwiseLogicalXorDenotation #-} in makeBuiltinMeaning - bitwiseLogicalXorDenotation - (runCostingFunThreeArguments . unimplementedCostingFun) + bitwiseLogicalXorDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar BitwiseLogicalComplement = - let bitwiseLogicalComplementDenotation :: BS.ByteString -> BS.ByteString - bitwiseLogicalComplementDenotation = Logical.bitwiseLogicalComplement - {-# INLINE bitwiseLogicalComplementDenotation #-} + let bitwiseLogicalComplementDenotation :: BS.ByteString -> BS.ByteString + bitwiseLogicalComplementDenotation = Logical.bitwiseLogicalComplement + {-# INLINE bitwiseLogicalComplementDenotation #-} in makeBuiltinMeaning - bitwiseLogicalComplementDenotation - (runCostingFunOneArgument . unimplementedCostingFun) + bitwiseLogicalComplementDenotation + (runCostingFunOneArgument . unimplementedCostingFun) + toBuiltinMeaning _semvar ReadBit = - let readBitDenotation :: BS.ByteString -> Int -> BuiltinResult Bool - readBitDenotation = Logical.readBit - {-# INLINE readBitDenotation #-} + let readBitDenotation :: BS.ByteString -> Int -> BuiltinResult Bool + readBitDenotation = Logical.readBit + {-# INLINE readBitDenotation #-} in makeBuiltinMeaning - readBitDenotation - (runCostingFunTwoArguments . unimplementedCostingFun) + readBitDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar WriteBits = - let writeBitsDenotation :: BS.ByteString -> [(Integer, Bool)] -> BuiltinResult BS.ByteString - writeBitsDenotation = Logical.writeBits - {-# INLINE writeBitsDenotation #-} + let writeBitsDenotation :: BS.ByteString -> [(Integer, Bool)] -> BuiltinResult BS.ByteString + writeBitsDenotation = Logical.writeBits + {-# INLINE writeBitsDenotation #-} in makeBuiltinMeaning writeBitsDenotation (runCostingFunTwoArguments . unimplementedCostingFun) + toBuiltinMeaning _semvar ByteStringReplicate = - let byteStringReplicateDenotation :: Int -> Word8 -> BuiltinResult BS.ByteString - byteStringReplicateDenotation = Logical.byteStringReplicate - {-# INLINE byteStringReplicateDenotation #-} + let byteStringReplicateDenotation :: Int -> Word8 -> BuiltinResult BS.ByteString + byteStringReplicateDenotation = Logical.byteStringReplicate + {-# INLINE byteStringReplicateDenotation #-} in makeBuiltinMeaning byteStringReplicateDenotation (runCostingFunTwoArguments . unimplementedCostingFun) From 7b0b7f65cfacbd9fb08c9cdfecfb973a7792eac3 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 10 May 2024 10:05:38 +1200 Subject: [PATCH 06/16] Rename byteStringReplicate to replicateByteString --- .../plutus-core/src/PlutusCore/Bitwise/Logical.hs | 6 +++--- .../plutus-core/src/PlutusCore/Default/Builtins.hs | 10 +++++----- .../test/Evaluation/Builtins/Definition.hs | 2 +- .../test/Evaluation/Builtins/Laws.hs | 10 +++++----- plutus-tx/src/PlutusTx/Builtins/Internal.hs | 2 +- 5 files changed, 15 insertions(+), 15 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs index d399984c858..c2c8a035c47 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs @@ -10,7 +10,7 @@ module PlutusCore.Bitwise.Logical ( bitwiseLogicalComplement, readBit, writeBits, - byteStringReplicate, + replicateByteString ) where import Control.Exception (Exception, throw, try) @@ -267,8 +267,8 @@ writeBits bs changelist = case unsafeDupablePerformIO . try $ go of -- | Byte replication, as per [the relevant -- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md) -byteStringReplicate :: Int -> Word8 -> BuiltinResult ByteString -byteStringReplicate len w8 +replicateByteString :: Int -> Word8 -> BuiltinResult ByteString +replicateByteString len w8 | len < 0 = do emit "byteStringReplicate: negative length requested" evaluationFailure diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index f348193975d..0eb19d9d45e 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -160,7 +160,7 @@ data DefaultFun | BitwiseLogicalComplement | ReadBit | WriteBits - | ByteStringReplicate + | ReplicateByteString deriving stock (Show, Eq, Ord, Enum, Bounded, Generic, Ix) deriving anyclass (NFData, Hashable, PrettyBy PrettyConfigPlc) @@ -1880,9 +1880,9 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where writeBitsDenotation (runCostingFunTwoArguments . unimplementedCostingFun) - toBuiltinMeaning _semvar ByteStringReplicate = + toBuiltinMeaning _semvar ReplicateByteString = let byteStringReplicateDenotation :: Int -> Word8 -> BuiltinResult BS.ByteString - byteStringReplicateDenotation = Logical.byteStringReplicate + byteStringReplicateDenotation = Logical.replicateByteString {-# INLINE byteStringReplicateDenotation #-} in makeBuiltinMeaning byteStringReplicateDenotation @@ -2021,7 +2021,7 @@ instance Flat DefaultFun where BitwiseLogicalComplement -> 78 ReadBit -> 79 WriteBits -> 80 - ByteStringReplicate -> 81 + ReplicateByteString -> 81 decode = go =<< decodeBuiltin where go 0 = pure AddInteger @@ -2105,7 +2105,7 @@ instance Flat DefaultFun where go 78 = pure BitwiseLogicalComplement go 79 = pure ReadBit go 80 = pure WriteBits - go 81 = pure ByteStringReplicate + go 81 = pure ReplicateByteString go t = fail $ "Failed to decode builtin tag, got: " ++ show t size _ n = n + builtinTagWidth diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index 1b923a32618..2ae0307a206 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -916,7 +916,7 @@ test_Logical = Laws.setSet, Laws.writeBitsHomomorphismLaws ], - testGroup "byteStringReplicate" [ + testGroup "replicateByteString" [ Laws.replicateHomomorphismLaws, Laws.replicateIndex ] diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs index cbaa7bb6d61..7e50445bb7c 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs @@ -42,7 +42,7 @@ replicateIndex = testPropertyNamed "every byte is the same" "replicate_all_match n <- forAll . Gen.integral . Range.linear 1 $ 1024 b <- forAll . Gen.integral . Range.constant 0 $ 255 i <- forAll . Gen.integral . Range.linear 0 $ n - 1 - let lhsInner = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + let lhsInner = mkIterAppNoAnn (builtin () PLC.ReplicateByteString) [ mkConstant @Integer () n, mkConstant @Integer () b ] @@ -168,7 +168,7 @@ replicateHomomorphismLaws = identityProp :: Property identityProp = property $ do b <- forAll . Gen.integral . Range.constant 0 $ 255 - let lhs = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + let lhs = mkIterAppNoAnn (builtin () PLC.ReplicateByteString) [ mkConstant @Integer () 0, mkConstant @Integer () b ] @@ -182,11 +182,11 @@ replicateHomomorphismLaws = b <- forAll . Gen.integral . Range.constant 0 $ 255 n1 <- forAll . Gen.integral . Range.linear 0 $ 512 n2 <- forAll . Gen.integral . Range.linear 0 $ 512 - let lhsInner1 = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + let lhsInner1 = mkIterAppNoAnn (builtin () PLC.ReplicateByteString) [ mkConstant @Integer () n1, mkConstant @Integer () b ] - let lhsInner2 = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + let lhsInner2 = mkIterAppNoAnn (builtin () PLC.ReplicateByteString) [ mkConstant @Integer () n2, mkConstant @Integer () b ] @@ -194,7 +194,7 @@ replicateHomomorphismLaws = lhsInner1, lhsInner2 ] - let rhs = mkIterAppNoAnn (builtin () PLC.ByteStringReplicate) [ + let rhs = mkIterAppNoAnn (builtin () PLC.ReplicateByteString) [ mkConstant @Integer () (n1 + n2), mkConstant @Integer () b ] diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index ab6d428a06c..12994a211f8 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -777,7 +777,7 @@ byteStringReplicate :: BuiltinInteger -> BuiltinByteString byteStringReplicate n w8 = - case Logical.byteStringReplicate (fromIntegral n) (fromIntegral w8) of + case Logical.replicateByteString (fromIntegral n) (fromIntegral w8) of BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ Haskell.error "byteStringReplicate errored." BuiltinSuccess bs -> BuiltinByteString bs From b32e3d310bed5b03b4307120020111297583587e Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 10 May 2024 10:45:26 +1200 Subject: [PATCH 07/16] Correct references to CIP-121 --- plutus-core/plutus-core/src/PlutusCore/Bitwise/Convert.hs | 4 ++-- .../test/Evaluation/Builtins/Conversion.hs | 7 +++---- .../test/Evaluation/Builtins/Definition.hs | 4 ++-- plutus-tx/src/PlutusTx/Builtins.hs | 6 ++---- 4 files changed, 9 insertions(+), 12 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Convert.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Convert.hs index 1365cbb798e..bd6ccd317eb 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Convert.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Convert.hs @@ -118,7 +118,7 @@ data IntegerToByteStringError = deriving stock (Eq, Show) -- | Conversion from 'Integer' to 'ByteString', as per --- [CIP-0087](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-XXXX). +-- [CIP-121](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-0121). -- -- For performance and clarity, the endianness argument uses -- 'ByteOrder', and the length argument is an 'Int'. @@ -232,7 +232,7 @@ integerToByteString requestedByteOrder requestedLength input Builder.bytes (BS.replicate paddingLength 0x0) <> acc -- | Conversion from 'ByteString' to 'Integer', as per --- [CIP-0087](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-XXXX). +-- [CIP-121](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-0121). -- -- For clarity, the stated endianness argument uses 'ByteOrder'. byteStringToInteger :: ByteOrder -> ByteString -> Integer diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Conversion.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Conversion.hs index b3bd8777a5d..ebf400278c4 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Conversion.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Conversion.hs @@ -36,11 +36,10 @@ import Test.Tasty (TestTree) import Test.Tasty.HUnit (assertEqual, assertFailure, testCase) import Text.Show.Pretty (ppShow) --- Properties and examples directly from CIP-0087: +-- Properties and examples directly from CIP-121: -- --- - https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-XXXX#builtinintegertobytestring --- - https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-XXXX#builtinbytestringtointeger - +-- - https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-0121#builtinintegertobytestring +-- - https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-0121#builtinbytestringtointeger -- lengthOfByteString (integerToByteString e d 0) = d i2bProperty1 :: PropertyT IO () diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index 2ae0307a206..2098f745f84 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -862,7 +862,7 @@ test_Conversion = -- appendByteString (integerToByteString False 0 q) -- (integerToByteString False 0 r) testPropertyNamed "property 7" "i2b_prop7" . property $ Conversion.i2bProperty7, - testGroup "CIP-0087 examples" Conversion.i2bCipExamples, + testGroup "CIP-121 examples" Conversion.i2bCipExamples, testGroup "Tests for integerToByteString size limit" Conversion.i2bLimitTests ], testGroup "ByteString -> Integer" [ @@ -872,7 +872,7 @@ test_Conversion = testPropertyNamed "property 2" "b2i_prop2" . property $ Conversion.b2iProperty2, -- integerToByteString b (lengthOfByteString bs) (byteStringToInteger b bs) = bs testPropertyNamed "property 3" "b2i_prop3" . property $ Conversion.b2iProperty3, - testGroup "CIP-0087 examples" Conversion.b2iCipExamples + testGroup "CIP-121 examples" Conversion.b2iCipExamples ] ] diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 6d3c9c59ef1..043de1af126 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -117,7 +117,6 @@ module PlutusTx.Builtins ( , byteStringReplicate ) where -import Data.Functor (fmap) import Data.Maybe import PlutusTx.Base (const, uncurry) import PlutusTx.Bool (Bool (..)) @@ -624,9 +623,8 @@ byteOrderToBool :: ByteOrder -> Bool byteOrderToBool BigEndian = True byteOrderToBool LittleEndian = False - -- | Convert a 'BuiltinInteger' into a 'BuiltinByteString', as described in --- [CIP-0087](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-XXXX). +-- [CIP-121](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-0121). -- The first argument indicates the endianness of the conversion and the third -- argument is the integer to be converted, which must be non-negative. The -- second argument must also be non-negative and it indicates the required width @@ -644,7 +642,7 @@ integerToByteString :: ByteOrder -> Integer -> Integer -> BuiltinByteString integerToByteString endianness = BI.integerToByteString (toBuiltin (byteOrderToBool endianness)) -- | Convert a 'BuiltinByteString' to a 'BuiltinInteger', as described in --- [CIP-0087](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-XXXX). +-- [CIP-121](https://github.com/mlabs-haskell/CIPs/tree/koz/to-from-bytestring/CIP-0121). -- The first argument indicates the endianness of the conversion and the second -- is the bytestring to be converted. There is no limitation on the size of -- the bytestring. The empty bytestring is converted to the integer 0. From e3f267da41ef6266c984648cc94313d08e0b160e Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 10 May 2024 11:05:32 +1200 Subject: [PATCH 08/16] Changelogs, document tests --- .../20240510_104627_koz.ross_logical.md | 39 +++++++++++++++++++ .../test/Evaluation/Builtins/Definition.hs | 2 +- .../test/Evaluation/Builtins/Laws.hs | 38 ++++++++++++++++++ .../20240510_110418_koz.ross_logical.md | 39 +++++++++++++++++++ 4 files changed, 117 insertions(+), 1 deletion(-) create mode 100644 plutus-core/changelog.d/20240510_104627_koz.ross_logical.md create mode 100644 plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md diff --git a/plutus-core/changelog.d/20240510_104627_koz.ross_logical.md b/plutus-core/changelog.d/20240510_104627_koz.ross_logical.md new file mode 100644 index 00000000000..a2232c6d197 --- /dev/null +++ b/plutus-core/changelog.d/20240510_104627_koz.ross_logical.md @@ -0,0 +1,39 @@ + + + +### Added + +- Logical operations as per [this + CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). + +### Changed + +- References to CIP-87 have been corrected to refer to CIP-121. + + + + diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index 2098f745f84..31791d534d7 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -876,7 +876,7 @@ test_Conversion = ] ] --- Tests that the logical builtins are behaving correctly +-- Tests for the logical operations, as per https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md test_Logical :: TestTree test_Logical = adjustOption (\x -> max x . HedgehogTestLimit . Just $ 4000) . diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs index 7e50445bb7c..5e07fa37d69 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs @@ -37,6 +37,8 @@ import Test.Tasty (TestTree, testGroup) import Test.Tasty.Hedgehog (testPropertyNamed) import UntypedPlutusCore qualified as UPLC +-- | Any call to 'replicateByteString' must produce the same byte at +-- every valid index, namely the byte specified. replicateIndex :: TestTree replicateIndex = testPropertyNamed "every byte is the same" "replicate_all_match" . property $ do n <- forAll . Gen.integral . Range.linear 1 $ 1024 @@ -56,6 +58,8 @@ replicateIndex = testPropertyNamed "every byte is the same" "replicate_all_match ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | If you retrieve a bit value at an index, then write that same value to +-- the same index, nothing should happen. getSet :: TestTree getSet = testPropertyNamed "get-set" "get_set" . property $ do @@ -79,6 +83,8 @@ getSet = ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | If you write a bit value to an index, then retrieve the bit value at the +-- same index, you should get back what you wrote. setGet :: TestTree setGet = testPropertyNamed "set-get" "set_get" . property $ do @@ -95,6 +101,7 @@ setGet = ] evaluateAndVerify (mkConstant @Bool () b) lhs +-- | If you write twice to the same bit index, the second write should win. setSet :: TestTree setSet = testPropertyNamed "set-set" "set_set" . property $ do @@ -116,6 +123,11 @@ setSet = ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | Checks that: +-- +-- * Writing with an empty changelist does nothing; and +-- * If you write with one changelist, then a second, it is the same as +-- writing with their concatenation. writeBitsHomomorphismLaws :: TestTree writeBitsHomomorphismLaws = testGroup "homomorphism to lists" [ @@ -158,6 +170,12 @@ writeBitsHomomorphismLaws = ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | Checks that: +-- +-- * Replicating any byte 0 times produces the empty 'ByteString'; and +-- * Replicating a byte @n@ times, then replicating a byte @m@ times and +-- concatenating the results, is the same as replicating that byte @n + m@ +-- times. replicateHomomorphismLaws :: TestTree replicateHomomorphismLaws = testGroup "homomorphism" [ @@ -204,6 +222,7 @@ replicateHomomorphismLaws = ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | If you complement a 'ByteString' twice, nothing should change. complementSelfInverse :: TestTree complementSelfInverse = testPropertyNamed "self-inverse" "self_inverse" . property $ do @@ -220,6 +239,10 @@ complementSelfInverse = ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | Checks that: +-- +-- * The complement of an AND is an OR of complements; and +-- * The complement of an OR is an AND of complements. deMorgan :: TestTree deMorgan = testGroup "De Morgan's laws" [ testPropertyNamed "NOT AND -> OR" "demorgan_and" . go PLC.BitwiseLogicalAnd $ PLC.BitwiseLogicalOr, @@ -256,6 +279,7 @@ deMorgan = testGroup "De Morgan's laws" [ ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | If you XOR any 'ByteString' with itself twice, nothing should change. xorInvoluteLaw :: TestTree xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" . property $ do bs <- forAllByteString @@ -276,12 +300,16 @@ xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" . property ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | Checks that the first 'DefaultFun' distributes over the second from the +-- left, given the specified semantics (as a 'Bool'). More precisely, for +-- 'DefaultFun's @f@ and @g@, checks that @f x (g y z) = g (f x y) (f x z)@. leftDistributiveLaw :: String -> String -> UPLC.DefaultFun -> UPLC.DefaultFun -> Bool -> TestTree leftDistributiveLaw name distOpName f distOp isPadding = testPropertyNamed ("left distribution (" <> name <> ") over " <> distOpName) ("left_distribution_" <> fromString name <> "_" <> fromString distOpName) (leftDistProp f distOp isPadding) +-- | Checks that the given function self-distributes both left and right. distributiveLaws :: String -> UPLC.DefaultFun -> Bool -> TestTree distributiveLaws name f isPadding = testGroup ("distributivity over itself (" <> name <> ")") [ @@ -289,6 +317,8 @@ distributiveLaws name f isPadding = testPropertyNamed "right distribution" "right_distribution" (rightDistProp f isPadding) ] +-- | Checks that the given 'DefaultFun', under the given semantics, forms an +-- abelian semigroup: that is, the operation both commutes and associates. abelianSemigroupLaws :: String -> UPLC.DefaultFun -> Bool -> TestTree abelianSemigroupLaws name f isPadding = testGroup ("abelian semigroup (" <> name <> ")") [ @@ -296,6 +326,8 @@ abelianSemigroupLaws name f isPadding = testPropertyNamed "associativity" "associativity" (assocProp f isPadding) ] +-- | As 'abelianSemigroupLaws', but also checks that the provided 'ByteString' +-- is both a left and right identity. abelianMonoidLaws :: String -> UPLC.DefaultFun -> Bool -> ByteString -> TestTree abelianMonoidLaws name f isPadding unit = testGroup ("abelian monoid (" <> name <> ")") [ @@ -304,6 +336,8 @@ abelianMonoidLaws name f isPadding unit = testPropertyNamed "unit" "unit" (unitProp f isPadding unit) ] +-- | Checks that the provided 'DefaultFun', under the given semantics, is +-- idempotent; namely, that @f x x = x@ for any @x@. idempotenceLaw :: String -> UPLC.DefaultFun -> Bool -> TestTree idempotenceLaw name f isPadding = testPropertyNamed ("idempotence (" <> name <> ")") @@ -324,6 +358,10 @@ idempotenceLaw name f isPadding = ] evaluateAndVerify (mkConstant @Bool () True) compareExp +-- | Checks that the provided 'ByteString' is an absorbing element for the +-- given 'DefaultFun', under the given semantics. Specifically, given @f@ +-- as the operation and @0@ as the absorbing element, for any @x@, +-- @f x 0 = f 0 x = 0@. absorbtionLaw :: String -> UPLC.DefaultFun -> Bool -> ByteString -> TestTree absorbtionLaw name f isPadding absorber = testPropertyNamed ("absorbing element (" <> name <> ")") diff --git a/plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md b/plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md new file mode 100644 index 00000000000..1125063b730 --- /dev/null +++ b/plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md @@ -0,0 +1,39 @@ + + + +### Added + +- Builtins corresponding to the logical operations from [this + CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). + +### Changed + +- References to CIP-0087 now correctly refer to CIP-121. + + + + From f014f205ea690309758ef39c215ee5286c6f5836 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 10 May 2024 11:42:48 +1200 Subject: [PATCH 09/16] Note commutativity for new operations --- .../Transform/RewriteRules/CommuteFnWithConst.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs index 1f52b55900a..569f64d62d4 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs @@ -129,3 +129,12 @@ isCommutative = \case MkNilPairData -> False IntegerToByteString -> False ByteStringToInteger -> False + -- Currently, this requires commutativity in all arguments, which the + -- logical operations are not. + BitwiseLogicalAnd -> False + BitwiseLogicalOr -> False + BitwiseLogicalXor -> False + BitwiseLogicalComplement -> False + ReadBit -> False + WriteBits -> False + ReplicateByteString -> False From c0abae37901709e7c48c569154cdf704ff1106b9 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 10 May 2024 13:00:31 +1200 Subject: [PATCH 10/16] Properly rename replicate builtin, add to plutus-tx-plugin --- .../src/PlutusTx/Compiler/Builtins.hs | 17 +++++++++++++++++ plutus-tx/src/PlutusTx/Builtins.hs | 8 ++++---- plutus-tx/src/PlutusTx/Builtins/Internal.hs | 6 +++--- 3 files changed, 24 insertions(+), 7 deletions(-) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 077f99932eb..5782e94ee98 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -277,6 +277,14 @@ builtinNames = [ , 'Builtins.integerToByteString , 'Builtins.byteStringToInteger + + , 'Builtins.bitwiseLogicalAnd + , 'Builtins.bitwiseLogicalOr + , 'Builtins.bitwiseLogicalXor + , 'Builtins.bitwiseLogicalComplement + , 'Builtins.readBit + , 'Builtins.writeBits + , 'Builtins.replicateByteString ] defineBuiltinTerm :: CompilingDefault uni fun m ann => Ann -> TH.Name -> PIRTerm uni fun -> m () @@ -434,6 +442,15 @@ defineBuiltinTerms = do PLC.IntegerToByteString -> defineBuiltinInl 'Builtins.integerToByteString PLC.ByteStringToInteger -> defineBuiltinInl 'Builtins.byteStringToInteger + -- Logical operations + PLC.BitwiseLogicalAnd -> defineBuiltinInl 'Builtins.bitwiseLogicalAnd + PLC.BitwiseLogicalOr -> defineBuiltinInl 'Builtins.bitwiseLogicalOr + PLC.BitwiseLogicalXor -> defineBuiltinInl 'Builtins.bitwiseLogicalXor + PLC.BitwiseLogicalComplement -> defineBuiltinInl 'Builtins.bitwiseLogicalComplement + PLC.ReadBit -> defineBuiltinInl 'Builtins.readBit + PLC.WriteBits -> defineBuiltinInl 'Builtins.writeBits + PLC.ReplicateByteString -> defineBuiltinInl 'Builtins.replicateByteString + defineBuiltinTypes :: CompilingDefault uni fun m ann => m () diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 043de1af126..46ca657e019 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -114,7 +114,7 @@ module PlutusTx.Builtins ( , bitwiseLogicalComplement , readBit , writeBits - , byteStringReplicate + , replicateByteString ) where import Data.Maybe @@ -772,9 +772,9 @@ writeBits = BI.writeBits -- -- * [Operation -- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinreplicate) -{-# INLINEABLE byteStringReplicate #-} -byteStringReplicate :: +{-# INLINEABLE replicateByteString #-} +replicateByteString :: Integer -> Integer -> BuiltinByteString -byteStringReplicate = BI.byteStringReplicate +replicateByteString = BI.replicateByteString diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 12994a211f8..dfb233208e9 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -771,12 +771,12 @@ writeBits (BuiltinByteString bs) (BuiltinList xs) = BuiltinSuccess bs' -> BuiltinByteString bs' BuiltinSuccessWithLogs logs bs' -> traceAll logs $ BuiltinByteString bs' -{-# NOINLINE byteStringReplicate #-} -byteStringReplicate :: +{-# NOINLINE replicateByteString #-} +replicateByteString :: BuiltinInteger -> BuiltinInteger -> BuiltinByteString -byteStringReplicate n w8 = +replicateByteString n w8 = case Logical.replicateByteString (fromIntegral n) (fromIntegral w8) of BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $ Haskell.error "byteStringReplicate errored." From 71a53814ae456c3ff8eff5d5fb2bce885031f892 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 10 May 2024 13:08:41 +1200 Subject: [PATCH 11/16] Make new logical builtins available in V3 --- plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index 728b096ea3c..5cba6a0b802 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -115,7 +115,9 @@ builtinsIntroducedIn = Map.fromList [ Bls12_381_G2_equal, Bls12_381_G2_hashToGroup, Bls12_381_G2_compress, Bls12_381_G2_uncompress, Bls12_381_millerLoop, Bls12_381_mulMlResult, Bls12_381_finalVerify, - Keccak_256, Blake2b_224, IntegerToByteString, ByteStringToInteger + Keccak_256, Blake2b_224, IntegerToByteString, ByteStringToInteger, + BitwiseLogicalAnd, BitwiseLogicalOr, BitwiseLogicalXor, BitwiseLogicalComplement, + ReadBit, WriteBits, ReplicateByteString ]) ] From 5206690db62534ec9e446da56156f6fdfadcc38c Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 21 May 2024 09:33:37 +1200 Subject: [PATCH 12/16] Fix links to CIP-122, use toOpaque and fromOpaque instead --- plutus-tx/src/PlutusTx/Builtins.hs | 40 +++++++++++++++--------------- 1 file changed, 20 insertions(+), 20 deletions(-) diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 09c769c996f..e1905c1fa19 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -658,7 +658,7 @@ byteStringToInteger endianness = -- Logical operations -- | Perform logical AND on two 'BuiltinByteString' arguments, as described --- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinlogicaland). +-- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bitwiselogicaland). -- -- The first argument indicates whether padding semantics should be used or not; -- if 'False', truncation semantics will be used instead. @@ -666,19 +666,19 @@ byteStringToInteger endianness = -- = See also -- -- * [Padding and truncation --- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#padding-versus-truncation-semantics) +-- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#padding-versus-truncation-semantics) -- * [Bit indexing --- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) {-# INLINEABLE bitwiseLogicalAnd #-} bitwiseLogicalAnd :: Bool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalAnd b = BI.bitwiseLogicalAnd (toBuiltin b) +bitwiseLogicalAnd b = BI.bitwiseLogicalAnd (toOpaque b) -- | Perform logical OR on two 'BuiltinByteString' arguments, as described --- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinlogicalor). +-- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bitwiselogicalor). -- -- The first argument indicates whether padding semantics should be used or not; -- if 'False', truncation semantics will be used instead. @@ -686,19 +686,19 @@ bitwiseLogicalAnd b = BI.bitwiseLogicalAnd (toBuiltin b) -- = See also -- -- * [Padding and truncation --- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#padding-versus-truncation-semantics) +-- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#padding-versus-truncation-semantics) -- * [Bit indexing --- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) {-# INLINEABLE bitwiseLogicalOr #-} bitwiseLogicalOr :: Bool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalOr b = BI.bitwiseLogicalOr (toBuiltin b) +bitwiseLogicalOr b = BI.bitwiseLogicalOr (toOpaque b) -- | Perform logical XOR on two 'BuiltinByteString' arguments, as described --- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinlogicalxor). +-- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bitwiselogicalxor). -- -- The first argument indicates whether padding semantics should be used or not; -- if 'False', truncation semantics will be used instead. @@ -706,24 +706,24 @@ bitwiseLogicalOr b = BI.bitwiseLogicalOr (toBuiltin b) -- = See also -- -- * [Padding and truncation --- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#padding-versus-truncation-semantics) +-- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#padding-versus-truncation-semantics) -- * [Bit indexing --- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) {-# INLINEABLE bitwiseLogicalXor #-} bitwiseLogicalXor :: Bool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalXor b = BI.bitwiseLogicalXor (toBuiltin b) +bitwiseLogicalXor b = BI.bitwiseLogicalXor (toOpaque b) -- | Perform logical complement on a 'BuiltinByteString', as described --- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinlogicalcomplement). +-- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bitwiselogicalcomplement). -- -- = See also -- -- * [Bit indexing --- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) {-# INLINEABLE bitwiseLogicalComplement #-} bitwiseLogicalComplement :: BuiltinByteString -> @@ -739,15 +739,15 @@ bitwiseLogicalComplement = BI.bitwiseLogicalComplement -- = See also -- -- * [Bit indexing --- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) -- * [Operation --- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinreadbit) +-- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#readbit) {-# INLINEABLE readBit #-} readBit :: BuiltinByteString -> Integer -> Bool -readBit bs i = fromBuiltin (BI.readBit bs i) +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 @@ -758,9 +758,9 @@ readBit bs i = fromBuiltin (BI.readBit bs i) -- = See also -- -- * [Bit indexing --- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#bit-indexing-scheme) +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) -- * [Operation --- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinsetbits) +-- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#writebits) {-# INLINEABLE writeBits #-} writeBits :: BuiltinByteString -> @@ -775,7 +775,7 @@ writeBits = BI.writeBits -- = See also -- -- * [Operation --- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md#builtinreplicate) +-- description](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#replicateByteString) {-# INLINEABLE replicateByteString #-} replicateByteString :: Integer -> From 8dcebb57b7425d4523c8ced9609ae4a665df5594 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 21 May 2024 09:42:02 +1200 Subject: [PATCH 13/16] Correct all references to CIP-122 --- .../20240510_104627_koz.ross_logical.md | 3 +-- .../src/PlutusCore/Bitwise/Logical.hs | 21 +++++++------------ .../test/Evaluation/Builtins/Definition.hs | 2 +- .../20240510_110418_koz.ross_logical.md | 3 +-- 4 files changed, 10 insertions(+), 19 deletions(-) diff --git a/plutus-core/changelog.d/20240510_104627_koz.ross_logical.md b/plutus-core/changelog.d/20240510_104627_koz.ross_logical.md index a2232c6d197..56b247b8098 100644 --- a/plutus-core/changelog.d/20240510_104627_koz.ross_logical.md +++ b/plutus-core/changelog.d/20240510_104627_koz.ross_logical.md @@ -12,8 +12,7 @@ Uncomment the section that is right (remove the HTML comment wrapper). --> ### Added -- Logical operations as per [this - CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +- Logical operations as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). ### Changed diff --git a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs index c2c8a035c47..8d539188f4b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs @@ -102,8 +102,7 @@ import System.IO.Unsafe (unsafeDupablePerformIO) figure this out, even with `INLINE` is placed on `helper1`. -} --- | Bitwise logical AND, as per [the relevant --- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +-- | Bitwise logical AND, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). bitwiseLogicalAnd :: Bool -> ByteString -> ByteString -> ByteString bitwiseLogicalAnd shouldPad bs1 bs2 = let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) @@ -131,8 +130,7 @@ bitwiseLogicalAnd shouldPad bs1 bs2 = w8_2 <- peekElemOff smallTraversePtr i pokeElemOff smallDstPtr i $ w8_1 Bits..&. w8_2 --- | Bitwise logical OR, as per [the relevant --- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +-- | Bitwise logical OR, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). bitwiseLogicalOr :: Bool -> ByteString -> ByteString -> ByteString bitwiseLogicalOr shouldPad bs1 bs2 = let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) @@ -160,8 +158,7 @@ bitwiseLogicalOr shouldPad bs1 bs2 = w8_2 <- peekElemOff smallTraversePtr i pokeElemOff smallDstPtr i $ w8_1 Bits..|. w8_2 --- | Bitwise logical XOR, as per [the relevant --- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +-- | Bitwise logical XOR, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). bitwiseLogicalXor :: Bool -> ByteString -> ByteString -> ByteString bitwiseLogicalXor shouldPad bs1 bs2 = let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) @@ -189,8 +186,7 @@ bitwiseLogicalXor shouldPad bs1 bs2 = w8_2 <- peekElemOff smallTraversePtr i pokeElemOff smallDstPtr i $ Bits.xor w8_1 w8_2 --- | Bitwise logical complement, as per [the relevant --- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +-- | Bitwise logical complement, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). {-# INLINEABLE bitwiseLogicalComplement #-} bitwiseLogicalComplement :: ByteString -> ByteString bitwiseLogicalComplement bs = unsafeDupablePerformIO . BS.useAsCStringLen bs $ \(srcPtr, len) -> do @@ -209,8 +205,7 @@ bitwiseLogicalComplement bs = unsafeDupablePerformIO . BS.useAsCStringLen bs $ \ w8 <- peekElemOff smallSrcPtr i pokeElemOff smallDstPtr i . Bits.complement $ w8 --- | Bit read at index, as per [the relevant --- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md) +-- | Bit read at index, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md) {-# INLINEABLE readBit #-} readBit :: ByteString -> Int -> BuiltinResult Bool readBit bs ix @@ -230,8 +225,7 @@ readBit bs ix len :: Int len = BS.length bs --- | Bulk bit write, as per [the relevant --- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md) +-- | Bulk bit write, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md) {-# INLINEABLE writeBits #-} writeBits :: ByteString -> [(Integer, Bool)] -> BuiltinResult ByteString writeBits bs changelist = case unsafeDupablePerformIO . try $ go of @@ -265,8 +259,7 @@ writeBits bs changelist = case unsafeDupablePerformIO . try $ go of else Bits.clearBit w8 . fromIntegral $ littleIx pokeByteOff ptr flipIx toWrite --- | Byte replication, as per [the relevant --- CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md) +-- | Byte replication, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md) replicateByteString :: Int -> Word8 -> BuiltinResult ByteString replicateByteString len w8 | len < 0 = do diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index 31791d534d7..1643b56d87d 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -876,7 +876,7 @@ test_Conversion = ] ] --- Tests for the logical operations, as per https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md +-- Tests for the logical operations, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md) test_Logical :: TestTree test_Logical = adjustOption (\x -> max x . HedgehogTestLimit . Just $ 4000) . diff --git a/plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md b/plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md index 1125063b730..eb9750f68f3 100644 --- a/plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md +++ b/plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md @@ -12,8 +12,7 @@ Uncomment the section that is right (remove the HTML comment wrapper). --> ### Added -- Builtins corresponding to the logical operations from [this - CIP](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-XXX/CIP-XXX.md). +- Builtins corresponding to the logical operations from [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). ### Changed From 9e215afd580ecc9e29f021f6adfc388a58112db0 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 6 Jun 2024 13:31:23 +1200 Subject: [PATCH 14/16] Rename bitwise builtins, use proper costing --- .../src/PlutusCore/Bitwise/Logical.hs | 37 ++++++----- .../src/PlutusCore/Default/Builtins.hs | 64 +++++++++---------- .../RewriteRules/CommuteFnWithConst.hs | 8 +-- .../test/Evaluation/Builtins/Definition.hs | 36 +++++------ .../test/Evaluation/Builtins/Laws.hs | 24 +++---- .../src/PlutusLedgerApi/Common/Versions.hs | 2 +- .../src/PlutusTx/Compiler/Builtins.hs | 16 ++--- .../Budget/9.6/patternMatching.uplc.golden | 8 +-- .../test/Budget/9.6/map2.uplc.golden | 4 +- .../test/Budget/9.6/map3.uplc.golden | 4 +- plutus-tx/src/PlutusTx/Builtins.hs | 32 +++++----- plutus-tx/src/PlutusTx/Builtins/Internal.hs | 32 +++++----- 12 files changed, 135 insertions(+), 132 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs index 8d539188f4b..7e228ad80ab 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs @@ -4,10 +4,10 @@ -- | Implementations of bitwise logical primops. module PlutusCore.Bitwise.Logical ( - bitwiseLogicalAnd, - bitwiseLogicalOr, - bitwiseLogicalXor, - bitwiseLogicalComplement, + andByteString, + orByteString, + xorByteString, + complementByteString, readBit, writeBits, replicateByteString @@ -30,8 +30,8 @@ import System.IO.Unsafe (unsafeDupablePerformIO) {- Note [Binary bitwise operation implementation and manual specialization] - All of the 'binary' bitwise operations (namely `bitwiseLogicalAnd`, - `bitwiseLogicalOr` and `bitwiseLogicalXor`) operate similarly: + All of the 'binary' bitwise operations (namely `andByteString`, + `orByteString` and `xorByteString`) operate similarly: 1. Decide which of their two `ByteString` arguments determines the length of the result. For padding semantics, this is the _longer_ argument, @@ -41,8 +41,8 @@ import System.IO.Unsafe (unsafeDupablePerformIO) 2. Copy the choice made in step 1 into a fresh mutable buffer. 3. Traverse over each byte of the argument _not_ chosen in step 1, and combine each of those bytes with the byte at the corresponding index of - the fresh mutable buffer from step 2 (`.&.` for `bitwiseLogicalAnd`, - `.|.` for `bitwiseLogicalOr`, `xor` for `bitwiseLogicalXor`). + the fresh mutable buffer from step 2 (`.&.` for `andByteString`, + `.|.` for `orByteString`, `xor` for `xorByteString`). We also make use of loop sectioning to optimize this operation: see Note [Loop sectioning] explaining why we do this. Fundamentally, this doesn't @@ -103,8 +103,9 @@ import System.IO.Unsafe (unsafeDupablePerformIO) -} -- | Bitwise logical AND, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). -bitwiseLogicalAnd :: Bool -> ByteString -> ByteString -> ByteString -bitwiseLogicalAnd shouldPad bs1 bs2 = +{-# INLINEABLE andByteString #-} +andByteString :: Bool -> ByteString -> ByteString -> ByteString +andByteString shouldPad bs1 bs2 = let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) (toCopy, toTraverse) = if shouldPad then (longer, shorter) else (shorter, longer) in go toCopy toTraverse (BS.length shorter) @@ -131,8 +132,9 @@ bitwiseLogicalAnd shouldPad bs1 bs2 = pokeElemOff smallDstPtr i $ w8_1 Bits..&. w8_2 -- | Bitwise logical OR, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). -bitwiseLogicalOr :: Bool -> ByteString -> ByteString -> ByteString -bitwiseLogicalOr shouldPad bs1 bs2 = +{-# INLINEABLE orByteString #-} +orByteString :: Bool -> ByteString -> ByteString -> ByteString +orByteString shouldPad bs1 bs2 = let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) (toCopy, toTraverse) = if shouldPad then (longer, shorter) else (shorter, longer) in go toCopy toTraverse (BS.length shorter) @@ -159,8 +161,9 @@ bitwiseLogicalOr shouldPad bs1 bs2 = pokeElemOff smallDstPtr i $ w8_1 Bits..|. w8_2 -- | Bitwise logical XOR, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). -bitwiseLogicalXor :: Bool -> ByteString -> ByteString -> ByteString -bitwiseLogicalXor shouldPad bs1 bs2 = +{-# INLINEABLE xorByteString #-} +xorByteString :: Bool -> ByteString -> ByteString -> ByteString +xorByteString shouldPad bs1 bs2 = let (shorter, longer) = if BS.length bs1 < BS.length bs2 then (bs1, bs2) else (bs2, bs1) (toCopy, toTraverse) = if shouldPad then (longer, shorter) else (shorter, longer) in go toCopy toTraverse (BS.length shorter) @@ -187,9 +190,9 @@ bitwiseLogicalXor shouldPad bs1 bs2 = pokeElemOff smallDstPtr i $ Bits.xor w8_1 w8_2 -- | Bitwise logical complement, as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). -{-# INLINEABLE bitwiseLogicalComplement #-} -bitwiseLogicalComplement :: ByteString -> ByteString -bitwiseLogicalComplement bs = unsafeDupablePerformIO . BS.useAsCStringLen bs $ \(srcPtr, len) -> do +{-# INLINEABLE complementByteString #-} +complementByteString :: ByteString -> ByteString +complementByteString bs = unsafeDupablePerformIO . BS.useAsCStringLen bs $ \(srcPtr, len) -> do -- We use loop sectioning here; see Note [Loop sectioning] as to why we do this let (bigStrides, littleStrides) = len `quotRem` 8 let offset = bigStrides * 8 diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 12495105440..a34d129237f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -154,10 +154,10 @@ data DefaultFun | IntegerToByteString | ByteStringToInteger -- Logical - | BitwiseLogicalAnd - | BitwiseLogicalOr - | BitwiseLogicalXor - | BitwiseLogicalComplement + | AndByteString + | OrByteString + | XorByteString + | ComplementByteString | ReadBit | WriteBits | ReplicateByteString @@ -1832,36 +1832,36 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where (runCostingFunTwoArguments . paramByteStringToInteger) -- Logical - toBuiltinMeaning _semvar BitwiseLogicalAnd = - let bitwiseLogicalAndDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - bitwiseLogicalAndDenotation = Logical.bitwiseLogicalAnd - {-# INLINE bitwiseLogicalAndDenotation #-} + toBuiltinMeaning _semvar AndByteString = + let andByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + andByteStringDenotation = Logical.andByteString + {-# INLINE andByteStringDenotation #-} in makeBuiltinMeaning - bitwiseLogicalAndDenotation + andByteStringDenotation (runCostingFunThreeArguments . unimplementedCostingFun) - toBuiltinMeaning _semvar BitwiseLogicalOr = - let bitwiseLogicalOrDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - bitwiseLogicalOrDenotation = Logical.bitwiseLogicalOr - {-# INLINE bitwiseLogicalOrDenotation #-} + toBuiltinMeaning _semvar OrByteString = + let orByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + orByteStringDenotation = Logical.orByteString + {-# INLINE orByteStringDenotation #-} in makeBuiltinMeaning - bitwiseLogicalOrDenotation + orByteStringDenotation (runCostingFunThreeArguments . unimplementedCostingFun) - toBuiltinMeaning _semvar BitwiseLogicalXor = - let bitwiseLogicalXorDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString - bitwiseLogicalXorDenotation = Logical.bitwiseLogicalXor - {-# INLINE bitwiseLogicalXorDenotation #-} + toBuiltinMeaning _semvar XorByteString = + let xorByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + xorByteStringDenotation = Logical.xorByteString + {-# INLINE xorByteStringDenotation #-} in makeBuiltinMeaning - bitwiseLogicalXorDenotation + xorByteStringDenotation (runCostingFunThreeArguments . unimplementedCostingFun) - toBuiltinMeaning _semvar BitwiseLogicalComplement = - let bitwiseLogicalComplementDenotation :: BS.ByteString -> BS.ByteString - bitwiseLogicalComplementDenotation = Logical.bitwiseLogicalComplement - {-# INLINE bitwiseLogicalComplementDenotation #-} + toBuiltinMeaning _semvar ComplementByteString = + let complementByteStringDenotation :: BS.ByteString -> BS.ByteString + complementByteStringDenotation = Logical.complementByteString + {-# INLINE complementByteStringDenotation #-} in makeBuiltinMeaning - bitwiseLogicalComplementDenotation + complementByteStringDenotation (runCostingFunOneArgument . unimplementedCostingFun) toBuiltinMeaning _semvar ReadBit = @@ -2015,10 +2015,10 @@ instance Flat DefaultFun where IntegerToByteString -> 73 ByteStringToInteger -> 74 - BitwiseLogicalAnd -> 75 - BitwiseLogicalOr -> 76 - BitwiseLogicalXor -> 77 - BitwiseLogicalComplement -> 78 + AndByteString -> 75 + OrByteString -> 76 + XorByteString -> 77 + ComplementByteString -> 78 ReadBit -> 79 WriteBits -> 80 ReplicateByteString -> 81 @@ -2099,10 +2099,10 @@ instance Flat DefaultFun where go 72 = pure Blake2b_224 go 73 = pure IntegerToByteString go 74 = pure ByteStringToInteger - go 75 = pure BitwiseLogicalAnd - go 76 = pure BitwiseLogicalOr - go 77 = pure BitwiseLogicalXor - go 78 = pure BitwiseLogicalComplement + go 75 = pure AndByteString + go 76 = pure OrByteString + go 77 = pure XorByteString + go 78 = pure ComplementByteString go 79 = pure ReadBit go 80 = pure WriteBits go 81 = pure ReplicateByteString diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs index 569f64d62d4..4db5179eb6b 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/RewriteRules/CommuteFnWithConst.hs @@ -131,10 +131,10 @@ isCommutative = \case ByteStringToInteger -> False -- Currently, this requires commutativity in all arguments, which the -- logical operations are not. - BitwiseLogicalAnd -> False - BitwiseLogicalOr -> False - BitwiseLogicalXor -> False - BitwiseLogicalComplement -> False + AndByteString -> False + OrByteString -> False + XorByteString -> False + ComplementByteString -> False ReadBit -> False WriteBits -> False ReplicateByteString -> False diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index 68350a34645..054f414e2f4 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -909,29 +909,29 @@ test_Logical = adjustOption (\x -> max x . HedgehogTestLimit . Just $ 4000) . testGroup "Logical" $ [ testGroup "bitwiseLogicalAnd" [ - Laws.abelianSemigroupLaws "truncation" PLC.BitwiseLogicalAnd False, - Laws.idempotenceLaw "truncation" PLC.BitwiseLogicalAnd False, - Laws.absorbtionLaw "truncation" PLC.BitwiseLogicalAnd False "", - Laws.leftDistributiveLaw "truncation" "itself" PLC.BitwiseLogicalAnd PLC.BitwiseLogicalAnd False, - Laws.leftDistributiveLaw "truncation" "OR" PLC.BitwiseLogicalAnd PLC.BitwiseLogicalOr False, - Laws.leftDistributiveLaw "truncation" "XOR" PLC.BitwiseLogicalAnd PLC.BitwiseLogicalXor False, - Laws.abelianMonoidLaws "padding" PLC.BitwiseLogicalAnd True "", - Laws.distributiveLaws "padding" PLC.BitwiseLogicalAnd True + Laws.abelianSemigroupLaws "truncation" PLC.AndByteString False, + Laws.idempotenceLaw "truncation" PLC.AndByteString False, + Laws.absorbtionLaw "truncation" PLC.AndByteString False "", + Laws.leftDistributiveLaw "truncation" "itself" PLC.AndByteString PLC.AndByteString False, + Laws.leftDistributiveLaw "truncation" "OR" PLC.AndByteString PLC.OrByteString False, + Laws.leftDistributiveLaw "truncation" "XOR" PLC.AndByteString PLC.XorByteString False, + Laws.abelianMonoidLaws "padding" PLC.AndByteString True "", + Laws.distributiveLaws "padding" PLC.AndByteString True ], testGroup "bitwiseLogicalOr" [ - Laws.abelianSemigroupLaws "truncation" PLC.BitwiseLogicalOr False, - Laws.idempotenceLaw "truncation" PLC.BitwiseLogicalOr False, - Laws.absorbtionLaw "truncation" PLC.BitwiseLogicalOr False "", - Laws.leftDistributiveLaw "truncation" "itself" PLC.BitwiseLogicalOr PLC.BitwiseLogicalOr False, - Laws.leftDistributiveLaw "truncation" "AND" PLC.BitwiseLogicalOr PLC.BitwiseLogicalAnd False, - Laws.abelianMonoidLaws "padding" PLC.BitwiseLogicalOr True "", - Laws.distributiveLaws "padding" PLC.BitwiseLogicalOr True + Laws.abelianSemigroupLaws "truncation" PLC.OrByteString False, + Laws.idempotenceLaw "truncation" PLC.OrByteString False, + Laws.absorbtionLaw "truncation" PLC.OrByteString False "", + Laws.leftDistributiveLaw "truncation" "itself" PLC.OrByteString PLC.OrByteString False, + Laws.leftDistributiveLaw "truncation" "AND" PLC.OrByteString PLC.AndByteString False, + Laws.abelianMonoidLaws "padding" PLC.OrByteString True "", + Laws.distributiveLaws "padding" PLC.OrByteString True ], testGroup "bitwiseLogicalXor" [ - Laws.abelianSemigroupLaws "truncation" PLC.BitwiseLogicalXor False, - Laws.absorbtionLaw "truncation" PLC.BitwiseLogicalXor False "", + Laws.abelianSemigroupLaws "truncation" PLC.XorByteString False, + Laws.absorbtionLaw "truncation" PLC.XorByteString False "", Laws.xorInvoluteLaw, - Laws.abelianMonoidLaws "padding" PLC.BitwiseLogicalXor True "" + Laws.abelianMonoidLaws "padding" PLC.XorByteString True "" ], testGroup "bitwiseLogicalComplement" [ Laws.complementSelfInverse, diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs index 5e07fa37d69..a7bbe8021ea 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs @@ -30,7 +30,7 @@ import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Numeric (showHex) import PlutusCore qualified as PLC -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModel) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModelForTesting) import PlutusCore.MkPlc (builtin, mkConstant, mkIterAppNoAnn) import PlutusPrelude (Word8, def) import Test.Tasty (TestTree, testGroup) @@ -69,7 +69,7 @@ getSet = mkConstant @ByteString () bs, mkConstant @Integer () i ] - case typecheckReadKnownCek def defaultBuiltinCostModel lookupExp of + case typecheckReadKnownCek def defaultBuiltinCostModelForTesting lookupExp of Left err -> annotateShow err >> failure Right (Left err) -> annotateShow err >> failure Right (Right b) -> do @@ -227,10 +227,10 @@ complementSelfInverse :: TestTree complementSelfInverse = testPropertyNamed "self-inverse" "self_inverse" . property $ do bs <- forAllByteString - let lhsInner = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + let lhsInner = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ mkConstant @ByteString () bs ] - let lhs = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + let lhs = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ lhsInner ] let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ @@ -245,8 +245,8 @@ complementSelfInverse = -- * The complement of an OR is an AND of complements. deMorgan :: TestTree deMorgan = testGroup "De Morgan's laws" [ - testPropertyNamed "NOT AND -> OR" "demorgan_and" . go PLC.BitwiseLogicalAnd $ PLC.BitwiseLogicalOr, - testPropertyNamed "NOT OR -> AND" "demorgan_or" . go PLC.BitwiseLogicalOr $ PLC.BitwiseLogicalAnd + testPropertyNamed "NOT AND -> OR" "demorgan_and" . go PLC.AndByteString $ PLC.OrByteString, + testPropertyNamed "NOT OR -> AND" "demorgan_or" . go PLC.OrByteString $ PLC.AndByteString ] where go :: UPLC.DefaultFun -> UPLC.DefaultFun -> Property @@ -259,13 +259,13 @@ deMorgan = testGroup "De Morgan's laws" [ mkConstant @ByteString () bs1, mkConstant @ByteString () bs2 ] - let lhs = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + let lhs = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ lhsInner ] - let rhsInner1 = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + let rhsInner1 = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ mkConstant @ByteString () bs1 ] - let rhsInner2 = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalComplement) [ + let rhsInner2 = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ mkConstant @ByteString () bs2 ] let rhs = mkIterAppNoAnn (builtin () g) [ @@ -284,12 +284,12 @@ xorInvoluteLaw :: TestTree xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" . property $ do bs <- forAllByteString semantics <- forAllWith showSemantics Gen.bool - let lhsInner = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalXor) [ + let lhsInner = mkIterAppNoAnn (builtin () PLC.XorByteString) [ mkConstant @Bool () semantics, mkConstant @ByteString () bs, mkConstant @ByteString () bs ] - let lhs = mkIterAppNoAnn (builtin () PLC.BitwiseLogicalXor) [ + let lhs = mkIterAppNoAnn (builtin () PLC.XorByteString) [ mkConstant @Bool () semantics, mkConstant @ByteString () bs, lhsInner @@ -557,7 +557,7 @@ evaluateAndVerify :: PLC.Term UPLC.TyName UPLC.Name UPLC.DefaultUni UPLC.DefaultFun () -> PropertyT IO () evaluateAndVerify expected actual = - case typecheckEvaluateCek def defaultBuiltinCostModel actual of + case typecheckEvaluateCek def defaultBuiltinCostModelForTesting actual of Left x -> annotateShow x >> failure Right (res, logs) -> case res of PLC.EvaluationFailure -> annotateShow logs >> failure diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index b1c06de200f..b9033f2c5a0 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -118,7 +118,7 @@ builtinsIntroducedIn = Map.fromList [ Bls12_381_G2_compress, Bls12_381_G2_uncompress, Bls12_381_millerLoop, Bls12_381_mulMlResult, Bls12_381_finalVerify, Keccak_256, Blake2b_224, IntegerToByteString, ByteStringToInteger, - BitwiseLogicalAnd, BitwiseLogicalOr, BitwiseLogicalXor, BitwiseLogicalComplement, + AndByteString, OrByteString, XorByteString, ComplementByteString, ReadBit, WriteBits, ReplicateByteString ]) ] diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index 93b0ff92866..c8741b870ee 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -277,10 +277,10 @@ builtinNames = [ , 'Builtins.integerToByteString , 'Builtins.byteStringToInteger - , 'Builtins.bitwiseLogicalAnd - , 'Builtins.bitwiseLogicalOr - , 'Builtins.bitwiseLogicalXor - , 'Builtins.bitwiseLogicalComplement + , 'Builtins.andByteString + , 'Builtins.orByteString + , 'Builtins.xorByteString + , 'Builtins.complementByteString , 'Builtins.readBit , 'Builtins.writeBits , 'Builtins.replicateByteString @@ -442,10 +442,10 @@ defineBuiltinTerms = do PLC.ByteStringToInteger -> defineBuiltinInl 'Builtins.byteStringToInteger -- Logical operations - PLC.BitwiseLogicalAnd -> defineBuiltinInl 'Builtins.bitwiseLogicalAnd - PLC.BitwiseLogicalOr -> defineBuiltinInl 'Builtins.bitwiseLogicalOr - PLC.BitwiseLogicalXor -> defineBuiltinInl 'Builtins.bitwiseLogicalXor - PLC.BitwiseLogicalComplement -> defineBuiltinInl 'Builtins.bitwiseLogicalComplement + PLC.AndByteString -> defineBuiltinInl 'Builtins.andByteString + PLC.OrByteString -> defineBuiltinInl 'Builtins.orByteString + PLC.XorByteString -> defineBuiltinInl 'Builtins.xorByteString + PLC.ComplementByteString -> defineBuiltinInl 'Builtins.complementByteString PLC.ReadBit -> defineBuiltinInl 'Builtins.readBit PLC.WriteBits -> defineBuiltinInl 'Builtins.writeBits PLC.ReplicateByteString -> defineBuiltinInl 'Builtins.replicateByteString diff --git a/plutus-tx-plugin/test/AsData/Budget/9.6/patternMatching.uplc.golden b/plutus-tx-plugin/test/AsData/Budget/9.6/patternMatching.uplc.golden index e2393ed1fc3..d264e9c829c 100644 --- a/plutus-tx-plugin/test/AsData/Budget/9.6/patternMatching.uplc.golden +++ b/plutus-tx-plugin/test/AsData/Budget/9.6/patternMatching.uplc.golden @@ -26,10 +26,10 @@ program (addInteger cse cse)) [ (delay (addInteger cse cse)) , (delay (addInteger cse cse)) ]))) - (case cse [(\x y z w -> z)])) - (case cse [(\x y z w -> w)])) - (case cse [(\x y z w -> x)])) - (case cse [(\x y z w -> y)])) + (case cse [(\x y z w -> w)])) + (case cse [(\x y z w -> y)])) + (case cse [(\x y z w -> z)])) + (case cse [(\x y z w -> x)])) (\x y -> force ifThenElse (lessThanInteger x y) diff --git a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden index f1bf99b0f21..e2e0f98905e 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map2.uplc.golden @@ -212,8 +212,8 @@ program [ (addInteger 7 n) , #534556454e ]) , (constr 0 []) ]) ]) ]) ]))) - (addInteger 4 n)) - (addInteger 3 n)) + (addInteger 3 n)) + (addInteger 4 n)) (\`$dToData` `$dToData` -> (\go eta -> goList (go eta)) (fix1 diff --git a/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden b/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden index f1bf99b0f21..e2e0f98905e 100644 --- a/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden +++ b/plutus-tx-plugin/test/Budget/9.6/map3.uplc.golden @@ -212,8 +212,8 @@ program [ (addInteger 7 n) , #534556454e ]) , (constr 0 []) ]) ]) ]) ]))) - (addInteger 4 n)) - (addInteger 3 n)) + (addInteger 3 n)) + (addInteger 4 n)) (\`$dToData` `$dToData` -> (\go eta -> goList (go eta)) (fix1 diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 0981a6a4d12..e242df14841 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -111,10 +111,10 @@ module PlutusTx.Builtins ( , integerToByteString , byteStringToInteger -- * Logical - , bitwiseLogicalAnd - , bitwiseLogicalOr - , bitwiseLogicalXor - , bitwiseLogicalComplement + , andByteString + , orByteString + , xorByteString + , complementByteString , readBit , writeBits , replicateByteString @@ -674,13 +674,13 @@ byteStringToInteger endianness = -- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#padding-versus-truncation-semantics) -- * [Bit indexing -- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) -{-# INLINEABLE bitwiseLogicalAnd #-} -bitwiseLogicalAnd :: +{-# INLINEABLE andByteString #-} +andByteString :: Bool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalAnd b = BI.bitwiseLogicalAnd (toOpaque b) +andByteString b = BI.andByteString (toOpaque b) -- | Perform logical OR on two 'BuiltinByteString' arguments, as described -- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bitwiselogicalor). @@ -694,13 +694,13 @@ bitwiseLogicalAnd b = BI.bitwiseLogicalAnd (toOpaque b) -- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#padding-versus-truncation-semantics) -- * [Bit indexing -- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) -{-# INLINEABLE bitwiseLogicalOr #-} -bitwiseLogicalOr :: +{-# INLINEABLE orByteString #-} +orByteString :: Bool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalOr b = BI.bitwiseLogicalOr (toOpaque b) +orByteString b = BI.orByteString (toOpaque b) -- | Perform logical XOR on two 'BuiltinByteString' arguments, as described -- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bitwiselogicalxor). @@ -714,13 +714,13 @@ bitwiseLogicalOr b = BI.bitwiseLogicalOr (toOpaque b) -- semantics](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#padding-versus-truncation-semantics) -- * [Bit indexing -- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) -{-# INLINEABLE bitwiseLogicalXor #-} -bitwiseLogicalXor :: +{-# INLINEABLE xorByteString #-} +xorByteString :: Bool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalXor b = BI.bitwiseLogicalXor (toOpaque b) +xorByteString b = BI.xorByteString (toOpaque b) -- | Perform logical complement on a 'BuiltinByteString', as described -- [here](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bitwiselogicalcomplement). @@ -729,11 +729,11 @@ bitwiseLogicalXor b = BI.bitwiseLogicalXor (toOpaque b) -- -- * [Bit indexing -- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) -{-# INLINEABLE bitwiseLogicalComplement #-} -bitwiseLogicalComplement :: +{-# INLINEABLE complementByteString #-} +complementByteString :: BuiltinByteString -> BuiltinByteString -bitwiseLogicalComplement = BI.bitwiseLogicalComplement +complementByteString = BI.complementByteString -- | Read a bit at the _bit_ index given by the 'Integer' argument in the -- 'BuiltinByteString' argument. The result will be 'True' if the corresponding bit is set, and diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index dfb233208e9..af39c643a3c 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -712,39 +712,39 @@ byteStringToInteger (BuiltinBool statedEndianness) (BuiltinByteString input) = LOGICAL -} -{-# NOINLINE bitwiseLogicalAnd #-} -bitwiseLogicalAnd :: +{-# NOINLINE andByteString #-} +andByteString :: BuiltinBool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalAnd (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = - BuiltinByteString . Logical.bitwiseLogicalAnd isPaddingSemantics data1 $ data2 +andByteString (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.andByteString isPaddingSemantics data1 $ data2 -{-# NOINLINE bitwiseLogicalOr #-} -bitwiseLogicalOr :: +{-# NOINLINE orByteString #-} +orByteString :: BuiltinBool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalOr (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = - BuiltinByteString . Logical.bitwiseLogicalOr isPaddingSemantics data1 $ data2 +orByteString (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.orByteString isPaddingSemantics data1 $ data2 -{-# NOINLINE bitwiseLogicalXor #-} -bitwiseLogicalXor :: +{-# NOINLINE xorByteString #-} +xorByteString :: BuiltinBool -> BuiltinByteString -> BuiltinByteString -> BuiltinByteString -bitwiseLogicalXor (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = - BuiltinByteString . Logical.bitwiseLogicalXor isPaddingSemantics data1 $ data2 +xorByteString (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.xorByteString isPaddingSemantics data1 $ data2 -{-# NOINLINE bitwiseLogicalComplement #-} -bitwiseLogicalComplement :: +{-# NOINLINE complementByteString #-} +complementByteString :: BuiltinByteString -> BuiltinByteString -bitwiseLogicalComplement (BuiltinByteString bs) = - BuiltinByteString . Logical.bitwiseLogicalComplement $ bs +complementByteString (BuiltinByteString bs) = + BuiltinByteString . Logical.complementByteString $ bs {-# NOINLINE readBit #-} readBit :: From f567655c7445051492d7bc68429796a9ca7f49ed Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 7 Jun 2024 09:27:36 +1200 Subject: [PATCH 15/16] Bitwise primops will not be in Conway --- plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index b9033f2c5a0..4a68bb38c4c 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -117,7 +117,9 @@ builtinsIntroducedIn = Map.fromList [ Bls12_381_G2_equal, Bls12_381_G2_hashToGroup, Bls12_381_G2_compress, Bls12_381_G2_uncompress, Bls12_381_millerLoop, Bls12_381_mulMlResult, Bls12_381_finalVerify, - Keccak_256, Blake2b_224, IntegerToByteString, ByteStringToInteger, + Keccak_256, Blake2b_224, IntegerToByteString, ByteStringToInteger + ]), + ((PlutusV3, futurePV), Set.fromList [ AndByteString, OrByteString, XorByteString, ComplementByteString, ReadBit, WriteBits, ReplicateByteString ]) From fa690f74a4b4eb077ec308cd0fe0b4cd96a7257f Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 7 Jun 2024 09:57:46 +1200 Subject: [PATCH 16/16] Rename tests to suit new primop names --- .../test/Evaluation/Builtins/Definition.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index 054f414e2f4..83041a34e83 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -908,7 +908,7 @@ test_Logical :: TestTree test_Logical = adjustOption (\x -> max x . HedgehogTestLimit . Just $ 4000) . testGroup "Logical" $ [ - testGroup "bitwiseLogicalAnd" [ + testGroup "andByteString" [ Laws.abelianSemigroupLaws "truncation" PLC.AndByteString False, Laws.idempotenceLaw "truncation" PLC.AndByteString False, Laws.absorbtionLaw "truncation" PLC.AndByteString False "", @@ -918,7 +918,7 @@ test_Logical = Laws.abelianMonoidLaws "padding" PLC.AndByteString True "", Laws.distributiveLaws "padding" PLC.AndByteString True ], - testGroup "bitwiseLogicalOr" [ + testGroup "orByteString" [ Laws.abelianSemigroupLaws "truncation" PLC.OrByteString False, Laws.idempotenceLaw "truncation" PLC.OrByteString False, Laws.absorbtionLaw "truncation" PLC.OrByteString False "", @@ -927,7 +927,7 @@ test_Logical = Laws.abelianMonoidLaws "padding" PLC.OrByteString True "", Laws.distributiveLaws "padding" PLC.OrByteString True ], - testGroup "bitwiseLogicalXor" [ + testGroup "xorByteString" [ Laws.abelianSemigroupLaws "truncation" PLC.XorByteString False, Laws.absorbtionLaw "truncation" PLC.XorByteString False "", Laws.xorInvoluteLaw,