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..56b247b8098 --- /dev/null +++ b/plutus-core/changelog.d/20240510_104627_koz.ross_logical.md @@ -0,0 +1,38 @@ + + + +### Added + +- Logical operations as per [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). + +### Changed + +- References to CIP-87 have been corrected to refer to CIP-121. + + + + diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 9158c964044..91948b911c1 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -93,6 +93,7 @@ library PlutusCore.Annotation PlutusCore.Arity PlutusCore.Bitwise.Convert + PlutusCore.Bitwise.Logical PlutusCore.Builtin PlutusCore.Builtin.Debug PlutusCore.Builtin.Elaborate @@ -423,6 +424,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/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/plutus-core/src/PlutusCore/Bitwise/Logical.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs new file mode 100644 index 00000000000..7e228ad80ab --- /dev/null +++ b/plutus-core/plutus-core/src/PlutusCore/Bitwise/Logical.hs @@ -0,0 +1,464 @@ +-- editorconfig-checker-disable-file + +{-# LANGUAGE OverloadedStrings #-} + +-- | Implementations of bitwise logical primops. +module PlutusCore.Bitwise.Logical ( + andByteString, + orByteString, + xorByteString, + complementByteString, + readBit, + writeBits, + replicateByteString + ) 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 `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, + 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 `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 + 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 [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). +{-# 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) + 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 [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). +{-# 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) + 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 [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). +{-# 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) + 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 [CIP-122](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md). +{-# 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 + 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 [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 + | ix < 0 = do + emit "readBit: index out of bounds" + emit $ "Index: " <> (pack . show $ ix) + evaluationFailure + | ix >= len * 8 = 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 [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 + 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 = 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 [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 + 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 a10228f5f80..a34d129237f 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 + | AndByteString + | OrByteString + | XorByteString + | ComplementByteString + | ReadBit + | WriteBits + | ReplicateByteString deriving stock (Show, Eq, Ord, Enum, Bounded, Generic, Ix) deriving anyclass (NFData, Hashable, PrettyBy PrettyConfigPlc) @@ -1805,21 +1814,80 @@ 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 AndByteString = + let andByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + andByteStringDenotation = Logical.andByteString + {-# INLINE andByteStringDenotation #-} + in makeBuiltinMeaning + andByteStringDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + + toBuiltinMeaning _semvar OrByteString = + let orByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + orByteStringDenotation = Logical.orByteString + {-# INLINE orByteStringDenotation #-} + in makeBuiltinMeaning + orByteStringDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + + toBuiltinMeaning _semvar XorByteString = + let xorByteStringDenotation :: Bool -> BS.ByteString -> BS.ByteString -> BS.ByteString + xorByteStringDenotation = Logical.xorByteString + {-# INLINE xorByteStringDenotation #-} + in makeBuiltinMeaning + xorByteStringDenotation + (runCostingFunThreeArguments . unimplementedCostingFun) + + toBuiltinMeaning _semvar ComplementByteString = + let complementByteStringDenotation :: BS.ByteString -> BS.ByteString + complementByteStringDenotation = Logical.complementByteString + {-# INLINE complementByteStringDenotation #-} + in makeBuiltinMeaning + complementByteStringDenotation + (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 ReplicateByteString = + let byteStringReplicateDenotation :: Int -> Word8 -> BuiltinResult BS.ByteString + byteStringReplicateDenotation = Logical.replicateByteString + {-# INLINE byteStringReplicateDenotation #-} + in makeBuiltinMeaning + byteStringReplicateDenotation + (runCostingFunTwoArguments . unimplementedCostingFun) + -- See Note [Inlining meanings of builtins]. {-# INLINE toBuiltinMeaning #-} @@ -1947,6 +2015,14 @@ instance Flat DefaultFun where IntegerToByteString -> 73 ByteStringToInteger -> 74 + AndByteString -> 75 + OrByteString -> 76 + XorByteString -> 77 + ComplementByteString -> 78 + ReadBit -> 79 + WriteBits -> 80 + ReplicateByteString -> 81 + decode = go =<< decodeBuiltin where go 0 = pure AddInteger go 1 = pure SubtractInteger @@ -2023,6 +2099,13 @@ instance Flat DefaultFun where go 72 = pure Blake2b_224 go 73 = pure IntegerToByteString go 74 = pure ByteStringToInteger + 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 go t = fail $ "Failed to decode builtin tag, got: " ++ show t size _ n = n + builtinTagWidth 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..4db5179eb6b 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. + 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/Conversion.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Conversion.hs index c4547df890b..ba5929d7ff1 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 1212d1167e7..83041a34e83 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 @@ -39,20 +40,19 @@ import PlutusCore.StdLib.Data.ScottList qualified as Scott import PlutusCore.StdLib.Data.ScottUnit qualified as Scott 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.SignatureVerification (ecdsaSecp256k1Prop, ed25519_VariantAProp, - ed25519_VariantBProp, ed25519_VariantCProp, - schnorrSecp256k1Prop) - - import Control.Exception import Data.ByteString (ByteString, pack) import Data.DList qualified as DList import Data.Proxy import Data.String (IsString (fromString)) import Data.Text (Text) +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_VariantAProp, + ed25519_VariantBProp, ed25519_VariantCProp, + schnorrSecp256k1Prop) import Hedgehog hiding (Opaque, Size, Var) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -889,7 +889,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" [ @@ -899,10 +899,56 @@ 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 ] ] +-- 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) . + testGroup "Logical" $ [ + testGroup "andByteString" [ + 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 "orByteString" [ + 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 "xorByteString" [ + Laws.abelianSemigroupLaws "truncation" PLC.XorByteString False, + Laws.absorbtionLaw "truncation" PLC.XorByteString False "", + Laws.xorInvoluteLaw, + Laws.abelianMonoidLaws "padding" PLC.XorByteString True "" + ], + testGroup "bitwiseLogicalComplement" [ + Laws.complementSelfInverse, + Laws.deMorgan + ], + testGroup "bit reading and modification" [ + Laws.getSet, + Laws.setGet, + Laws.setSet, + Laws.writeBitsHomomorphismLaws + ], + testGroup "replicateByteString" [ + Laws.replicateHomomorphismLaws, + Laws.replicateIndex + ] + ] + test_definition :: TestTree test_definition = testGroup "definition" @@ -938,4 +984,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..a7bbe8021ea --- /dev/null +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs @@ -0,0 +1,565 @@ +-- editorconfig-checker-disable-file +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Evaluation.Builtins.Laws ( + abelianSemigroupLaws, + abelianMonoidLaws, + idempotenceLaw, + absorbtionLaw, + leftDistributiveLaw, + distributiveLaws, + 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, typecheckReadKnownCek) +import GHC.Exts (fromString) +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) +import PlutusCore qualified as PLC +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModelForTesting) +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 + +-- | 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 + b <- forAll . Gen.integral . Range.constant 0 $ 255 + i <- forAll . Gen.integral . Range.linear 0 $ n - 1 + let lhsInner = mkIterAppNoAnn (builtin () PLC.ReplicateByteString) [ + 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 + +-- | 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 + bs <- forAllByteString1 + i <- forAllIndexOf bs + let lookupExp = mkIterAppNoAnn (builtin () PLC.ReadBit) [ + mkConstant @ByteString () bs, + mkConstant @Integer () i + ] + case typecheckReadKnownCek def defaultBuiltinCostModelForTesting 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 + +-- | 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 + 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 + +-- | If you write twice to the same bit index, the second write should win. +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 + +-- | 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" [ + 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 + +-- | 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" [ + 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.ReplicateByteString) [ + 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.ReplicateByteString) [ + mkConstant @Integer () n1, + mkConstant @Integer () b + ] + let lhsInner2 = mkIterAppNoAnn (builtin () PLC.ReplicateByteString) [ + mkConstant @Integer () n2, + mkConstant @Integer () b + ] + let lhs = mkIterAppNoAnn (builtin () PLC.AppendByteString) [ + lhsInner1, + lhsInner2 + ] + let rhs = mkIterAppNoAnn (builtin () PLC.ReplicateByteString) [ + mkConstant @Integer () (n1 + n2), + mkConstant @Integer () b + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + rhs + ] + evaluateAndVerify (mkConstant @Bool () True) compareExp + +-- | If you complement a 'ByteString' twice, nothing should change. +complementSelfInverse :: TestTree +complementSelfInverse = + testPropertyNamed "self-inverse" "self_inverse" . property $ do + bs <- forAllByteString + let lhsInner = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ + mkConstant @ByteString () bs + ] + let lhs = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ + lhsInner + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () bs + ] + 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.AndByteString $ PLC.OrByteString, + testPropertyNamed "NOT OR -> AND" "demorgan_or" . go PLC.OrByteString $ PLC.AndByteString + ] + 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.ComplementByteString) [ + lhsInner + ] + let rhsInner1 = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ + mkConstant @ByteString () bs1 + ] + let rhsInner2 = mkIterAppNoAnn (builtin () PLC.ComplementByteString) [ + 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 + +-- | If you XOR any 'ByteString' with itself twice, nothing should change. +xorInvoluteLaw :: TestTree +xorInvoluteLaw = testPropertyNamed "involute (both)" "involute_both" . property $ do + bs <- forAllByteString + semantics <- forAllWith showSemantics Gen.bool + let lhsInner = mkIterAppNoAnn (builtin () PLC.XorByteString) [ + mkConstant @Bool () semantics, + mkConstant @ByteString () bs, + mkConstant @ByteString () bs + ] + let lhs = mkIterAppNoAnn (builtin () PLC.XorByteString) [ + mkConstant @Bool () semantics, + mkConstant @ByteString () bs, + lhsInner + ] + let compareExp = mkIterAppNoAnn (builtin () PLC.EqualsByteString) [ + lhs, + mkConstant @ByteString () bs + ] + 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 <> ")") [ + testPropertyNamed "left distribution" "left_distribution" (leftDistProp f 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 <> ")") [ + testPropertyNamed "commutativity" "commutativity" (commProp 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 <> ")") [ + testPropertyNamed "commutativity" "commutativity" (commProp f isPadding), + testPropertyNamed "associativity" "associativity" (assocProp f isPadding), + 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 <> ")") + ("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 + +-- | 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 <> ")") + ("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 + +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 + 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 + +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 + 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 defaultBuiltinCostModelForTesting actual of + Left x -> annotateShow x >> failure + Right (res, logs) -> case res of + PLC.EvaluationFailure -> annotateShow logs >> failure + PLC.EvaluationSuccess r -> r === expected + diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index 24a553dd651..4a68bb38c4c 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -118,6 +118,10 @@ 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 + ]), + ((PlutusV3, futurePV), Set.fromList [ + 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 e75dde029ec..c8741b870ee 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -276,6 +276,14 @@ builtinNames = [ , 'Builtins.integerToByteString , 'Builtins.byteStringToInteger + + , 'Builtins.andByteString + , 'Builtins.orByteString + , 'Builtins.xorByteString + , 'Builtins.complementByteString + , 'Builtins.readBit + , 'Builtins.writeBits + , 'Builtins.replicateByteString ] defineBuiltinTerm :: CompilingDefault uni fun m ann => Ann -> TH.Name -> PIRTerm uni fun -> m () @@ -433,6 +441,15 @@ defineBuiltinTerms = do PLC.IntegerToByteString -> defineBuiltinInl 'Builtins.integerToByteString PLC.ByteStringToInteger -> defineBuiltinInl 'Builtins.byteStringToInteger + -- Logical operations + 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 + defineBuiltinTypes :: CompilingDefault uni fun m ann => m () 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/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..eb9750f68f3 --- /dev/null +++ b/plutus-tx/changelog.d/20240510_110418_koz.ross_logical.md @@ -0,0 +1,38 @@ + + + +### Added + +- 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 + +- References to CIP-0087 now correctly refer to CIP-121. + + + + diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 5e9550d9bb6..e242df14841 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -110,6 +110,14 @@ module PlutusTx.Builtins ( , toBuiltin , integerToByteString , byteStringToInteger + -- * Logical + , andByteString + , orByteString + , xorByteString + , complementByteString + , readBit + , writeBits + , replicateByteString ) where import Data.Maybe @@ -624,9 +632,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 +651,7 @@ integerToByteString :: ByteOrder -> Integer -> Integer -> BuiltinByteString integerToByteString endianness = BI.integerToByteString (toOpaque (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. @@ -652,3 +659,131 @@ integerToByteString endianness = BI.integerToByteString (toOpaque (byteOrderToBo byteStringToInteger :: ByteOrder -> BuiltinByteString -> Integer byteStringToInteger endianness = BI.byteStringToInteger (toOpaque (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-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. +-- +-- = See also +-- +-- * [Padding and truncation +-- 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 andByteString #-} +andByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +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). +-- +-- 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-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 orByteString #-} +orByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +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). +-- +-- 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-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 xorByteString #-} +xorByteString :: + Bool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +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). +-- +-- = See also +-- +-- * [Bit indexing +-- scheme](https://github.com/mlabs-haskell/CIPs/blob/koz/logic-ops/CIP-0122/CIP-0122.md#bit-indexing-scheme) +{-# INLINEABLE complementByteString #-} +complementByteString :: + BuiltinByteString -> + BuiltinByteString +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 +-- '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-0122/CIP-0122.md#bit-indexing-scheme) +-- * [Operation +-- 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 = fromOpaque (BI.readBit bs i) + +-- | Given a 'BuiltinByteString' and a changelist of index-value pairs, set the _bit_ at each index +-- where the corresponding value is 'True', and clear the bit at each index where the corresponding +-- value is 'False'. Will error if any of the indexes are out-of-bounds: that is, if the index is +-- either negative, or equal to or greater than the total number of bits in the 'BuiltinByteString' +-- argument. +-- +-- = See also +-- +-- * [Bit indexing +-- 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-0122/CIP-0122.md#writebits) +{-# 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-0122/CIP-0122.md#replicateByteString) +{-# INLINEABLE replicateByteString #-} +replicateByteString :: + Integer -> + Integer -> + BuiltinByteString +replicateByteString = BI.replicateByteString diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 229e0968d92..38da315b54c 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 andByteString #-} +andByteString :: + BuiltinBool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +andByteString (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.andByteString isPaddingSemantics data1 $ data2 + +{-# NOINLINE orByteString #-} +orByteString :: + BuiltinBool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +orByteString (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.orByteString isPaddingSemantics data1 $ data2 + +{-# NOINLINE xorByteString #-} +xorByteString :: + BuiltinBool -> + BuiltinByteString -> + BuiltinByteString -> + BuiltinByteString +xorByteString (BuiltinBool isPaddingSemantics) (BuiltinByteString data1) (BuiltinByteString data2) = + BuiltinByteString . Logical.xorByteString isPaddingSemantics data1 $ data2 + +{-# NOINLINE complementByteString #-} +complementByteString :: + BuiltinByteString -> + BuiltinByteString +complementByteString (BuiltinByteString bs) = + BuiltinByteString . Logical.complementByteString $ 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 replicateByteString #-} +replicateByteString :: + BuiltinInteger -> + BuiltinInteger -> + BuiltinByteString +replicateByteString n w8 = + case Logical.replicateByteString (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