From 0ce86be1146506c0e67c22f9ff7db3e008140e17 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 24 Jun 2022 13:46:37 +1200 Subject: [PATCH 01/73] Start on bitwise primitive implementations in Core --- plutus-core/plutus-core.cabal | 2 + plutus-core/plutus-core/src/Bitwise.hs | 240 +++++++++++++++++++++++++ 2 files changed, 242 insertions(+) create mode 100644 plutus-core/plutus-core/src/Bitwise.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 137afeb5636..71f108453cf 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -49,6 +49,7 @@ common lang library import: lang exposed-modules: + Bitwise Crypto Data.ByteString.Hash Data.Either.Extras @@ -304,6 +305,7 @@ library , semigroups >=0.19.1 , serialise , some <1.0.3 + , split , template-haskell , text , th-compat diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs new file mode 100644 index 00000000000..077dc08f41a --- /dev/null +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Bitwise ( + integerToByteString, + byteStringToInteger, + andByteString, + iorByteString, + xorByteString, + complementByteString, + popCountByteString + ) where + +import Data.Bits (FiniteBits, bit, complement, popCount, shiftL, xor, (.&.), (.|.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, unsafeUseAsCStringLen) +import Data.Foldable (foldl') +import Data.Kind (Type) +import Data.List.Split (chunksOf) +import Data.Text (Text, pack) +import Data.Word (Word64, Word8) +import Foreign.C.Types (CChar) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (Storable (peek, poke)) +import GHC.Exts (fromList) +import PlutusCore.Builtin.Emitter (Emitter, emit) +import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure)) +import System.IO.Unsafe (unsafeDupablePerformIO) + +integerToByteString :: Integer -> ByteString +integerToByteString i = case signum i of + 0 -> BS.singleton 0 + (-1) -> twosComplement . integerToByteString . abs $ i + _ -> fromList . intoBytes . toBitSequence $ i + +byteStringToInteger :: ByteString -> Integer +byteStringToInteger bs = let len = BS.length bs in + snd . foldl' go (1, 0) $ [len - 1, len - 2 .. 0] + where + go :: (Integer, Integer) -> Int -> (Integer, Integer) + go (e, acc) ix = (e * 256, acc + e * (fromIntegral . BS.index bs $ ix)) + +{-# NOINLINE popCountByteString #-} +popCountByteString :: ByteString -> Integer +popCountByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go + where + go :: (Ptr CChar, Int) -> IO Integer + go (ptr, len) = do + let (bigSteps, smallSteps) = len `quotRem` 8 + let bigPtr :: Ptr Word64 = castPtr ptr + let smallPtr :: Ptr Word8 = castPtr . plusPtr ptr $ bigSteps * 8 + bigCount <- countBits bigPtr bigSteps + smallCount <- countBits smallPtr smallSteps + pure . fromIntegral $ bigCount + smallCount + +{-# NOINLINE andByteString #-} +andByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) +andByteString bs bs' + | BS.length bs /= BS.length bs' = mismatchedLengthError "andByteString" bs bs' + | otherwise = pure . pure . unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> + unsafeUseAsCString bs' $ \ptr' -> + zipBuild (.&.) ptr ptr' len >>= (unsafePackMallocCStringLen . (,len)) + +{-# NOINLINE iorByteString #-} +iorByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) +iorByteString bs bs' + | BS.length bs /= BS.length bs' = mismatchedLengthError "iorByteString" bs bs' + | otherwise = pure . pure . unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> + unsafeUseAsCString bs' $ \ptr' -> + zipBuild (.|.) ptr ptr' len >>= (unsafePackMallocCStringLen . (,len)) + +{-# NOINLINE xorByteString #-} +xorByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) +xorByteString bs bs' + | BS.length bs /= BS.length bs' = mismatchedLengthError "xorByteString" bs bs' + | otherwise = pure . pure . unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> + unsafeUseAsCString bs' $ \ptr' -> + zipBuild xor ptr ptr' len >>= (unsafePackMallocCStringLen . (,len)) + +{-# NOINLINE complementByteString #-} +complementByteString :: ByteString -> ByteString +complementByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> do + resPtr <- mallocBytes len + let (bigSteps, smallSteps) = len `quotRem` 8 + let bigDst :: Ptr Word64 = castPtr resPtr + let smallDst :: Ptr Word8 = castPtr . plusPtr resPtr $ bigSteps * 8 + let bigSrc :: Ptr Word64 = castPtr ptr + let smallSrc :: Ptr Word8 = castPtr . plusPtr ptr $ bigSteps * 8 + go bigDst bigSrc 0 bigSteps + go smallDst smallSrc 0 smallSteps + unsafePackMallocCStringLen (resPtr, len) + where + go :: forall (a :: Type) . + (Storable a, FiniteBits a) => + Ptr a -> Ptr a -> Int -> Int -> IO () + go dst src offset lim + | offset == lim = pure () + | otherwise = do + block :: a <- peek . plusPtr src $ offset + poke dst . complement $ block + go dst src (offset + 1) lim + +-- Helpers + +toBitSequence :: Integer -> [Bool] +toBitSequence i = go 0 (separateBit i) [] + where + go :: Int -> Maybe (Integer, Bool) -> [Bool] -> [Bool] + go len curr acc = case curr of + Nothing -> case len `rem` 8 of + 0 -> acc + _ -> go (len + 1) Nothing (False : acc) + Just (d, b) -> go (len + 1) (separateBit d) (b : acc) + +separateBit :: Integer -> Maybe (Integer, Bool) +separateBit i = case i of + 0 -> Nothing + _ -> Just . fmap go $ i `quotRem` 2 + where + go :: Integer -> Bool + go = \case + 0 -> False + _ -> True + +intoBytes :: [Bool] -> [Word8] +intoBytes = fmap go . chunksOf 8 + where + go :: [Bool] -> Word8 + go = \case + [b7, b6, b5, b4, b3, b2, b1, b0] -> + let b0Val = if b0 then 1 else 0 + b1Val = if b1 then 2 else 0 + b2Val = if b2 then 4 else 0 + b3Val = if b3 then 8 else 0 + b4Val = if b4 then 16 else 0 + b5Val = if b5 then 32 else 0 + b6Val = if b6 then 64 else 0 + b7Val = if b7 then 128 else 0 in + b0Val + b1Val + b2Val + b3Val + b4Val + b5Val + b6Val + b7Val + _ -> 0 -- should never happen + +twosComplement :: ByteString -> ByteString +twosComplement bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> do + dst <- mallocBytes len + let src :: Ptr Word8 = castPtr ptr + go dst src 1 len False + unsafePackMallocCStringLen (castPtr dst, len) + where + go :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> Bool -> IO () + go dst src offset len added + | offset > len = pure () + | otherwise = do + w8 :: Word8 <- peek . plusPtr src $ len - offset + if added + then do + poke (plusPtr dst $ len - offset) (complement w8) + go dst src (offset + 1) len added + else do + let (added', w8') = computeAddByte w8 + poke (plusPtr dst $ len - offset) w8' + go dst src (offset + 1) len added' + +computeAddByte :: Word8 -> (Bool, Word8) +computeAddByte = \case + 0 -> (False, 0) + w8 -> go 0 (False, 0) $ w8 `quotRem` 2 + where + go :: Int -> (Bool, Word8) -> (Word8, Word8) -> (Bool, Word8) + go step acc@(added, w8) (d, r) + | step == 8 = acc + | otherwise = let mask = bit 0 `shiftL` step + dr' = d `quotRem` 2 in + if added + then go (step + 1) (added, w8 `xor` mask) dr' + else case r of + 0 -> go (step + 1) acc dr' + _ -> go (step + 1) (True, w8 .|. mask) dr' + +mismatchedLengthError :: forall (a :: Type) . + Text -> + ByteString -> + ByteString -> + Emitter (EvaluationResult a) +mismatchedLengthError loc bs bs' = do + emit $ loc <> " failed" + emit "Reason: mismatched argument lengths" + emit $ "Length of first argument: " <> (pack . show . BS.length $ bs) + emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') + pure EvaluationFailure + +zipBuild :: + (forall (a :: Type) . (FiniteBits a, Storable a) => a -> a -> a) -> + Ptr CChar -> + Ptr CChar -> + Int -> + IO (Ptr CChar) +zipBuild f ptr ptr' len = do + resPtr <- mallocBytes len + let (bigSteps, smallSteps) = len `quotRem` 8 + let bigPtr :: Ptr Word64 = castPtr resPtr + let smallPtr :: Ptr Word8 = castPtr . plusPtr resPtr $ bigSteps * 8 + go bigPtr (castPtr ptr) (castPtr ptr') 0 bigSteps + let ptrRest :: Ptr Word8 = castPtr . plusPtr ptr $ bigSteps * 8 + let ptrRest' :: Ptr Word8 = castPtr . plusPtr ptr' $ bigSteps * 8 + go smallPtr ptrRest ptrRest' 0 smallSteps + pure resPtr + where + go :: forall (b :: Type) . + (FiniteBits b, Storable b) => + Ptr b -> + Ptr b -> + Ptr b -> + Int -> + Int -> + IO () + go dst src src' offset lim + | offset == lim = pure () + | otherwise = do + block :: b <- peek . plusPtr src $ offset + block' :: b <- peek . plusPtr src' $ offset + poke (plusPtr dst offset) (f block block') + go dst src src' (offset + 1) lim + +countBits :: forall (a :: Type) . + (FiniteBits a, Storable a) => + Ptr a -> Int -> IO Int +countBits ptr len = go 0 0 + where + go :: Int -> Int -> IO Int + go total offset + | offset == len = pure total + | otherwise = do + block :: a <- peek . plusPtr ptr $ offset + let total' = total + popCount block + go total' (offset + 1) From 2ec6f0e72fa42907d663fe7ee9c72a1d2369a8ad Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 27 Jun 2022 13:24:26 +1200 Subject: [PATCH 02/73] Remaining implementations of bitwise operations --- plutus-core/plutus-core/src/Bitwise.hs | 199 ++++++++++++++++++++++++- 1 file changed, 192 insertions(+), 7 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 077dc08f41a..86cef51090c 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -11,14 +11,21 @@ module Bitwise ( iorByteString, xorByteString, complementByteString, - popCountByteString + popCountByteString, + testBitByteString, + writeBitByteString, + findFirstSetByteString, + shiftByteString, + rotateByteString, ) where -import Data.Bits (FiniteBits, bit, complement, popCount, shiftL, xor, (.&.), (.|.)) +import Control.Monad (foldM_, unless) +import Data.Bits (FiniteBits, bit, complement, popCount, shiftL, shiftR, xor, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, unsafeUseAsCStringLen) -import Data.Foldable (foldl') +import Data.Foldable (foldl', for_) +import Data.Functor (void) import Data.Kind (Type) import Data.List.Split (chunksOf) import Data.Text (Text, pack) @@ -26,12 +33,149 @@ import Data.Word (Word64, Word8) import Foreign.C.Types (CChar) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (Storable (peek, poke)) +import Foreign.Storable (Storable (peek, poke, sizeOf)) import GHC.Exts (fromList) +import GHC.IO.Handle.Text (memcpy) import PlutusCore.Builtin.Emitter (Emitter, emit) import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure)) import System.IO.Unsafe (unsafeDupablePerformIO) +{-# NOINLINE rotateByteString #-} +rotateByteString :: ByteString -> Integer -> ByteString +rotateByteString bs i = case magnitude `rem` bitLength of + 0 -> bs -- nothing to do irrespective of direction + actualMagnitude -> case signum i of + 0 -> bs -- dummy case that never happens + (-1) -> + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ decreasingRotation actualMagnitude + _ -> + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ increasingRotation actualMagnitude + where + magnitude :: Int + magnitude = fromIntegral . abs $ i + bitLength :: Int + bitLength = BS.length bs * 8 + decreasingRotation :: Int -> (Ptr CChar, Int) -> IO ByteString + decreasingRotation actualMagnitude (src, len) = do + let (bigShift, smallShift) = actualMagnitude `quotRem` 8 + dst <- mallocBytes len + -- rotate over bytes + for_ [0 .. len - 1] $ \srcIx -> do + byte :: Word8 <- peek . plusPtr src $ srcIx + let dstIx = (srcIx + bigShift) `mod` len + poke (plusPtr dst dstIx) byte + endByte :: Word8 <- peek . plusPtr src $ len - 1 + let mask = endByte `shiftL` (8 - smallShift) + unless (smallShift == 0) + (foldM_ (decreasingFixUp smallShift dst) mask [0 .. len - 1]) + unsafePackMallocCStringLen (dst, len) + increasingRotation :: Int -> (Ptr CChar, Int) -> IO ByteString + increasingRotation actualMagnitude (src, len) = do + let (bigShift, smallShift) = actualMagnitude `quotRem` 8 + dst <- mallocBytes len + for_ [0 .. len - 1] $ \srcIx -> do + byte :: Word8 <- peek . plusPtr src $ srcIx + let dstIx = (srcIx + len - bigShift) `mod` len + poke (plusPtr dst dstIx) byte + startByte :: Word8 <- peek . castPtr $ src + let mask = startByte `shiftR` smallShift + unless (smallShift == 0) + (foldM_ (increasingFixUp smallShift dst) mask [len - 1, len - 2 .. 0]) + unsafePackMallocCStringLen (dst, len) + +{-# NOINLINE shiftByteString #-} +shiftByteString :: ByteString -> Integer -> ByteString +shiftByteString bs i + | magnitude >= bitLength = BS.replicate (BS.length bs) 0 + | otherwise = case signum i of + 0 -> bs + (-1) -> + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ decreasingShift + _ -> + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ increasingShift + where + magnitude :: Int + magnitude = fromIntegral . abs $ i + bitLength :: Int + bitLength = BS.length bs * 8 + decreasingShift :: (Ptr CChar, Int) -> IO ByteString + decreasingShift (src, len) = do + let (bigShift, smallShift) = magnitude `quotRem` 8 + dst <- mallocBytes len + -- clear the first bigShift bytes + for_ [0 .. bigShift - 1] $ \j -> poke (plusPtr dst j) (0 :: CChar) + -- copy in the rest, offset by bigShift + void . memcpy (plusPtr dst bigShift) src . fromIntegral $ len - bigShift + -- correct any outstanding shifts + unless (smallShift == 0) + (foldM_ (decreasingFixUp smallShift dst) 0 [bigShift .. len - 1]) + -- pack it all up and go + unsafePackMallocCStringLen (dst, len) + increasingShift :: (Ptr CChar, Int) -> IO ByteString + increasingShift (src, len) = do + let (bigShift, smallShift) = magnitude `quotRem` 8 + dst <- mallocBytes len + -- copy in the last len - bigShift bytes, offset to start from 0 + void . memcpy dst (plusPtr src bigShift) . fromIntegral $ len - bigShift + -- clear the rest + for_ [len - bigShift, len - bigShift + 1 .. len - 1] $ \j -> poke (plusPtr dst j) (0 :: CChar) + -- correct any outstanding shifts + unless (smallShift == 0) + (foldM_ (increasingFixUp smallShift dst) 0 [len - bigShift - 1, len - bigShift .. 0]) + -- pack it all up and go + unsafePackMallocCStringLen (dst, len) + +findFirstSetByteString :: ByteString -> Integer +findFirstSetByteString bs = foldl' go (-1) [0 .. len - 1] + where + go :: Integer -> Int -> Integer + go acc ix + | acc /= (-1) = acc -- we found one already + | otherwise = case BS.index bs (len - ix - 1) of + 0 -> (-1) -- keep looking, nothing to find here + w8 -> fromIntegral $ (ix * 8) + findPosition w8 + len :: Int + len = BS.length bs + +testBitByteString :: ByteString -> Integer -> Emitter (EvaluationResult Bool) +testBitByteString bs i + | i < 0 || i >= bitLen = indexOutOfBoundsError "testBitByteString" bitLen i + | otherwise = do + let (bigOffset, smallOffset) = i `quotRem` 8 + let bigIx = fromIntegral $ byteLen - bigOffset - 1 + let mask = bit 0 `shiftL` fromIntegral smallOffset + pure . pure $ case mask .&. BS.index bs bigIx of + 0 -> False + _ -> True + where + byteLen :: Integer + byteLen = fromIntegral . BS.length $ bs + bitLen :: Integer + bitLen = byteLen * 8 + +{-# NOINLINE writeBitByteString #-} +writeBitByteString :: ByteString -> Integer -> Bool -> Emitter (EvaluationResult ByteString) +writeBitByteString bs i b + | i < 0 || i >= bitLen = indexOutOfBoundsError "writeBitByteString" bitLen i + | otherwise = do + let (bigOffset, smallOffset) = i `quotRem` 8 + let bigIx = fromIntegral $ byteLen - bigOffset - 1 + let mask = bit 0 `shiftL` fromIntegral smallOffset + pure . pure . unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go bigIx mask + where + byteLen :: Integer + byteLen = fromIntegral . BS.length $ bs + bitLen :: Integer + bitLen = byteLen * 8 + go :: Int -> Word8 -> (Ptr CChar, Int) -> IO ByteString + go bigIx mask (src, len) = do + dst <- mallocBytes len + void . memcpy dst src . fromIntegral $ len + byte :: Word8 <- peek . plusPtr src $ bigIx + let byte' = if b then mask .|. byte else complement mask .&. byte + poke (castPtr . plusPtr src $ bigIx) byte' + unsafePackMallocCStringLen (dst, len) + integerToByteString :: Integer -> ByteString integerToByteString i = case signum i of 0 -> BS.singleton 0 @@ -193,6 +337,18 @@ mismatchedLengthError loc bs bs' = do emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') pure EvaluationFailure +indexOutOfBoundsError :: forall (a :: Type) . + Text -> + Integer -> + Integer -> + Emitter (EvaluationResult a) +indexOutOfBoundsError loc lim i = do + emit $ loc <> " failed" + emit "Reason: out of bounds" + emit $ "Attempted access at index " <> (pack . show $ i) + emit $ "Valid indexes: from 0 to " <> (pack . show $ lim - 1) + pure EvaluationFailure + zipBuild :: (forall (a :: Type) . (FiniteBits a, Storable a) => a -> a -> a) -> Ptr CChar -> @@ -221,11 +377,40 @@ zipBuild f ptr ptr' len = do go dst src src' offset lim | offset == lim = pure () | otherwise = do - block :: b <- peek . plusPtr src $ offset - block' :: b <- peek . plusPtr src' $ offset - poke (plusPtr dst offset) (f block block') + let offset' = sizeOf (undefined :: b) * offset + block :: b <- peek . plusPtr src $ offset' + block' :: b <- peek . plusPtr src' $ offset' + poke (plusPtr dst offset') (f block block') go dst src src' (offset + 1) lim +findPosition :: Word8 -> Int +findPosition w8 = foldl' go 7 . fmap (\i -> (i, bit 0 `shiftL` i)) $ [0 .. 7] + where + go :: Int -> (Int, Word8) -> Int + go acc (i, mask) = case mask .&. w8 of + 0 -> acc -- nothing to see here, move along + _ -> min acc i + +decreasingFixUp :: Int -> Ptr CChar -> Word8 -> Int -> IO Word8 +decreasingFixUp smallShift dst mask ix = do + let ptr = plusPtr dst ix + byte :: Word8 <- peek ptr + let bitsWeCareAbout = byte `shiftR` smallShift + let mask' = byte `shiftL` (8 - smallShift) + let masked = bitsWeCareAbout .|. mask + poke ptr masked + pure mask' + +increasingFixUp :: Int -> Ptr CChar -> Word8 -> Int -> IO Word8 +increasingFixUp smallShift dst mask ix = do + let ptr = plusPtr dst ix + byte :: Word8 <- peek ptr + let bitsWeCareAbout = byte `shiftL` smallShift + let mask' = byte `shiftR` (8 - smallShift) + let masked = bitsWeCareAbout .|. mask + poke ptr masked + pure mask' + countBits :: forall (a :: Type) . (FiniteBits a, Storable a) => Ptr a -> Int -> IO Int From 0e0ae36b7e9ffb89fe266ac55368cedb8b93f81d Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 28 Jun 2022 07:51:40 +1200 Subject: [PATCH 03/73] Plutus Core builtins for bitwise ops --- .../src/PlutusCore/Default/Builtins.hs | 67 +++++++++++++++++++ .../src/PlutusLedgerApi/Common/Versions.hs | 7 ++ 2 files changed, 74 insertions(+) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 267feeb0134..c3e05287953 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Werror #-} module PlutusCore.Default.Builtins where @@ -23,6 +24,9 @@ import PlutusCore.Evaluation.Machine.ExMemory import PlutusCore.Evaluation.Result import PlutusCore.Pretty +import Bitwise (andByteString, byteStringToInteger, complementByteString, findFirstSetByteString, integerToByteString, + iorByteString, popCountByteString, rotateByteString, shiftByteString, testBitByteString, + writeBitByteString, xorByteString) import Codec.Serialise (serialise) import Crypto (verifyEcdsaSecp256k1Signature, verifyEd25519Signature, verifySchnorrSecp256k1Signature) import Data.ByteString qualified as BS @@ -115,6 +119,19 @@ data DefaultFun | MkPairData | MkNilData | MkNilPairData + -- Bitwise + | IntegerToByteString + | ByteStringToInteger + | AndByteString + | IorByteString + | XorByteString + | ComplementByteString + | ShiftByteString + | RotateByteString + | PopCountByteString + | TestBitByteString + | WriteBitByteString + | FindFirstSetByteString deriving stock (Show, Eq, Ord, Enum, Bounded, Generic, Ix) deriving anyclass (NFData, Hashable, PrettyBy PrettyConfigPlc) @@ -1333,6 +1350,31 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where makeBuiltinMeaning (\() -> [] @(Data,Data)) (runCostingFunOneArgument . paramMkNilPairData) + -- Bitwise + toBuiltinMeaning IntegerToByteString = + makeBuiltinMeaning integerToByteString mempty + toBuiltinMeaning ByteStringToInteger = + makeBuiltinMeaning byteStringToInteger mempty + toBuiltinMeaning AndByteString = + makeBuiltinMeaning andByteString mempty + toBuiltinMeaning IorByteString = + makeBuiltinMeaning iorByteString mempty + toBuiltinMeaning XorByteString = + makeBuiltinMeaning xorByteString mempty + toBuiltinMeaning ComplementByteString = + makeBuiltinMeaning complementByteString mempty + toBuiltinMeaning ShiftByteString = + makeBuiltinMeaning shiftByteString mempty + toBuiltinMeaning RotateByteString = + makeBuiltinMeaning rotateByteString mempty + toBuiltinMeaning PopCountByteString = + makeBuiltinMeaning popCountByteString mempty + toBuiltinMeaning TestBitByteString = + makeBuiltinMeaning testBitByteString mempty + toBuiltinMeaning WriteBitByteString = + makeBuiltinMeaning writeBitByteString mempty + toBuiltinMeaning FindFirstSetByteString = + makeBuiltinMeaning findFirstSetByteString mempty -- See Note [Inlining meanings of builtins]. {-# INLINE toBuiltinMeaning #-} @@ -1416,6 +1458,19 @@ instance Flat DefaultFun where MkNilPairData -> 50 SerialiseData -> 51 + IntegerToByteString -> 54 + ByteStringToInteger -> 55 + AndByteString -> 56 + IorByteString -> 57 + XorByteString -> 58 + ComplementByteString -> 59 + ShiftByteString -> 60 + RotateByteString -> 61 + PopCountByteString -> 62 + TestBitByteString -> 63 + WriteBitByteString -> 64 + FindFirstSetByteString -> 65 + decode = go =<< decodeBuiltin where go 0 = pure AddInteger go 1 = pure SubtractInteger @@ -1471,6 +1526,18 @@ instance Flat DefaultFun where go 51 = pure SerialiseData go 52 = pure VerifyEcdsaSecp256k1Signature go 53 = pure VerifySchnorrSecp256k1Signature + go 54 = pure IntegerToByteString + go 55 = pure ByteStringToInteger + go 56 = pure AndByteString + go 57 = pure IorByteString + go 58 = pure XorByteString + go 59 = pure ComplementByteString + go 60 = pure ShiftByteString + go 61 = pure RotateByteString + go 62 = pure PopCountByteString + go 63 = pure TestBitByteString + go 64 = pure WriteBitByteString + go 65 = pure FindFirstSetByteString go t = fail $ "Failed to decode builtin tag, got: " ++ show t size _ n = n + builtinTagWidth diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs index 94dfac72c88..35ff274b7b4 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Versions.hs @@ -65,6 +65,13 @@ builtinsIntroducedIn = Map.fromList [ -- Vasil is protocolversion=7.0 ((PlutusV2, vasilPV), Set.fromList [ SerialiseData, VerifyEcdsaSecp256k1Signature, VerifySchnorrSecp256k1Signature + ]), + ((PlutusV3, changPV), Set.fromList [ + IntegerToByteString, ByteStringToInteger, + AndByteString, IorByteString, XorByteString, ComplementByteString, + ShiftByteString, RotateByteString, + TestBitByteString, WriteBitByteString, + PopCountByteString, FindFirstSetByteString ]) ] From d1579a619c0519ec7f3fbb3f24e07a06caf629e6 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 28 Jun 2022 15:25:08 +1200 Subject: [PATCH 04/73] More bitwise operation checks, fix bug in complement --- plutus-core/plutus-core.cabal | 2 + plutus-core/plutus-core/src/Bitwise.hs | 5 +- .../test/Evaluation/Builtins/Bitwise.hs | 318 ++++++++++++++++++ .../test/Evaluation/Builtins/Definition.hs | 51 ++- 4 files changed, 371 insertions(+), 5 deletions(-) create mode 100644 plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 71f108453cf..abfcc54b064 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -257,6 +257,7 @@ library UntypedPlutusCore.Transform.ForceDelay UntypedPlutusCore.Transform.Inline + ghc-options: -fsimpl-tick-factor=200 build-depends: , aeson , algebraic-graphs >=0.3 @@ -470,6 +471,7 @@ test-suite untyped-plutus-core-test DeBruijn.Spec DeBruijn.UnDeBruijnify Evaluation.Builtins + Evaluation.Builtins.Bitwise Evaluation.Builtins.Coherence Evaluation.Builtins.Common Evaluation.Builtins.Definition diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 86cef51090c..307250aa3d6 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -245,8 +245,9 @@ complementByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \( go dst src offset lim | offset == lim = pure () | otherwise = do - block :: a <- peek . plusPtr src $ offset - poke dst . complement $ block + let offset' = offset * sizeOf (undefined :: a) + block :: a <- peek . plusPtr src $ offset' + poke (plusPtr dst offset') . complement $ block go dst src (offset + 1) lim -- Helpers diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs new file mode 100644 index 00000000000..47c168bfc57 --- /dev/null +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Werror #-} + +module Evaluation.Builtins.Bitwise ( + bitwiseAndCommutes, + bitwiseIorCommutes, + bitwiseXorCommutes, + bitwiseAndIdentity, + bitwiseIorIdentity, + bitwiseXorIdentity, + bitwiseAndAbsorbing, + bitwiseIorAbsorbing, + bitwiseXorComplement, + bitwiseAndSelf, + bitwiseIorSelf, + bitwiseXorSelf, + ) where + +import Control.Lens.Fold (Fold, folding, has, hasn't, preview) +import Data.Bitraversable (bitraverse) +import Data.Bits (complement, xor, zeroBits, (.&.), (.|.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Word (Word8) +import Evaluation.Builtins.Common (typecheckEvaluateCek) +import GHC.Exts (fromListN) +import Hedgehog (Gen, PropertyT, Range, annotate, cover, evalEither, failure, forAllWith, success, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import PlutusCore (DefaultFun (AndByteString, ComplementByteString, IorByteString, XorByteString), DefaultUni, + EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters) +import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) +import Text.Show.Pretty (ppShow) +import UntypedPlutusCore qualified as Untyped + +bitwiseIorCommutes :: PropertyT IO () +bitwiseIorCommutes = commutative (.|.) IorByteString + +bitwiseAndCommutes :: PropertyT IO () +bitwiseAndCommutes = commutative (.&.) AndByteString + +bitwiseXorCommutes :: PropertyT IO () +bitwiseXorCommutes = commutative xor XorByteString + +bitwiseAndIdentity :: PropertyT IO () +bitwiseAndIdentity = identity (complement zeroBits) AndByteString + +bitwiseIorIdentity :: PropertyT IO () +bitwiseIorIdentity = identity zeroBits IorByteString + +bitwiseXorIdentity :: PropertyT IO () +bitwiseXorIdentity = identity zeroBits XorByteString + +bitwiseAndAbsorbing :: PropertyT IO () +bitwiseAndAbsorbing = absorbing zeroBits AndByteString + +bitwiseIorAbsorbing :: PropertyT IO () +bitwiseIorAbsorbing = absorbing (complement zeroBits) IorByteString + +bitwiseXorComplement :: PropertyT IO () +bitwiseXorComplement = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + let len = BS.length bs + let allOnes = BS.replicate len . complement $ zeroBits + outcome1 <- goXor bs allOnes + outcome2 <- goComplement bs + case (outcome1, outcome2) of + (EvaluationSuccess res1, EvaluationSuccess res2) -> res1 === res2 + _ -> failure + where + goXor :: + ByteString -> + ByteString -> + PropertyT IO (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) + goXor leftArg rightArg = do + let leftArg' = mkConstant @ByteString () leftArg + let rightArg' = mkConstant @ByteString () rightArg + let comp = mkIterApp () (builtin () XorByteString) [leftArg', rightArg'] + cekEval comp + goComplement :: + ByteString -> + PropertyT IO (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) + goComplement bs = do + let bs' = mkConstant @ByteString () bs + let comp = mkIterApp () (builtin () ComplementByteString) [bs'] + cekEval comp + +bitwiseAndSelf :: PropertyT IO () +bitwiseAndSelf = self AndByteString + +bitwiseIorSelf :: PropertyT IO () +bitwiseIorSelf = self IorByteString + +bitwiseXorSelf :: PropertyT IO () +bitwiseXorSelf = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + let len = BS.length bs + let bs' = mkConstant @ByteString () bs + let expected = mkConstant @ByteString () . BS.replicate len $ zeroBits + let comp = mkIterApp () (builtin () XorByteString) [bs', bs'] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === expected + _ -> failure + +-- Helpers + +self :: DefaultFun -> PropertyT IO () +self b = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + let bs' = mkConstant @ByteString () bs + let comp = mkIterApp () (builtin () b) [bs', bs'] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant @ByteString () bs + _ -> failure + +data AbsorbingCase = + AbsorbingMismatched ByteString Int Word8 | + AbsorbingMatched ByteString Word8 + deriving stock (Eq, Show) + +_AbsorbingResult :: Fold AbsorbingCase ByteString +_AbsorbingResult = folding $ \case + AbsorbingMatched bs w8 -> pure . BS.replicate (BS.length bs) $ w8 + _ -> Nothing + +getAbsorbingArgs :: AbsorbingCase -> (ByteString, ByteString) +getAbsorbingArgs = \case + AbsorbingMismatched bs len w8 -> (bs, BS.replicate len w8) + AbsorbingMatched bs w8 -> (bs, BS.replicate (BS.length bs) w8) + +absorbing :: + Word8 -> + DefaultFun -> + PropertyT IO () +absorbing w8 b = do + testCase <- forAllWith ppShow . genAbsorbingCase $ w8 + cover 45 "mismatched lengths" . hasn't _AbsorbingResult $ testCase + cover 45 "matched lengths" . has _AbsorbingResult $ testCase + let expectedMay = preview _AbsorbingResult testCase + let (leftArg, rightArg) = getAbsorbingArgs testCase + outcome <- commutatively b leftArg rightArg + case (outcome, expectedMay) of + ((EvaluationFailure, EvaluationFailure), Nothing) -> success + (_, Nothing) -> do + annotate "Unexpected success" + failure + ((EvaluationSuccess l2r, EvaluationSuccess r2l), Just expected) -> do + l2r === r2l + l2r === mkConstant () expected + _ -> do + annotate "Unexpected failure" + failure + +data IdentityCase = + IdentityMismatched ByteString Int Word8 | + IdentityMatched ByteString Word8 + deriving stock (Eq, Show) + +_IdentityResult :: Fold IdentityCase ByteString +_IdentityResult = folding $ \case + IdentityMatched res _ -> pure res + _ -> Nothing + +getIdentityArgs :: IdentityCase -> (ByteString, ByteString) +getIdentityArgs = \case + IdentityMismatched bs len w8 -> (bs, BS.replicate len w8) + IdentityMatched bs w8 -> (bs, BS.replicate (BS.length bs) w8) + +identity :: + Word8 -> + DefaultFun -> + PropertyT IO () +identity w8 b = do + testCase <- forAllWith ppShow . genIdentityCase $ w8 + cover 45 "mismatched lengths" . hasn't _IdentityResult $ testCase + cover 45 "matched lengths" . has _IdentityResult $ testCase + let expectedMay = preview _IdentityResult testCase + let (leftArg, rightArg) = getIdentityArgs testCase + outcome <- commutatively b leftArg rightArg + case (outcome, expectedMay) of + ((EvaluationFailure, EvaluationFailure), Nothing) -> success + (_, Nothing) -> do + annotate "Unexpected success" + failure + ((EvaluationSuccess l2r, EvaluationSuccess r2l), Just expected) -> do + l2r === r2l + l2r === mkConstant () expected + _ -> do + annotate "Unexpected failure" + failure + +data CommutativeCase = + MismatchedLengths ByteString ByteString | + MatchedLengths ByteString ByteString ByteString + deriving stock (Eq, Show) + +getArgs :: CommutativeCase -> (ByteString, ByteString) +getArgs = \case + MismatchedLengths bs bs' -> (bs, bs') + MatchedLengths bs bs' _ -> (bs, bs') + +_CommutativeResult :: Fold CommutativeCase ByteString +_CommutativeResult = folding $ \case + MatchedLengths _ _ res -> pure res + _ -> Nothing + +commutative :: + (Word8 -> Word8 -> Word8) -> + DefaultFun -> + PropertyT IO () +commutative f b = do + testCase <- forAllWith ppShow . genCommutativeCase $ f + cover 45 "mismatched lengths" . hasn't _CommutativeResult $ testCase + cover 45 "matched lengths" . has _CommutativeResult $ testCase + let expectedMay = preview _CommutativeResult testCase + let (leftArg, rightArg) = getArgs testCase + outcome <- commutatively b leftArg rightArg + case (outcome, expectedMay) of + ((EvaluationFailure, EvaluationFailure), Nothing) -> success + (_, Nothing) -> do + annotate "Unexpected success" + failure + ((EvaluationSuccess l2r, EvaluationSuccess r2l), Just expected) -> do + l2r === r2l + l2r === mkConstant () expected + _ -> do + annotate "Unexpected failure" + failure + +commutatively :: + DefaultFun -> + ByteString -> + ByteString -> + PropertyT IO (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ()), + EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) +commutatively fun leftArg rightArg = do + let leftArg' = mkConstant @ByteString () leftArg + let rightArg' = mkConstant @ByteString () rightArg + let oneDirection = go leftArg' rightArg' + let otherDirection = go rightArg' leftArg' + bitraverse cekEval cekEval (oneDirection, otherDirection) + where + go :: Term Untyped.TyName Name DefaultUni DefaultFun () -> + Term Untyped.TyName Name DefaultUni DefaultFun () -> + Term Untyped.TyName Name DefaultUni DefaultFun () + go arg1 arg2 = mkIterApp () (builtin () fun) [arg1, arg2] + +cekEval :: + Term Untyped.TyName Name DefaultUni DefaultFun () -> + PropertyT IO (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) +cekEval = fmap fst . evalEither . typecheckEvaluateCek defaultCekParameters + +-- Generators + +genCommutativeCase :: (Word8 -> Word8 -> Word8) -> Gen CommutativeCase +genCommutativeCase f = Gen.choice [mismatched, matched] + where + mismatched :: Gen CommutativeCase + mismatched = do + leftArg <- Gen.bytes byteBoundRange + rightArg <- Gen.bytes byteBoundRange + if BS.length leftArg /= BS.length rightArg + then pure . MismatchedLengths leftArg $ rightArg + else do + let diff = BS.length leftArg - BS.length rightArg + extension <- Gen.bytes . diffRange $ diff + let leftArg' = leftArg <> extension + Gen.element [MismatchedLengths leftArg' rightArg, + MismatchedLengths rightArg leftArg'] + matched :: Gen CommutativeCase + matched = do + leftArg <- Gen.bytes byteBoundRange + let len = BS.length leftArg + rightArg <- Gen.bytes . Range.singleton $ len + let result = fromListN len . BS.zipWith f leftArg $ rightArg + pure . MatchedLengths leftArg rightArg $ result + +genIdentityCase :: Word8 -> Gen IdentityCase +genIdentityCase w8 = Gen.choice [mismatched, matched] + where + mismatched :: Gen IdentityCase + mismatched = do + bs <- Gen.bytes byteBoundRange + let len = BS.length bs + genLen <- Gen.filter (/= len) . Gen.int $ byteBoundRange + pure . IdentityMismatched bs genLen $ w8 + matched :: Gen IdentityCase + matched = do + bs <- Gen.bytes byteBoundRange + pure . IdentityMatched bs $ w8 + +genAbsorbingCase :: Word8 -> Gen AbsorbingCase +genAbsorbingCase w8 = Gen.choice [mismatched, matched] + where + mismatched :: Gen AbsorbingCase + mismatched = do + bs <- Gen.bytes byteBoundRange + let len = BS.length bs + genLen <- Gen.filter (/= len) . Gen.int $ byteBoundRange + pure . AbsorbingMismatched bs genLen $ w8 + matched :: Gen AbsorbingCase + matched = do + bs <- Gen.bytes byteBoundRange + pure . AbsorbingMatched bs $ w8 + +-- Ranges + +byteBoundRange :: Range Int +byteBoundRange = Range.linear 0 64 + +diffRange :: Int -> Range Int +diffRange diff = let param = abs diff + 1 in + Range.linear param (param * 2) 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 ea995c2a513..5a6d3a7bd0b 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -30,6 +30,9 @@ import PlutusCore.StdLib.Data.Pair import PlutusCore.StdLib.Data.ScottList qualified as Scott import PlutusCore.StdLib.Data.Unit +import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndCommutes, bitwiseAndIdentity, bitwiseAndSelf, + bitwiseIorAbsorbing, bitwiseIorCommutes, bitwiseIorIdentity, bitwiseIorSelf, + bitwiseXorCommutes, bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -70,7 +73,7 @@ test_Factorial = -- a const defined in PLC itself. test_Const :: TestTree test_Const = - testProperty "Const" . property $ do + testPropertyNamed "Const" "Const" . property $ do c <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode b <- forAll Gen.bool let tC = mkConstant () c @@ -580,10 +583,51 @@ testSECP256k1 :: TestTree testSECP256k1 = adjustOption (\x -> max x . HedgehogTestLimit . Just $ 8000) . testGroup "Signatures on the SECP256k1 curve" $ [ - testProperty "ECDSA verification behaves correctly on all inputs" . property $ ecdsaSecp256k1Prop, - testProperty "Schnorr verification behaves correctly on all inputs" . property $ schnorrSecp256k1Prop + testPropertyNamed "ECDSA verification behaves correctly on all inputs" + "ECDSA verification behaves correctly on all inputs" . + property $ ecdsaSecp256k1Prop, + testPropertyNamed "Schnorr verification behaves correctly on all inputs" + "Schnorr verification behaves correctly on all inputs" . + property $ schnorrSecp256k1Prop ] +-- Test the bitwise builtins are behaving correctly +testBitwise :: TestTree +testBitwise = + adjustOption (\x -> max x . HedgehogTestLimit . Just $ 8000) . + testGroup "Bitwise operations" $ [ + testAndByteString, + testIorByteString, + testXorByteString + ] + +-- Tests for bitwise AND on ByteStrings +testAndByteString :: TestTree +testAndByteString = testGroup "AndByteString" [ + testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseAndCommutes, + testPropertyNamed "All-1s is an identity" "All-1s is an identity" . property $ bitwiseAndIdentity, + testPropertyNamed "All-0s is absorbing" "All-0s is absorbing" . property $ bitwiseAndAbsorbing, + testPropertyNamed "AND with yourself does nothing" "AND with yourself does nothing" . property $ bitwiseAndSelf + ] + +-- Tests for bitwise IOR on ByteStrings +testIorByteString :: TestTree +testIorByteString = testGroup "IorByteString" [ + testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseIorCommutes, + testPropertyNamed "All-0s is an identity" "All-0s is an identity" . property $ bitwiseIorIdentity, + testPropertyNamed "All-1s is absorbing" "All-0s is absorbing" . property $ bitwiseIorAbsorbing, + testPropertyNamed "IOR with yourself does nothing" "IOR with yourself does nothing" . property $ bitwiseIorSelf + ] + +-- Tests for bitwise XOR on ByteStrings +testXorByteString :: TestTree +testXorByteString = testGroup "XorByteString" [ + testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseXorCommutes, + testPropertyNamed "All-0s is an identity" "All-0s is an identity" . property $ bitwiseXorIdentity, + testPropertyNamed "XOR with all-1s is complement" "XOR with all 1s is complement" . property $ bitwiseXorComplement, + testPropertyNamed "XOR with yourself gives all-0" "XOR with yourself gives all-0" . property $ bitwiseXorSelf + ] + test_definition :: TestTree test_definition = testGroup "definition" @@ -608,5 +652,6 @@ test_definition = , test_Data , test_Crypto , testSECP256k1 + , testBitwise , test_Other ] From e89cfd243523ba6a462d89456020d492a1fe7abb Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 29 Jun 2022 08:19:25 +1200 Subject: [PATCH 05/73] Finish tests for AND, IOR, XOR, complement --- .../test/Evaluation/Builtins/Bitwise.hs | 147 +++++++++++++++++- .../test/Evaluation/Builtins/Definition.hs | 26 +++- 2 files changed, 166 insertions(+), 7 deletions(-) diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 47c168bfc57..2ecd87f1083 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -16,6 +16,12 @@ module Evaluation.Builtins.Bitwise ( bitwiseAndSelf, bitwiseIorSelf, bitwiseXorSelf, + bitwiseAndAssociates, + bitwiseIorAssociates, + bitwiseXorAssociates, + bitwiseComplementSelfInverts, + bitwiseAndDeMorgan, + bitwiseIorDeMorgan, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) @@ -25,7 +31,7 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Word (Word8) import Evaluation.Builtins.Common (typecheckEvaluateCek) -import GHC.Exts (fromListN) +import GHC.Exts (fromListN, toList) import Hedgehog (Gen, PropertyT, Range, annotate, cover, evalEither, failure, forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range @@ -106,8 +112,122 @@ bitwiseXorSelf = do EvaluationSuccess res -> res === expected _ -> failure +bitwiseAndAssociates :: PropertyT IO () +bitwiseAndAssociates = associative (.&.) AndByteString + +bitwiseIorAssociates :: PropertyT IO () +bitwiseIorAssociates = associative (.|.) IorByteString + +bitwiseXorAssociates :: PropertyT IO () +bitwiseXorAssociates = associative xor XorByteString + +bitwiseComplementSelfInverts :: PropertyT IO () +bitwiseComplementSelfInverts = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + let bs' = mkConstant @ByteString () bs + let comp = mkIterApp () (builtin () ComplementByteString) [ + mkIterApp () (builtin () ComplementByteString) [bs'] + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant () bs + _ -> failure + +bitwiseAndDeMorgan :: PropertyT IO () +bitwiseAndDeMorgan = demorgan AndByteString IorByteString + +bitwiseIorDeMorgan :: PropertyT IO () +bitwiseIorDeMorgan = demorgan IorByteString AndByteString + -- Helpers +demorgan :: + DefaultFun -> + DefaultFun -> + PropertyT IO () +demorgan b b' = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + let len = BS.length bs + bs' <- forAllWith ppShow . Gen.bytes . Range.singleton $ len + outcome <- demorganing b b' bs bs' + case outcome of + (EvaluationSuccess res1, EvaluationSuccess res2) -> res1 === res2 + _ -> failure + +demorganing :: + DefaultFun -> + DefaultFun -> + ByteString -> + ByteString -> + PropertyT IO (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ()), + EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) +demorganing fun fun' x y = do + let x' = mkConstant @ByteString () x + let y' = mkConstant @ByteString () y + let comp = mkIterApp () (builtin () ComplementByteString) [ + mkIterApp () (builtin () fun) [x', y'] + ] + let comp' = mkIterApp () (builtin () fun') [ + mkIterApp () (builtin () ComplementByteString) [x'], + mkIterApp () (builtin () ComplementByteString) [y'] + ] + bitraverse cekEval cekEval (comp, comp') + +data AssociativeCase = + AssociativeMismatched ByteString ByteString ByteString | + AssociativeMatched ByteString ByteString ByteString ByteString + deriving stock (Eq, Show) + +getAssociativeArgs :: AssociativeCase -> (ByteString, ByteString, ByteString) +getAssociativeArgs = \case + AssociativeMismatched x y z -> (x, y, z) + AssociativeMatched x y z _ -> (x, y, z) + +_AssociativeResult :: Fold AssociativeCase ByteString +_AssociativeResult = folding $ \case + AssociativeMatched _ _ _ res -> pure res + _ -> Nothing + +associative :: + (Word8 -> Word8 -> Word8) -> + DefaultFun -> + PropertyT IO () +associative f b = do + testCase <- forAllWith ppShow . genAssociativeCase $ f + cover 45 "mismatched lengths" . hasn't _AssociativeResult $ testCase + cover 45 "matched lengths" . has _AssociativeResult $ testCase + let expectedMay = preview _AssociativeResult testCase + let (x, y, z) = getAssociativeArgs testCase + outcome <- associatively b x y z + case (outcome, expectedMay) of + ((EvaluationFailure, EvaluationFailure), Nothing) -> success + (_, Nothing) -> annotate "Unexpected failure" >> failure + ((EvaluationSuccess leftAssoc, EvaluationSuccess rightAssoc), Just expected) -> do + leftAssoc === rightAssoc + leftAssoc === mkConstant () expected + _ -> annotate "Unexpected failure" >> failure + +associatively :: + DefaultFun -> + ByteString -> + ByteString -> + ByteString -> + PropertyT IO (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ()), + EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) +associatively fun x y z = do + let x' = mkConstant @ByteString () x + let y' = mkConstant @ByteString () y + let z' = mkConstant @ByteString () z + let leftAssoc = mkIterApp () (builtin () fun) [ + mkIterApp () (builtin () fun) [x', y'], + z' + ] + let rightAssoc = mkIterApp () (builtin () fun) [ + x', + mkIterApp () (builtin () fun) [y', z'] + ] + bitraverse cekEval cekEval (leftAssoc, rightAssoc) + self :: DefaultFun -> PropertyT IO () self b = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange @@ -308,6 +428,31 @@ genAbsorbingCase w8 = Gen.choice [mismatched, matched] bs <- Gen.bytes byteBoundRange pure . AbsorbingMatched bs $ w8 +genAssociativeCase :: (Word8 -> Word8 -> Word8) -> Gen AssociativeCase +genAssociativeCase f = Gen.choice [mismatched, matched] + where + mismatched :: Gen AssociativeCase + mismatched = do + x <- Gen.bytes byteBoundRange + y <- Gen.bytes byteBoundRange + z <- Gen.bytes byteBoundRange + if BS.length x == BS.length y && BS.length y == BS.length z + then do + extension <- Gen.bytes . diffRange $ 5 + let x' = x <> extension + Gen.element [AssociativeMismatched x' y z, + AssociativeMismatched y x' z, + AssociativeMismatched y z x'] + else pure . AssociativeMismatched x y $ z + matched :: Gen AssociativeCase + matched = do + x <- Gen.bytes byteBoundRange + let len = BS.length x + y <- Gen.bytes . Range.singleton $ len + z <- Gen.bytes . Range.singleton $ len + let result = fromListN len . zipWith f (toList x) . BS.zipWith f y $ z + pure . AssociativeMatched x y z $ result + -- Ranges byteBoundRange :: Range Int 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 5a6d3a7bd0b..42b21de4666 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -30,9 +30,11 @@ import PlutusCore.StdLib.Data.Pair import PlutusCore.StdLib.Data.ScottList qualified as Scott import PlutusCore.StdLib.Data.Unit -import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndCommutes, bitwiseAndIdentity, bitwiseAndSelf, - bitwiseIorAbsorbing, bitwiseIorCommutes, bitwiseIorIdentity, bitwiseIorSelf, - bitwiseXorCommutes, bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf) +import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, bitwiseAndCommutes, bitwiseAndDeMorgan, + bitwiseAndIdentity, bitwiseAndSelf, bitwiseComplementSelfInverts, + bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, + bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, + bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -598,36 +600,48 @@ testBitwise = testGroup "Bitwise operations" $ [ testAndByteString, testIorByteString, - testXorByteString + testXorByteString, + testComplementByteString ] -- Tests for bitwise AND on ByteStrings testAndByteString :: TestTree testAndByteString = testGroup "AndByteString" [ testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseAndCommutes, + testPropertyNamed "Associativity" "Associativity" . property $ bitwiseAndAssociates, testPropertyNamed "All-1s is an identity" "All-1s is an identity" . property $ bitwiseAndIdentity, testPropertyNamed "All-0s is absorbing" "All-0s is absorbing" . property $ bitwiseAndAbsorbing, - testPropertyNamed "AND with yourself does nothing" "AND with yourself does nothing" . property $ bitwiseAndSelf + testPropertyNamed "AND with yourself does nothing" "AND with yourself does nothing" . property $ bitwiseAndSelf, + testPropertyNamed "De Morgan's law" "De Morgan's law" . property $ bitwiseAndDeMorgan ] -- Tests for bitwise IOR on ByteStrings testIorByteString :: TestTree testIorByteString = testGroup "IorByteString" [ testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseIorCommutes, + testPropertyNamed "Associativity" "Associativity" . property $ bitwiseIorAssociates, testPropertyNamed "All-0s is an identity" "All-0s is an identity" . property $ bitwiseIorIdentity, testPropertyNamed "All-1s is absorbing" "All-0s is absorbing" . property $ bitwiseIorAbsorbing, - testPropertyNamed "IOR with yourself does nothing" "IOR with yourself does nothing" . property $ bitwiseIorSelf + testPropertyNamed "IOR with yourself does nothing" "IOR with yourself does nothing" . property $ bitwiseIorSelf, + testPropertyNamed "De Morgan's law" "De Morgan's law" . property $ bitwiseIorDeMorgan ] -- Tests for bitwise XOR on ByteStrings testXorByteString :: TestTree testXorByteString = testGroup "XorByteString" [ testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseXorCommutes, + testPropertyNamed "Associativity" "Associativity" . property $ bitwiseXorAssociates, testPropertyNamed "All-0s is an identity" "All-0s is an identity" . property $ bitwiseXorIdentity, testPropertyNamed "XOR with all-1s is complement" "XOR with all 1s is complement" . property $ bitwiseXorComplement, testPropertyNamed "XOR with yourself gives all-0" "XOR with yourself gives all-0" . property $ bitwiseXorSelf ] +-- Tests for bitwise complement on ByteStrings +testComplementByteString :: TestTree +testComplementByteString = testGroup "ComplementByteString" [ + testPropertyNamed "Self-inversion" "Self-inversion" . property $ bitwiseComplementSelfInverts + ] + test_definition :: TestTree test_definition = testGroup "definition" From 139532e18e079dd64d269f106ebcb95a249d937b Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 29 Jun 2022 10:05:36 +1200 Subject: [PATCH 06/73] Popcount bugfix, tests for popcount --- plutus-core/plutus-core/src/Bitwise.hs | 3 +- .../test/Evaluation/Builtins/Bitwise.hs | 39 +++++++++++++++++-- .../test/Evaluation/Builtins/Definition.hs | 17 +++++++- 3 files changed, 53 insertions(+), 6 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 307250aa3d6..a79a89d4ea5 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -421,6 +421,7 @@ countBits ptr len = go 0 0 go total offset | offset == len = pure total | otherwise = do - block :: a <- peek . plusPtr ptr $ offset + let offset' = offset * sizeOf (undefined :: a) + block :: a <- peek . plusPtr ptr $ offset' let total' = total + popCount block go total' (offset + 1) diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 2ecd87f1083..1f48ca6e1b7 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -22,11 +22,13 @@ module Evaluation.Builtins.Bitwise ( bitwiseComplementSelfInverts, bitwiseAndDeMorgan, bitwiseIorDeMorgan, + popCountSingleByte, + popCountAppend, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) import Data.Bitraversable (bitraverse) -import Data.Bits (complement, xor, zeroBits, (.&.), (.|.)) +import Data.Bits (complement, popCount, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Word (Word8) @@ -35,8 +37,8 @@ import GHC.Exts (fromListN, toList) import Hedgehog (Gen, PropertyT, Range, annotate, cover, evalEither, failure, forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (DefaultFun (AndByteString, ComplementByteString, IorByteString, XorByteString), DefaultUni, - EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) +import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, IorByteString, PopCountByteString, XorByteString), + DefaultUni, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters) import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) import Text.Show.Pretty (ppShow) @@ -139,6 +141,37 @@ bitwiseAndDeMorgan = demorgan AndByteString IorByteString bitwiseIorDeMorgan :: PropertyT IO () bitwiseIorDeMorgan = demorgan IorByteString AndByteString +popCountSingleByte :: PropertyT IO () +popCountSingleByte = do + w8 <- forAllWith ppShow Gen.enumBounded + let bs = BS.singleton w8 + let expected :: Integer = fromIntegral . popCount $ w8 + let comp = mkIterApp () (builtin () PopCountByteString) [ + mkConstant @ByteString () bs + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant () expected + _ -> failure + +popCountAppend :: PropertyT IO () +popCountAppend = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + bs' <- forAllWith ppShow . Gen.bytes $ byteBoundRange + let arg1 = mkConstant @ByteString () bs + let arg2 = mkConstant @ByteString () bs' + let comp1 = mkIterApp () (builtin () PopCountByteString) [ + mkIterApp () (builtin () AppendByteString) [arg1, arg2] + ] + let comp2 = mkIterApp () (builtin () AddInteger) [ + mkIterApp () (builtin () PopCountByteString) [arg1], + mkIterApp () (builtin () PopCountByteString) [arg2] + ] + outcome <- bitraverse cekEval cekEval (comp1, comp2) + case outcome of + (EvaluationSuccess res, EvaluationSuccess res') -> res === res' + _ -> failure + -- Helpers demorgan :: 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 42b21de4666..4d9cc962f96 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -34,7 +34,8 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseAndIdentity, bitwiseAndSelf, bitwiseComplementSelfInverts, bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, - bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf) + bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, popCountAppend, + popCountSingleByte) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -601,7 +602,8 @@ testBitwise = testAndByteString, testIorByteString, testXorByteString, - testComplementByteString + testComplementByteString, + testPopCountByteString ] -- Tests for bitwise AND on ByteStrings @@ -642,6 +644,17 @@ testComplementByteString = testGroup "ComplementByteString" [ testPropertyNamed "Self-inversion" "Self-inversion" . property $ bitwiseComplementSelfInverts ] +-- Tests for population count on ByteStrings +testPopCountByteString :: TestTree +testPopCountByteString = testGroup "PopCountByteString" [ + testCase "popcount of empty ByteString is 0" $ do + let arg = mkConstant @ByteString () "" + let comp = mkIterApp () (builtin () PopCountByteString) [ arg ] + typecheckEvaluateCekNoEmit defaultCekParameters comp @?= Right (EvaluationSuccess . mkConstant @Integer () $ 0), + testPropertyNamed "popcount of singleton ByteString is correct" "popcount of singleton ByteString is correct" . property $ popCountSingleByte, + testPropertyNamed "popcount of append is sum of popcounts" "popcount of append is sum of popcounts" . property $ popCountAppend + ] + test_definition :: TestTree test_definition = testGroup "definition" From 06d0f9bffafce1053cbfac49b259c28dc883daf7 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 29 Jun 2022 13:37:22 +1200 Subject: [PATCH 07/73] Tests for bit indexing --- .../test/Evaluation/Builtins/Bitwise.hs | 160 +++++++++++++++++- .../test/Evaluation/Builtins/Definition.hs | 13 +- 2 files changed, 168 insertions(+), 5 deletions(-) diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 1f48ca6e1b7..6e49a6705ae 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -24,20 +24,24 @@ module Evaluation.Builtins.Bitwise ( bitwiseIorDeMorgan, popCountSingleByte, popCountAppend, + testBitEmpty, + testBitSingleByte, + testBitAppend, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) +import Control.Monad (guard) import Data.Bitraversable (bitraverse) -import Data.Bits (complement, popCount, xor, zeroBits, (.&.), (.|.)) +import Data.Bits (bit, complement, popCount, shiftL, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Word (Word8) import Evaluation.Builtins.Common (typecheckEvaluateCek) import GHC.Exts (fromListN, toList) -import Hedgehog (Gen, PropertyT, Range, annotate, cover, evalEither, failure, forAllWith, success, (===)) +import Hedgehog (Gen, PropertyT, Range, annotate, annotateShow, cover, evalEither, failure, forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, IorByteString, PopCountByteString, XorByteString), +import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, IorByteString, PopCountByteString, TestBitByteString, XorByteString), DefaultUni, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters) import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) @@ -172,8 +176,115 @@ popCountAppend = do (EvaluationSuccess res, EvaluationSuccess res') -> res === res' _ -> failure +testBitEmpty :: PropertyT IO () +testBitEmpty = do + ix <- forAllWith ppShow . Gen.integral $ indexRange + let arg = mkConstant @ByteString () "" + let comp = mkIterApp () (builtin () TestBitByteString) [ + arg, + mkConstant @Integer () ix + ] + outcome <- cekEval comp + case outcome of + EvaluationFailure -> success + _ -> failure + +testBitSingleByte :: PropertyT IO () +testBitSingleByte = do + w8 <- forAllWith ppShow Gen.enumBounded + let bs = BS.singleton w8 + ix <- forAllWith ppShow . Gen.integral . indexRangeOf $ 8 + cover 45 "out of bounds" $ ix < 0 || ix >= 8 + cover 45 "in-bounds" $ 0 <= ix && ix < 8 + let expected = bitAt w8 ix + let comp = mkIterApp () (builtin () TestBitByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () ix + ] + outcome <- cekEval comp + case (expected, outcome) of + (Nothing, EvaluationFailure) -> success + (Just b, EvaluationSuccess res) -> res === mkConstant @Bool () b + _ -> failure + +testBitAppend :: PropertyT IO () +testBitAppend = do + testCase <- forAllWith ppShow genBitAppendCase + cover 30 "out of bounds" . appendOutOfBounds $ testCase + cover 30 "in-bounds, first argument" . appendInBoundsFirst $ testCase + cover 30 "in-bounds, second argument" . appendInBoundsSecond $ testCase + let (x, y, ix) = getBitAppendArgs testCase + let arg1 = mkConstant @ByteString () x + let arg2 = mkConstant @ByteString () y + let argIx = mkConstant @Integer () ix + let comp = mkIterApp () (builtin () TestBitByteString) [ + mkIterApp () (builtin () AppendByteString) [arg1, arg2], + argIx + ] + let comp' = go x y ix + outcome <- bitraverse cekEval cekEval (comp, comp') + case outcome of + (EvaluationFailure, EvaluationFailure) -> success + (EvaluationSuccess res, EvaluationSuccess res') -> do + annotateShow res + annotateShow res' + res === res' + _ -> failure + where + go :: + ByteString -> + ByteString -> + Integer -> + Term Untyped.TyName Name DefaultUni DefaultFun () + go bs bs' ix = let len' = fromIntegral $ 8 * BS.length bs' in + case compare ix len' of + LT -> mkIterApp () (builtin () TestBitByteString) [ + mkConstant @ByteString () bs', + mkConstant @Integer () ix + ] + _ -> mkIterApp () (builtin () TestBitByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () (ix - len') + ] + -- Helpers +data BitAppendCase = + AppendOutOfBounds ByteString ByteString Integer | + AppendInBoundsFirst ByteString ByteString Integer | + AppendInBoundsSecond ByteString ByteString Integer + deriving stock (Eq, Show) + +appendOutOfBounds :: BitAppendCase -> Bool +appendOutOfBounds = \case + AppendOutOfBounds{} -> True + _ -> False + +appendInBoundsFirst :: BitAppendCase -> Bool +appendInBoundsFirst = \case + AppendInBoundsFirst{} -> True + _ -> False + +appendInBoundsSecond :: BitAppendCase -> Bool +appendInBoundsSecond = \case + AppendInBoundsSecond{} -> True + _ -> False + +getBitAppendArgs :: BitAppendCase -> (ByteString, ByteString, Integer) +getBitAppendArgs = \case + AppendOutOfBounds bs bs' ix -> (bs, bs', ix) + AppendInBoundsFirst bs bs' ix -> (bs, bs', ix) + AppendInBoundsSecond bs bs' ix -> (bs, bs', ix) + +bitAt :: Word8 -> Integer -> Maybe Bool +bitAt w8 ix = do + guard (ix >= 0) + guard (ix < 8) + let mask = bit 0 `shiftL` fromIntegral ix + pure $ case mask .&. w8 of + 0 -> False + _ -> True + demorgan :: DefaultFun -> DefaultFun -> @@ -486,6 +597,40 @@ genAssociativeCase f = Gen.choice [mismatched, matched] let result = fromListN len . zipWith f (toList x) . BS.zipWith f y $ z pure . AssociativeMatched x y z $ result +genBitAppendCase :: Gen BitAppendCase +genBitAppendCase = Gen.choice [oob, inBounds1, inBounds2] + where + oob :: Gen BitAppendCase + oob = do + bs <- Gen.bytes byteBoundRange + bs' <- Gen.bytes byteBoundRange + let len = fromIntegral $ 8 * (BS.length bs + BS.length bs') + ix <- Gen.choice [tooLowIx len, tooHighIx len] + pure . AppendOutOfBounds bs bs' $ ix + inBounds1 :: Gen BitAppendCase + inBounds1 = do + bs <- Gen.bytes byteBoundRange + w8 <- Gen.enumBounded + let firstArg = BS.cons w8 bs + bs' <- Gen.bytes byteBoundRange + let len = fromIntegral $ 8 * BS.length firstArg + let len' = fromIntegral $ 8 * BS.length bs' + ix <- (len' +) <$> (Gen.integral . indexRangeFor $ len) + pure . AppendInBoundsFirst firstArg bs' $ ix + inBounds2 :: Gen BitAppendCase + inBounds2 = do + bs <- Gen.bytes byteBoundRange + bs' <- Gen.bytes byteBoundRange + w8 <- Gen.enumBounded + let secondArg = BS.cons w8 bs' + let len' = fromIntegral $ 8 * BS.length secondArg + ix <- Gen.integral . indexRangeFor $ len' + pure . AppendInBoundsSecond bs secondArg $ ix + tooLowIx :: Integer -> Gen Integer + tooLowIx i = Gen.integral . Range.linear (-1) . negate $ i + tooHighIx :: Integer -> Gen Integer + tooHighIx i = Gen.integral . Range.linear i $ i * 2 + -- Ranges byteBoundRange :: Range Int @@ -494,3 +639,12 @@ byteBoundRange = Range.linear 0 64 diffRange :: Int -> Range Int diffRange diff = let param = abs diff + 1 in Range.linear param (param * 2) + +indexRange :: Range Integer +indexRange = Range.linearFrom 0 (-100) 100 + +indexRangeOf :: Integer -> Range Integer +indexRangeOf lim = Range.constantFrom 0 (negate lim) (lim - 1) + +indexRangeFor :: Integer -> Range Integer +indexRangeFor i = Range.constant 0 (i - 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 4d9cc962f96..d704a1b69d0 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -35,7 +35,7 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, popCountAppend, - popCountSingleByte) + popCountSingleByte, testBitAppend, testBitEmpty, testBitSingleByte) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -603,7 +603,8 @@ testBitwise = testIorByteString, testXorByteString, testComplementByteString, - testPopCountByteString + testPopCountByteString, + testTestBitByteString ] -- Tests for bitwise AND on ByteStrings @@ -655,6 +656,14 @@ testPopCountByteString = testGroup "PopCountByteString" [ testPropertyNamed "popcount of append is sum of popcounts" "popcount of append is sum of popcounts" . property $ popCountAppend ] +-- Tests for bit indexing into a ByteString +testTestBitByteString :: TestTree +testTestBitByteString = testGroup "TestBitByteString" [ + testPropertyNamed "any index on an empty ByteString fails" "any index on an empty ByteString fails" . property $ testBitEmpty, + testPropertyNamed "indexing on singletons works correctly" "indexing on singletons works correctly" . property $ testBitSingleByte, + testPropertyNamed "indexing appends agrees with components" "indexing appends agrees with components" . property $ testBitAppend + ] + test_definition :: TestTree test_definition = testGroup "definition" From 15206d43ea2e3b93ad3ac2b1758f049c04fd4caf Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 29 Jun 2022 15:41:48 +1200 Subject: [PATCH 08/73] Tests for bit writing, some for find first set --- plutus-core/plutus-core/src/Bitwise.hs | 2 +- .../test/Evaluation/Builtins/Bitwise.hs | 112 +++++++++++++++++- .../test/Evaluation/Builtins/Definition.hs | 26 +++- 3 files changed, 130 insertions(+), 10 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index a79a89d4ea5..61feb16e8d7 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -173,7 +173,7 @@ writeBitByteString bs i b void . memcpy dst src . fromIntegral $ len byte :: Word8 <- peek . plusPtr src $ bigIx let byte' = if b then mask .|. byte else complement mask .&. byte - poke (castPtr . plusPtr src $ bigIx) byte' + poke (castPtr . plusPtr dst $ bigIx) byte' unsafePackMallocCStringLen (dst, len) integerToByteString :: Integer -> ByteString diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 6e49a6705ae..f3b8af55875 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -27,12 +27,15 @@ module Evaluation.Builtins.Bitwise ( testBitEmpty, testBitSingleByte, testBitAppend, + writeBitRead, + writeBitDouble, + ffsSingleByte, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) import Control.Monad (guard) import Data.Bitraversable (bitraverse) -import Data.Bits (bit, complement, popCount, shiftL, xor, zeroBits, (.&.), (.|.)) +import Data.Bits (bit, complement, countTrailingZeros, popCount, shiftL, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Word (Word8) @@ -41,7 +44,7 @@ import GHC.Exts (fromListN, toList) import Hedgehog (Gen, PropertyT, Range, annotate, annotateShow, cover, evalEither, failure, forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, IorByteString, PopCountByteString, TestBitByteString, XorByteString), +import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, FindFirstSetByteString, IorByteString, PopCountByteString, TestBitByteString, WriteBitByteString, XorByteString), DefaultUni, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters) import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) @@ -247,8 +250,83 @@ testBitAppend = do mkConstant @Integer () (ix - len') ] +writeBitRead :: PropertyT IO () +writeBitRead = do + testCase <- forAllWith ppShow genWriteBitCase + cover 45 "out of bounds" . hasn't _WriteBitResult $ testCase + cover 45 "in-bounds" . has _WriteBitResult $ testCase + let (bs, ix, b) = getWriteBitArgs testCase + let expected = preview _WriteBitResult testCase + let bs' = mkConstant @ByteString () bs + let ix' = mkConstant @Integer () ix + let b' = mkConstant @Bool () b + let comp = mkIterApp () (builtin () TestBitByteString) [ + mkIterApp () (builtin () WriteBitByteString) [bs', ix', b'], + ix' + ] + outcome <- cekEval comp + case (expected, outcome) of + (Nothing, EvaluationFailure) -> success + (Just res, EvaluationSuccess res') -> mkConstant @Bool () res === res' + _ -> failure + +writeBitDouble :: PropertyT IO () +writeBitDouble = do + testCase <- forAllWith ppShow genWriteBitCase + cover 45 "out of bounds" . hasn't _WriteBitResult $ testCase + cover 45 "in-bounds" . has _WriteBitResult $ testCase + let (bs, ix, b) = getWriteBitArgs testCase + b' <- forAllWith ppShow Gen.enumBounded + let bs' = mkConstant @ByteString () bs + let ix' = mkConstant @Integer () ix + let writeTwice = mkIterApp () (builtin () WriteBitByteString) [ + mkIterApp () (builtin () WriteBitByteString) [bs', ix', mkConstant @Bool () b], + ix', + mkConstant @Bool () b' + ] + let writeOnce = mkIterApp () (builtin () WriteBitByteString) [ + bs', + ix', + mkConstant @Bool () b' + ] + outcome <- bitraverse cekEval cekEval (writeTwice, writeOnce) + case outcome of + (EvaluationFailure, EvaluationFailure) -> success + (EvaluationSuccess res, EvaluationSuccess res') -> res === res' + _ -> failure + +ffsSingleByte :: PropertyT IO () +ffsSingleByte = do + w8 <- forAllWith ppShow Gen.enumBounded + let bs = BS.singleton w8 + let expected = case w8 of + 0 -> (-1) + _ -> fromIntegral . countTrailingZeros $ w8 + let comp = mkIterApp () (builtin () FindFirstSetByteString) [ + mkConstant @ByteString () bs + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant @Integer () expected + _ -> failure + -- Helpers +data WriteBitCase = + WriteBitOutOfBounds ByteString Integer Bool | + WriteBitInBounds ByteString Integer Bool + deriving stock (Eq, Show) + +_WriteBitResult :: Fold WriteBitCase Bool +_WriteBitResult = folding $ \case + WriteBitInBounds _ _ b -> pure b + _ -> Nothing + +getWriteBitArgs :: WriteBitCase -> (ByteString, Integer, Bool) +getWriteBitArgs = \case + WriteBitOutOfBounds bs ix b -> (bs, ix, b) + WriteBitInBounds bs ix b -> (bs, ix, b) + data BitAppendCase = AppendOutOfBounds ByteString ByteString Integer | AppendInBoundsFirst ByteString ByteString Integer | @@ -626,10 +704,32 @@ genBitAppendCase = Gen.choice [oob, inBounds1, inBounds2] let len' = fromIntegral $ 8 * BS.length secondArg ix <- Gen.integral . indexRangeFor $ len' pure . AppendInBoundsSecond bs secondArg $ ix - tooLowIx :: Integer -> Gen Integer - tooLowIx i = Gen.integral . Range.linear (-1) . negate $ i - tooHighIx :: Integer -> Gen Integer - tooHighIx i = Gen.integral . Range.linear i $ i * 2 + +genWriteBitCase :: Gen WriteBitCase +genWriteBitCase = Gen.choice [oob, inBounds] + where + oob :: Gen WriteBitCase + oob = do + bs <- Gen.bytes byteBoundRange + let len = fromIntegral $ 8 * BS.length bs + b <- Gen.enumBounded + ix <- Gen.choice [tooLowIx len, tooHighIx len] + pure . WriteBitOutOfBounds bs ix $ b + inBounds :: Gen WriteBitCase + inBounds = do + bs <- Gen.bytes byteBoundRange + w8 <- Gen.enumBounded + let bs' = BS.cons w8 bs + let len = fromIntegral $ 8 * BS.length bs' + b <- Gen.enumBounded + ix <- Gen.integral . indexRangeFor $ len + pure . WriteBitInBounds bs' ix $ b + +tooLowIx :: Integer -> Gen Integer +tooLowIx = Gen.integral . Range.linear (-1) . negate + +tooHighIx :: Integer -> Gen Integer +tooHighIx i = Gen.integral . Range.linear i $ i * 2 -- Ranges 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 d704a1b69d0..52d5381d59a 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -34,8 +34,9 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseAndIdentity, bitwiseAndSelf, bitwiseComplementSelfInverts, bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, - bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, popCountAppend, - popCountSingleByte, testBitAppend, testBitEmpty, testBitSingleByte) + bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, ffsSingleByte, + popCountAppend, popCountSingleByte, testBitAppend, testBitEmpty, testBitSingleByte, + writeBitDouble, writeBitRead) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -604,7 +605,9 @@ testBitwise = testXorByteString, testComplementByteString, testPopCountByteString, - testTestBitByteString + testTestBitByteString, + testWriteBitByteString, + testFindFirstSetByteString ] -- Tests for bitwise AND on ByteStrings @@ -664,6 +667,23 @@ testTestBitByteString = testGroup "TestBitByteString" [ testPropertyNamed "indexing appends agrees with components" "indexing appends agrees with components" . property $ testBitAppend ] +-- Tests for bit setting or clearing of a ByteString +testWriteBitByteString :: TestTree +testWriteBitByteString = testGroup "WriteBitByteString" [ + testPropertyNamed "writing then reading gives back what you wrote" "writing then reading gives back what you wrote" . property $ writeBitRead, + testPropertyNamed "second write wins" "second write wins" . property $ writeBitDouble + ] + +-- Tests for finding first set bit of a ByteString +testFindFirstSetByteString :: TestTree +testFindFirstSetByteString = testGroup "FindFirstSetByteString" [ + testCase "find first set of empty Bytestring is -1" $ do + let arg = mkConstant @ByteString () "" + let comp = mkIterApp () (builtin () FindFirstSetByteString) [ arg ] + typecheckEvaluateCekNoEmit defaultCekParameters comp @?= Right (EvaluationSuccess . mkConstant @Integer () $ (-1)), + testPropertyNamed "find first set on singletons works correctly" "find first set on singletons works correctly" . property $ ffsSingleByte + ] + test_definition :: TestTree test_definition = testGroup "definition" From fb1c854bf2088e7a6919cddfae31c215a0a54960 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 30 Jun 2022 10:43:32 +1200 Subject: [PATCH 09/73] Finish find first set tests --- .../test/Evaluation/Builtins/Bitwise.hs | 76 +++++++++++++++++++ .../test/Evaluation/Builtins/Definition.hs | 5 +- 2 files changed, 79 insertions(+), 2 deletions(-) diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index f3b8af55875..ffa87963406 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -30,6 +30,7 @@ module Evaluation.Builtins.Bitwise ( writeBitRead, writeBitDouble, ffsSingleByte, + ffsAppend, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) @@ -310,8 +311,60 @@ ffsSingleByte = do EvaluationSuccess res -> res === mkConstant @Integer () expected _ -> failure +ffsAppend :: PropertyT IO () +ffsAppend = do + testCase <- forAllWith ppShow genFFSAppendCase + let which = ffsAppendType testCase + cover 30 "both arguments zero" $ which == ZeroBoth + cover 30 "second argument zero" $ which == ZeroSecond + cover 30 "second argument nonzero" $ which == NotZeroSecond + let (bs, bs') = getFFSAppendArgs testCase + let comp = mkIterApp () (builtin () FindFirstSetByteString) [ + mkIterApp () (builtin () AppendByteString) [ + mkConstant @ByteString () bs, + mkConstant @ByteString () bs' + ] + ] + let comp' = case which of + ZeroBoth -> mkConstant @Integer () (-1) + ZeroSecond -> let bitLen' = fromIntegral $ 8 * BS.length bs' in + mkIterApp () (builtin () AddInteger) [ + mkIterApp () (builtin () FindFirstSetByteString) [ + mkConstant @ByteString () bs + ], + mkConstant @Integer () bitLen' + ] + NotZeroSecond -> mkIterApp () (builtin () FindFirstSetByteString) [ + mkConstant @ByteString () bs' + ] + outcome <- bitraverse cekEval cekEval (comp, comp') + case outcome of + (EvaluationSuccess res, EvaluationSuccess res') -> res === res' + _ -> failure + -- Helpers +data FFSAppendType = ZeroBoth | ZeroSecond | NotZeroSecond + deriving stock (Eq) + +data FFSAppendCase = + FFSAppendBothZero Int Int | + FFSAppendSecondZero ByteString Int | + FFSAppendSecondNonZero ByteString ByteString + deriving stock (Eq, Show) + +getFFSAppendArgs :: FFSAppendCase -> (ByteString, ByteString) +getFFSAppendArgs = \case + FFSAppendBothZero len len' -> (BS.replicate len zeroBits, BS.replicate len' zeroBits) + FFSAppendSecondZero bs len -> (bs, BS.replicate len zeroBits) + FFSAppendSecondNonZero bs bs' -> (bs, bs') + +ffsAppendType :: FFSAppendCase -> FFSAppendType +ffsAppendType = \case + FFSAppendBothZero{} -> ZeroBoth + FFSAppendSecondZero{} -> ZeroSecond + FFSAppendSecondNonZero{} -> NotZeroSecond + data WriteBitCase = WriteBitOutOfBounds ByteString Integer Bool | WriteBitInBounds ByteString Integer Bool @@ -725,6 +778,29 @@ genWriteBitCase = Gen.choice [oob, inBounds] ix <- Gen.integral . indexRangeFor $ len pure . WriteBitInBounds bs' ix $ b +genFFSAppendCase :: Gen FFSAppendCase +genFFSAppendCase = Gen.choice [allZero, secondZero, secondNonZero] + where + allZero :: Gen FFSAppendCase + allZero = do + len <- Gen.integral . Range.linear 0 $ 63 + len' <- Gen.integral . Range.linear 0 $ 63 + pure . FFSAppendBothZero len $ len' + secondZero :: Gen FFSAppendCase + secondZero = do + bs <- Gen.bytes byteBoundRange + w8 <- Gen.filter (/= zeroBits) Gen.enumBounded + let firstArg = BS.cons w8 bs + len' <- Gen.integral . Range.linear 0 $ 63 + pure . FFSAppendSecondZero firstArg $ len' + secondNonZero :: Gen FFSAppendCase + secondNonZero = do + bs <- Gen.bytes byteBoundRange + w8 <- Gen.filter (/= zeroBits) Gen.enumBounded + bs' <- Gen.bytes byteBoundRange + w8' <- Gen.filter (/= zeroBits) Gen.enumBounded + pure . FFSAppendSecondNonZero (BS.cons w8 bs) . BS.cons w8' $ bs' + tooLowIx :: Integer -> Gen Integer tooLowIx = Gen.integral . Range.linear (-1) . negate 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 52d5381d59a..9a740783416 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -34,7 +34,7 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseAndIdentity, bitwiseAndSelf, bitwiseComplementSelfInverts, bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, - bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, ffsSingleByte, + bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, ffsAppend, ffsSingleByte, popCountAppend, popCountSingleByte, testBitAppend, testBitEmpty, testBitSingleByte, writeBitDouble, writeBitRead) import Evaluation.Builtins.Common @@ -681,7 +681,8 @@ testFindFirstSetByteString = testGroup "FindFirstSetByteString" [ let arg = mkConstant @ByteString () "" let comp = mkIterApp () (builtin () FindFirstSetByteString) [ arg ] typecheckEvaluateCekNoEmit defaultCekParameters comp @?= Right (EvaluationSuccess . mkConstant @Integer () $ (-1)), - testPropertyNamed "find first set on singletons works correctly" "find first set on singletons works correctly" . property $ ffsSingleByte + testPropertyNamed "find first set on singletons works correctly" "find first set on singletons works correctly" . property $ ffsSingleByte, + testPropertyNamed "find first set on appended ByteStrings works correctly" "find first set on appended ByteStrings works correctly" . property $ ffsAppend ] test_definition :: TestTree From 8ef6322bcf941bd16b89b423f95b4d98684c87b2 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 30 Jun 2022 15:21:15 +1200 Subject: [PATCH 10/73] Fix rotate bug, test for rotations --- plutus-core/plutus-core/src/Bitwise.hs | 18 ++++++++++-------- .../test/Evaluation/Builtins/Bitwise.hs | 15 ++++++++++++++- .../test/Evaluation/Builtins/Definition.hs | 13 ++++++++++--- 3 files changed, 34 insertions(+), 12 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 61feb16e8d7..27e2f82299c 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -42,14 +42,16 @@ import System.IO.Unsafe (unsafeDupablePerformIO) {-# NOINLINE rotateByteString #-} rotateByteString :: ByteString -> Integer -> ByteString -rotateByteString bs i = case magnitude `rem` bitLength of - 0 -> bs -- nothing to do irrespective of direction - actualMagnitude -> case signum i of - 0 -> bs -- dummy case that never happens - (-1) -> - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ decreasingRotation actualMagnitude - _ -> - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ increasingRotation actualMagnitude +rotateByteString bs i + | BS.null bs = bs + | otherwise = case magnitude `rem` bitLength of + 0 -> bs -- nothing to do irrespective of direction + actualMagnitude -> case signum i of + 0 -> bs -- dummy case that never happens + (-1) -> + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ decreasingRotation actualMagnitude + _ -> + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ increasingRotation actualMagnitude where magnitude :: Int magnitude = fromIntegral . abs $ i diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index ffa87963406..52485518269 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -31,6 +31,7 @@ module Evaluation.Builtins.Bitwise ( writeBitDouble, ffsSingleByte, ffsAppend, + rotateIdentity, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) @@ -45,7 +46,7 @@ import GHC.Exts (fromListN, toList) import Hedgehog (Gen, PropertyT, Range, annotate, annotateShow, cover, evalEither, failure, forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, FindFirstSetByteString, IorByteString, PopCountByteString, TestBitByteString, WriteBitByteString, XorByteString), +import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, FindFirstSetByteString, IorByteString, PopCountByteString, RotateByteString, TestBitByteString, WriteBitByteString, XorByteString), DefaultUni, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters) import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) @@ -342,6 +343,18 @@ ffsAppend = do (EvaluationSuccess res, EvaluationSuccess res') -> res === res' _ -> failure +rotateIdentity :: PropertyT IO () +rotateIdentity = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + let comp = mkIterApp () (builtin () RotateByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () 0 + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant () bs + _ -> failure + -- Helpers data FFSAppendType = ZeroBoth | ZeroSecond | NotZeroSecond 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 9a740783416..6f6e3445cbc 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -35,8 +35,8 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, ffsAppend, ffsSingleByte, - popCountAppend, popCountSingleByte, testBitAppend, testBitEmpty, testBitSingleByte, - writeBitDouble, writeBitRead) + popCountAppend, popCountSingleByte, rotateIdentity, testBitAppend, testBitEmpty, + testBitSingleByte, writeBitDouble, writeBitRead) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -607,7 +607,8 @@ testBitwise = testPopCountByteString, testTestBitByteString, testWriteBitByteString, - testFindFirstSetByteString + testFindFirstSetByteString, + testRotateByteString ] -- Tests for bitwise AND on ByteStrings @@ -685,6 +686,12 @@ testFindFirstSetByteString = testGroup "FindFirstSetByteString" [ testPropertyNamed "find first set on appended ByteStrings works correctly" "find first set on appended ByteStrings works correctly" . property $ ffsAppend ] +-- Tests for ByteString rotations +testRotateByteString :: TestTree +testRotateByteString = testGroup "RotateByteString" [ + testPropertyNamed "rotating by 0 does nothing" "rotating by 0 does nothing" . property $ rotateIdentity + ] + test_definition :: TestTree test_definition = testGroup "definition" From 23d5a38a0957117c2db08e0f449445996516672c Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 4 Jul 2022 13:28:57 +1200 Subject: [PATCH 11/73] Fix rotation bugs, rotation tests --- plutus-core/plutus-core/src/Bitwise.hs | 108 ++++++++------- .../test/Evaluation/Builtins/Bitwise.hs | 125 ++++++++++++++++++ .../test/Evaluation/Builtins/Definition.hs | 13 +- 3 files changed, 191 insertions(+), 55 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 27e2f82299c..d8f8fe7dd79 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -20,7 +20,7 @@ module Bitwise ( ) where import Control.Monad (foldM_, unless) -import Data.Bits (FiniteBits, bit, complement, popCount, shiftL, shiftR, xor, (.&.), (.|.)) +import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shiftL, shiftR, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, unsafeUseAsCStringLen) @@ -30,7 +30,7 @@ import Data.Kind (Type) import Data.List.Split (chunksOf) import Data.Text (Text, pack) import Data.Word (Word64, Word8) -import Foreign.C.Types (CChar) +import Foreign.C.Types (CChar, CSize) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (Storable (peek, poke, sizeOf)) @@ -43,47 +43,44 @@ import System.IO.Unsafe (unsafeDupablePerformIO) {-# NOINLINE rotateByteString #-} rotateByteString :: ByteString -> Integer -> ByteString rotateByteString bs i - | BS.null bs = bs - | otherwise = case magnitude `rem` bitLength of - 0 -> bs -- nothing to do irrespective of direction - actualMagnitude -> case signum i of - 0 -> bs -- dummy case that never happens - (-1) -> - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ decreasingRotation actualMagnitude - _ -> - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ increasingRotation actualMagnitude + | BS.length bs == 0 = bs + | BS.maximum bs == zeroBits = bs + | BS.minimum bs == complement zeroBits = bs + | otherwise = case i `rem` bitLen of + 0 -> bs -- nothing to do irrespective of direction + magnitude -> overPtrLen bs $ \ptr len -> + go ptr len magnitude >>= packWithLen len where - magnitude :: Int - magnitude = fromIntegral . abs $ i - bitLength :: Int - bitLength = BS.length bs * 8 - decreasingRotation :: Int -> (Ptr CChar, Int) -> IO ByteString - decreasingRotation actualMagnitude (src, len) = do - let (bigShift, smallShift) = actualMagnitude `quotRem` 8 + go :: Ptr Word8 -> Int -> Integer -> IO (Ptr Word8) + go src len displacement = do dst <- mallocBytes len - -- rotate over bytes - for_ [0 .. len - 1] $ \srcIx -> do - byte :: Word8 <- peek . plusPtr src $ srcIx - let dstIx = (srcIx + bigShift) `mod` len - poke (plusPtr dst dstIx) byte - endByte :: Word8 <- peek . plusPtr src $ len - 1 - let mask = endByte `shiftL` (8 - smallShift) - unless (smallShift == 0) - (foldM_ (decreasingFixUp smallShift dst) mask [0 .. len - 1]) - unsafePackMallocCStringLen (dst, len) - increasingRotation :: Int -> (Ptr CChar, Int) -> IO ByteString - increasingRotation actualMagnitude (src, len) = do - let (bigShift, smallShift) = actualMagnitude `quotRem` 8 - dst <- mallocBytes len - for_ [0 .. len - 1] $ \srcIx -> do - byte :: Word8 <- peek . plusPtr src $ srcIx - let dstIx = (srcIx + len - bigShift) `mod` len - poke (plusPtr dst dstIx) byte - startByte :: Word8 <- peek . castPtr $ src - let mask = startByte `shiftR` smallShift - unless (smallShift == 0) - (foldM_ (increasingFixUp smallShift dst) mask [len - 1, len - 2 .. 0]) - unsafePackMallocCStringLen (dst, len) + case len of + 1 -> do + srcByte <- peek src + let srcByte' = srcByte `rotate` fromIntegral displacement + poke dst srcByte' + _ -> case displacement `quotRem` 8 of + (bigMove, 0) -> do + let mainLen :: CSize = fromIntegral . abs $ bigMove + let restLen :: CSize = fromIntegral len - mainLen + void $ case signum bigMove of + 1 -> memcpy (plusPtr dst . fromIntegral $ restLen) src mainLen >> + memcpy dst (plusPtr src . fromIntegral $ mainLen) restLen + _ -> memcpy (plusPtr dst . fromIntegral $ mainLen) src restLen >> + memcpy dst (plusPtr src . fromIntegral $ restLen) mainLen + _ -> for_ [0 .. len - 1] $ \j -> do + let start = (len - 1 - j) * 8 + let dstByte = foldl' (addBit start displacement) zeroBits [0 .. 7] + poke (plusPtr dst j) dstByte + pure dst + bitLen :: Integer + bitLen = fromIntegral $ BS.length bs * 8 + addBit :: Int -> Integer -> Word8 -> Integer -> Word8 + addBit start displacement acc offset = + let oldIx = (offset + fromIntegral start + bitLen - displacement) `rem` bitLen in + if dangerousRead bs oldIx + then acc .|. (bit . fromIntegral $ offset) + else acc {-# NOINLINE shiftByteString #-} shiftByteString :: ByteString -> Integer -> ByteString @@ -142,18 +139,10 @@ findFirstSetByteString bs = foldl' go (-1) [0 .. len - 1] testBitByteString :: ByteString -> Integer -> Emitter (EvaluationResult Bool) testBitByteString bs i | i < 0 || i >= bitLen = indexOutOfBoundsError "testBitByteString" bitLen i - | otherwise = do - let (bigOffset, smallOffset) = i `quotRem` 8 - let bigIx = fromIntegral $ byteLen - bigOffset - 1 - let mask = bit 0 `shiftL` fromIntegral smallOffset - pure . pure $ case mask .&. BS.index bs bigIx of - 0 -> False - _ -> True + | otherwise = pure . pure . dangerousRead bs $ i where - byteLen :: Integer - byteLen = fromIntegral . BS.length $ bs bitLen :: Integer - bitLen = byteLen * 8 + bitLen = fromIntegral $ BS.length bs * 8 {-# NOINLINE writeBitByteString #-} writeBitByteString :: ByteString -> Integer -> Bool -> Emitter (EvaluationResult ByteString) @@ -254,6 +243,23 @@ complementByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \( -- Helpers +dangerousRead :: ByteString -> Integer -> Bool +dangerousRead bs i = + let (bigOffset, smallOffset) = i `quotRem` 8 + bigIx = BS.length bs - fromIntegral bigOffset - 1 + mask = bit (fromIntegral smallOffset) in + case mask .&. BS.index bs bigIx of + 0 -> False + _ -> True + +packWithLen :: Int -> Ptr Word8 -> IO ByteString +packWithLen len p = unsafePackMallocCStringLen (castPtr p, len) + +overPtrLen :: forall (a :: Type) . + ByteString -> (Ptr Word8 -> Int -> IO a) -> a +overPtrLen bs f = + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> f (castPtr ptr) len + toBitSequence :: Integer -> [Bool] toBitSequence i = go 0 (separateBit i) [] where diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 52485518269..1cb8f4014ce 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -29,9 +29,13 @@ module Evaluation.Builtins.Bitwise ( testBitAppend, writeBitRead, writeBitDouble, + writeBitAgreement, ffsSingleByte, ffsAppend, rotateIdentity, + rotateIndexMotion, + rotateHomogenous, + rotateSum, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) @@ -297,6 +301,28 @@ writeBitDouble = do (EvaluationSuccess res, EvaluationSuccess res') -> res === res' _ -> failure +writeBitAgreement :: PropertyT IO () +writeBitAgreement = do + testCase <- forAllWith ppShow genWriteBitAgreementCase + let (bs, writeIx, readIx) = getWriteBitAgreementArgs testCase + cover 45 "read known zero" $ writeIx /= readIx + cover 45 "read known one" $ writeIx == readIx + let comp = mkIterApp () (builtin () TestBitByteString) [ + mkIterApp () (builtin () WriteBitByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () writeIx, + mkConstant @Bool () True + ], + mkConstant @Integer () readIx + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> + if writeIx == readIx + then res === mkConstant @Bool () True + else res === mkConstant @Bool () False + _ -> failure + ffsSingleByte :: PropertyT IO () ffsSingleByte = do w8 <- forAllWith ppShow Gen.enumBounded @@ -355,8 +381,90 @@ rotateIdentity = do EvaluationSuccess res -> res === mkConstant () bs _ -> failure +rotateIndexMotion :: PropertyT IO () +rotateIndexMotion = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + w8 <- forAllWith ppShow Gen.enumBounded + let bs' = BS.cons w8 bs + let bitLen = fromIntegral $ BS.length bs' * 8 + i <- forAllWith ppShow . Gen.integral . indexRangeOf $ bitLen + readIx <- forAllWith ppShow . Gen.integral . indexRangeFor $ bitLen + let expectedReadIx = case signum i of + 1 -> let raw = readIx - i in + case signum raw of + (-1) -> bitLen + raw + _ -> raw + 0 -> readIx + _ -> (readIx - i) `rem` bitLen + let comp = mkIterApp () (builtin () TestBitByteString) [ + mkIterApp () (builtin () RotateByteString) [ + mkConstant @ByteString () bs', + mkConstant @Integer () i + ], + mkConstant @Integer () readIx + ] + let expected = mkIterApp () (builtin () TestBitByteString) [ + mkConstant @ByteString () bs', + mkConstant @Integer () expectedReadIx + ] + outcome <- bitraverse cekEval cekEval (expected, comp) + case outcome of + (EvaluationSuccess res, EvaluationSuccess actual) -> res === actual + _ -> failure + +rotateHomogenous :: PropertyT IO () +rotateHomogenous = do + w8 <- forAllWith ppShow . Gen.element $ [zeroBits, complement zeroBits] + cover 45 "all ones" $ w8 == complement zeroBits + cover 45 "all zeroes" $ w8 == zeroBits + len <- forAllWith ppShow . Gen.integral $ byteBoundRange + let bs = BS.replicate len w8 + rotation <- forAllWith ppShow . Gen.integral $ indexRange + let comp = mkIterApp () (builtin () RotateByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () rotation + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant @ByteString () bs + _ -> failure + +rotateSum :: PropertyT IO () +rotateSum = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + i <- forAllWith ppShow . Gen.integral $ indexRange + j <- forAllWith ppShow . Gen.integral $ indexRange + let comp1 = mkIterApp () (builtin () RotateByteString) [ + mkIterApp () (builtin () RotateByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () i + ], + mkConstant @Integer () j + ] + let comp2 = mkIterApp () (builtin () RotateByteString) [ + mkConstant @ByteString () bs, + mkIterApp () (builtin () AddInteger) [ + mkConstant @Integer () i, + mkConstant @Integer () j + ] + ] + outcome <- bitraverse cekEval cekEval (comp1, comp2) + case outcome of + (EvaluationSuccess res, EvaluationSuccess res') -> res === res' + _ -> failure + -- Helpers +data WriteBitAgreementCase = + WriteBitReadSame Int Integer | + WriteBitReadDifferent Int Integer Integer + deriving stock (Eq, Show) + +getWriteBitAgreementArgs :: WriteBitAgreementCase -> (ByteString, Integer, Integer) +getWriteBitAgreementArgs = \case + WriteBitReadSame len ix -> (BS.replicate len zeroBits, ix, ix) + WriteBitReadDifferent len ix ix' -> (BS.replicate len zeroBits, ix, ix') + data FFSAppendType = ZeroBoth | ZeroSecond | NotZeroSecond deriving stock (Eq) @@ -665,6 +773,23 @@ cekEval = fmap fst . evalEither . typecheckEvaluateCek defaultCekParameters -- Generators +genWriteBitAgreementCase :: Gen WriteBitAgreementCase +genWriteBitAgreementCase = do + len <- Gen.integral . Range.linear 1 $ 64 + Gen.choice [same len, different len] + where + same :: Int -> Gen WriteBitAgreementCase + same len = do + let bitLen = fromIntegral $ len * 8 + ix <- Gen.integral . indexRangeFor $ bitLen + pure . WriteBitReadSame len $ ix + different :: Int -> Gen WriteBitAgreementCase + different len = do + let bitLen = fromIntegral $ len * 8 + readIx <- Gen.integral . indexRangeFor $ bitLen + writeIx <- Gen.filter (readIx /=) . Gen.integral . indexRangeFor $ bitLen + pure . WriteBitReadDifferent len writeIx $ readIx + genCommutativeCase :: (Word8 -> Word8 -> Word8) -> Gen CommutativeCase genCommutativeCase f = Gen.choice [mismatched, matched] where 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 6f6e3445cbc..e2f25727285 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -35,8 +35,9 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, ffsAppend, ffsSingleByte, - popCountAppend, popCountSingleByte, rotateIdentity, testBitAppend, testBitEmpty, - testBitSingleByte, writeBitDouble, writeBitRead) + popCountAppend, popCountSingleByte, rotateHomogenous, rotateIdentity, + rotateIndexMotion, rotateSum, testBitAppend, testBitEmpty, testBitSingleByte, + writeBitAgreement, writeBitDouble, writeBitRead) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -672,7 +673,8 @@ testTestBitByteString = testGroup "TestBitByteString" [ testWriteBitByteString :: TestTree testWriteBitByteString = testGroup "WriteBitByteString" [ testPropertyNamed "writing then reading gives back what you wrote" "writing then reading gives back what you wrote" . property $ writeBitRead, - testPropertyNamed "second write wins" "second write wins" . property $ writeBitDouble + testPropertyNamed "second write wins" "second write wins" . property $ writeBitDouble, + testPropertyNamed "single write to zeroes gives right reads" "single write to zeroes gives right reads" . property $ writeBitAgreement ] -- Tests for finding first set bit of a ByteString @@ -689,7 +691,10 @@ testFindFirstSetByteString = testGroup "FindFirstSetByteString" [ -- Tests for ByteString rotations testRotateByteString :: TestTree testRotateByteString = testGroup "RotateByteString" [ - testPropertyNamed "rotating by 0 does nothing" "rotating by 0 does nothing" . property $ rotateIdentity + testPropertyNamed "rotating by 0 does nothing" "rotating by 0 does nothing" . property $ rotateIdentity, + testPropertyNamed "rotation adjusts indices correctly" "rotation adjusts indices correctly" . property $ rotateIndexMotion, + testPropertyNamed "rotating all-zero or all-one changes nothing" "rotating all-zero or all-one changes nothing" . property $ rotateHomogenous, + testPropertyNamed "rotating by i, then by j is the same as rotating by i + j" "rotating by i, then by j is the same as rotating by i + j" . property $ rotateSum ] test_definition :: TestTree From ecde7e49766e6172b29bdce6e104215e66cde6a7 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 4 Jul 2022 14:33:13 +1200 Subject: [PATCH 12/73] Reimplement shift similarly to rotate, shift tests --- plutus-core/plutus-core/src/Bitwise.hs | 54 +++++++++++++++++-- .../test/Evaluation/Builtins/Bitwise.hs | 44 ++++++++++++++- .../test/Evaluation/Builtins/Definition.hs | 14 +++-- 3 files changed, 105 insertions(+), 7 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index d8f8fe7dd79..ce7a8c3a9e3 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -1,8 +1,11 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Werror #-} module Bitwise ( integerToByteString, @@ -19,8 +22,7 @@ module Bitwise ( rotateByteString, ) where -import Control.Monad (foldM_, unless) -import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shiftL, shiftR, xor, zeroBits, (.&.), (.|.)) +import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shift, shiftL, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, unsafeUseAsCStringLen) @@ -43,7 +45,7 @@ import System.IO.Unsafe (unsafeDupablePerformIO) {-# NOINLINE rotateByteString #-} rotateByteString :: ByteString -> Integer -> ByteString rotateByteString bs i - | BS.length bs == 0 = bs + | BS.null bs = bs | BS.maximum bs == zeroBits = bs | BS.minimum bs == complement zeroBits = bs | otherwise = case i `rem` bitLen of @@ -84,6 +86,49 @@ rotateByteString bs i {-# NOINLINE shiftByteString #-} shiftByteString :: ByteString -> Integer -> ByteString +shiftByteString bs i + | abs i >= bitLen = BS.replicate (BS.length bs) zeroBits + | BS.maximum bs == zeroBits = bs + | otherwise = overPtrLen bs $ \ptr len -> + go ptr len >>= packWithLen len + where + bitLen :: Integer + bitLen = fromIntegral $ BS.length bs * 8 + go :: Ptr Word8 -> Int -> IO (Ptr Word8) + go src len = do + dst <- mallocBytes len + case len of + 1 -> do + srcByte <- peek src + let srcByte' = srcByte `shift` fromIntegral i + poke dst srcByte' + _ -> case i `quotRem` 8 of + (bigMove, 0) -> do + let mainLen :: CSize = fromIntegral . abs $ bigMove + let restLen :: CSize = fromIntegral len - mainLen + case signum bigMove of + 1 -> do + void . memcpy dst (plusPtr src . fromIntegral $ mainLen) $ restLen + for_ [fromIntegral restLen, fromIntegral $ restLen + 1 .. len - 1] $ \j -> + poke @Word8 (plusPtr dst j) zeroBits + _ -> do + for_ [0 .. fromIntegral mainLen - 1] $ \j -> poke @Word8 (plusPtr dst j) zeroBits + void . memcpy (plusPtr dst . fromIntegral $ mainLen) src $ restLen + _ -> for_ [0 .. len - 1] $ \j -> do + let start = (len - 1 - j) * 8 + let dstByte = foldl' (addBit start) zeroBits [0 .. 7] + poke (plusPtr dst j) dstByte + pure dst + addBit :: Int -> Word8 -> Integer -> Word8 + addBit start acc offset = + let possibleIx = offset + fromIntegral start - i in + if | possibleIx < 0 -> acc + | possibleIx >= bitLen -> acc + | dangerousRead bs possibleIx -> acc .|. (bit . fromIntegral $ offset) + | otherwise -> acc + +{- +shiftByteString :: ByteString -> Integer -> ByteString shiftByteString bs i | magnitude >= bitLength = BS.replicate (BS.length bs) 0 | otherwise = case signum i of @@ -123,6 +168,7 @@ shiftByteString bs i (foldM_ (increasingFixUp smallShift dst) 0 [len - bigShift - 1, len - bigShift .. 0]) -- pack it all up and go unsafePackMallocCStringLen (dst, len) +-} findFirstSetByteString :: ByteString -> Integer findFirstSetByteString bs = foldl' go (-1) [0 .. len - 1] @@ -400,6 +446,7 @@ findPosition w8 = foldl' go 7 . fmap (\i -> (i, bit 0 `shiftL` i)) $ [0 .. 7] 0 -> acc -- nothing to see here, move along _ -> min acc i +{- decreasingFixUp :: Int -> Ptr CChar -> Word8 -> Int -> IO Word8 decreasingFixUp smallShift dst mask ix = do let ptr = plusPtr dst ix @@ -419,6 +466,7 @@ increasingFixUp smallShift dst mask ix = do let masked = bitsWeCareAbout .|. mask poke ptr masked pure mask' +-} countBits :: forall (a :: Type) . (FiniteBits a, Storable a) => diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 1cb8f4014ce..06e6ace7f33 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -36,6 +36,8 @@ module Evaluation.Builtins.Bitwise ( rotateIndexMotion, rotateHomogenous, rotateSum, + shiftIdentity, + shiftSum, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) @@ -50,7 +52,7 @@ import GHC.Exts (fromListN, toList) import Hedgehog (Gen, PropertyT, Range, annotate, annotateShow, cover, evalEither, failure, forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, FindFirstSetByteString, IorByteString, PopCountByteString, RotateByteString, TestBitByteString, WriteBitByteString, XorByteString), +import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, FindFirstSetByteString, IorByteString, PopCountByteString, RotateByteString, ShiftByteString, TestBitByteString, WriteBitByteString, XorByteString), DefaultUni, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters) import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) @@ -381,6 +383,19 @@ rotateIdentity = do EvaluationSuccess res -> res === mkConstant () bs _ -> failure +shiftIdentity :: PropertyT IO () +shiftIdentity = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + let comp = mkIterApp () (builtin () ShiftByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () 0 + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant () bs + _ -> failure + + rotateIndexMotion :: PropertyT IO () rotateIndexMotion = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange @@ -453,6 +468,27 @@ rotateSum = do (EvaluationSuccess res, EvaluationSuccess res') -> res === res' _ -> failure +shiftSum :: PropertyT IO () +shiftSum = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + ij <- forAllWith ppShow . Gen.integral $ indexRange + (i, j) <- forAllWith ppShow . genSplit $ ij + let comp1 = mkIterApp () (builtin () ShiftByteString) [ + mkIterApp () (builtin () ShiftByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () i + ], + mkConstant @Integer () j + ] + let comp2 = mkIterApp () (builtin () ShiftByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () ij + ] + outcome <- bitraverse cekEval cekEval (comp1, comp2) + case outcome of + (EvaluationSuccess res, EvaluationSuccess res') -> res === res' + _ -> failure + -- Helpers data WriteBitAgreementCase = @@ -945,6 +981,12 @@ tooLowIx = Gen.integral . Range.linear (-1) . negate tooHighIx :: Integer -> Gen Integer tooHighIx i = Gen.integral . Range.linear i $ i * 2 +genSplit :: Integer -> Gen (Integer, Integer) +genSplit ij = Gen.element $ case signum ij of + 1 -> [(i, j) | i <- [0 .. ij], j <- [0 .. ij], i + j == ij] + 0 -> [(0, 0)] + _ -> [(i, j) | i <- [0, (-1) .. ij], j <- [0, (-1) .. ij], i + j == ij] + -- Ranges byteBoundRange :: Range Int 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 e2f25727285..e0ba5ce83de 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -36,8 +36,8 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, ffsAppend, ffsSingleByte, popCountAppend, popCountSingleByte, rotateHomogenous, rotateIdentity, - rotateIndexMotion, rotateSum, testBitAppend, testBitEmpty, testBitSingleByte, - writeBitAgreement, writeBitDouble, writeBitRead) + rotateIndexMotion, rotateSum, shiftIdentity, shiftSum, testBitAppend, testBitEmpty, + testBitSingleByte, writeBitAgreement, writeBitDouble, writeBitRead) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -609,7 +609,8 @@ testBitwise = testTestBitByteString, testWriteBitByteString, testFindFirstSetByteString, - testRotateByteString + testRotateByteString, + testShiftByteString ] -- Tests for bitwise AND on ByteStrings @@ -697,6 +698,13 @@ testRotateByteString = testGroup "RotateByteString" [ testPropertyNamed "rotating by i, then by j is the same as rotating by i + j" "rotating by i, then by j is the same as rotating by i + j" . property $ rotateSum ] +-- Tests for ByteString shifts +testShiftByteString :: TestTree +testShiftByteString = testGroup "ShiftByteString" [ + testPropertyNamed "shifting by 0 does nothing" "shifting by 0 does nothing" . property $ shiftIdentity, + testPropertyNamed "shifting in two steps is the same as shifting in one" "shifting in two steps is the same as shifting in one" . property $ shiftSum + ] + test_definition :: TestTree test_definition = testGroup "definition" From 05761211f587e8ad2ac5ea0429d2f1a0b13b6fba Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 5 Jul 2022 09:18:58 +1200 Subject: [PATCH 13/73] Shifting tests --- plutus-core/plutus-core/src/Bitwise.hs | 65 ------------------- .../test/Evaluation/Builtins/Bitwise.hs | 44 +++++++++++++ .../test/Evaluation/Builtins/Definition.hs | 7 +- 3 files changed, 49 insertions(+), 67 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index ce7a8c3a9e3..5f2b93a3d3f 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -127,49 +127,6 @@ shiftByteString bs i | dangerousRead bs possibleIx -> acc .|. (bit . fromIntegral $ offset) | otherwise -> acc -{- -shiftByteString :: ByteString -> Integer -> ByteString -shiftByteString bs i - | magnitude >= bitLength = BS.replicate (BS.length bs) 0 - | otherwise = case signum i of - 0 -> bs - (-1) -> - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ decreasingShift - _ -> - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ increasingShift - where - magnitude :: Int - magnitude = fromIntegral . abs $ i - bitLength :: Int - bitLength = BS.length bs * 8 - decreasingShift :: (Ptr CChar, Int) -> IO ByteString - decreasingShift (src, len) = do - let (bigShift, smallShift) = magnitude `quotRem` 8 - dst <- mallocBytes len - -- clear the first bigShift bytes - for_ [0 .. bigShift - 1] $ \j -> poke (plusPtr dst j) (0 :: CChar) - -- copy in the rest, offset by bigShift - void . memcpy (plusPtr dst bigShift) src . fromIntegral $ len - bigShift - -- correct any outstanding shifts - unless (smallShift == 0) - (foldM_ (decreasingFixUp smallShift dst) 0 [bigShift .. len - 1]) - -- pack it all up and go - unsafePackMallocCStringLen (dst, len) - increasingShift :: (Ptr CChar, Int) -> IO ByteString - increasingShift (src, len) = do - let (bigShift, smallShift) = magnitude `quotRem` 8 - dst <- mallocBytes len - -- copy in the last len - bigShift bytes, offset to start from 0 - void . memcpy dst (plusPtr src bigShift) . fromIntegral $ len - bigShift - -- clear the rest - for_ [len - bigShift, len - bigShift + 1 .. len - 1] $ \j -> poke (plusPtr dst j) (0 :: CChar) - -- correct any outstanding shifts - unless (smallShift == 0) - (foldM_ (increasingFixUp smallShift dst) 0 [len - bigShift - 1, len - bigShift .. 0]) - -- pack it all up and go - unsafePackMallocCStringLen (dst, len) --} - findFirstSetByteString :: ByteString -> Integer findFirstSetByteString bs = foldl' go (-1) [0 .. len - 1] where @@ -446,28 +403,6 @@ findPosition w8 = foldl' go 7 . fmap (\i -> (i, bit 0 `shiftL` i)) $ [0 .. 7] 0 -> acc -- nothing to see here, move along _ -> min acc i -{- -decreasingFixUp :: Int -> Ptr CChar -> Word8 -> Int -> IO Word8 -decreasingFixUp smallShift dst mask ix = do - let ptr = plusPtr dst ix - byte :: Word8 <- peek ptr - let bitsWeCareAbout = byte `shiftR` smallShift - let mask' = byte `shiftL` (8 - smallShift) - let masked = bitsWeCareAbout .|. mask - poke ptr masked - pure mask' - -increasingFixUp :: Int -> Ptr CChar -> Word8 -> Int -> IO Word8 -increasingFixUp smallShift dst mask ix = do - let ptr = plusPtr dst ix - byte :: Word8 <- peek ptr - let bitsWeCareAbout = byte `shiftL` smallShift - let mask' = byte `shiftR` (8 - smallShift) - let masked = bitsWeCareAbout .|. mask - poke ptr masked - pure mask' --} - countBits :: forall (a :: Type) . (FiniteBits a, Storable a) => Ptr a -> Int -> IO Int diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 06e6ace7f33..56ef144cf82 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Werror #-} @@ -37,6 +38,8 @@ module Evaluation.Builtins.Bitwise ( rotateHomogenous, rotateSum, shiftIdentity, + shiftIndexMotion, + shiftHomogenous, shiftSum, ) where @@ -427,6 +430,33 @@ rotateIndexMotion = do (EvaluationSuccess res, EvaluationSuccess actual) -> res === actual _ -> failure +shiftIndexMotion :: PropertyT IO () +shiftIndexMotion = do + bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange + w8 <- forAllWith ppShow Gen.enumBounded + let bs' = BS.cons w8 bs + let bitLen = fromIntegral $ BS.length bs' * 8 + i <- forAllWith ppShow . Gen.integral . indexRangeOf $ bitLen + readIx <- forAllWith ppShow . Gen.integral . indexRangeFor $ bitLen + let comp = mkIterApp () (builtin () TestBitByteString) [ + mkIterApp () (builtin () ShiftByteString) [ + mkConstant @ByteString () bs', + mkConstant @Integer () i + ], + mkConstant @Integer () readIx + ] + let comp' = let expectedIx = readIx - i in + if | expectedIx < 0 -> mkConstant @Bool () False + | expectedIx >= bitLen -> mkConstant @Bool () False + | otherwise -> mkIterApp () (builtin () TestBitByteString) [ + mkConstant @ByteString () bs', + mkConstant @Integer () expectedIx + ] + outcome <- bitraverse cekEval cekEval (comp, comp') + case outcome of + (EvaluationSuccess res, EvaluationSuccess res') -> res === res' + _ -> failure + rotateHomogenous :: PropertyT IO () rotateHomogenous = do w8 <- forAllWith ppShow . Gen.element $ [zeroBits, complement zeroBits] @@ -444,6 +474,20 @@ rotateHomogenous = do EvaluationSuccess res -> res === mkConstant @ByteString () bs _ -> failure +shiftHomogenous :: PropertyT IO () +shiftHomogenous = do + len <- forAllWith ppShow . Gen.integral $ byteBoundRange + i <- forAllWith ppShow . Gen.integral $ indexRange + let bs = BS.replicate len zeroBits + let comp = mkIterApp () (builtin () ShiftByteString) [ + mkConstant @ByteString () bs, + mkConstant @Integer () i + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant @ByteString () bs + _ -> failure + rotateSum :: PropertyT IO () rotateSum = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange 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 e0ba5ce83de..f2789282a87 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -36,8 +36,9 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, ffsAppend, ffsSingleByte, popCountAppend, popCountSingleByte, rotateHomogenous, rotateIdentity, - rotateIndexMotion, rotateSum, shiftIdentity, shiftSum, testBitAppend, testBitEmpty, - testBitSingleByte, writeBitAgreement, writeBitDouble, writeBitRead) + rotateIndexMotion, rotateSum, shiftHomogenous, shiftIdentity, shiftIndexMotion, + shiftSum, testBitAppend, testBitEmpty, testBitSingleByte, writeBitAgreement, + writeBitDouble, writeBitRead) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -702,6 +703,8 @@ testRotateByteString = testGroup "RotateByteString" [ testShiftByteString :: TestTree testShiftByteString = testGroup "ShiftByteString" [ testPropertyNamed "shifting by 0 does nothing" "shifting by 0 does nothing" . property $ shiftIdentity, + testPropertyNamed "shifting adjusts indices correctly" "shifting adjusts indices correctly" . property $ shiftIndexMotion, + testPropertyNamed "shifting all-zeroes does nothing" "shifting all-zeroes does nothing" . property $ shiftHomogenous, testPropertyNamed "shifting in two steps is the same as shifting in one" "shifting in two steps is the same as shifting in one" . property $ shiftSum ] From 409f710caa5970aa961b59cae9426226f1352fa1 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 6 Jul 2022 09:41:58 +1200 Subject: [PATCH 14/73] Finish bytestring conversion tests --- plutus-core/plutus-core/src/Bitwise.hs | 83 +++++++++++- .../test/Evaluation/Builtins/Bitwise.hs | 124 +++++++++++++++++- .../test/Evaluation/Builtins/Definition.hs | 20 ++- 3 files changed, 216 insertions(+), 11 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 5f2b93a3d3f..a925894d15c 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -22,6 +22,8 @@ module Bitwise ( rotateByteString, ) where +import Control.Monad (foldM, when) +import Control.Monad.State.Strict (State, evalState, get, modify, put) import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shift, shiftL, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS @@ -29,14 +31,14 @@ import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, u import Data.Foldable (foldl', for_) import Data.Functor (void) import Data.Kind (Type) -import Data.List.Split (chunksOf) +-- import Data.List.Split (chunksOf) import Data.Text (Text, pack) import Data.Word (Word64, Word8) import Foreign.C.Types (CChar, CSize) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (Storable (peek, poke, sizeOf)) -import GHC.Exts (fromList) +import GHC.Exts (fromList, fromListN) import GHC.IO.Handle.Text (memcpy) import PlutusCore.Builtin.Emitter (Emitter, emit) import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure)) @@ -170,18 +172,63 @@ writeBitByteString bs i b poke (castPtr . plusPtr dst $ bigIx) byte' unsafePackMallocCStringLen (dst, len) +integerToByteString :: Integer -> ByteString +integerToByteString i = case signum i of + 0 -> BS.singleton zeroBits + (-1) -> twosCompToNegative . fromList . go . abs $ i + _ -> fromList . go $ i + where + go :: Integer -> [Word8] + go = \case + 0 -> [] + pos -> case pos `quotRem` 256 of + (d, r) -> go d <> [fromIntegral r] + +byteStringToInteger :: ByteString -> Integer +byteStringToInteger bs = case BS.uncons bs of + Nothing -> 0 + Just (w8, bs') -> + let len = BS.length bs + f x = evalState (foldM (go x) 0 [len - 1, len - 2 .. 0]) 1 in + if | isPositivePowerOf2 w8 bs' -> f bs + | bit 7 .&. w8 == zeroBits -> f bs + | otherwise -> negate . f . twosCompToPositive $ bs + where + go :: ByteString -> Integer -> Int -> State Integer Integer + go bs' acc i = do + mult <- get + let byte = BS.index bs' i + modify (256 *) + pure $ acc + (fromIntegral byte * mult) + +{- integerToByteString :: Integer -> ByteString integerToByteString i = case signum i of 0 -> BS.singleton 0 (-1) -> twosComplement . integerToByteString . abs $ i _ -> fromList . intoBytes . toBitSequence $ i +byteStringToInteger :: ByteString -> Integer +byteStringToInteger bs = case BS.uncons bs of + Nothing -> 0 + Just (w8, bs') -> + if | isPositivePowerOf2 w8 bs' -> go bs + | bit 7 .&. w8 == zeroBits -> go bs + | otherwise -> negate . go . twosComplement $ bs + where + go :: ByteString -> Integer + go bs' = let len = BS.length bs' in + snd . foldl' go2 (1, 0) $ [len - 1, len -2 .. 0] + go2 :: (Integer, Integer) -> Int -> (Integer, Integer) + go2 (e, acc) ix = (e * 256, acc + e * (fromIntegral . BS.index bs $ ix)) + byteStringToInteger :: ByteString -> Integer byteStringToInteger bs = let len = BS.length bs in snd . foldl' go (1, 0) $ [len - 1, len - 2 .. 0] where go :: (Integer, Integer) -> Int -> (Integer, Integer) go (e, acc) ix = (e * 256, acc + e * (fromIntegral . BS.index bs $ ix)) +-} {-# NOINLINE popCountByteString #-} popCountByteString :: ByteString -> Integer @@ -246,6 +293,9 @@ complementByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \( -- Helpers +isPositivePowerOf2 :: Word8 -> ByteString -> Bool +isPositivePowerOf2 w8 bs = w8 == 0x80 && BS.all (== zeroBits) bs + dangerousRead :: ByteString -> Integer -> Bool dangerousRead bs i = let (bigOffset, smallOffset) = i `quotRem` 8 @@ -263,6 +313,7 @@ overPtrLen :: forall (a :: Type) . overPtrLen bs f = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> f (castPtr ptr) len +{- toBitSequence :: Integer -> [Bool] toBitSequence i = go 0 (separateBit i) [] where @@ -299,7 +350,34 @@ intoBytes = fmap go . chunksOf 8 b7Val = if b7 then 128 else 0 in b0Val + b1Val + b2Val + b3Val + b4Val + b5Val + b6Val + b7Val _ -> 0 -- should never happen +-} + +-- When we complement a power of two, we have to ensure we pad with ones +-- +-- Thus, we have two versions of this function: one that performs this padding, +-- and one which doesn't +twosCompToNegative :: ByteString -> ByteString +twosCompToNegative bs = case twosComp bs of + bs' -> if bs == bs' + then BS.cons (complement zeroBits) bs' + else bs' + +twosCompToPositive :: ByteString -> ByteString +twosCompToPositive = twosComp + +twosComp :: ByteString -> ByteString +twosComp bs = let len = BS.length bs in + evalState (fromListN len <$> foldM go [] [len - 1, len - 2 .. 0]) False + where + go :: [Word8] -> Int -> State Bool [Word8] + go acc i = do + let byte = BS.index bs i + added <- get + let byte' = if added then complement byte else complement byte + 1 + when (byte /= byte') (put True) + pure $ byte' : acc +{- twosComplement :: ByteString -> ByteString twosComplement bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> do dst <- mallocBytes len @@ -336,6 +414,7 @@ computeAddByte = \case else case r of 0 -> go (step + 1) acc dr' _ -> go (step + 1) (True, w8 .|. mask) dr' +-} mismatchedLengthError :: forall (a :: Type) . Text -> diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 56ef144cf82..127b7bcae7f 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -41,6 +41,9 @@ module Evaluation.Builtins.Bitwise ( shiftIndexMotion, shiftHomogenous, shiftSum, + -- iToBSRoundtrip, + bsToITrailing, + bsToIHomogenous, ) where import Control.Lens.Fold (Fold, folding, has, hasn't, preview) @@ -49,14 +52,15 @@ import Data.Bitraversable (bitraverse) import Data.Bits (bit, complement, countTrailingZeros, popCount, shiftL, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS +import Data.Text (Text) import Data.Word (Word8) import Evaluation.Builtins.Common (typecheckEvaluateCek) import GHC.Exts (fromListN, toList) import Hedgehog (Gen, PropertyT, Range, annotate, annotateShow, cover, evalEither, failure, forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ComplementByteString, FindFirstSetByteString, IorByteString, PopCountByteString, RotateByteString, ShiftByteString, TestBitByteString, WriteBitByteString, XorByteString), - DefaultUni, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) +import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ByteStringToInteger, ComplementByteString, FindFirstSetByteString, IorByteString, PopCountByteString, RotateByteString, ShiftByteString, TestBitByteString, WriteBitByteString, XorByteString), + DefaultUni, Error, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters) import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) import Text.Show.Pretty (ppShow) @@ -533,8 +537,86 @@ shiftSum = do (EvaluationSuccess res, EvaluationSuccess res') -> res === res' _ -> failure +{- +iToBSRoundtrip :: PropertyT IO () +iToBSRoundtrip = do + i <- forAllWith ppShow . Gen.integral $ indexRange + tripping (mkConstant @Integer () i) toBits fromBits + where + toBits :: + Term Untyped.TyName Name DefaultUni DefaultFun () -> + Either (Error DefaultUni DefaultFun ()) + (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) + toBits i = let comp = mkIterApp () (builtin () IntegerToByteString) [i] in + fst <$> cekEval' comp + fromBits :: + Either (Error DefaultUni DefaultFun ()) + (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) -> + Maybe (Term Untyped.TyName Name DefaultUni DefaultFun ()) + fromBits = \case + Right (EvaluationSuccess res) -> do + let comp = mkIterApp () (builtin () ByteStringToInteger) [res] + case fst <$> cekEval' comp of + Right (EvaluationSuccess res') -> pure res' + _ -> Nothing + _ -> Nothing +-} + +bsToITrailing :: PropertyT IO () +bsToITrailing = do + testCase <- forAllWith ppShow genBsToITrailingCase + cover 45 "negative representation" . isNegativeCase $ testCase + cover 45 "non-negative representation" . not . isNegativeCase $ testCase + let (extension, bs) = getBsToITrailingArgs testCase + let comp = mkIterApp () (builtin () ByteStringToInteger) [ + mkIterApp () (builtin () AppendByteString) [ + mkConstant @ByteString () extension, + mkConstant @ByteString () bs + ] + ] + let comp' = mkIterApp () (builtin () ByteStringToInteger) [ + mkConstant @ByteString () bs + ] + outcome <- bitraverse cekEval cekEval (comp, comp') + case outcome of + (EvaluationSuccess res, EvaluationSuccess res') -> res === res' + _ -> failure + +bsToIHomogenous :: PropertyT IO () +bsToIHomogenous = do + w8 <- forAllWith ppShow . Gen.element $ [zeroBits, complement zeroBits] + len <- forAllWith ppShow . Gen.integral $ integerRange + cover 45 "all zeroes" $ w8 == zeroBits + cover 45 "all ones" $ w8 == complement zeroBits + let bs = BS.replicate len w8 + let comp = mkIterApp () (builtin () ByteStringToInteger) [ + mkConstant @ByteString () bs + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> + res === (mkConstant @Integer () $ if | len == 0 -> 0 + | w8 == zeroBits -> 0 + | otherwise -> (-1)) + _ -> failure + -- Helpers +data BsToITrailingCase = + BsToINonNegative ByteString ByteString | + BsToINegative ByteString ByteString + deriving stock (Eq, Show) + +isNegativeCase :: BsToITrailingCase -> Bool +isNegativeCase = \case + BsToINegative{} -> True + _ -> False + +getBsToITrailingArgs :: BsToITrailingCase -> (ByteString, ByteString) +getBsToITrailingArgs = \case + BsToINegative bs bs' -> (bs, bs') + BsToINonNegative bs bs' -> (bs, bs') + data WriteBitAgreementCase = WriteBitReadSame Int Integer | WriteBitReadDifferent Int Integer Integer @@ -849,10 +931,43 @@ commutatively fun leftArg rightArg = do cekEval :: Term Untyped.TyName Name DefaultUni DefaultFun () -> PropertyT IO (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) -cekEval = fmap fst . evalEither . typecheckEvaluateCek defaultCekParameters +cekEval = fmap fst . evalEither . cekEval' + +cekEval' :: + Term Untyped.TyName Name DefaultUni DefaultFun () -> + Either (Error DefaultUni DefaultFun ()) + (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ()), [Text]) +cekEval' = typecheckEvaluateCek defaultCekParameters -- Generators +genBsToITrailingCase :: Gen BsToITrailingCase +genBsToITrailingCase = Gen.choice [negative, nonNegative] + where + negative :: Gen BsToITrailingCase + negative = do + len <- Gen.integral byteBoundRange + extLen <- Gen.integral byteBoundRange + w8 <- Gen.element [129 :: Word8 .. 255] + bs <- Gen.bytes . Range.singleton $ len + pure . + BsToINegative (BS.replicate extLen . complement $ zeroBits) . + BS.cons w8 $ bs + nonNegative :: Gen BsToITrailingCase + nonNegative = do + len <- Gen.integral byteBoundRange + extLen <- Gen.integral byteBoundRange + BsToINonNegative (BS.replicate extLen zeroBits) <$> + case len of + 0 -> pure BS.empty + _ -> Gen.choice [pure . powerOf2 $ len, notPowerOf2 len] + powerOf2 :: Int -> ByteString + powerOf2 len = BS.cons 128 . BS.replicate (len - 1) $ zeroBits + notPowerOf2 :: Int -> Gen ByteString + notPowerOf2 len = + BS.cons <$> Gen.element [0 :: Word8 .. 127] <*> + (Gen.bytes . Range.singleton $ len - 1) + genWriteBitAgreementCase :: Gen WriteBitAgreementCase genWriteBitAgreementCase = do len <- Gen.integral . Range.linear 1 $ 64 @@ -1048,3 +1163,6 @@ indexRangeOf lim = Range.constantFrom 0 (negate lim) (lim - 1) indexRangeFor :: Integer -> Range Integer indexRangeFor i = Range.constant 0 (i - 1) + +integerRange :: Range Int +integerRange = Range.linear 0 8 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 f2789282a87..593831786ad 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -34,11 +34,11 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseAndIdentity, bitwiseAndSelf, bitwiseComplementSelfInverts, bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, - bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, ffsAppend, ffsSingleByte, - popCountAppend, popCountSingleByte, rotateHomogenous, rotateIdentity, - rotateIndexMotion, rotateSum, shiftHomogenous, shiftIdentity, shiftIndexMotion, - shiftSum, testBitAppend, testBitEmpty, testBitSingleByte, writeBitAgreement, - writeBitDouble, writeBitRead) + bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, bsToIHomogenous, + bsToITrailing, ffsAppend, ffsSingleByte, popCountAppend, popCountSingleByte, + rotateHomogenous, rotateIdentity, rotateIndexMotion, rotateSum, shiftHomogenous, + shiftIdentity, shiftIndexMotion, shiftSum, testBitAppend, testBitEmpty, + testBitSingleByte, writeBitAgreement, writeBitDouble, writeBitRead) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -611,7 +611,8 @@ testBitwise = testWriteBitByteString, testFindFirstSetByteString, testRotateByteString, - testShiftByteString + testShiftByteString, + testByteStringToInteger ] -- Tests for bitwise AND on ByteStrings @@ -708,6 +709,13 @@ testShiftByteString = testGroup "ShiftByteString" [ testPropertyNamed "shifting in two steps is the same as shifting in one" "shifting in two steps is the same as shifting in one" . property $ shiftSum ] +-- Tests for conversion into Integer from ByteString +testByteStringToInteger :: TestTree +testByteStringToInteger = testGroup "ByteStringToInteger" [ + testPropertyNamed "all zeroes give 0, all ones give -1" "all zeroes give 0, all ones give -1" . property $ bsToIHomogenous, + testPropertyNamed "trailing ones ignored for negative, trailing zeroes for positive" "trailing ones ignored for negative, trailing zeroes for positive" . property $ bsToITrailing + ] + test_definition :: TestTree test_definition = testGroup "definition" From a2f1748f79433e9e7477879d71876333b04598e7 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 6 Jul 2022 12:20:28 +1200 Subject: [PATCH 15/73] PlutusTx bitwise builtins --- plutus-tx/src/PlutusTx/Builtins.hs | 283 ++++++++++++++++++++ plutus-tx/src/PlutusTx/Builtins/Internal.hs | 81 ++++++ 2 files changed, 364 insertions(+) diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index b2a7ef5d47e..4ad4132f002 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -72,6 +72,19 @@ module PlutusTx.Builtins ( -- * Conversions , fromBuiltin , toBuiltin + -- * Bitwise builtins + , integerToByteString + , byteStringToInteger + , andByteString + , iorByteString + , xorByteString + , complementByteString + , shiftByteString + , rotateByteString + , popCountByteString + , testBitByteString + , writeBitByteString + , findFirstSetByteString ) where import PlutusTx.Base (const, uncurry) @@ -202,6 +215,276 @@ verifySchnorrSecp256k1Signature verifySchnorrSecp256k1Signature vk msg sig = fromBuiltin (BI.verifySchnorrSecp256k1Signature vk msg sig) +-- | Converts an 'Integer' into its 'BuiltinByteString' representation. +-- +-- = Notes +-- +-- Throughout, let @maxInteger@ be the maximum function for 'Integer's, +-- and @absInteger@ be the absolute value function for 'Integer's. +-- We define @zeroes :: 'Integer' -> 'BuiltinByteString'@ be the +-- function which, given input @i@, produces a 'BuiltinByteString' @bs@ such +-- that: +-- +-- * @'lengthByteString' bs@ @=@ @'maxInteger' 0 i@; and +-- * For all @j :: 'Integer'@ such that @'greaterThanEqualsInteger' j 0@, +-- @'indexByteString' bs j = 0@; +-- +-- We define @ones :: 'Integer' -> 'BuiltinByteString'@ identically to @zeroes@, +-- except that @'indexByteString' bs j = 255@ instead. +-- +-- == Laws +-- +-- 'integerToByteString' must roundtrip via 'byteStringToInteger'. Specifically, +-- for all @i :: 'Integer'@, we must have: +-- +-- @'byteStringToInteger '.' 'integerToByteString' '$' i@ @=@ @i@ +-- +-- Furthermore, the length of any result of 'integerToByteString' must be +-- strictly positive: +-- +-- @'greaterThanInteger' ('lengthByteString' '.' 'integerToByteString' i) 0@ @=@ +-- @True@ +-- +-- Lastly, the result /must/ be encoded as defined in the Encoding section +-- below. +-- +-- == Encoding +-- +-- 'integerToByteString' follows the encoding we describe below; let @i :: +-- 'Integer'@. If @i@ is zero, @'integerToByteString' i@ @=@ @zeroes 1@; +-- we call this the /zero representation/. If @i@ is non-zero, the encoding +-- depends on the sign of @i@. +-- +-- If @i@ is positive, @'integerToByteString' i@ @=@ @bs@ such that the +-- following hold: +-- +-- * @'greaterThanInteger' ('byteStringLength' bs) 0@ @=@ @True@; +-- * Let @polyQuotientInteger :: 'Integer' -> 'Integer' -> +-- 'Integer' -> 'Integer'@ be defined such that +-- @polyQuotientInteger i j reps@ be a repeat application of 'quotientInteger' +-- with @j@ as its second argument @'maxInteger' 0 reps@ times to @i@. Let +-- @ix :: 'BuiltinInteger'@ such that @'greaterThanEqualsInteger' ix 0@ and +-- @'lessThanInteger' ix k@. Then, @'indexByteString' bs ix@ @=@ +-- @'remainderInteger' (polyQuotientInteger i 256 ('subtractInteger' ('subtractInteger' k 1) ix)) 256@ +-- +-- We call this a /positive representation/. +-- +-- If @i@ is negative, there are two cases: +-- +-- * If the absolute value of @i@ is /not/ an exact power of 256, then +-- @'integerToByteString' i@ is the [two's +-- complement](https://en.wikipedia.org/wiki/Two%27s_complement) of the positive +-- representation of @'absInteger' i@. +-- * Otherwise, let @bs@ be the two's complement of the positive representation +-- of @'absInteger' i@. Then, @'integerToByteString' i@ is @'appendByteString' +-- (ones 1) bs@. +-- +-- We call this a /negative representation/. We need to introduce the special +-- second case (with the \'ones padding\') for negative representations as exact +-- powers of 256 are their own two's complement: thus, we have to distinguish +-- positive cases from negative ones. We choose to do this by \'padding\', as +-- this makes the decode direction easier. +{-# INLINEABLE integerToByteString #-} +integerToByteString :: Integer -> BuiltinByteString +integerToByteString i = BI.integerToByteString (toBuiltin i) + +-- | Converts a 'BuiltinByteString' into its 'Integer' representation. +-- +-- = Notes +-- +-- We inherit all definitions described for 'integerToByteString'. +-- +-- == Laws +-- +-- In addition to the roundtrip requirements specified by the laws of +-- 'integerToByteString', we also add the following requirements. Throughout, +-- let @i :: Integer@ and @j :: Integer@ such that @'greaterThanInteger' j 0@. +-- +-- * /Padding/: If @bs@ is a zero representation or +-- a positive representation, then @'byteStringToInteger' bs@ @=@ +-- @'byteStringToInteger' ('appendByteString' (zeroes i) bs)@; otherwise, +-- @'byteStringToInteger' bs@ @=@ @'byteStringToInteger' ('appendByteString' +-- (ones i) bs)@. +-- * /Zero homogeneity/: @'byteStringToInteger' (zeroes i)@ @=@ @0@. +-- * /One homogeneity/: @'byteStringToInteger' (ones j)@ @=@ @(-1)@. +-- +-- A theorem of zero homogeneity is that @'byteStringToInteger' ""@ @=@ @0@. +-- +-- == Redundant encodings +-- +-- Unfortunately, the padding, zero homogeneity and one homogeneity laws mean +-- that the combination of 'byteStringToInteger' and 'integerToByteString' +-- cannot be an isomorphism. This is unavoidable: we either have to make +-- 'byteStringToInteger' partial, or allow redundant encodings. We chose the +-- second option as it is harmless, and as long as 'integerToByteString' +-- produces non-redundant encodings, shouldn't cause issues. +{-# INLINEABLE byteStringToInteger #-} +byteStringToInteger :: BuiltinByteString -> Integer +byteStringToInteger bs = fromBuiltin (BI.byteStringToInteger bs) + +-- | If given arguments of identical length, constructs their bitwise logical +-- AND, erroring otherwise. +-- +-- = Notes +-- +-- We inherit all definitions described for 'integerToByteString'. +-- +-- == Laws +-- +-- 'andByteString' follows these laws: +-- +-- * /Commutativity/: @'andByteString' bs1 bs2@ @=@ @'andByteString' bs2 bs1@ +-- * /Associativity/: @'andByteString' bs1 ('andByteString' bs2 bs3)@ @=@ +-- @'andByteString' ('andByteString' bs1 bs2) bs3@ +-- * /Identity/: @'andByteString' bs (ones '.' 'lengthByteString' '$' bs)@ @=@ +-- @bs@ +-- * /Absorbtion/: @'andByteString' bs (zeroes '.' 'lengthByteString' '$' bs)@ +-- @=@ @zeroes '.' 'lengthByteString' '$' bs@ +-- * /De Morgan's law for AND/: @'complementByteString' ('andByteString' bs1 +-- bs2)@ @=@ @'iorByteString' ('complementByteString' bs1) +-- ('complementByteString' bs2)@ +-- * /Idempotence/: @'andByteString' bs bs@ @=@ @bs@ +{-# INLINEABLE andByteString #-} +andByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString +andByteString = BI.andByteString + +-- | If given arguments of identical length, constructs their bitwise logical +-- IOR, erroring otherwise. +-- +-- = Notes +-- +-- We inherit all definitions described for 'integerToByteString'. +-- +-- == Laws +-- +-- 'iorByteString' follows these laws: +-- +-- * /Commutativity/: @'iorByteString' bs1 bs2@ @=@ @'iorByteString' bs2 bs1@ +-- * /Associativity/: @'iorByteString' bs1 ('iorByteString' bs2 bs3)@ @=@ +-- @'iorByteString' ('iorByteString' bs1 bs2) bs3@ +-- * /Identity/: @'iorByteString' bs (zeroes '.' 'lengthByteString' '$' bs)@ @=@ +-- @bs@ +-- * /Absorbtion/: @'iorByteString' bs (ones '.' 'lengthByteString' '$' bs)@ +-- @=@ @ones '.' 'lengthByteString' '$' bs@ +-- * /De Morgan's law for IOR/: @'complementByteString' ('iorByteString' bs1 +-- bs2)@ @=@ @'andByteString' ('complementByteString' bs1) +-- ('complementByteString' bs2)@ +-- * /Idempotence/: @'iorByteString' bs bs@ @=@ @bs@ +{-# INLINEABLE iorByteString #-} +iorByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString +iorByteString = BI.iorByteString + +-- | If given arguments of identical length, constructs their bitwise logical +-- XOR, erroring otherwise. +-- +-- = Notes +-- +-- We inherit all definitions described for 'integerToByteString'. +-- +-- == Laws +-- +-- 'xorByteString' follows these laws: +-- +-- * /Commutativity/: @'xorByteString' bs1 bs2@ @=@ @'xorByteString' bs2 bs1@ +-- * /Associativity/: @'xorByteString' bs1 ('xorByteString' bs2 bs3)@ @=@ +-- @'xorByteString' ('xorByteString' bs1 bs2) bs3@ +-- * /Identity/: @'xorByteString' bs (zeroes '.' 'lengthByteString' '$' bs)@ @=@ +-- @bs@ +-- * /Complementarity/: @'xorByteString' bs (ones '.' 'lengthByteString' '$' +-- bs)@ @=@ @'complementByteString' bs@ +-- * /Self-absorbtion/: @'xorByteString' bs bs@ @=@ @zeroes '.' +-- 'lengthByteString' '$' bs@ +{-# INLINEABLE xorByteString #-} +xorByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString +xorByteString = BI.xorByteString + +-- | Constructs the [one's complement](https://en.wikipedia.org/wiki/Ones%27_complement) +-- of its argument. +-- +-- = Laws +-- +-- `complementByteString` is self-inverting: specifically, we have +-- @'complementByteString' '.' 'complementByteString' '$' bs@ @=@ @bs@. +{-# INLINEABLE complementByteString #-} +complementByteString :: BuiltinByteString -> BuiltinByteString +complementByteString = BI.complementByteString + +-- | Shifts the 'BuiltinByteString' argument. More precisely, constructs a new +-- 'BuiltinByteString' by \'adjusting\' the bit indexes of the +-- 'BuiltinByteString' argument by the 'Integer' argument; if this would cause +-- an \'out-of-bounds\', that bit is 0 instead. +-- +-- = Notes +-- +-- We inherit all definitions described for 'integerToByteString'. +-- +-- == Laws +-- +-- 'shiftByteString' follows these laws: +-- +-- * /Identity/: @'shiftByteString' bs 0@ @=@ @bs@ +-- * /Decomposition/: Let @i, j :: 'Integer'@ such that either at least one of +-- @i@, @j@ is zero or @i@ and @j@ have the same sign. Then @'shiftByteString' +-- bs ('addInteger' i j)@ @=@ @'shiftByteString' ('shiftByteString' bs i) j@ +-- * /Erasure/: If @greaterThanEqualsInteger ('absInteger' i) '.' 'lengthByteString' '$' bs@, +-- then @'shiftByteString' bs i@ @=@ @zeroes '.' 'lengthByteString' '$' bs@ +{-# INLINEABLE shiftByteString #-} +shiftByteString :: BuiltinByteString -> Integer -> BuiltinByteString +shiftByteString bs i = BI.shiftByteString bs (toBuiltin i) + +-- | Rotates the 'BuiltinByteString' argument. More precisely, constructs a new +-- 'BuiltinByteString' by \'adjusting\' the bit indexes of the +-- 'BuiltinByteString' argument by the 'Integer' argument; if this would cause +-- an \'out-of-bounds\', we \'wrap around\'. +-- +-- = Laws +-- +-- 'rotateByteString' follows these laws: +-- +-- * /Identity/: @'rotateByteString' bs 0@ @=@ @bs@ +-- * /Decomposition/: @'rotateByteString' bs ('addInteger' i j)@ @=@ +-- @'rotateByteString' ('rotateByteString' bs i) j@ +-- * /Wraparound/: Let @i :: Integer@ be nonzero. Then @'rotateByteString' bs i@ +-- @=@ @'rotateByteString' bs ('remainderInteger' i ('timesInteger' 8 '.' +-- 'lengthByteString' '$' bs))@ +{-# INLINEABLE rotateByteString #-} +rotateByteString :: BuiltinByteString -> Integer -> BuiltinByteString +rotateByteString bs i = BI.rotateByteString bs (toBuiltin i) + +-- | Counts the number of 1 bits in the argument. +-- +-- = Laws +-- +-- 'popCountByteString' follows these laws: +-- +-- * @'popCountByteString' ""@ @=@ @0@ +-- * @'popCountByteString' ('appendByteString' bs1 bs2)@ @=@ +-- @'addInteger' ('popCountByteString' bs1) ('popCountByteString' bs2)@ +{-# INLINEABLE popCountByteString #-} +popCountByteString :: BuiltinByteString -> Integer +popCountByteString bs = fromBuiltin (BI.popCountByteString bs) + +-- | Bitwise indexing operation. Errors when given an index that's not +-- in-bounds: specifically, indexes that are either negative or greater than or +-- equal to the number of bits in the 'BuiltinByteString' argument. +{-# INLINEABLE testBitByteString #-} +testBitByteString :: BuiltinByteString -> Integer -> Bool +testBitByteString bs i = fromBuiltin (BI.testBitByteString bs (toBuiltin i)) + +-- | Bitwise modification at an index. Errors when given an index that's not +-- in-bounds: specifically, indexes that are either negative or greater than +-- or equal to the number of bits in the 'BuiltinByteString' argument. +{-# INLINEABLE writeBitByteString #-} +writeBitByteString :: BuiltinByteString -> Integer -> Bool -> BuiltinByteString +writeBitByteString bs i b = BI.writeBitByteString bs (toBuiltin i) (toBuiltin b) + +-- | Finds the lowest bit index such that 'testBitByteString' at that index is +-- 'True'. Returns @-1@ if no such index exists: that is, the +-- 'BuiltinByteString' argument has only zero bytes in it, or is empty. +{-# INLINEABLE findFirstSetByteString #-} +findFirstSetByteString :: BuiltinByteString -> Integer +findFirstSetByteString bs = fromBuiltin (BI.findFirstSetByteString bs) + {-# INLINABLE addInteger #-} -- | Add two 'Integer's. addInteger :: Integer -> Integer -> Integer diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index ec5a338f4a1..37e207866ef 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -15,6 +15,7 @@ -- Most users should not use this module directly, but rather use 'PlutusTx.Builtins'. module PlutusTx.Builtins.Internal where +import Bitwise qualified import Codec.Serialise import Control.DeepSeq (NFData (..)) import Control.Monad.Trans.Writer.Strict (runWriter) @@ -290,6 +291,86 @@ lessThanEqualsByteString (BuiltinByteString b1) (BuiltinByteString b2) = Builtin decodeUtf8 :: BuiltinByteString -> BuiltinString decodeUtf8 (BuiltinByteString b) = BuiltinString $ Text.decodeUtf8 b +{-# NOINLINE integerToByteString #-} +integerToByteString :: BuiltinInteger -> BuiltinByteString +integerToByteString = BuiltinByteString . Bitwise.integerToByteString + +{-# NOINLINE byteStringToInteger #-} +byteStringToInteger :: BuiltinByteString -> BuiltinInteger +byteStringToInteger (BuiltinByteString bs) = Bitwise.byteStringToInteger bs + +{-# NOINLINE andByteString #-} +andByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString +andByteString (BuiltinByteString bs) (BuiltinByteString bs') = + case Bitwise.andByteString bs bs' of + Emitter f -> case runWriter f of + (res, logs) -> traceAll logs $ case res of + EvaluationFailure -> mustBeReplaced "Bitwise AND errored." + EvaluationSuccess bs'' -> BuiltinByteString bs'' + +{-# NOINLINE iorByteString #-} +iorByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString +iorByteString (BuiltinByteString bs) (BuiltinByteString bs') = + case Bitwise.iorByteString bs bs' of + Emitter f -> case runWriter f of + (res, logs) -> traceAll logs $ case res of + EvaluationFailure -> mustBeReplaced "Bitwise IOR errored." + EvaluationSuccess bs'' -> BuiltinByteString bs'' + +{-# NOINLINE xorByteString #-} +xorByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString +xorByteString (BuiltinByteString bs) (BuiltinByteString bs') = + case Bitwise.xorByteString bs bs' of + Emitter f -> case runWriter f of + (res, logs) -> traceAll logs $ case res of + EvaluationFailure -> mustBeReplaced "Bitwise XOR errored." + EvaluationSuccess bs'' -> BuiltinByteString bs'' + +{-# NOINLINE complementByteString #-} +complementByteString :: BuiltinByteString -> BuiltinByteString +complementByteString (BuiltinByteString bs) = + BuiltinByteString . Bitwise.complementByteString $ bs + +{-# NOINLINE shiftByteString #-} +shiftByteString :: BuiltinByteString -> BuiltinInteger -> BuiltinByteString +shiftByteString (BuiltinByteString bs) = + BuiltinByteString . Bitwise.shiftByteString bs + +{-# NOINLINE rotateByteString #-} +rotateByteString :: BuiltinByteString -> BuiltinInteger -> BuiltinByteString +rotateByteString (BuiltinByteString bs) = + BuiltinByteString . Bitwise.rotateByteString bs + +{-# NOINLINE popCountByteString #-} +popCountByteString :: BuiltinByteString -> BuiltinInteger +popCountByteString (BuiltinByteString bs) = Bitwise.popCountByteString bs + +{-# NOINLINE testBitByteString #-} +testBitByteString :: BuiltinByteString -> BuiltinInteger -> BuiltinBool +testBitByteString (BuiltinByteString bs) i = + case Bitwise.testBitByteString bs i of + Emitter f -> case runWriter f of + (res, logs) -> traceAll logs $ case res of + EvaluationFailure -> mustBeReplaced "Bitwise indexing errored." + EvaluationSuccess b -> BuiltinBool b + +{-# NOINLINE writeBitByteString #-} +writeBitByteString :: + BuiltinByteString -> + BuiltinInteger -> + BuiltinBool -> + BuiltinByteString +writeBitByteString (BuiltinByteString bs) i (BuiltinBool b) = + case Bitwise.writeBitByteString bs i b of + Emitter f -> case runWriter f of + (res, logs) -> traceAll logs $ case res of + EvaluationFailure -> mustBeReplaced "Bitwise indexed write errored." + EvaluationSuccess bs' -> BuiltinByteString bs' + +{-# NOINLINE findFirstSetByteString #-} +findFirstSetByteString :: BuiltinByteString -> BuiltinInteger +findFirstSetByteString (BuiltinByteString bs) = Bitwise.popCountByteString bs + {- STRING -} From 5acf262da5eaaa5cae46f9f84685ae53a9114163 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 7 Jul 2022 09:40:33 +1200 Subject: [PATCH 16/73] Fix Nix issues, ensure we don't break on line length --- cabal.project | 2 +- flake.lock | 42 +++++----- plutus-core/plutus-core.cabal | 1 - plutus-core/plutus-core/src/Bitwise.hs | 2 +- .../Golden/AndByteString.plc.golden | 1 + .../Golden/ByteStringToInteger.plc.golden | 1 + .../Golden/ComplementByteString.plc.golden | 1 + .../Golden/FindFirstSetByteString.plc.golden | 1 + .../Golden/IntegerToByteString.plc.golden | 1 + .../Golden/IorByteString.plc.golden | 1 + .../Golden/PopCountByteString.plc.golden | 1 + .../Golden/RotateByteString.plc.golden | 1 + .../Golden/ShiftByteString.plc.golden | 1 + .../Golden/TestBitByteString.plc.golden | 1 + .../Golden/WriteBitByteString.plc.golden | 1 + .../Golden/XorByteString.plc.golden | 1 + .../test/Evaluation/Builtins/Bitwise.hs | 1 + .../test/Evaluation/Builtins/Definition.hs | 84 +++++++++---------- 18 files changed, 77 insertions(+), 67 deletions(-) create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/AndByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/ByteStringToInteger.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/ComplementByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/FindFirstSetByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/IntegerToByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/IorByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/PopCountByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/RotateByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/ShiftByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/TestBitByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/WriteBitByteString.plc.golden create mode 100644 plutus-core/plutus-core/test/TypeSynthesis/Golden/XorByteString.plc.golden diff --git a/cabal.project b/cabal.project index fc9ed2f2453..ed59e4fb22f 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,5 @@ -- Bump this if you need newer packages -index-state: 2022-05-12T00:00:00Z +index-state: 2022-02-09T00:00:00Z packages: doc plutus-benchmark diff --git a/flake.lock b/flake.lock index 01fd31b834f..ef504e44de8 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "cardano-repo-tool": { "flake": false, "locked": { - "lastModified": 1645663501, - "narHash": "sha256-oNbE8byEeH9H0n3lYPwxauzJj3IDQrEwU/5LKhANgvw=", + "lastModified": 1624584417, + "narHash": "sha256-YSepT97PagR/1jTYV/Yer8a2GjFe9+tTwaTCHxuK50M=", "owner": "input-output-hk", "repo": "cardano-repo-tool", - "rev": "efeedd89676b22bd1deae312e0392e3028d2cf22", + "rev": "30e826ed8f00e3e154453b122a6f3d779b2f73ec", "type": "github" }, "original": { @@ -19,11 +19,11 @@ "gitignore-nix": { "flake": false, "locked": { - "lastModified": 1646480205, - "narHash": "sha256-kekOlTlu45vuK2L9nq8iVN17V3sB0WWPqTTW3a2SQG0=", + "lastModified": 1611672876, + "narHash": "sha256-qHu3uZ/o9jBHiA3MEKHJ06k7w4heOhA+4HCSIvflRxo=", "owner": "hercules-ci", "repo": "gitignore.nix", - "rev": "bff2832ec341cf30acb3a4d3e2e7f1f7b590116a", + "rev": "211907489e9f198594c0eb0ca9256a1949c9d412", "type": "github" }, "original": { @@ -35,11 +35,11 @@ "hackage-nix": { "flake": false, "locked": { - "lastModified": 1652663624, - "narHash": "sha256-WeZYALZ6wjXJaMi0ZiSLq5A/ybvES8vN3zPozUgzkFs=", + "lastModified": 1651108473, + "narHash": "sha256-zHGCnBdwKvrcYanjf3GARTWF8V2pyJl1QNONUNZSoc0=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "70c6780e617190a1ecc26bd004ece9ea67dcc260", + "rev": "dbab3b292c3400d028a2257e3acd2ac0249da774", "type": "github" }, "original": { @@ -68,11 +68,11 @@ "haskell-nix": { "flake": false, "locked": { - "lastModified": 1652663727, - "narHash": "sha256-cAIPH4JAVF6pKCs7ABOWN6ZSXyn4i77zV0Mv6l5UbDE=", + "lastModified": 1651151636, + "narHash": "sha256-WdMP9IMB5kByT0zimDuCYZF/dinRB104H8iDTG/c1Eo=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "d76d7f061677a87b946cefda57ee1c16dbd12f74", + "rev": "f707aa2e75c0d33473166abc61c0b43ac6e107c0", "type": "github" }, "original": { @@ -84,11 +84,11 @@ "iohk-nix": { "flake": false, "locked": { - "lastModified": 1652277463, - "narHash": "sha256-JAO2IuaaqYA3zsA63y2N3QsmyrcsDM6dEVc9n1CTBjw=", + "lastModified": 1626953580, + "narHash": "sha256-iEI9aTOaZMGsjWzcrctrC0usmiagwKT2v1LSDe9/tMU=", "owner": "input-output-hk", "repo": "iohk-nix", - "rev": "6a5b69dc042f521db028fed68799eb460bce05a7", + "rev": "cbd497f5844249ef8fe617166337d59f2a6ebe90", "type": "github" }, "original": { @@ -100,11 +100,11 @@ "nixpkgs": { "flake": false, "locked": { - "lastModified": 1652632955, - "narHash": "sha256-cSxiAaS8ozw63rLJHdN6RPwhA4lY2XeC/J+uggodYXw=", + "lastModified": 1645493675, + "narHash": "sha256-9xundbZQbhFodsQRh6QMN1GeSXfo3y/5NL0CZcJULz0=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "34e4df55664c24df350f59adba8c7a042dece61e", + "rev": "74b10859829153d5c5d50f7c77b86763759e8654", "type": "github" }, "original": { @@ -117,11 +117,11 @@ "pre-commit-hooks-nix": { "flake": false, "locked": { - "lastModified": 1649054408, - "narHash": "sha256-wz8AH7orqUE4Xog29WMTqOYBs0DMj2wFM8ulrTRVgz0=", + "lastModified": 1624971177, + "narHash": "sha256-Amf/nBj1E77RmbSSmV+hg6YOpR+rddCbbVgo5C7BS0I=", "owner": "cachix", "repo": "pre-commit-hooks.nix", - "rev": "e5e7b3b542e7f4f96967966a943d7e1c07558042", + "rev": "397f0713d007250a2c7a745e555fa16c5dc8cadb", "type": "github" }, "original": { diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index cc7c7467571..0a694b82089 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -307,7 +307,6 @@ library , semigroups >=0.19.1 , serialise , some <1.0.3 - , split , template-haskell , text , th-compat diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index a925894d15c..89e0bf99d11 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -1,3 +1,4 @@ +-- editorconfig-checker-disable-file {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} @@ -31,7 +32,6 @@ import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, u import Data.Foldable (foldl', for_) import Data.Functor (void) import Data.Kind (Type) --- import Data.List.Split (chunksOf) import Data.Text (Text, pack) import Data.Word (Word64, Word8) import Foreign.C.Types (CChar, CSize) diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/AndByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/AndByteString.plc.golden new file mode 100644 index 00000000000..01714abd65b --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/AndByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (fun (con bytestring) (con bytestring))) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/ByteStringToInteger.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/ByteStringToInteger.plc.golden new file mode 100644 index 00000000000..6495d849f0e --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/ByteStringToInteger.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (con integer)) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/ComplementByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/ComplementByteString.plc.golden new file mode 100644 index 00000000000..e8a4293b5b2 --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/ComplementByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (con bytestring)) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/FindFirstSetByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/FindFirstSetByteString.plc.golden new file mode 100644 index 00000000000..6495d849f0e --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/FindFirstSetByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (con integer)) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/IntegerToByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/IntegerToByteString.plc.golden new file mode 100644 index 00000000000..e0f1cb81a8e --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/IntegerToByteString.plc.golden @@ -0,0 +1 @@ +(fun (con integer) (con bytestring)) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/IorByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/IorByteString.plc.golden new file mode 100644 index 00000000000..01714abd65b --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/IorByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (fun (con bytestring) (con bytestring))) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/PopCountByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/PopCountByteString.plc.golden new file mode 100644 index 00000000000..6495d849f0e --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/PopCountByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (con integer)) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/RotateByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/RotateByteString.plc.golden new file mode 100644 index 00000000000..d98998e13d6 --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/RotateByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (fun (con integer) (con bytestring))) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/ShiftByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/ShiftByteString.plc.golden new file mode 100644 index 00000000000..d98998e13d6 --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/ShiftByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (fun (con integer) (con bytestring))) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/TestBitByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/TestBitByteString.plc.golden new file mode 100644 index 00000000000..a647f8f46a6 --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/TestBitByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (fun (con integer) (con bool))) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/WriteBitByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/WriteBitByteString.plc.golden new file mode 100644 index 00000000000..a4a93f8f64e --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/WriteBitByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (fun (con integer) (fun (con bool) (con bytestring)))) \ No newline at end of file diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/XorByteString.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/XorByteString.plc.golden new file mode 100644 index 00000000000..01714abd65b --- /dev/null +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/XorByteString.plc.golden @@ -0,0 +1 @@ +(fun (con bytestring) (fun (con bytestring) (con bytestring))) \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 127b7bcae7f..294f2d8f03c 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -1,3 +1,4 @@ +-- editorconfig-checker-disable-file {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} 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 eeb756c7dba..491fab9b313 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -80,7 +80,7 @@ test_Factorial = -- a const defined in PLC itself. test_Const :: TestTree test_Const = - testPropertyNamed "Const" "Const" . property $ do + testProperty "Const" . property $ do c <- forAll $ Gen.text (Range.linear 0 100) Gen.unicode b <- forAll Gen.bool let tC = mkConstant () c @@ -590,11 +590,9 @@ testSECP256k1 :: TestTree testSECP256k1 = adjustOption (\x -> max x . HedgehogTestLimit . Just $ 8000) . testGroup "Signatures on the SECP256k1 curve" $ [ - testPropertyNamed "ECDSA verification behaves correctly on all inputs" - "ECDSA verification behaves correctly on all inputs" . + testProperty "ECDSA verification behaves correctly on all inputs" . property $ ecdsaSecp256k1Prop, - testPropertyNamed "Schnorr verification behaves correctly on all inputs" - "Schnorr verification behaves correctly on all inputs" . + testProperty "Schnorr verification behaves correctly on all inputs" . property $ schnorrSecp256k1Prop ] @@ -619,39 +617,39 @@ testBitwise = -- Tests for bitwise AND on ByteStrings testAndByteString :: TestTree testAndByteString = testGroup "AndByteString" [ - testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseAndCommutes, - testPropertyNamed "Associativity" "Associativity" . property $ bitwiseAndAssociates, - testPropertyNamed "All-1s is an identity" "All-1s is an identity" . property $ bitwiseAndIdentity, - testPropertyNamed "All-0s is absorbing" "All-0s is absorbing" . property $ bitwiseAndAbsorbing, - testPropertyNamed "AND with yourself does nothing" "AND with yourself does nothing" . property $ bitwiseAndSelf, - testPropertyNamed "De Morgan's law" "De Morgan's law" . property $ bitwiseAndDeMorgan + testProperty "Commutativity" . property $ bitwiseAndCommutes, + testProperty "Associativity" . property $ bitwiseAndAssociates, + testProperty "All-1s is an identity" . property $ bitwiseAndIdentity, + testProperty "All-0s is absorbing" . property $ bitwiseAndAbsorbing, + testProperty "AND with yourself does nothing" . property $ bitwiseAndSelf, + testProperty "De Morgan's law" . property $ bitwiseAndDeMorgan ] -- Tests for bitwise IOR on ByteStrings testIorByteString :: TestTree testIorByteString = testGroup "IorByteString" [ - testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseIorCommutes, - testPropertyNamed "Associativity" "Associativity" . property $ bitwiseIorAssociates, - testPropertyNamed "All-0s is an identity" "All-0s is an identity" . property $ bitwiseIorIdentity, - testPropertyNamed "All-1s is absorbing" "All-0s is absorbing" . property $ bitwiseIorAbsorbing, - testPropertyNamed "IOR with yourself does nothing" "IOR with yourself does nothing" . property $ bitwiseIorSelf, - testPropertyNamed "De Morgan's law" "De Morgan's law" . property $ bitwiseIorDeMorgan + testProperty "Commutativity" . property $ bitwiseIorCommutes, + testProperty "Associativity" . property $ bitwiseIorAssociates, + testProperty "All-0s is an identity" . property $ bitwiseIorIdentity, + testProperty "All-0s is absorbing" . property $ bitwiseIorAbsorbing, + testProperty "IOR with yourself does nothing" . property $ bitwiseIorSelf, + testProperty "De Morgan's law" . property $ bitwiseIorDeMorgan ] -- Tests for bitwise XOR on ByteStrings testXorByteString :: TestTree testXorByteString = testGroup "XorByteString" [ - testPropertyNamed "Commutativity" "Commutativity" . property $ bitwiseXorCommutes, - testPropertyNamed "Associativity" "Associativity" . property $ bitwiseXorAssociates, - testPropertyNamed "All-0s is an identity" "All-0s is an identity" . property $ bitwiseXorIdentity, - testPropertyNamed "XOR with all-1s is complement" "XOR with all 1s is complement" . property $ bitwiseXorComplement, - testPropertyNamed "XOR with yourself gives all-0" "XOR with yourself gives all-0" . property $ bitwiseXorSelf + testProperty "Commutativity" . property $ bitwiseXorCommutes, + testProperty "Associativity" . property $ bitwiseXorAssociates, + testProperty "All-0s is an identity" . property $ bitwiseXorIdentity, + testProperty "XOR with all 1s is complement" . property $ bitwiseXorComplement, + testProperty "XOR with yourself gives all-0" . property $ bitwiseXorSelf ] -- Tests for bitwise complement on ByteStrings testComplementByteString :: TestTree testComplementByteString = testGroup "ComplementByteString" [ - testPropertyNamed "Self-inversion" "Self-inversion" . property $ bitwiseComplementSelfInverts + testProperty "Self-inversion" . property $ bitwiseComplementSelfInverts ] -- Tests for population count on ByteStrings @@ -661,24 +659,24 @@ testPopCountByteString = testGroup "PopCountByteString" [ let arg = mkConstant @ByteString () "" let comp = mkIterApp () (builtin () PopCountByteString) [ arg ] typecheckEvaluateCekNoEmit defaultCekParameters comp @?= Right (EvaluationSuccess . mkConstant @Integer () $ 0), - testPropertyNamed "popcount of singleton ByteString is correct" "popcount of singleton ByteString is correct" . property $ popCountSingleByte, - testPropertyNamed "popcount of append is sum of popcounts" "popcount of append is sum of popcounts" . property $ popCountAppend + testProperty "popcount of singleton ByteString is correct" . property $ popCountSingleByte, + testProperty "popcount of append is sum of popcounts" . property $ popCountAppend ] -- Tests for bit indexing into a ByteString testTestBitByteString :: TestTree testTestBitByteString = testGroup "TestBitByteString" [ - testPropertyNamed "any index on an empty ByteString fails" "any index on an empty ByteString fails" . property $ testBitEmpty, - testPropertyNamed "indexing on singletons works correctly" "indexing on singletons works correctly" . property $ testBitSingleByte, - testPropertyNamed "indexing appends agrees with components" "indexing appends agrees with components" . property $ testBitAppend + testProperty "any index on an empty ByteString fails" . property $ testBitEmpty, + testProperty "indexing on singletons works correctly" . property $ testBitSingleByte, + testProperty "indexing appends agrees with components" . property $ testBitAppend ] -- Tests for bit setting or clearing of a ByteString testWriteBitByteString :: TestTree testWriteBitByteString = testGroup "WriteBitByteString" [ - testPropertyNamed "writing then reading gives back what you wrote" "writing then reading gives back what you wrote" . property $ writeBitRead, - testPropertyNamed "second write wins" "second write wins" . property $ writeBitDouble, - testPropertyNamed "single write to zeroes gives right reads" "single write to zeroes gives right reads" . property $ writeBitAgreement + testProperty "writing then reading gives back what you wrote" . property $ writeBitRead, + testProperty "second write wins" . property $ writeBitDouble, + testProperty "single write to zeroes gives right reads" . property $ writeBitAgreement ] -- Tests for finding first set bit of a ByteString @@ -688,33 +686,33 @@ testFindFirstSetByteString = testGroup "FindFirstSetByteString" [ let arg = mkConstant @ByteString () "" let comp = mkIterApp () (builtin () FindFirstSetByteString) [ arg ] typecheckEvaluateCekNoEmit defaultCekParameters comp @?= Right (EvaluationSuccess . mkConstant @Integer () $ (-1)), - testPropertyNamed "find first set on singletons works correctly" "find first set on singletons works correctly" . property $ ffsSingleByte, - testPropertyNamed "find first set on appended ByteStrings works correctly" "find first set on appended ByteStrings works correctly" . property $ ffsAppend + testProperty "find first set on singletons works correctly" . property $ ffsSingleByte, + testProperty "find first set on appended ByteStrings works correctly" . property $ ffsAppend ] -- Tests for ByteString rotations testRotateByteString :: TestTree testRotateByteString = testGroup "RotateByteString" [ - testPropertyNamed "rotating by 0 does nothing" "rotating by 0 does nothing" . property $ rotateIdentity, - testPropertyNamed "rotation adjusts indices correctly" "rotation adjusts indices correctly" . property $ rotateIndexMotion, - testPropertyNamed "rotating all-zero or all-one changes nothing" "rotating all-zero or all-one changes nothing" . property $ rotateHomogenous, - testPropertyNamed "rotating by i, then by j is the same as rotating by i + j" "rotating by i, then by j is the same as rotating by i + j" . property $ rotateSum + testProperty "rotating by 0 does nothing" . property $ rotateIdentity, + testProperty "rotation adjusts indices correctly" . property $ rotateIndexMotion, + testProperty "rotating all-zero or all-one changes nothing" . property $ rotateHomogenous, + testProperty "rotating by i, then by j is the same as rotating by i + j" . property $ rotateSum ] -- Tests for ByteString shifts testShiftByteString :: TestTree testShiftByteString = testGroup "ShiftByteString" [ - testPropertyNamed "shifting by 0 does nothing" "shifting by 0 does nothing" . property $ shiftIdentity, - testPropertyNamed "shifting adjusts indices correctly" "shifting adjusts indices correctly" . property $ shiftIndexMotion, - testPropertyNamed "shifting all-zeroes does nothing" "shifting all-zeroes does nothing" . property $ shiftHomogenous, - testPropertyNamed "shifting in two steps is the same as shifting in one" "shifting in two steps is the same as shifting in one" . property $ shiftSum + testProperty "shifting by 0 does nothing" . property $ shiftIdentity, + testProperty "shifting adjusts indices correctly" . property $ shiftIndexMotion, + testProperty "shifting all-zeroes does nothing" . property $ shiftHomogenous, + testProperty "shifting in two steps is the same as shifting in one" . property $ shiftSum ] -- Tests for conversion into Integer from ByteString testByteStringToInteger :: TestTree testByteStringToInteger = testGroup "ByteStringToInteger" [ - testPropertyNamed "all zeroes give 0, all ones give -1" "all zeroes give 0, all ones give -1" . property $ bsToIHomogenous, - testPropertyNamed "trailing ones ignored for negative, trailing zeroes for positive" "trailing ones ignored for negative, trailing zeroes for positive" . property $ bsToITrailing + testProperty "all zeroes give 0, all ones give -1" . property $ bsToIHomogenous, + testProperty "trailing ones ignored for negative, trailing zeroes for positive" . property $ bsToITrailing ] test_definition :: TestTree From 9b9ea9e075df3fb24c46015c2685d9a7efb1913e Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 7 Jul 2022 10:23:23 +1200 Subject: [PATCH 17/73] Tests for IntegerToByteString primitive, finish #4252 --- .../test/Evaluation/Builtins/Bitwise.hs | 38 +++++++------------ .../test/Evaluation/Builtins/Definition.hs | 15 ++++++-- 2 files changed, 24 insertions(+), 29 deletions(-) diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 294f2d8f03c..b9edeec78bb 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -42,7 +42,7 @@ module Evaluation.Builtins.Bitwise ( shiftIndexMotion, shiftHomogenous, shiftSum, - -- iToBSRoundtrip, + iToBsRoundtrip, bsToITrailing, bsToIHomogenous, ) where @@ -60,7 +60,7 @@ import GHC.Exts (fromListN, toList) import Hedgehog (Gen, PropertyT, Range, annotate, annotateShow, cover, evalEither, failure, forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ByteStringToInteger, ComplementByteString, FindFirstSetByteString, IorByteString, PopCountByteString, RotateByteString, ShiftByteString, TestBitByteString, WriteBitByteString, XorByteString), +import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ByteStringToInteger, ComplementByteString, FindFirstSetByteString, IntegerToByteString, IorByteString, PopCountByteString, RotateByteString, ShiftByteString, TestBitByteString, WriteBitByteString, XorByteString), DefaultUni, Error, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters) import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) @@ -538,30 +538,18 @@ shiftSum = do (EvaluationSuccess res, EvaluationSuccess res') -> res === res' _ -> failure -{- -iToBSRoundtrip :: PropertyT IO () -iToBSRoundtrip = do +iToBsRoundtrip :: PropertyT IO () +iToBsRoundtrip = do i <- forAllWith ppShow . Gen.integral $ indexRange - tripping (mkConstant @Integer () i) toBits fromBits - where - toBits :: - Term Untyped.TyName Name DefaultUni DefaultFun () -> - Either (Error DefaultUni DefaultFun ()) - (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) - toBits i = let comp = mkIterApp () (builtin () IntegerToByteString) [i] in - fst <$> cekEval' comp - fromBits :: - Either (Error DefaultUni DefaultFun ()) - (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) -> - Maybe (Term Untyped.TyName Name DefaultUni DefaultFun ()) - fromBits = \case - Right (EvaluationSuccess res) -> do - let comp = mkIterApp () (builtin () ByteStringToInteger) [res] - case fst <$> cekEval' comp of - Right (EvaluationSuccess res') -> pure res' - _ -> Nothing - _ -> Nothing --} + let comp = mkIterApp () (builtin () ByteStringToInteger) [ + mkIterApp () (builtin () IntegerToByteString) [ + mkConstant @Integer () i + ] + ] + outcome <- cekEval comp + case outcome of + EvaluationSuccess res -> res === mkConstant @Integer () i + _ -> failure bsToITrailing :: PropertyT IO () bsToITrailing = 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 491fab9b313..4eb8e0a0991 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -36,10 +36,10 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, bsToIHomogenous, - bsToITrailing, ffsAppend, ffsSingleByte, popCountAppend, popCountSingleByte, - rotateHomogenous, rotateIdentity, rotateIndexMotion, rotateSum, shiftHomogenous, - shiftIdentity, shiftIndexMotion, shiftSum, testBitAppend, testBitEmpty, - testBitSingleByte, writeBitAgreement, writeBitDouble, writeBitRead) + bsToITrailing, ffsAppend, ffsSingleByte, iToBsRoundtrip, popCountAppend, + popCountSingleByte, rotateHomogenous, rotateIdentity, rotateIndexMotion, rotateSum, + shiftHomogenous, shiftIdentity, shiftIndexMotion, shiftSum, testBitAppend, + testBitEmpty, testBitSingleByte, writeBitAgreement, writeBitDouble, writeBitRead) import Evaluation.Builtins.Common import Evaluation.Builtins.SECP256k1 (ecdsaSecp256k1Prop, schnorrSecp256k1Prop) @@ -611,6 +611,7 @@ testBitwise = testFindFirstSetByteString, testRotateByteString, testShiftByteString, + testIntegerToByteString, testByteStringToInteger ] @@ -708,6 +709,12 @@ testShiftByteString = testGroup "ShiftByteString" [ testProperty "shifting in two steps is the same as shifting in one" . property $ shiftSum ] +-- Tests for conversion into ByteString from Integer +testIntegerToByteString :: TestTree +testIntegerToByteString = testGroup "IntegerToByteString" [ + testProperty "Round trip" . property $ iToBsRoundtrip + ] + -- Tests for conversion into Integer from ByteString testByteStringToInteger :: TestTree testByteStringToInteger = testGroup "ByteStringToInteger" [ From 25968aa9eb44a5cec2e2b7f22f4c97ac623cf87a Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 11 Jul 2022 10:18:28 +1200 Subject: [PATCH 18/73] Remove -fsimpl-tick-factor parameter --- plutus-core/plutus-core.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 33e8bf4155f..303c0ca36c5 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -258,7 +258,6 @@ library UntypedPlutusCore.Transform.ForceDelay UntypedPlutusCore.Transform.Inline - ghc-options: -fsimpl-tick-factor=200 build-depends: , aeson , algebraic-graphs >=0.3 From 7e5a1fb98ea03cb9ab940f6a21912257fd191f50 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 11 Jul 2022 10:49:52 +1200 Subject: [PATCH 19/73] Add note for overPtrLen safety, remove commented code --- plutus-core/plutus-core/src/Bitwise.hs | 135 +++---------------------- 1 file changed, 16 insertions(+), 119 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 89e0bf99d11..3508ef0dbe4 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -51,9 +51,8 @@ rotateByteString bs i | BS.maximum bs == zeroBits = bs | BS.minimum bs == complement zeroBits = bs | otherwise = case i `rem` bitLen of - 0 -> bs -- nothing to do irrespective of direction - magnitude -> overPtrLen bs $ \ptr len -> - go ptr len magnitude >>= packWithLen len + 0 -> bs -- nothing to do irrespective of direction + magnitude -> overPtrLen bs $ \ptr len -> go ptr len magnitude where go :: Ptr Word8 -> Int -> Integer -> IO (Ptr Word8) go src len displacement = do @@ -91,8 +90,7 @@ shiftByteString :: ByteString -> Integer -> ByteString shiftByteString bs i | abs i >= bitLen = BS.replicate (BS.length bs) zeroBits | BS.maximum bs == zeroBits = bs - | otherwise = overPtrLen bs $ \ptr len -> - go ptr len >>= packWithLen len + | otherwise = overPtrLen bs go where bitLen :: Integer bitLen = fromIntegral $ BS.length bs * 8 @@ -201,35 +199,6 @@ byteStringToInteger bs = case BS.uncons bs of modify (256 *) pure $ acc + (fromIntegral byte * mult) -{- -integerToByteString :: Integer -> ByteString -integerToByteString i = case signum i of - 0 -> BS.singleton 0 - (-1) -> twosComplement . integerToByteString . abs $ i - _ -> fromList . intoBytes . toBitSequence $ i - -byteStringToInteger :: ByteString -> Integer -byteStringToInteger bs = case BS.uncons bs of - Nothing -> 0 - Just (w8, bs') -> - if | isPositivePowerOf2 w8 bs' -> go bs - | bit 7 .&. w8 == zeroBits -> go bs - | otherwise -> negate . go . twosComplement $ bs - where - go :: ByteString -> Integer - go bs' = let len = BS.length bs' in - snd . foldl' go2 (1, 0) $ [len - 1, len -2 .. 0] - go2 :: (Integer, Integer) -> Int -> (Integer, Integer) - go2 (e, acc) ix = (e * 256, acc + e * (fromIntegral . BS.index bs $ ix)) - -byteStringToInteger :: ByteString -> Integer -byteStringToInteger bs = let len = BS.length bs in - snd . foldl' go (1, 0) $ [len - 1, len - 2 .. 0] - where - go :: (Integer, Integer) -> Int -> (Integer, Integer) - go (e, acc) ix = (e * 256, acc + e * (fromIntegral . BS.index bs $ ix)) --} - {-# NOINLINE popCountByteString #-} popCountByteString :: ByteString -> Integer popCountByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go @@ -305,52 +274,19 @@ dangerousRead bs i = 0 -> False _ -> True -packWithLen :: Int -> Ptr Word8 -> IO ByteString -packWithLen len p = unsafePackMallocCStringLen (castPtr p, len) - -overPtrLen :: forall (a :: Type) . - ByteString -> (Ptr Word8 -> Int -> IO a) -> a -overPtrLen bs f = - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> f (castPtr ptr) len - -{- -toBitSequence :: Integer -> [Bool] -toBitSequence i = go 0 (separateBit i) [] - where - go :: Int -> Maybe (Integer, Bool) -> [Bool] -> [Bool] - go len curr acc = case curr of - Nothing -> case len `rem` 8 of - 0 -> acc - _ -> go (len + 1) Nothing (False : acc) - Just (d, b) -> go (len + 1) (separateBit d) (b : acc) - -separateBit :: Integer -> Maybe (Integer, Bool) -separateBit i = case i of - 0 -> Nothing - _ -> Just . fmap go $ i `quotRem` 2 - where - go :: Integer -> Bool - go = \case - 0 -> False - _ -> True - -intoBytes :: [Bool] -> [Word8] -intoBytes = fmap go . chunksOf 8 - where - go :: [Bool] -> Word8 - go = \case - [b7, b6, b5, b4, b3, b2, b1, b0] -> - let b0Val = if b0 then 1 else 0 - b1Val = if b1 then 2 else 0 - b2Val = if b2 then 4 else 0 - b3Val = if b3 then 8 else 0 - b4Val = if b4 then 16 else 0 - b5Val = if b5 then 32 else 0 - b6Val = if b6 then 64 else 0 - b7Val = if b7 then 128 else 0 in - b0Val + b1Val + b2Val + b3Val + b4Val + b5Val + b6Val + b7Val - _ -> 0 -- should never happen --} +-- Important note: this function is only safe under the following conditions: +-- +-- * The IO used in the function argument only performs memory allocations using +-- malloc, as well as reads and writes via the Storable interface; +-- * The pointer argument is only read from, not written to; +-- * The result of the function argument points to freshly-allocated, malloced +-- memory; and +-- * The result of the function argument points to memory whose length matches +-- that of the input ByteString (in bytes) +overPtrLen :: ByteString -> (Ptr Word8 -> Int -> IO (Ptr Word8)) -> ByteString +overPtrLen bs f = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ + \(ptr, len) -> f (castPtr ptr) len >>= \p -> + unsafePackMallocCStringLen (castPtr p, len) -- When we complement a power of two, we have to ensure we pad with ones -- @@ -377,45 +313,6 @@ twosComp bs = let len = BS.length bs in when (byte /= byte') (put True) pure $ byte' : acc -{- -twosComplement :: ByteString -> ByteString -twosComplement bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> do - dst <- mallocBytes len - let src :: Ptr Word8 = castPtr ptr - go dst src 1 len False - unsafePackMallocCStringLen (castPtr dst, len) - where - go :: Ptr Word8 -> Ptr Word8 -> Int -> Int -> Bool -> IO () - go dst src offset len added - | offset > len = pure () - | otherwise = do - w8 :: Word8 <- peek . plusPtr src $ len - offset - if added - then do - poke (plusPtr dst $ len - offset) (complement w8) - go dst src (offset + 1) len added - else do - let (added', w8') = computeAddByte w8 - poke (plusPtr dst $ len - offset) w8' - go dst src (offset + 1) len added' - -computeAddByte :: Word8 -> (Bool, Word8) -computeAddByte = \case - 0 -> (False, 0) - w8 -> go 0 (False, 0) $ w8 `quotRem` 2 - where - go :: Int -> (Bool, Word8) -> (Word8, Word8) -> (Bool, Word8) - go step acc@(added, w8) (d, r) - | step == 8 = acc - | otherwise = let mask = bit 0 `shiftL` step - dr' = d `quotRem` 2 in - if added - then go (step + 1) (added, w8 `xor` mask) dr' - else case r of - 0 -> go (step + 1) acc dr' - _ -> go (step + 1) (True, w8 .|. mask) dr' --} - mismatchedLengthError :: forall (a :: Type) . Text -> ByteString -> From 2610321c4704a3a6b3a3dcb949267c682a4cb0b1 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 11 Jul 2022 13:01:01 +1200 Subject: [PATCH 20/73] Restore simpl-tick with comment, document Bitwise --- plutus-core/plutus-core.cabal | 10 ++ plutus-core/plutus-core/src/Bitwise.hs | 196 +++++++++++++++++++++++-- 2 files changed, 196 insertions(+), 10 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 303c0ca36c5..40222a98ec7 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -320,6 +320,16 @@ library , witherable , word-array + -- When compiling PlutusCore.Evaluation.Machine.MachineParameters.Default, you + -- can occasionally hit a 'Simplifier ticks exhausted' error. This is because + -- the default tick factor of 100 isn't always enough on a full rebuild. This + -- happens often when we need to rebuild tests due to a change in + -- plutus-core-the-library. + -- + -- Doubling this gives us more headroom to ensure we don't have spurious + -- failures in compilation. + ghc-options: -fsimpl-tick-factor=200 + -- could split this up if we split up the main library for UPLC/PLC/PIR library plutus-core-testlib import: lang diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 3508ef0dbe4..53f7b182f72 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -47,21 +47,30 @@ import System.IO.Unsafe (unsafeDupablePerformIO) {-# NOINLINE rotateByteString #-} rotateByteString :: ByteString -> Integer -> ByteString rotateByteString bs i - | BS.null bs = bs - | BS.maximum bs == zeroBits = bs - | BS.minimum bs == complement zeroBits = bs + -- If a ByteString is completely homogenous, rotating won't change it. This + -- also covers emptiness, since empty ByteStrings are homogenous vacuously. + | isAllZero bs || isAllOne bs = bs + -- Rotating by more than the number of bits in a ByteString 'wraps around', + -- so we're only interested in the rotation modulo the number of bits. | otherwise = case i `rem` bitLen of - 0 -> bs -- nothing to do irrespective of direction + -- Means we have a multiple of the bit count, so nothing to do. + 0 -> bs magnitude -> overPtrLen bs $ \ptr len -> go ptr len magnitude where go :: Ptr Word8 -> Int -> Integer -> IO (Ptr Word8) go src len displacement = do dst <- mallocBytes len case len of + -- If we only have one byte, we an borrow from the Bits instance for + -- Word8. 1 -> do srcByte <- peek src let srcByte' = srcByte `rotate` fromIntegral displacement poke dst srcByte' + -- If we rotate by a multiple of 8, we only need to move around whole + -- bytes, rather than individual bits. Because we only move contiguous + -- blocks (regardless of rotation direction), we can do this using + -- memcpy, which is must faster, especially on larger ByteStrings. _ -> case displacement `quotRem` 8 of (bigMove, 0) -> do let mainLen :: CSize = fromIntegral . abs $ bigMove @@ -71,6 +80,17 @@ rotateByteString bs i memcpy dst (plusPtr src . fromIntegral $ mainLen) restLen _ -> memcpy (plusPtr dst . fromIntegral $ mainLen) src restLen >> memcpy dst (plusPtr src . fromIntegral $ restLen) mainLen + -- If we don't rotate by a multiple of 8, we have to construct new + -- bytes, rather than just copying over old ones. We do this in two + -- steps: + -- + -- 1. Compute the 'read offset' into the source ByteString based on + -- the rotation magnitude and direction. + -- 2. Use that read offset to perform an (unchecked) bit lookup for an + -- entire 8-bit block, then construct the byte that results. + -- + -- We can do the bytes in the result in any order using this method: + -- we choose to do it in traversal order. _ -> for_ [0 .. len - 1] $ \j -> do let start = (len - 1 - j) * 8 let dstByte = foldl' (addBit start displacement) zeroBits [0 .. 7] @@ -88,8 +108,13 @@ rotateByteString bs i {-# NOINLINE shiftByteString #-} shiftByteString :: ByteString -> Integer -> ByteString shiftByteString bs i + -- Shifting by the number of bits, or more, would zero everything anyway, + -- regardless of direction. This also covers the empty ByteString case, as its + -- bit length is zero. | abs i >= bitLen = BS.replicate (BS.length bs) zeroBits - | BS.maximum bs == zeroBits = bs + -- Shifting an all-zero ByteString will not change it, regardless of + -- direction. + | allZeroes bs = bs | otherwise = overPtrLen bs go where bitLen :: Integer @@ -98,10 +123,16 @@ shiftByteString bs i go src len = do dst <- mallocBytes len case len of + -- If we only have one byte, we an borrow from the Bits instance for + -- Word8. 1 -> do srcByte <- peek src let srcByte' = srcByte `shift` fromIntegral i poke dst srcByte' + -- If we shift by a multiple of 8, we only need to move a contiguous + -- block of bytes, then clear what remains. This is much more efficient: + -- it would be nice if we had memset available, but at least the copy + -- can be done with memcpy. _ -> case i `quotRem` 8 of (bigMove, 0) -> do let mainLen :: CSize = fromIntegral . abs $ bigMove @@ -114,6 +145,11 @@ shiftByteString bs i _ -> do for_ [0 .. fromIntegral mainLen - 1] $ \j -> poke @Word8 (plusPtr dst j) zeroBits void . memcpy (plusPtr dst . fromIntegral $ mainLen) src $ restLen + -- If we shift by something other than a multiple of 8, we have to + -- construct new bytes, similarly to rotations. We use the same + -- two-step process to construct new bytes, but due to not having the + -- 'wraparound' behaviour (unlike rotations), we clear any bits that + -- would be sourced 'out of bounds'. _ -> for_ [0 .. len - 1] $ \j -> do let start = (len - 1 - j) * 8 let dstByte = foldl' (addBit start) zeroBits [0 .. 7] @@ -151,6 +187,23 @@ testBitByteString bs i writeBitByteString :: ByteString -> Integer -> Bool -> Emitter (EvaluationResult ByteString) writeBitByteString bs i b | i < 0 || i >= bitLen = indexOutOfBoundsError "writeBitByteString" bitLen i + -- When we write a bit at a location, we have to return a new copy of the + -- original with the bit modified. We do this as follows: + -- + -- 1. Compute the byte that has to change. Because _byte_ indexes and _bit_ + -- indexes go in opposite directions, we have to compute the byte by a + -- combination of modulus and offset from the end. + -- 2. Use the remainder to construct a mask which 'selects' the bit within the + -- byte we want to change. + -- 3. Memcpy everything over. + -- 4. Use the mask at the computed byte index to modify the result in-place: + -- we do a different operation depending on whether we're setting or clearing. + -- + -- We use memcpy plus a single write as this is _much_ faster than going + -- byte-by-byte and checking if we've reached the index we want each time: + -- memcpy is highly-optimized using SIMD instructions on every platform, and a + -- branchy per-byte loop is absolutely horrid everywhere for speed due to the + -- branch count. | otherwise = do let (bigOffset, smallOffset) = i `quotRem` 8 let bigIx = fromIntegral $ byteLen - bigOffset - 1 @@ -176,6 +229,9 @@ integerToByteString i = case signum i of (-1) -> twosCompToNegative . fromList . go . abs $ i _ -> fromList . go $ i where + -- We encode into Word8-sized 'limbs', using a stack to ensure that their + -- ordering is little-endian. Effectively, we encode as a base-256 number, + -- where the least significant digit is at the end. go :: Integer -> [Word8] go = \case 0 -> [] @@ -185,6 +241,11 @@ integerToByteString i = case signum i of byteStringToInteger :: ByteString -> Integer byteStringToInteger bs = case BS.uncons bs of Nothing -> 0 + -- We have to take some care with representations of exact powers of 256, as + -- the two's complement in such a case is the identity function. Therefore, if + -- we find an 'unpadded' power, we have to presume that it's positive; if we + -- find a leading 0x80, but _something_ else is not a zero byte, we assume + -- it's negative instead. Just (w8, bs') -> let len = BS.length bs f x = evalState (foldM (go x) 0 [len - 1, len - 2 .. 0]) 1 in @@ -192,6 +253,13 @@ byteStringToInteger bs = case BS.uncons bs of | bit 7 .&. w8 == zeroBits -> f bs | otherwise -> negate . f . twosCompToPositive $ bs where + -- This is essentially the opposite to encoding. However, because + -- ByteStrings can be indexed from the end in constant time, we don't need + -- to use something like a stack: instead, we start from the end, and + -- accumulate the radix base as we go, increasing the further along we get. + -- This is more efficient, as we'd otherwise first have to compute the + -- largest power of 256 we need, then divide down, essentially doing the + -- work _twice_. go :: ByteString -> Integer -> Int -> State Integer Integer go bs' acc i = do mult <- get @@ -203,6 +271,18 @@ byteStringToInteger bs = case BS.uncons bs of popCountByteString :: ByteString -> Integer popCountByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go where + -- We use a standard 'big step, small step' approach. The reason for this is + -- that bit counting (via a FiniteBits instance) is defined for much larger + -- types than Word8. We can thus read 8-blocks of bytes as 64-bit words + -- instead (as we don't care about sign and GHC ensures word alignment), + -- which gives us potentially up to an 8x speedup. + -- + -- Thus, our 'big step, small step' approach first walks as much of its + -- input as it can using steps whose size is Word64, then finishes the job + -- with steps whose size is Word8. We use a rank-2 polymorphic method to + -- avoid code duplication, since the only operation we need comes from a + -- type class, and is thus agnostic to what we're working over. Step size + -- can also be determined via Storable in a similar way. go :: (Ptr CChar, Int) -> IO Integer go (ptr, len) = do let (bigSteps, smallSteps) = len `quotRem` 8 @@ -212,6 +292,35 @@ popCountByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go smallCount <- countBits smallPtr smallSteps pure . fromIntegral $ bigCount + smallCount +-- We use a standard 'big step, small step' construction for all the operators +-- below. The reason for this is that each of these operations are bit-parallel: +-- it doesn't matter what width of bit block you operate on, you'll have the +-- same outcome. As a result, these operations are defined for much larger +-- blocks than Word8. We can thus read 8-blocks of bytes as 64-bit words instead +-- (as we don't care about sign and GHC ensures word alignment), which gives us +-- potentially up to an 8x speedup. +-- +-- Thus, our 'big step, small step' approach processes the inputs in two stages: +-- +-- 1. Walk lockstep in blocks of Word64 size over both inputs, and set the +-- corresponding place in the output to the result of the bitwise operation on +-- those blocks. +-- 2. For whatever remains, walk lockstep in blocks of Word8 size over both +-- inputs, and set the corresponding place in the output to the result of the +-- bitwise operation on those blocks. +-- +-- We use a rank-2 polymorphic method to avoid code duplication, since all of +-- the operations over blocks we are interested in (of either size) come from a +-- type class (Bits) without caring about what specific type we're dealing with. +-- Step size can also be determined via Storable in a similar way. +-- +-- We use a mutable construction inside IO instead of something immutable to +-- avoid excessive 'sloshing': on our current version of the 'bytestring' +-- library, there is no way to 'zip together' two ByteStrings directly: your +-- only option was to 'zip out' into a list, then rebuild. This is not only +-- inefficient (as you can't do a 'big step, little step' approach to this in +-- general), it also copies too much. + {-# NOINLINE andByteString #-} andByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) andByteString bs bs' @@ -236,6 +345,11 @@ xorByteString bs bs' unsafeUseAsCString bs' $ \ptr' -> zipBuild xor ptr ptr' len >>= (unsafePackMallocCStringLen . (,len)) +-- Similarly to the above, we use a 'big step, little step' here as well. The +-- only difference is that there is only one input to read from, rather than +-- two. Similar reasoning applies to why we made this choice as to the +-- previous operations. + {-# NOINLINE complementByteString #-} complementByteString :: ByteString -> ByteString complementByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> do @@ -262,9 +376,12 @@ complementByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \( -- Helpers -isPositivePowerOf2 :: Word8 -> ByteString -> Bool -isPositivePowerOf2 w8 bs = w8 == 0x80 && BS.all (== zeroBits) bs +isPositivePowerOf256 :: Word8 -> ByteString -> Bool +isPositivePowerOf256 w8 bs = w8 == 0x80 && BS.all (== zeroBits) bs +-- We compute the read similarly to how we determine the change when we write. +-- The only difference is that the mask is used on the input to read it, rather +-- than to modify anything. dangerousRead :: ByteString -> Integer -> Bool dangerousRead bs i = let (bigOffset, smallOffset) = i `quotRem` 8 @@ -283,24 +400,52 @@ dangerousRead bs i = -- memory; and -- * The result of the function argument points to memory whose length matches -- that of the input ByteString (in bytes) +-- +-- Even though a ByteString is represented as Ptr CChar, we can ignore sign (we +-- only treat them as binary data anyway), and on POSIX platforms (which GHC +-- silently assumes, even on Windows), CChar _must_ be exactly a byte. Thus, we +-- allow working over a pointer to Word8 instead, to avoid issues with signs. overPtrLen :: ByteString -> (Ptr Word8 -> Int -> IO (Ptr Word8)) -> ByteString overPtrLen bs f = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> f (castPtr ptr) len >>= \p -> unsafePackMallocCStringLen (castPtr p, len) --- When we complement a power of two, we have to ensure we pad with ones +-- Two's complement in a signed, unbounded representation is somewhat +-- problematic: in our particular case, we hit this issue on exact powers of +-- 256. This issue stems from such values (or rather, the ByteString +-- representations of such) having a two's complement identical to themselves, +-- as well as a trailing 1. This means that we can't distinguish between a +-- _negative_ and a _positive_ power from representation alone, and must default +-- one way or the other. -- --- Thus, we have two versions of this function: one that performs this padding, --- and one which doesn't +-- Thus, when we want to produce a negative representation, we have to ensure +-- that we 'mark' the result in a way that ensures we can detect that it was +-- negative. We do this by padding with trailing ones. twosCompToNegative :: ByteString -> ByteString twosCompToNegative bs = case twosComp bs of bs' -> if bs == bs' then BS.cons (complement zeroBits) bs' else bs' +-- If we're taking a two's complement to produce a positive representation, +-- padding doesn't matter, as any trailing ones become trailing zeroes. twosCompToPositive :: ByteString -> ByteString twosCompToPositive = twosComp +-- This is a fused version of the 'standard' definition of two's complement: +-- 'flip all bits then add one'. We do this in one pass to avoid having to +-- produce two ByteStrings, only to throw one away. This is done by tracking +-- the add carry manually, and walking over the representation from the highest +-- byte index downward: if the carry is still present, we attempt an 'add one' +-- there and then. This can cause the carry to become 'absorbed', in which case +-- we no longer need to track it; otherwise, we continue on, tracking the carry. +-- +-- This operation has to be done byte-wise, as bigger blocks would make carry +-- tracking too difficult, which would probably dwarf any performance +-- improvements. Furthermore, it's not even clear if a 'big step, small step' +-- approach would even help here, as we're reading backwards (against prefetch +-- order), and likely from unaligned memory to boot (as GHC only guarantees +-- alignment from the _start_, not the _end_). twosComp :: ByteString -> ByteString twosComp bs = let len = BS.length bs in evalState (fromListN len <$> foldM go [] [len - 1, len - 2 .. 0]) False @@ -337,6 +482,22 @@ indexOutOfBoundsError loc lim i = do emit $ "Valid indexes: from 0 to " <> (pack . show $ lim - 1) pure EvaluationFailure +-- A general method for 'zipping together' two ByteString inputs to produce a +-- new ByteString output, assuming the 'zipping function' is bit-parallel. This +-- uses a standard 'big step, little step' construction. We can do this because +-- bit-parallel operations don't change semantics based on the size of the block +-- read; furthermore, as GHC guarantees word alignment and we don't care about +-- sign, we can potentially get up to an 8x speedup. +-- +-- We use a mutable construction inside IO instead of something immutable to +-- avoid excessive 'sloshing': on our current version of the 'bytestring' +-- library, there is no way to 'zip together' two ByteStrings directly: your +-- only option was to 'zip out' into a list, then rebuild. This is not only +-- inefficient (as you can't do a 'big step, little step' approach to this in +-- general), it also copies too much. +-- +-- Note: the function argument must be bit-parallel. The type guarantees it to +-- some degree, but in general, we can't enforce this in the type system. zipBuild :: (forall (a :: Type) . (FiniteBits a, Storable a) => a -> a -> a) -> Ptr CChar -> @@ -371,6 +532,10 @@ zipBuild f ptr ptr' len = do poke (plusPtr dst offset') (f block block') go dst src src' (offset + 1) lim +-- Check every bit position in a byte for a set bit, returning its index if we +-- find one. We default return 7, even though this index is valid, as no +-- consumer function ever looks at this value, since that can only happen on +-- zero bytes, which we ignore anyway. findPosition :: Word8 -> Int findPosition w8 = foldl' go 7 . fmap (\i -> (i, bit 0 `shiftL` i)) $ [0 .. 7] where @@ -379,6 +544,9 @@ findPosition w8 = foldl' go 7 . fmap (\i -> (i, bit 0 `shiftL` i)) $ [0 .. 7] 0 -> acc -- nothing to see here, move along _ -> min acc i +-- A polymorphic bit counter in a block, which we can segment by chunks of a +-- type of arbitrary size, provided it is both Storable (so we can read at +-- offsets) and FiniteBits (so we can count it). countBits :: forall (a :: Type) . (FiniteBits a, Storable a) => Ptr a -> Int -> IO Int @@ -392,3 +560,11 @@ countBits ptr len = go 0 0 block :: a <- peek . plusPtr ptr $ offset' let total' = total + popCount block go total' (offset + 1) + +-- Check if every byte of a ByteString is zero +isAllZero :: ByteString -> Bool +isAllZero = BS.all (== zeroBits) + +-- Check if every byte of a ByteString is one +isAllOne :: ByteString -> Bool +isAllOne = BS.all (== complement zeroBits) From b7180e4402fe8cb8831ddf0ca229aee42aab8a7d Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 11 Jul 2022 13:03:52 +1200 Subject: [PATCH 21/73] Remove -Werror in source files --- plutus-core/plutus-core/src/Bitwise.hs | 1 - plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs | 1 - .../untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs | 1 - 3 files changed, 3 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 53f7b182f72..1c7ffbedafa 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -6,7 +6,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Werror #-} module Bitwise ( integerToByteString, diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 7a983fc0dff..b211be3c8ba 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Werror #-} module PlutusCore.Default.Builtins where diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index b9edeec78bb..433251deacf 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -3,7 +3,6 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Werror #-} module Evaluation.Builtins.Bitwise ( bitwiseAndCommutes, From 2e3d05480a6754f6fa3c31e3d2af5019a908de21 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 19 Jul 2022 13:51:32 +1200 Subject: [PATCH 22/73] Benchmarks for bitwise binary ops --- plutus-core/plutus-core.cabal | 19 +++ plutus-core/plutus-core/bench/bitwise/Main.hs | 158 ++++++++++++++++++ 2 files changed, 177 insertions(+) create mode 100644 plutus-core/plutus-core/bench/bitwise/Main.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 08f9609444e..23661149043 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -785,3 +785,22 @@ test-suite index-envs-test , quickcheck-instances , tasty , tasty-quickcheck + +benchmark bitwise + import: lang + type: exitcode-stdio-1.0 + hs-source-dirs: plutus-core/bench/bitwise + default-language: Haskell2010 + main-is: Main.hs + build-depends: + , base + , bytestring + , deepseq + , plutus-core + , random + , tasty-bench + , text + , transformers + , vector + + ghc-options: -O2 -rtsopts "-with-rtsopts=-A32m --nonmoving-gc -T" diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs new file mode 100644 index 00000000000..2bf67776758 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +-- Needed for tasty-bench +{-# OPTIONS_GHC -Wno-orphans #-} + +module Main (main) where + +import Bitwise (andByteString, iorByteString, xorByteString) +import Control.DeepSeq (NFData (rnf)) +import Control.Monad (replicateM) +import Control.Monad.ST (ST) +import Control.Monad.Trans.State.Strict (StateT) +import Data.Bits (xor, (.&.), (.|.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Kind (Type) +import Data.Text (pack) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import GHC.Exts (fromListN, toList) +import GHC.IO.Encoding (setLocaleEncoding, utf8) +import PlutusCore.Builtin.Emitter (Emitter, emit, runEmitter) +import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure, EvaluationSuccess)) +import System.Random.Stateful (StateGenM, StdGen, mkStdGen, randomM, runStateGenST_) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nf) + +main :: IO () +main = do + setLocaleEncoding utf8 + defaultMain [ + bgroup "Bitwise AND" bandBenches, + bgroup "Bitwise IOR" biorBenches, + bgroup "Bitwise XOR" bxorBenches + ] + +-- Benchmarks + +bandBenches :: [Benchmark] +bandBenches = toList sampleData >>= go + where + go :: (Int, ByteString, ByteString) -> [Benchmark] + go (len, bs, bs') = + let label = "naive, length " <> show len + label' = "optimized, length " <> show len + matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise AND\"" in + [ + bench label' . nf (andByteString bs) $ bs', + bcompare matchLabel . bench label . nf (naiveAnd bs) $ bs' + ] + +biorBenches :: [Benchmark] +biorBenches = toList sampleData >>= go + where + go :: (Int, ByteString, ByteString) -> [Benchmark] + go (len, bs, bs') = + let label = "naive, length " <> show len + label' = "optimized, length " <> show len + matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise IOR\"" in + [ + bench label' . nf (iorByteString bs) $ bs', + bcompare matchLabel . bench label . nf (naiveIor bs) $ bs' + ] + +bxorBenches :: [Benchmark] +bxorBenches = toList sampleData >>= go + where + go :: (Int, ByteString, ByteString) -> [Benchmark] + go (len, bs, bs') = + let label = "naive, length " <> show len + label' = "optimized, length " <> show len + matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise XOR\"" in + [ + bench label' . nf (xorByteString bs) $ bs', + bcompare matchLabel . bench label . nf (naiveXor bs) $ bs' + ] + + +-- Naive implementations for comparison + +naiveAnd :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) +naiveAnd bs bs' + | BS.length bs /= BS.length bs' = do + emit "andByteString failed" + emit "Reason: mismatched argument lengths" + emit $ "Length of first argument: " <> (pack . show . BS.length $ bs) + emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') + pure EvaluationFailure + | otherwise = do + let len = BS.length bs + pure . pure . fromListN len . BS.zipWith (.&.) bs $ bs' + +naiveIor :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) +naiveIor bs bs' + | BS.length bs /= BS.length bs' = do + emit "iorByteString failed" + emit "Reason: mismatched argument lengths" + emit $ "Length of first argument: " <> (pack . show . BS.length $ bs) + emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') + pure EvaluationFailure + | otherwise = do + let len = BS.length bs + pure . pure . fromListN len . BS.zipWith (.|.) bs $ bs' + +naiveXor :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) +naiveXor bs bs' + | BS.length bs /= BS.length bs' = do + emit "xorByteString failed" + emit "Reason: mismatched argument lengths" + emit $ "Length of first argument: " <> (pack . show . BS.length $ bs) + emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') + pure EvaluationFailure + | otherwise = do + let len = BS.length bs + pure . pure . fromListN len . BS.zipWith xor bs $ bs' + +-- Data + +-- Note: Methodology for benchmarking data sizes +-- +-- As the on-chain memory limit is approximately 13KiB, which has to include the +-- code as well as the arguments, we consider an upper limit of usefulness on +-- the length of a ByteString to be about 2KiB, which is 2048 bytes. Likewise, +-- ByteStrings whose length is significantly shorter than 64 bytes fit into a +-- single cache line on basically any architecture we care about, which means +-- that the differences in implementation strategies would probably be fairly +-- minimal. +-- +-- On the basis of the above, we generate test data pairs of the following +-- byte lengths (for each element of each pair): +-- +-- * 64 +-- * 128 +-- * 256 +-- * 512 +-- * 1024 +-- * 2048 + +sampleData :: Vector (Int, ByteString, ByteString) +sampleData = + runStateGenST_ (mkStdGen 42) (\gen -> Vector.generateM 6 (go gen)) + where + go :: forall (s :: Type) . + StateGenM StdGen -> + Int -> + StateT StdGen (ST s) (Int, ByteString, ByteString) + go gen ix = do + let len = 64 * (2 ^ ix) + leftRes <- fromListN len <$> replicateM len (randomM gen) + rightRes <- fromListN len <$> replicateM len (randomM gen) + pure (len, leftRes, rightRes) + +-- We unfortunately need this orphan or tasty-bench won't do much for us +instance NFData (Emitter (EvaluationResult ByteString)) where + rnf x = case runEmitter x of + (res, logs) -> case res of + EvaluationFailure -> rnf logs + EvaluationSuccess y -> seq y . rnf $ logs From 470baee64d2f268f51b92856ee2f83163c495878 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 20 Jul 2022 14:48:51 +1200 Subject: [PATCH 23/73] Refactor of bitwise binary ops, more accurate measurements --- plutus-core/plutus-core.cabal | 4 +- plutus-core/plutus-core/bench/bitwise/Main.hs | 75 +++++-------------- plutus-core/plutus-core/src/Bitwise.hs | 9 ++- plutus-core/plutus-core/src/Bitwise/Raw.hs | 69 +++++++++++++++++ 4 files changed, 98 insertions(+), 59 deletions(-) create mode 100644 plutus-core/plutus-core/src/Bitwise/Raw.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 23661149043..8ffd69611ac 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -50,6 +50,7 @@ library import: lang exposed-modules: Bitwise + Bitwise.Raw Crypto Data.ByteString.Hash Data.Either.Extras @@ -317,6 +318,7 @@ library , time , transformers , unordered-containers + , wide-word , witherable , word-array @@ -795,11 +797,9 @@ benchmark bitwise build-depends: , base , bytestring - , deepseq , plutus-core , random , tasty-bench - , text , transformers , vector diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 2bf67776758..b592bb19547 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -1,13 +1,10 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} --- Needed for tasty-bench -{-# OPTIONS_GHC -Wno-orphans #-} module Main (main) where -import Bitwise (andByteString, iorByteString, xorByteString) -import Control.DeepSeq (NFData (rnf)) +import Bitwise.Raw (rawBitwiseBinary) import Control.Monad (replicateM) import Control.Monad.ST (ST) import Control.Monad.Trans.State.Strict (StateT) @@ -15,13 +12,11 @@ import Data.Bits (xor, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Kind (Type) -import Data.Text (pack) import Data.Vector (Vector) import Data.Vector qualified as Vector +import Data.Word (Word8) import GHC.Exts (fromListN, toList) import GHC.IO.Encoding (setLocaleEncoding, utf8) -import PlutusCore.Builtin.Emitter (Emitter, emit, runEmitter) -import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure, EvaluationSuccess)) import System.Random.Stateful (StateGenM, StdGen, mkStdGen, randomM, runStateGenST_) import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nf) @@ -45,8 +40,8 @@ bandBenches = toList sampleData >>= go label' = "optimized, length " <> show len matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise AND\"" in [ - bench label' . nf (andByteString bs) $ bs', - bcompare matchLabel . bench label . nf (naiveAnd bs) $ bs' + bench label' . nf (rawBitwiseBinary (.&.) bs) $ bs', + bcompare matchLabel . bench label . nf (naiveBitwiseBinary (.&.) bs) $ bs' ] biorBenches :: [Benchmark] @@ -58,8 +53,8 @@ biorBenches = toList sampleData >>= go label' = "optimized, length " <> show len matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise IOR\"" in [ - bench label' . nf (iorByteString bs) $ bs', - bcompare matchLabel . bench label . nf (naiveIor bs) $ bs' + bench label' . nf (rawBitwiseBinary (.|.) bs) $ bs', + bcompare matchLabel . bench label . nf (naiveBitwiseBinary (.|.) bs) $ bs' ] bxorBenches :: [Benchmark] @@ -71,48 +66,23 @@ bxorBenches = toList sampleData >>= go label' = "optimized, length " <> show len matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise XOR\"" in [ - bench label' . nf (xorByteString bs) $ bs', - bcompare matchLabel . bench label . nf (naiveXor bs) $ bs' + bench label' . nf (rawBitwiseBinary xor bs) $ bs', + bcompare matchLabel . bench label . nf (naiveBitwiseBinary xor bs) $ bs' ] - -- Naive implementations for comparison -naiveAnd :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) -naiveAnd bs bs' - | BS.length bs /= BS.length bs' = do - emit "andByteString failed" - emit "Reason: mismatched argument lengths" - emit $ "Length of first argument: " <> (pack . show . BS.length $ bs) - emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') - pure EvaluationFailure - | otherwise = do - let len = BS.length bs - pure . pure . fromListN len . BS.zipWith (.&.) bs $ bs' - -naiveIor :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) -naiveIor bs bs' - | BS.length bs /= BS.length bs' = do - emit "iorByteString failed" - emit "Reason: mismatched argument lengths" - emit $ "Length of first argument: " <> (pack . show . BS.length $ bs) - emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') - pure EvaluationFailure - | otherwise = do - let len = BS.length bs - pure . pure . fromListN len . BS.zipWith (.|.) bs $ bs' - -naiveXor :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) -naiveXor bs bs' - | BS.length bs /= BS.length bs' = do - emit "xorByteString failed" - emit "Reason: mismatched argument lengths" - emit $ "Length of first argument: " <> (pack . show . BS.length $ bs) - emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') - pure EvaluationFailure - | otherwise = do - let len = BS.length bs - pure . pure . fromListN len . BS.zipWith xor bs $ bs' +naiveBitwiseBinary :: + (Word8 -> Word8 -> Word8) -> + ByteString -> + ByteString -> + Maybe ByteString +naiveBitwiseBinary f bs bs' + | len /= BS.length bs' = Nothing + | otherwise = pure . fromListN len . BS.zipWith f bs $ bs' + where + len :: Int + len = BS.length bs -- Data @@ -149,10 +119,3 @@ sampleData = leftRes <- fromListN len <$> replicateM len (randomM gen) rightRes <- fromListN len <$> replicateM len (randomM gen) pure (len, leftRes, rightRes) - --- We unfortunately need this orphan or tasty-bench won't do much for us -instance NFData (Emitter (EvaluationResult ByteString)) where - rnf x = case runEmitter x of - (res, logs) -> case res of - EvaluationFailure -> rnf logs - EvaluationSuccess y -> seq y . rnf $ logs diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index c11bf4224d2..58fa9af6f17 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -6,6 +6,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedSums #-} module Bitwise ( integerToByteString, @@ -22,6 +23,7 @@ module Bitwise ( rotateByteString, ) where +import Bitwise.Raw (rawBitwiseBinary) import Control.Monad (foldM, when) import Control.Monad.State.Strict (State, evalState, get, modify, put) import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shift, shiftL, xor, zeroBits, (.&.), (.|.)) @@ -319,7 +321,11 @@ popCountByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go -- only option was to 'zip out' into a list, then rebuild. This is not only -- inefficient (as you can't do a 'big step, little step' approach to this in -- general), it also copies too much. - +andByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) +andByteString bs bs' = case rawBitwiseBinary (.&.) bs bs' of + Nothing -> mismatchedLengthError "andByteString" bs bs' + Just result -> pure . pure $ result +{- {-# NOINLINE andByteString #-} andByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) andByteString bs bs' @@ -327,6 +333,7 @@ andByteString bs bs' | otherwise = pure . pure . unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> unsafeUseAsCString bs' $ \ptr' -> zipBuild (.&.) ptr ptr' len >>= (unsafePackMallocCStringLen . (,len)) +-} {-# NOINLINE iorByteString #-} iorByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) diff --git a/plutus-core/plutus-core/src/Bitwise/Raw.hs b/plutus-core/plutus-core/src/Bitwise/Raw.hs new file mode 100644 index 00000000000..2bd2ff5fd62 --- /dev/null +++ b/plutus-core/plutus-core/src/Bitwise/Raw.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -ddump-simpl -dsuppress-all #-} + +module Bitwise.Raw ( + rawBitwiseBinary + ) where + +import Control.Monad (foldM, foldM_) +import Data.Bits (FiniteBits) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) +import Data.Kind (Type) +import Data.WideWord.Word256 (Word256) +import Data.Word (Word64, Word8) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (Storable (peek, poke, sizeOf)) +import System.IO.Unsafe (unsafeDupablePerformIO) + +{-# NOINLINE rawBitwiseBinary #-} +rawBitwiseBinary :: + (forall (a :: Type) . (FiniteBits a, Storable a) => a -> a -> a) -> + ByteString -> + ByteString -> + Maybe ByteString +rawBitwiseBinary f bs bs' + | len /= BS.length bs' = Nothing + | otherwise = Just go + where + len :: Int + len = BS.length bs + go :: ByteString + go = unsafeDupablePerformIO $ + unsafeUseAsCStringLen bs $ \(srcPtr, _) -> + unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do + dstPtr :: Ptr Word8 <- mallocBytes len + bigStepSmallStep f len dstPtr (castPtr srcPtr) (castPtr srcPtr') + unsafePackMallocCStringLen (castPtr dstPtr, len) + +{-# INLINE bigStepSmallStep #-} +bigStepSmallStep :: + (forall (a :: Type) . (FiniteBits a, Storable a) => a -> a -> a) -> + Int -> + Ptr Word8 -> + Ptr Word8 -> + Ptr Word8 -> + IO () +bigStepSmallStep f len dstPtr srcPtr srcPtr' = do + let bigStepSize = sizeOf @Word256 undefined + let (bigSteps, smallSteps) = len `quotRem` bigStepSize + let bigPtrs = (castPtr dstPtr, castPtr srcPtr, castPtr srcPtr') + (mDstPtr, mSrcPtr, mSrcPtr') <- foldM (go @Word256 bigStepSize) bigPtrs . replicate bigSteps $ () + let smallPtrs = (castPtr mDstPtr, castPtr mSrcPtr, castPtr mSrcPtr') + foldM_ (go @Word8 1) smallPtrs . replicate smallSteps $ () + where + go :: forall (a :: Type) . + (FiniteBits a, Storable a) => + Int -> + (Ptr a, Ptr a, Ptr a) -> + () -> + IO (Ptr a, Ptr a, Ptr a) + go stepSize (dst, src, src') _ = do + srcBlock <- peek src + srcBlock' <- peek src' + poke dst (f srcBlock srcBlock') + pure (plusPtr dst stepSize, plusPtr src stepSize, plusPtr src' stepSize) From 1eb89ce6bef062b0c9e758e0fe254092d12203b8 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 20 Jul 2022 15:25:00 +1200 Subject: [PATCH 24/73] More rigid benching methodology, 3-stage loop --- plutus-core/plutus-core/bench/bitwise/Main.hs | 24 +++++++++++++------ plutus-core/plutus-core/src/Bitwise/Raw.hs | 9 ++++--- 2 files changed, 23 insertions(+), 10 deletions(-) diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index b592bb19547..c3a08224fbc 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -96,15 +96,25 @@ naiveBitwiseBinary f bs bs' -- that the differences in implementation strategies would probably be fairly -- minimal. -- +-- In order to make this comparison as fair as possible, we will make the +-- 'optimized' versions do as much work as possible. To do this, we need to give +-- them inputs whose lengths are one less than a power of 2: the reason for this +-- has to do with how big-little stepping loops operate. If we give a power of 2 +-- exactly, especially a large one, we never have to take any little steps at +-- all: in this setting, big-little stepping loops will have a huge advantage +-- due to processing more data per step. However, when given a length just one +-- less than this, they have to do the largest amount of work possible, as they +-- have maximally-long 'tails', which have to be done a byte at a time. +-- -- On the basis of the above, we generate test data pairs of the following -- byte lengths (for each element of each pair): -- --- * 64 --- * 128 --- * 256 --- * 512 --- * 1024 --- * 2048 +-- * 63 +-- * 127 +-- * 255 +-- * 511 +-- * 1023 +-- * 2047 sampleData :: Vector (Int, ByteString, ByteString) sampleData = @@ -115,7 +125,7 @@ sampleData = Int -> StateT StdGen (ST s) (Int, ByteString, ByteString) go gen ix = do - let len = 64 * (2 ^ ix) + let len = (64 * (2 ^ ix)) - 1 leftRes <- fromListN len <$> replicateM len (randomM gen) rightRes <- fromListN len <$> replicateM len (randomM gen) pure (len, leftRes, rightRes) diff --git a/plutus-core/plutus-core/src/Bitwise/Raw.hs b/plutus-core/plutus-core/src/Bitwise/Raw.hs index 2bd2ff5fd62..6e1c195446c 100644 --- a/plutus-core/plutus-core/src/Bitwise/Raw.hs +++ b/plutus-core/plutus-core/src/Bitwise/Raw.hs @@ -1,7 +1,6 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -ddump-simpl -dsuppress-all #-} module Bitwise.Raw ( rawBitwiseBinary @@ -50,10 +49,14 @@ bigStepSmallStep :: IO () bigStepSmallStep f len dstPtr srcPtr srcPtr' = do let bigStepSize = sizeOf @Word256 undefined - let (bigSteps, smallSteps) = len `quotRem` bigStepSize + let smallerStepSize = sizeOf @Word64 undefined + let (bigSteps, rest) = len `quotRem` bigStepSize + let (smallerSteps, smallSteps) = rest `quotRem` smallerStepSize let bigPtrs = (castPtr dstPtr, castPtr srcPtr, castPtr srcPtr') (mDstPtr, mSrcPtr, mSrcPtr') <- foldM (go @Word256 bigStepSize) bigPtrs . replicate bigSteps $ () - let smallPtrs = (castPtr mDstPtr, castPtr mSrcPtr, castPtr mSrcPtr') + let smallerPtrs = (castPtr mDstPtr, castPtr mSrcPtr, castPtr mSrcPtr') + (m2DstPtr, m2SrcPtr, m2SrcPtr') <- foldM (go @Word64 smallerStepSize) smallerPtrs . replicate smallerSteps $ () + let smallPtrs = (castPtr m2DstPtr, castPtr m2SrcPtr, castPtr m2SrcPtr') foldM_ (go @Word8 1) smallPtrs . replicate smallSteps $ () where go :: forall (a :: Type) . From 293f4c80e28b49a7bb8b5382549c84bc33a2a4ef Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 21 Jul 2022 12:09:57 +1200 Subject: [PATCH 25/73] Rewrite to use arrays of Ptrs --- plutus-core/plutus-core.cabal | 1 + plutus-core/plutus-core/src/Bitwise/Raw.hs | 46 ++++++++-------- plutus-core/plutus-core/src/Bitwise/RefIO.hs | 57 ++++++++++++++++++++ 3 files changed, 83 insertions(+), 21 deletions(-) create mode 100644 plutus-core/plutus-core/src/Bitwise/RefIO.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 8ffd69611ac..b770a3f8e30 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -51,6 +51,7 @@ library exposed-modules: Bitwise Bitwise.Raw + Bitwise.RefIO Crypto Data.ByteString.Hash Data.Either.Extras diff --git a/plutus-core/plutus-core/src/Bitwise/Raw.hs b/plutus-core/plutus-core/src/Bitwise/Raw.hs index 6e1c195446c..c7671c106d5 100644 --- a/plutus-core/plutus-core/src/Bitwise/Raw.hs +++ b/plutus-core/plutus-core/src/Bitwise/Raw.hs @@ -1,17 +1,20 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} module Bitwise.Raw ( rawBitwiseBinary ) where -import Control.Monad (foldM, foldM_) +import Bitwise.RefIO (MultiPtr (MultiPtr), RefIO, liftRefIO, readAndStep, runRefIO, writeAndStep) +import Control.Monad (replicateM_) import Data.Bits (FiniteBits) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) import Data.Kind (Type) +import Data.Primitive.PrimArray (newPrimArray, writePrimArray) import Data.WideWord.Word256 (Word256) import Data.Word (Word64, Word8) import Foreign.Marshal.Alloc (mallocBytes) @@ -52,21 +55,22 @@ bigStepSmallStep f len dstPtr srcPtr srcPtr' = do let smallerStepSize = sizeOf @Word64 undefined let (bigSteps, rest) = len `quotRem` bigStepSize let (smallerSteps, smallSteps) = rest `quotRem` smallerStepSize - let bigPtrs = (castPtr dstPtr, castPtr srcPtr, castPtr srcPtr') - (mDstPtr, mSrcPtr, mSrcPtr') <- foldM (go @Word256 bigStepSize) bigPtrs . replicate bigSteps $ () - let smallerPtrs = (castPtr mDstPtr, castPtr mSrcPtr, castPtr mSrcPtr') - (m2DstPtr, m2SrcPtr, m2SrcPtr') <- foldM (go @Word64 smallerStepSize) smallerPtrs . replicate smallerSteps $ () - let smallPtrs = (castPtr m2DstPtr, castPtr m2SrcPtr, castPtr m2SrcPtr') - foldM_ (go @Word8 1) smallPtrs . replicate smallSteps $ () + ptrs <- MultiPtr <$> do + arr <- newPrimArray 3 + writePrimArray arr 0 dstPtr + writePrimArray arr 1 srcPtr + writePrimArray arr 2 srcPtr' + pure arr + runRefIO ptrs $ do + replicateM_ bigSteps $ go @Word256 + replicateM_ smallerSteps $ go @Word64 + replicateM_ smallSteps $ go @Word8 where - go :: forall (a :: Type) . - (FiniteBits a, Storable a) => - Int -> - (Ptr a, Ptr a, Ptr a) -> - () -> - IO (Ptr a, Ptr a, Ptr a) - go stepSize (dst, src, src') _ = do - srcBlock <- peek src - srcBlock' <- peek src' - poke dst (f srcBlock srcBlock') - pure (plusPtr dst stepSize, plusPtr src stepSize, plusPtr src' stepSize) + go :: + forall (a :: Type) . + (Storable a, FiniteBits a) => + RefIO () + go = do + srcBlock <- liftRefIO (readAndStep @a 1) + srcBlock' <- liftRefIO (readAndStep @a 2) + liftRefIO (writeAndStep 0 (f srcBlock srcBlock')) diff --git a/plutus-core/plutus-core/src/Bitwise/RefIO.hs b/plutus-core/plutus-core/src/Bitwise/RefIO.hs new file mode 100644 index 00000000000..b008eeef2ef --- /dev/null +++ b/plutus-core/plutus-core/src/Bitwise/RefIO.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} + +module Bitwise.RefIO ( + MultiPtr (..), + readAndStep, + writeAndStep, + RefIO, + liftRefIO, + runRefIO, + ) + where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Primitive (PrimState) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Data.Kind (Type) +import Data.Primitive.PrimArray (MutablePrimArray, readPrimArray, writePrimArray) +import Data.Word (Word8) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (Storable (peek, poke, sizeOf)) + +newtype MultiPtr = MultiPtr (MutablePrimArray (PrimState IO) (Ptr Word8)) + +{-# INLINEABLE readAndStep #-} +readAndStep :: forall (a :: Type) . + (Storable a) => + Int -> MultiPtr -> IO a +readAndStep ix (MultiPtr arr) = do + let steps = sizeOf @a undefined + p <- readPrimArray arr ix + writePrimArray arr ix (plusPtr p steps) + peek . castPtr $ p + +{-# INLINEABLE writeAndStep #-} +writeAndStep :: forall (a :: Type) . + (Storable a) => + Int -> a -> MultiPtr -> IO () +writeAndStep ix what (MultiPtr arr) = do + let steps = sizeOf @a undefined + p <- readPrimArray arr ix + poke (castPtr p) what + writePrimArray arr ix (plusPtr p steps) + +newtype RefIO (a :: Type) = RefIO (ReaderT MultiPtr IO a) + deriving (Functor, Applicative, Monad, MonadIO) via (ReaderT MultiPtr IO) + +{-# INLINEABLE liftRefIO #-} +liftRefIO :: forall (a :: Type) . + (MultiPtr -> IO a) -> + RefIO a +liftRefIO f = RefIO (ask >>= (liftIO . f)) + +{-# INLINEABLE runRefIO #-} +runRefIO :: forall (a :: Type) . + MultiPtr -> RefIO a -> IO a +runRefIO env (RefIO comp) = runReaderT comp env From 86b9973a6585074ef114a01b12a3b8491a9fc86f Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 21 Jul 2022 14:29:59 +1200 Subject: [PATCH 26/73] Define a big-smaller-small loop generically --- plutus-core/plutus-core/src/Bitwise/Raw.hs | 60 ++++++++++++---------- 1 file changed, 32 insertions(+), 28 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise/Raw.hs b/plutus-core/plutus-core/src/Bitwise/Raw.hs index c7671c106d5..72fdc272dc7 100644 --- a/plutus-core/plutus-core/src/Bitwise/Raw.hs +++ b/plutus-core/plutus-core/src/Bitwise/Raw.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} @@ -20,6 +21,7 @@ import Data.Word (Word64, Word8) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (Storable (peek, poke, sizeOf)) +import GHC.Exts (Proxy#, proxy#) import System.IO.Unsafe (unsafeDupablePerformIO) {-# NOINLINE rawBitwiseBinary #-} @@ -39,38 +41,40 @@ rawBitwiseBinary f bs bs' unsafeUseAsCStringLen bs $ \(srcPtr, _) -> unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do dstPtr :: Ptr Word8 <- mallocBytes len - bigStepSmallStep f len dstPtr (castPtr srcPtr) (castPtr srcPtr') + ptrs <- MultiPtr <$> do + arr <- newPrimArray 3 + writePrimArray arr 0 dstPtr + writePrimArray arr 1 . castPtr $ srcPtr + writePrimArray arr 2 . castPtr $ srcPtr' + pure arr + loop step ptrs len unsafePackMallocCStringLen (castPtr dstPtr, len) + step :: forall (a :: Type) . + (FiniteBits a, Storable a) => + Proxy# a -> + MultiPtr -> + IO () + step _ mp = do + srcBlock <- readAndStep @a 1 mp + srcBlock' <- readAndStep @a 2 mp + writeAndStep 0 (f srcBlock srcBlock') mp -{-# INLINE bigStepSmallStep #-} -bigStepSmallStep :: - (forall (a :: Type) . (FiniteBits a, Storable a) => a -> a -> a) -> +{-# INLINE loop #-} +loop :: + (forall (a :: Type) . + (FiniteBits a, Storable a) => + Proxy# a -> + MultiPtr -> + IO ()) -> + MultiPtr -> Int -> - Ptr Word8 -> - Ptr Word8 -> - Ptr Word8 -> IO () -bigStepSmallStep f len dstPtr srcPtr srcPtr' = do +loop step mp len = do let bigStepSize = sizeOf @Word256 undefined let smallerStepSize = sizeOf @Word64 undefined let (bigSteps, rest) = len `quotRem` bigStepSize - let (smallerSteps, smallSteps) = rest `quotRem` smallerStepSize - ptrs <- MultiPtr <$> do - arr <- newPrimArray 3 - writePrimArray arr 0 dstPtr - writePrimArray arr 1 srcPtr - writePrimArray arr 2 srcPtr' - pure arr - runRefIO ptrs $ do - replicateM_ bigSteps $ go @Word256 - replicateM_ smallerSteps $ go @Word64 - replicateM_ smallSteps $ go @Word8 - where - go :: - forall (a :: Type) . - (Storable a, FiniteBits a) => - RefIO () - go = do - srcBlock <- liftRefIO (readAndStep @a 1) - srcBlock' <- liftRefIO (readAndStep @a 2) - liftRefIO (writeAndStep 0 (f srcBlock srcBlock')) + let (smallerSteps, smallestSteps) = rest `quotRem` smallerStepSize + runRefIO mp $ do + replicateM_ bigSteps . liftRefIO $ step (proxy# @Word256) + replicateM_ smallerSteps . liftRefIO $ step (proxy# @Word64) + replicateM_ smallestSteps . liftRefIO $ step (proxy# @Word8) From 5ed1dd352a2d4014839b6aa4474d63032e441de2 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 25 Jul 2022 14:25:47 +1200 Subject: [PATCH 27/73] Better benches, settle on implementation --- plutus-core/plutus-core.cabal | 7 +- plutus-core/plutus-core/bench/bitwise/Main.hs | 135 ++++++------------ plutus-core/plutus-core/src/Bitwise.hs | 7 - .../plutus-core/src/Bitwise/PackZipWith.hs | 43 ++++++ plutus-core/plutus-core/src/Bitwise/Raw.hs | 80 ----------- plutus-core/plutus-core/src/Bitwise/RefIO.hs | 57 -------- 6 files changed, 85 insertions(+), 244 deletions(-) create mode 100644 plutus-core/plutus-core/src/Bitwise/PackZipWith.hs delete mode 100644 plutus-core/plutus-core/src/Bitwise/Raw.hs delete mode 100644 plutus-core/plutus-core/src/Bitwise/RefIO.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index b770a3f8e30..14c402337be 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -50,8 +50,7 @@ library import: lang exposed-modules: Bitwise - Bitwise.Raw - Bitwise.RefIO + Bitwise.PackZipWith Crypto Data.ByteString.Hash Data.Either.Extras @@ -319,7 +318,6 @@ library , time , transformers , unordered-containers - , wide-word , witherable , word-array @@ -800,8 +798,7 @@ benchmark bitwise , bytestring , plutus-core , random + , tasty , tasty-bench - , transformers - , vector ghc-options: -O2 -rtsopts "-with-rtsopts=-A32m --nonmoving-gc -T" diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index c3a08224fbc..20d743d7829 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -1,131 +1,76 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Main (main) where -import Bitwise.Raw (rawBitwiseBinary) +import Bitwise.PackZipWith (packZipWithBinary) import Control.Monad (replicateM) -import Control.Monad.ST (ST) -import Control.Monad.Trans.State.Strict (StateT) -import Data.Bits (xor, (.&.), (.|.)) +import Data.Bits ((.&.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Kind (Type) -import Data.Vector (Vector) -import Data.Vector qualified as Vector import Data.Word (Word8) -import GHC.Exts (fromListN, toList) +import GHC.Exts (fromListN) import GHC.IO.Encoding (setLocaleEncoding, utf8) -import System.Random.Stateful (StateGenM, StdGen, mkStdGen, randomM, runStateGenST_) -import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nf) +import System.Random.Stateful (mkStdGen, randomM, runStateGen_) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nfIO) main :: IO () main = do setLocaleEncoding utf8 defaultMain [ - bgroup "Bitwise AND" bandBenches, - bgroup "Bitwise IOR" biorBenches, - bgroup "Bitwise XOR" bxorBenches + bgroup "Bitwise AND" . fmap bitwiseAndBench $ [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047] ] -- Benchmarks -bandBenches :: [Benchmark] -bandBenches = toList sampleData >>= go - where - go :: (Int, ByteString, ByteString) -> [Benchmark] - go (len, bs, bs') = - let label = "naive, length " <> show len - label' = "optimized, length " <> show len - matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise AND\"" in - [ - bench label' . nf (rawBitwiseBinary (.&.) bs) $ bs', - bcompare matchLabel . bench label . nf (naiveBitwiseBinary (.&.) bs) $ bs' +bitwiseAndBench :: Int -> Benchmark +bitwiseAndBench len = withResource (mkBinaryArgs len) noCleanup $ \xs -> + let label = "zipWith" + label' = "packZipWith" + label'' = "hybrid" + testLabel = "Bitwise AND, length " <> show len + matchLabel = "$NF == \"" <> label <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench label . nfIO $ uncurry (zipWithBinary (.&.)) <$> xs, + bcompare matchLabel . bench label' . nfIO $ uncurry (packZipWithBinary (.&.)) <$> xs, + bcompare matchLabel . bench label'' . nfIO $ uncurry (hybridBinary (.&.)) <$> xs ] -biorBenches :: [Benchmark] -biorBenches = toList sampleData >>= go - where - go :: (Int, ByteString, ByteString) -> [Benchmark] - go (len, bs, bs') = - let label = "naive, length " <> show len - label' = "optimized, length " <> show len - matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise IOR\"" in - [ - bench label' . nf (rawBitwiseBinary (.|.) bs) $ bs', - bcompare matchLabel . bench label . nf (naiveBitwiseBinary (.|.) bs) $ bs' - ] +-- Generators -bxorBenches :: [Benchmark] -bxorBenches = toList sampleData >>= go - where - go :: (Int, ByteString, ByteString) -> [Benchmark] - go (len, bs, bs') = - let label = "naive, length " <> show len - label' = "optimized, length " <> show len - matchLabel = "$NF == \"" <> label' <> "\" && $(NF -1) == \"Bitwise XOR\"" in - [ - bench label' . nf (rawBitwiseBinary xor bs) $ bs', - bcompare matchLabel . bench label . nf (naiveBitwiseBinary xor bs) $ bs' - ] +mkBinaryArgs :: Int -> IO (ByteString, ByteString) +mkBinaryArgs len = pure . runStateGen_ (mkStdGen 42) $ \gen -> + (,) <$> (fromListN len <$> replicateM len (randomM gen)) <*> + (fromListN len <$> replicateM len (randomM gen)) --- Naive implementations for comparison +-- Helpers -naiveBitwiseBinary :: +noCleanup :: forall (a :: Type) . a -> IO () +noCleanup = const (pure ()) + +-- Naive implementations for comparison +zipWithBinary :: (Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> Maybe ByteString -naiveBitwiseBinary f bs bs' +zipWithBinary f bs bs' | len /= BS.length bs' = Nothing | otherwise = pure . fromListN len . BS.zipWith f bs $ bs' where len :: Int len = BS.length bs --- Data - --- Note: Methodology for benchmarking data sizes --- --- As the on-chain memory limit is approximately 13KiB, which has to include the --- code as well as the arguments, we consider an upper limit of usefulness on --- the length of a ByteString to be about 2KiB, which is 2048 bytes. Likewise, --- ByteStrings whose length is significantly shorter than 64 bytes fit into a --- single cache line on basically any architecture we care about, which means --- that the differences in implementation strategies would probably be fairly --- minimal. --- --- In order to make this comparison as fair as possible, we will make the --- 'optimized' versions do as much work as possible. To do this, we need to give --- them inputs whose lengths are one less than a power of 2: the reason for this --- has to do with how big-little stepping loops operate. If we give a power of 2 --- exactly, especially a large one, we never have to take any little steps at --- all: in this setting, big-little stepping loops will have a huge advantage --- due to processing more data per step. However, when given a length just one --- less than this, they have to do the largest amount of work possible, as they --- have maximally-long 'tails', which have to be done a byte at a time. --- --- On the basis of the above, we generate test data pairs of the following --- byte lengths (for each element of each pair): --- --- * 63 --- * 127 --- * 255 --- * 511 --- * 1023 --- * 2047 - -sampleData :: Vector (Int, ByteString, ByteString) -sampleData = - runStateGenST_ (mkStdGen 42) (\gen -> Vector.generateM 6 (go gen)) - where - go :: forall (s :: Type) . - StateGenM StdGen -> - Int -> - StateT StdGen (ST s) (Int, ByteString, ByteString) - go gen ix = do - let len = (64 * (2 ^ ix)) - 1 - leftRes <- fromListN len <$> replicateM len (randomM gen) - rightRes <- fromListN len <$> replicateM len (randomM gen) - pure (len, leftRes, rightRes) +-- Hybrid to try and get the best of both +hybridBinary :: + (Word8 -> Word8 -> Word8) -> + ByteString -> + ByteString -> + Maybe ByteString +hybridBinary f bs bs' + | max (BS.length bs) (BS.length bs') < 16 = zipWithBinary f bs bs' + | otherwise = packZipWithBinary f bs bs' diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 58fa9af6f17..27d78fafe9b 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -23,7 +23,6 @@ module Bitwise ( rotateByteString, ) where -import Bitwise.Raw (rawBitwiseBinary) import Control.Monad (foldM, when) import Control.Monad.State.Strict (State, evalState, get, modify, put) import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shift, shiftL, xor, zeroBits, (.&.), (.|.)) @@ -321,11 +320,6 @@ popCountByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go -- only option was to 'zip out' into a list, then rebuild. This is not only -- inefficient (as you can't do a 'big step, little step' approach to this in -- general), it also copies too much. -andByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) -andByteString bs bs' = case rawBitwiseBinary (.&.) bs bs' of - Nothing -> mismatchedLengthError "andByteString" bs bs' - Just result -> pure . pure $ result -{- {-# NOINLINE andByteString #-} andByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) andByteString bs bs' @@ -333,7 +327,6 @@ andByteString bs bs' | otherwise = pure . pure . unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> unsafeUseAsCString bs' $ \ptr' -> zipBuild (.&.) ptr ptr' len >>= (unsafePackMallocCStringLen . (,len)) --} {-# NOINLINE iorByteString #-} iorByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) diff --git a/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs b/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs new file mode 100644 index 00000000000..9b530ee2683 --- /dev/null +++ b/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs @@ -0,0 +1,43 @@ +module Bitwise.PackZipWith ( + packZipWithBinary + ) where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) +import Data.Foldable (traverse_) +import Data.Word (Word8) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (peekElemOff, pokeElemOff) +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- Replicate packZipWith from newer bytestring +-- the INLINE is their idea +{-# INLINE packZipWithBinary #-} +packZipWithBinary :: + (Word8 -> Word8 -> Word8) -> + ByteString -> + ByteString -> + Maybe ByteString +packZipWithBinary f bs bs' + | BS.length bs /= BS.length bs' = Nothing + | otherwise = pure go + where + go :: ByteString + go = unsafeDupablePerformIO $ + unsafeUseAsCStringLen bs $ \(srcPtr, len) -> + unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do + dstPtr <- castPtr <$> mallocBytes len + traverse_ (step (castPtr srcPtr) (castPtr srcPtr') dstPtr) [0 .. len - 1] + unsafePackMallocCStringLen (castPtr dstPtr, len) + step :: + Ptr Word8 -> + Ptr Word8 -> + Ptr Word8 -> + Int -> + IO () + step src src' dst offset = do + res <- f <$> peekElemOff src offset <*> + peekElemOff src' offset + pokeElemOff dst offset res diff --git a/plutus-core/plutus-core/src/Bitwise/Raw.hs b/plutus-core/plutus-core/src/Bitwise/Raw.hs deleted file mode 100644 index 72fdc272dc7..00000000000 --- a/plutus-core/plutus-core/src/Bitwise/Raw.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} - -module Bitwise.Raw ( - rawBitwiseBinary - ) where - -import Bitwise.RefIO (MultiPtr (MultiPtr), RefIO, liftRefIO, readAndStep, runRefIO, writeAndStep) -import Control.Monad (replicateM_) -import Data.Bits (FiniteBits) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) -import Data.Kind (Type) -import Data.Primitive.PrimArray (newPrimArray, writePrimArray) -import Data.WideWord.Word256 (Word256) -import Data.Word (Word64, Word8) -import Foreign.Marshal.Alloc (mallocBytes) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (Storable (peek, poke, sizeOf)) -import GHC.Exts (Proxy#, proxy#) -import System.IO.Unsafe (unsafeDupablePerformIO) - -{-# NOINLINE rawBitwiseBinary #-} -rawBitwiseBinary :: - (forall (a :: Type) . (FiniteBits a, Storable a) => a -> a -> a) -> - ByteString -> - ByteString -> - Maybe ByteString -rawBitwiseBinary f bs bs' - | len /= BS.length bs' = Nothing - | otherwise = Just go - where - len :: Int - len = BS.length bs - go :: ByteString - go = unsafeDupablePerformIO $ - unsafeUseAsCStringLen bs $ \(srcPtr, _) -> - unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do - dstPtr :: Ptr Word8 <- mallocBytes len - ptrs <- MultiPtr <$> do - arr <- newPrimArray 3 - writePrimArray arr 0 dstPtr - writePrimArray arr 1 . castPtr $ srcPtr - writePrimArray arr 2 . castPtr $ srcPtr' - pure arr - loop step ptrs len - unsafePackMallocCStringLen (castPtr dstPtr, len) - step :: forall (a :: Type) . - (FiniteBits a, Storable a) => - Proxy# a -> - MultiPtr -> - IO () - step _ mp = do - srcBlock <- readAndStep @a 1 mp - srcBlock' <- readAndStep @a 2 mp - writeAndStep 0 (f srcBlock srcBlock') mp - -{-# INLINE loop #-} -loop :: - (forall (a :: Type) . - (FiniteBits a, Storable a) => - Proxy# a -> - MultiPtr -> - IO ()) -> - MultiPtr -> - Int -> - IO () -loop step mp len = do - let bigStepSize = sizeOf @Word256 undefined - let smallerStepSize = sizeOf @Word64 undefined - let (bigSteps, rest) = len `quotRem` bigStepSize - let (smallerSteps, smallestSteps) = rest `quotRem` smallerStepSize - runRefIO mp $ do - replicateM_ bigSteps . liftRefIO $ step (proxy# @Word256) - replicateM_ smallerSteps . liftRefIO $ step (proxy# @Word64) - replicateM_ smallestSteps . liftRefIO $ step (proxy# @Word8) diff --git a/plutus-core/plutus-core/src/Bitwise/RefIO.hs b/plutus-core/plutus-core/src/Bitwise/RefIO.hs deleted file mode 100644 index b008eeef2ef..00000000000 --- a/plutus-core/plutus-core/src/Bitwise/RefIO.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} - -module Bitwise.RefIO ( - MultiPtr (..), - readAndStep, - writeAndStep, - RefIO, - liftRefIO, - runRefIO, - ) - where - -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Primitive (PrimState) -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) -import Data.Kind (Type) -import Data.Primitive.PrimArray (MutablePrimArray, readPrimArray, writePrimArray) -import Data.Word (Word8) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (Storable (peek, poke, sizeOf)) - -newtype MultiPtr = MultiPtr (MutablePrimArray (PrimState IO) (Ptr Word8)) - -{-# INLINEABLE readAndStep #-} -readAndStep :: forall (a :: Type) . - (Storable a) => - Int -> MultiPtr -> IO a -readAndStep ix (MultiPtr arr) = do - let steps = sizeOf @a undefined - p <- readPrimArray arr ix - writePrimArray arr ix (plusPtr p steps) - peek . castPtr $ p - -{-# INLINEABLE writeAndStep #-} -writeAndStep :: forall (a :: Type) . - (Storable a) => - Int -> a -> MultiPtr -> IO () -writeAndStep ix what (MultiPtr arr) = do - let steps = sizeOf @a undefined - p <- readPrimArray arr ix - poke (castPtr p) what - writePrimArray arr ix (plusPtr p steps) - -newtype RefIO (a :: Type) = RefIO (ReaderT MultiPtr IO a) - deriving (Functor, Applicative, Monad, MonadIO) via (ReaderT MultiPtr IO) - -{-# INLINEABLE liftRefIO #-} -liftRefIO :: forall (a :: Type) . - (MultiPtr -> IO a) -> - RefIO a -liftRefIO f = RefIO (ask >>= (liftIO . f)) - -{-# INLINEABLE runRefIO #-} -runRefIO :: forall (a :: Type) . - MultiPtr -> RefIO a -> IO a -runRefIO env (RefIO comp) = runReaderT comp env From 22d329cbaec1ac4c48dee8845982d2adb443cffa Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 27 Jul 2022 08:29:02 +1200 Subject: [PATCH 28/73] Add benches for remaining binary bitwise ops --- plutus-core/plutus-core/bench/bitwise/Main.hs | 46 +++++++++++++------ 1 file changed, 31 insertions(+), 15 deletions(-) diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 20d743d7829..1ba75633866 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -7,7 +7,7 @@ module Main (main) where import Bitwise.PackZipWith (packZipWithBinary) import Control.Monad (replicateM) -import Data.Bits ((.&.)) +import Data.Bits (xor, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Kind (Type) @@ -22,23 +22,39 @@ main :: IO () main = do setLocaleEncoding utf8 defaultMain [ - bgroup "Bitwise AND" . fmap bitwiseAndBench $ [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047] + bgroup bandLabel . fmap (binaryOpBench bandLabel (.&.)) $ sizes, + bgroup biorLabel . fmap (binaryOpBench biorLabel (.|.)) $ sizes, + bgroup bxorLabel . fmap (binaryOpBench bxorLabel xor) $ sizes ] + where + sizes :: [Int] + sizes = [1, 3, 7, 15, 23, 27, 31, 63, 127, 255, 511, 1023, 2047] + bandLabel :: String + bandLabel = "Bitwise AND" + biorLabel :: String + biorLabel = "Bitwise IOR" + bxorLabel :: String + bxorLabel = "Bitwise XOR" -- Benchmarks -bitwiseAndBench :: Int -> Benchmark -bitwiseAndBench len = withResource (mkBinaryArgs len) noCleanup $ \xs -> - let label = "zipWith" - label' = "packZipWith" - label'' = "hybrid" - testLabel = "Bitwise AND, length " <> show len - matchLabel = "$NF == \"" <> label <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench label . nfIO $ uncurry (zipWithBinary (.&.)) <$> xs, - bcompare matchLabel . bench label' . nfIO $ uncurry (packZipWithBinary (.&.)) <$> xs, - bcompare matchLabel . bench label'' . nfIO $ uncurry (hybridBinary (.&.)) <$> xs - ] +binaryOpBench :: + String -> + (Word8 -> Word8 -> Word8) -> + Int -> + Benchmark +binaryOpBench mainLabel f len = + withResource (mkBinaryArgs len) noCleanup $ \xs -> + let zwLabel = "zipWith" + pzwLabel = "packZipWith" + hLabel = "hybrid" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> zwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench zwLabel . nfIO $ uncurry (zipWithBinary f) <$> xs, + bcompare matchLabel . bench pzwLabel . nfIO $ uncurry (packZipWithBinary f) <$> xs, + bcompare matchLabel . bench hLabel . nfIO $ uncurry (hybridBinary f) <$> xs + ] -- Generators @@ -72,5 +88,5 @@ hybridBinary :: ByteString -> Maybe ByteString hybridBinary f bs bs' - | max (BS.length bs) (BS.length bs') < 16 = zipWithBinary f bs bs' + | max (BS.length bs) (BS.length bs') < 24 = zipWithBinary f bs bs' | otherwise = packZipWithBinary f bs bs' From d8077c132c3e7dda8e4bc8fd1eac5df5657fa77a Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 1 Aug 2022 12:19:44 +1200 Subject: [PATCH 29/73] NOINLINE packZipWith --- plutus-core/plutus-core/src/Bitwise/PackZipWith.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs b/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs index 9b530ee2683..5c8e221137d 100644 --- a/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs +++ b/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs @@ -13,8 +13,7 @@ import Foreign.Storable (peekElemOff, pokeElemOff) import System.IO.Unsafe (unsafeDupablePerformIO) -- Replicate packZipWith from newer bytestring --- the INLINE is their idea -{-# INLINE packZipWithBinary #-} +{-# NOINLINE packZipWithBinary #-} packZipWithBinary :: (Word8 -> Word8 -> Word8) -> ByteString -> From 7d735d87551f9eb7709fa33a8771f9aba305f6a2 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 1 Aug 2022 12:52:40 +1200 Subject: [PATCH 30/73] Retry 2-step loop unrolls --- plutus-core/plutus-core.cabal | 1 + plutus-core/plutus-core/bench/bitwise/Main.hs | 28 +++------ .../plutus-core/src/Bitwise/ChunkZipWith.hs | 63 +++++++++++++++++++ 3 files changed, 74 insertions(+), 18 deletions(-) create mode 100644 plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 14c402337be..7a536444869 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -50,6 +50,7 @@ library import: lang exposed-modules: Bitwise + Bitwise.ChunkZipWith Bitwise.PackZipWith Crypto Data.ByteString.Hash diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 1ba75633866..29be497b48f 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -5,13 +5,14 @@ module Main (main) where +import Bitwise.ChunkZipWith (chunkZipWith2) import Bitwise.PackZipWith (packZipWithBinary) import Control.Monad (replicateM) import Data.Bits (xor, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Kind (Type) -import Data.Word (Word8) +import Data.Word (Word64, Word8) import GHC.Exts (fromListN) import GHC.IO.Encoding (setLocaleEncoding, utf8) import System.Random.Stateful (mkStdGen, randomM, runStateGen_) @@ -22,13 +23,13 @@ main :: IO () main = do setLocaleEncoding utf8 defaultMain [ - bgroup bandLabel . fmap (binaryOpBench bandLabel (.&.)) $ sizes, - bgroup biorLabel . fmap (binaryOpBench biorLabel (.|.)) $ sizes, - bgroup bxorLabel . fmap (binaryOpBench bxorLabel xor) $ sizes + bgroup bandLabel . fmap (binaryOpBench bandLabel (.&.) (.&.)) $ sizes, + bgroup biorLabel . fmap (binaryOpBench biorLabel (.|.) (.|.)) $ sizes, + bgroup bxorLabel . fmap (binaryOpBench bxorLabel xor xor) $ sizes ] where sizes :: [Int] - sizes = [1, 3, 7, 15, 23, 27, 31, 63, 127, 255, 511, 1023, 2047] + sizes = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047] bandLabel :: String bandLabel = "Bitwise AND" biorLabel :: String @@ -41,19 +42,20 @@ main = do binaryOpBench :: String -> (Word8 -> Word8 -> Word8) -> + (Word64 -> Word64 -> Word64) -> Int -> Benchmark -binaryOpBench mainLabel f len = +binaryOpBench mainLabel f f' len = withResource (mkBinaryArgs len) noCleanup $ \xs -> let zwLabel = "zipWith" pzwLabel = "packZipWith" - hLabel = "hybrid" + czwLabel = "chunkedZipWith (2 blocks)" testLabel = mainLabel <> ", length " <> show len matchLabel = "$NF == \"" <> zwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ bench zwLabel . nfIO $ uncurry (zipWithBinary f) <$> xs, bcompare matchLabel . bench pzwLabel . nfIO $ uncurry (packZipWithBinary f) <$> xs, - bcompare matchLabel . bench hLabel . nfIO $ uncurry (hybridBinary f) <$> xs + bcompare matchLabel . bench czwLabel . nfIO $ uncurry (chunkZipWith2 f f') <$> xs ] -- Generators @@ -80,13 +82,3 @@ zipWithBinary f bs bs' where len :: Int len = BS.length bs - --- Hybrid to try and get the best of both -hybridBinary :: - (Word8 -> Word8 -> Word8) -> - ByteString -> - ByteString -> - Maybe ByteString -hybridBinary f bs bs' - | max (BS.length bs) (BS.length bs') < 24 = zipWithBinary f bs bs' - | otherwise = packZipWithBinary f bs bs' diff --git a/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs b/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs new file mode 100644 index 00000000000..e7d9d5875a8 --- /dev/null +++ b/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeApplications #-} + +module Bitwise.ChunkZipWith ( + chunkZipWith2 + ) where + +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) +import Data.Foldable (traverse_) +import Data.Word (Word64, Word8) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (peekElemOff, pokeElemOff, sizeOf) +import System.IO.Unsafe (unsafeDupablePerformIO) + +-- We must ensure that both function arguments behave identically on their +-- respective inputs. Essentially, the two function arguments should be the same +-- function. +{-# NOINLINE chunkZipWith2 #-} +chunkZipWith2 :: + (Word8 -> Word8 -> Word8) -> + (Word64 -> Word64 -> Word64) -> + ByteString -> + ByteString -> + Maybe ByteString +chunkZipWith2 smallF bigF bs bs' + | BS.length bs /= BS.length bs' = Nothing + | otherwise = pure go + where + go :: ByteString + go = unsafeDupablePerformIO $ + unsafeUseAsCStringLen bs $ \(srcPtr, len) -> + unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do + dstPtr :: Ptr Word8 <- mallocBytes len + let bigStepSize = sizeOf @Word64 undefined + let (bigSteps, smallSteps) = len `quotRem` bigStepSize + traverse_ (bigStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) + [0 .. bigSteps - 1] + let firstSmallPosition = bigSteps * bigStepSize + traverse_ (smallStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) + [firstSmallPosition, firstSmallPosition + 1 .. firstSmallPosition + smallSteps - 1] + unsafePackMallocCStringLen (castPtr dstPtr, len) + bigStep :: + Ptr Word64 -> + Ptr Word64 -> + Ptr Word64 -> + Int -> + IO () + bigStep src src' dst offset = do + res <- bigF <$> peekElemOff src offset <*> + peekElemOff src' offset + pokeElemOff dst offset res + smallStep :: + Ptr Word8 -> + Ptr Word8 -> + Ptr Word8 -> + Int -> + IO () + smallStep src src' dst offset = do + res <- smallF <$> peekElemOff src offset <*> + peekElemOff src' offset + pokeElemOff dst offset res From adad03dd68e89d3a39e4345470b2f33d049171cb Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 1 Aug 2022 13:22:28 +1200 Subject: [PATCH 31/73] 3-step inlining --- plutus-core/plutus-core.cabal | 2 + plutus-core/plutus-core/bench/bitwise/Main.hs | 16 +++-- .../plutus-core/src/Bitwise/ChunkZipWith.hs | 72 ++++++++++++++++++- 3 files changed, 83 insertions(+), 7 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 7a536444869..b6aec8848ab 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -319,6 +319,7 @@ library , time , transformers , unordered-containers + , wide-word , witherable , word-array @@ -801,5 +802,6 @@ benchmark bitwise , random , tasty , tasty-bench + , wide-word ghc-options: -O2 -rtsopts "-with-rtsopts=-A32m --nonmoving-gc -T" diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 29be497b48f..e397c9c1682 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -5,13 +5,14 @@ module Main (main) where -import Bitwise.ChunkZipWith (chunkZipWith2) +import Bitwise.ChunkZipWith (chunkZipWith2, chunkZipWith3) import Bitwise.PackZipWith (packZipWithBinary) import Control.Monad (replicateM) import Data.Bits (xor, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Kind (Type) +import Data.WideWord.Word256 (Word256) import Data.Word (Word64, Word8) import GHC.Exts (fromListN) import GHC.IO.Encoding (setLocaleEncoding, utf8) @@ -23,9 +24,9 @@ main :: IO () main = do setLocaleEncoding utf8 defaultMain [ - bgroup bandLabel . fmap (binaryOpBench bandLabel (.&.) (.&.)) $ sizes, - bgroup biorLabel . fmap (binaryOpBench biorLabel (.|.) (.|.)) $ sizes, - bgroup bxorLabel . fmap (binaryOpBench bxorLabel xor xor) $ sizes + bgroup bandLabel . fmap (binaryOpBench bandLabel (.&.) (.&.) (.&.)) $ sizes, + bgroup biorLabel . fmap (binaryOpBench biorLabel (.|.) (.|.) (.|.)) $ sizes, + bgroup bxorLabel . fmap (binaryOpBench bxorLabel xor xor xor) $ sizes ] where sizes :: [Int] @@ -43,19 +44,22 @@ binaryOpBench :: String -> (Word8 -> Word8 -> Word8) -> (Word64 -> Word64 -> Word64) -> + (Word256 -> Word256 -> Word256) -> Int -> Benchmark -binaryOpBench mainLabel f f' len = +binaryOpBench mainLabel f f' f'' len = withResource (mkBinaryArgs len) noCleanup $ \xs -> let zwLabel = "zipWith" pzwLabel = "packZipWith" czwLabel = "chunkedZipWith (2 blocks)" + czwLabel' = "chunkedZipWith (3 blocks)" testLabel = mainLabel <> ", length " <> show len matchLabel = "$NF == \"" <> zwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ bench zwLabel . nfIO $ uncurry (zipWithBinary f) <$> xs, bcompare matchLabel . bench pzwLabel . nfIO $ uncurry (packZipWithBinary f) <$> xs, - bcompare matchLabel . bench czwLabel . nfIO $ uncurry (chunkZipWith2 f f') <$> xs + bcompare matchLabel . bench czwLabel . nfIO $ uncurry (chunkZipWith2 f f') <$> xs, + bcompare matchLabel . bench czwLabel' . nfIO $ uncurry (chunkZipWith3 f f' f'') <$> xs ] -- Generators diff --git a/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs b/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs index e7d9d5875a8..ecc2db1fec1 100644 --- a/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs +++ b/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs @@ -1,13 +1,15 @@ {-# LANGUAGE TypeApplications #-} module Bitwise.ChunkZipWith ( - chunkZipWith2 + chunkZipWith2, + chunkZipWith3 ) where import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) import Data.Foldable (traverse_) +import Data.WideWord.Word256 (Word256) import Data.Word (Word64, Word8) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr) @@ -61,3 +63,71 @@ chunkZipWith2 smallF bigF bs bs' res <- smallF <$> peekElemOff src offset <*> peekElemOff src' offset pokeElemOff dst offset res + +-- Same as above +{-# NOINLINE chunkZipWith3 #-} +chunkZipWith3 :: + (Word8 -> Word8 -> Word8) -> + (Word64 -> Word64 -> Word64) -> + (Word256 -> Word256 -> Word256) -> + ByteString -> + ByteString -> + Maybe ByteString +chunkZipWith3 smallF bigF biggestF bs bs' + | BS.length bs /= BS.length bs' = Nothing + | otherwise = pure go + where + go :: ByteString + go = unsafeDupablePerformIO $ + unsafeUseAsCStringLen bs $ \(srcPtr, len) -> + unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do + dstPtr :: Ptr Word8 <- mallocBytes len + let bigStepSize = sizeOf @Word64 undefined + let biggestStepSize = sizeOf @Word256 undefined + let (biggestSteps, rest) = len `quotRem` biggestStepSize + let (bigSteps, smallSteps) = rest `quotRem` bigStepSize + traverse_ (biggestStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) + [0 .. biggestSteps - 1] + -- We now have to compute a Word64 offset corresponding to + -- biggestSteps. This will be four times larger, as Word64 is + -- one-quarter the width of a Word256. + let firstBigPosition = biggestSteps * 4 + traverse_ (bigStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) + [firstBigPosition, firstBigPosition + 1 .. firstBigPosition + bigSteps - 1] + -- Same again, but now we have to multiply by 8 for similar reasons. + let firstSmallPosition = (firstBigPosition + bigSteps) * 8 + traverse_ (smallStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) + [firstSmallPosition, firstSmallPosition + 1 .. firstSmallPosition + smallSteps - 1] + unsafePackMallocCStringLen (castPtr dstPtr, len) + biggestStep :: + Ptr Word256 -> + Ptr Word256 -> + Ptr Word256 -> + Int -> + IO () + biggestStep src src' dst offset = do + res <- biggestF <$> peekElemOff src offset <*> + peekElemOff src' offset + pokeElemOff dst offset res + bigStep :: + Ptr Word64 -> + Ptr Word64 -> + Ptr Word64 -> + Int -> + IO () + bigStep src src' dst offset = do + res <- bigF <$> peekElemOff src offset <*> + peekElemOff src' offset + pokeElemOff dst offset res + smallStep :: + Ptr Word8 -> + Ptr Word8 -> + Ptr Word8 -> + Int -> + IO () + smallStep src src' dst offset = do + res <- smallF <$> peekElemOff src offset <*> + peekElemOff src' offset + pokeElemOff dst offset res + + From 089044e05baabc1d6371d360f847604d6fdd6729 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 1 Aug 2022 14:59:12 +1200 Subject: [PATCH 32/73] More bitwise AND implementations, big comparison --- plutus-core/plutus-core.cabal | 3 + plutus-core/plutus-core/bench/bitwise/Main.hs | 69 ++++++++++++++- .../plutus-core/bench/bitwise/cbits/cbits.h | 12 +++ .../bench/bitwise/cbits/implementation.c | 85 +++++++++++++++++++ 4 files changed, 168 insertions(+), 1 deletion(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/cbits.h create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/implementation.c diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index b6aec8848ab..6c26fbbb2ef 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -795,6 +795,9 @@ benchmark bitwise hs-source-dirs: plutus-core/bench/bitwise default-language: Haskell2010 main-is: Main.hs + include-dirs: plutus-core/bench/bitwise/cbits + c-sources: plutus-core/bench/bitwise/cbits/implementation.c + cc-options: -O2 build-depends: , base , bytestring diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index e397c9c1682..71ec952d160 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -11,11 +11,16 @@ import Control.Monad (replicateM) import Data.Bits (xor, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) import Data.Kind (Type) import Data.WideWord.Word256 (Word256) import Data.Word (Word64, Word8) +import Foreign.C.Types (CSize (CSize), CUChar) +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Ptr (Ptr, castPtr) import GHC.Exts (fromListN) import GHC.IO.Encoding (setLocaleEncoding, utf8) +import System.IO.Unsafe (unsafeDupablePerformIO) import System.Random.Stateful (mkStdGen, randomM, runStateGen_) import Test.Tasty (withResource) import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nfIO) @@ -24,7 +29,7 @@ main :: IO () main = do setLocaleEncoding utf8 defaultMain [ - bgroup bandLabel . fmap (binaryOpBench bandLabel (.&.) (.&.) (.&.)) $ sizes, + bgroup bandLabel . fmap (andBench bandLabel) $ sizes, bgroup biorLabel . fmap (binaryOpBench biorLabel (.|.) (.|.) (.|.)) $ sizes, bgroup bxorLabel . fmap (binaryOpBench bxorLabel xor xor xor) $ sizes ] @@ -40,6 +45,29 @@ main = do -- Benchmarks +andBench :: + String -> + Int -> + Benchmark +andBench mainLabel len = + withResource (mkBinaryArgs len) noCleanup $ \xs -> + let zwLabel = "zipWith" + pzwLabel = "packZipWith" + czwLabel2 = "chunkedZipWith (2 blocks)" + czwLabel2' = "chunkedZipWith (2 blocks, C)" + czwLabel3 = "chunkedZipWith (3 blocks)" + czwLabel3' = "chunkedZipWith (3 blocks, C)" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> zwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench zwLabel . nfIO $ uncurry (zipWithBinary (.&.)) <$> xs, + bcompare matchLabel . bench pzwLabel . nfIO $ uncurry (packZipWithBinary (.&.)) <$> xs, + bcompare matchLabel . bench czwLabel2 . nfIO $ uncurry (chunkZipWith2 (.&.) (.&.)) <$> xs, + bcompare matchLabel . bench czwLabel2' . nfIO $ uncurry candBinary2 <$> xs, + bcompare matchLabel . bench czwLabel3 . nfIO $ uncurry (chunkZipWith3 (.&.) (.&.) (.&.)) <$> xs, + bcompare matchLabel . bench czwLabel3' . nfIO $ uncurry candBinary3 <$> xs + ] + binaryOpBench :: String -> (Word8 -> Word8 -> Word8) -> @@ -86,3 +114,42 @@ zipWithBinary f bs bs' where len :: Int len = BS.length bs + +-- Wrapper for raw C bitwise AND +candBinary2 :: ByteString -> ByteString -> Maybe ByteString +candBinary2 bs bs' + | BS.length bs /= BS.length bs' = Nothing + | otherwise = pure . unsafeDupablePerformIO . + unsafeUseAsCStringLen bs $ \(src, len) -> + unsafeUseAsCStringLen bs' $ \(src', _) -> do + dst <- mallocBytes len + candImplementation2 dst (castPtr src) (castPtr src') (fromIntegral len) + unsafePackMallocCStringLen (castPtr dst, len) + +-- Same as above, but 3-fold unroll +candBinary3 :: ByteString -> ByteString -> Maybe ByteString +candBinary3 bs bs' + | BS.length bs /= BS.length bs' = Nothing + | otherwise = pure . unsafeDupablePerformIO . + unsafeUseAsCStringLen bs $ \(src, len) -> + unsafeUseAsCStringLen bs' $ \(src', _) -> do + dst <- mallocBytes len + candImplementation3 dst (castPtr src) (castPtr src') (fromIntegral len) + unsafePackMallocCStringLen (castPtr dst, len) + + +foreign import ccall unsafe "cbits.h c_and_implementation" + candImplementation2 :: + Ptr CUChar -> + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () + +foreign import ccall unsafe "cbits.h c_and_implementation_3" + candImplementation3 :: + Ptr CUChar -> + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h new file mode 100644 index 00000000000..7714835de2b --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -0,0 +1,12 @@ +#ifndef CBITS_H +#define CBITS_H + +#include + +void c_and_implementation(unsigned char *dst, unsigned char const *src1, + unsigned char const *src2, size_t const len); + +void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, + unsigned char const *src2, size_t const len); + +#endif /* CBITS_H */ diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c new file mode 100644 index 00000000000..751dfae5c87 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c @@ -0,0 +1,85 @@ +#include "cbits.h" + +void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, + unsigned char const *src2, size_t const len) { + if (len != 0) { + size_t const big_step_size = sizeof(unsigned long long); + size_t const biggest_step_size = big_step_size * 4; // four-way unroll + size_t const biggest_steps = len / biggest_step_size; + size_t const rest = len % biggest_step_size; + size_t const big_steps = rest / big_step_size; + size_t const small_steps = rest % big_step_size; + unsigned long long *big_ptr1 = (unsigned long long *)src1; + unsigned long long *big_ptr2 = (unsigned long long *)src2; + unsigned long long *big_dst = (unsigned long long *)dst; + for (size_t i = 0; i < biggest_steps; i++) { + // We have to do this as GCC is unreliable at unrolling, even if the loop + // has fixed length, we have enough registers _and_ we turn on O2. + unsigned long long const x1 = *big_ptr1; + unsigned long long const x2 = *(big_ptr1 + 1); + unsigned long long const x3 = *(big_ptr1 + 2); + unsigned long long const x4 = *(big_ptr1 + 3); + unsigned long long const y1 = *big_ptr2; + unsigned long long const y2 = *(big_ptr2 + 1); + unsigned long long const y3 = *(big_ptr2 + 2); + unsigned long long const y4 = *(big_ptr2 + 3); + *big_dst = x1 & y1; + *(big_dst + 1) = x2 & y2; + *(big_dst + 2) = x3 & y3; + *(big_dst + 3) = x4 & y4; + big_ptr1 += 4; + big_ptr2 += 4; + big_dst += 4; + } + for (size_t i = 0; i < big_steps; i++) { + unsigned long long const x = *big_ptr1; + unsigned long long const y = *big_ptr2; + *big_dst = x & y; + big_ptr1++; + big_ptr2++; + big_dst++; + } + unsigned char *small_ptr1 = (unsigned char *)big_ptr1; + unsigned char *small_ptr2 = (unsigned char *)big_ptr2; + unsigned char *small_dst = (unsigned char *)big_dst; + for (size_t i = 0; i < small_steps; i++) { + unsigned char const x = *small_ptr1; + unsigned char const y = *small_ptr2; + *small_dst = x & y; + small_ptr1++; + small_ptr2++; + small_dst++; + } + } +} + +void c_and_implementation(unsigned char *dst, unsigned char const *src1, + unsigned char const *src2, size_t const len) { + if (len != 0) { + size_t const big_step_size = sizeof(unsigned long long); + size_t const big_steps = len / big_step_size; + size_t const small_steps = len % big_step_size; + unsigned long long *big_ptr1 = (unsigned long long *)src1; + unsigned long long *big_ptr2 = (unsigned long long *)src2; + unsigned long long *big_dst = (unsigned long long *)dst; + for (size_t i = 0; i < big_steps; i++) { + unsigned long long const x = *big_ptr1; + unsigned long long const y = *big_ptr2; + *big_dst = x & y; + big_ptr1++; + big_ptr2++; + big_dst++; + } + unsigned char *small_ptr1 = (unsigned char *)big_ptr1; + unsigned char *small_ptr2 = (unsigned char *)big_ptr2; + unsigned char *small_dst = (unsigned char *)big_dst; + for (size_t i = 0; i < small_steps; i++) { + unsigned char const x = *small_ptr1; + unsigned char const y = *small_ptr2; + *small_dst = x & y; + small_ptr1++; + small_ptr2++; + small_dst++; + } + } +} From d162ead5e3b5795b1f4d5dcf43c580b5e701faf3 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 2 Aug 2022 11:19:28 +1200 Subject: [PATCH 33/73] Refactor, more measurements, measure complement --- plutus-core/plutus-core.cabal | 4 +- plutus-core/plutus-core/bench/bitwise/Main.hs | 76 +++++++++-------- .../plutus-core/bench/bitwise/cbits/cbits.h | 3 + .../bench/bitwise/cbits/implementation.c | 23 ++++++ .../Bitwise/{ChunkZipWith.hs => Internal.hs} | 81 ++++++++++++++++--- .../plutus-core/src/Bitwise/PackZipWith.hs | 42 ---------- 6 files changed, 141 insertions(+), 88 deletions(-) rename plutus-core/plutus-core/src/Bitwise/{ChunkZipWith.hs => Internal.hs} (66%) delete mode 100644 plutus-core/plutus-core/src/Bitwise/PackZipWith.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 6c26fbbb2ef..b276ef0ac5d 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -50,8 +50,7 @@ library import: lang exposed-modules: Bitwise - Bitwise.ChunkZipWith - Bitwise.PackZipWith + Bitwise.Internal Crypto Data.ByteString.Hash Data.Either.Extras @@ -805,6 +804,5 @@ benchmark bitwise , random , tasty , tasty-bench - , wide-word ghc-options: -O2 -rtsopts "-with-rtsopts=-A32m --nonmoving-gc -T" diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 71ec952d160..1ef66688e49 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -5,16 +5,14 @@ module Main (main) where -import Bitwise.ChunkZipWith (chunkZipWith2, chunkZipWith3) -import Bitwise.PackZipWith (packZipWithBinary) +import Bitwise.Internal (chunkMap2, chunkZipWith2, chunkZipWith3, packZipWithBinary) import Control.Monad (replicateM) -import Data.Bits (xor, (.&.), (.|.)) +import Data.Bits (complement, (.&.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) import Data.Kind (Type) -import Data.WideWord.Word256 (Word256) -import Data.Word (Word64, Word8) +import Data.Word (Word8) import Foreign.C.Types (CSize (CSize), CUChar) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr) @@ -29,22 +27,36 @@ main :: IO () main = do setLocaleEncoding utf8 defaultMain [ - bgroup bandLabel . fmap (andBench bandLabel) $ sizes, - bgroup biorLabel . fmap (binaryOpBench biorLabel (.|.) (.|.) (.|.)) $ sizes, - bgroup bxorLabel . fmap (binaryOpBench bxorLabel xor xor xor) $ sizes + bgroup bcompLabel . fmap (complementBench bcompLabel) $ sizes, + bgroup bandLabel . fmap (andBench bandLabel) $ sizes ] where sizes :: [Int] sizes = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047] bandLabel :: String bandLabel = "Bitwise AND" - biorLabel :: String - biorLabel = "Bitwise IOR" - bxorLabel :: String - bxorLabel = "Bitwise XOR" + bcompLabel :: String + bcompLabel = "Bitwise complement" -- Benchmarks +complementBench :: + String -> + Int -> + Benchmark +complementBench mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let mLabel = "map" + cmLabel2 = "chunkedMap (2 blocks)" + cmLabel2' = "chunkedMap (2 blocks, C)" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> mLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench mLabel . nfIO $ BS.map complement <$> xs, + bcompare matchLabel . bench cmLabel2 . nfIO $ chunkMap2 complement complement <$> xs, + bcompare matchLabel . bench cmLabel2' . nfIO $ ccomplement <$> xs + ] + andBench :: String -> Int -> @@ -68,30 +80,12 @@ andBench mainLabel len = bcompare matchLabel . bench czwLabel3' . nfIO $ uncurry candBinary3 <$> xs ] -binaryOpBench :: - String -> - (Word8 -> Word8 -> Word8) -> - (Word64 -> Word64 -> Word64) -> - (Word256 -> Word256 -> Word256) -> - Int -> - Benchmark -binaryOpBench mainLabel f f' f'' len = - withResource (mkBinaryArgs len) noCleanup $ \xs -> - let zwLabel = "zipWith" - pzwLabel = "packZipWith" - czwLabel = "chunkedZipWith (2 blocks)" - czwLabel' = "chunkedZipWith (3 blocks)" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> zwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench zwLabel . nfIO $ uncurry (zipWithBinary f) <$> xs, - bcompare matchLabel . bench pzwLabel . nfIO $ uncurry (packZipWithBinary f) <$> xs, - bcompare matchLabel . bench czwLabel . nfIO $ uncurry (chunkZipWith2 f f') <$> xs, - bcompare matchLabel . bench czwLabel' . nfIO $ uncurry (chunkZipWith3 f f' f'') <$> xs - ] - -- Generators +mkUnaryArg :: Int -> IO ByteString +mkUnaryArg len = pure . runStateGen_ (mkStdGen 42) $ \gen -> + fromListN len <$> replicateM len (randomM gen) + mkBinaryArgs :: Int -> IO (ByteString, ByteString) mkBinaryArgs len = pure . runStateGen_ (mkStdGen 42) $ \gen -> (,) <$> (fromListN len <$> replicateM len (randomM gen)) <*> @@ -137,6 +131,13 @@ candBinary3 bs bs' candImplementation3 dst (castPtr src) (castPtr src') (fromIntegral len) unsafePackMallocCStringLen (castPtr dst, len) +-- Wrapper for raw C bitwise complement +ccomplement :: ByteString -> ByteString +ccomplement bs = unsafeDupablePerformIO . + unsafeUseAsCStringLen bs $ \(src, len) -> do + dst <- mallocBytes len + ccomplementImplementation dst (castPtr src) (fromIntegral len) + unsafePackMallocCStringLen (castPtr dst, len) foreign import ccall unsafe "cbits.h c_and_implementation" candImplementation2 :: @@ -153,3 +154,10 @@ foreign import ccall unsafe "cbits.h c_and_implementation_3" Ptr CUChar -> CSize -> IO () + +foreign import ccall unsafe "cbits.h c_complement_implementation" + ccomplementImplementation :: + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index 7714835de2b..f65369d27f0 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -9,4 +9,7 @@ void c_and_implementation(unsigned char *dst, unsigned char const *src1, void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, unsigned char const *src2, size_t const len); +void c_complement_implementation(unsigned char *dst, unsigned char const *src, + size_t const len); + #endif /* CBITS_H */ diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c index 751dfae5c87..0e9f86215b9 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c @@ -83,3 +83,26 @@ void c_and_implementation(unsigned char *dst, unsigned char const *src1, } } } + +void c_complement_implementation(unsigned char *dst, unsigned char const *src, + size_t const len) { + size_t const big_step_size = sizeof(unsigned long long); + size_t const big_steps = len / big_step_size; + size_t const small_steps = len % big_step_size; + unsigned long long *big_src = (unsigned long long *)src; + unsigned long long *big_dst = (unsigned long long *)dst; + for (size_t i = 0; i < big_steps; i++) { + unsigned long long const x = *big_src; + *big_dst = ~x; + big_src++; + big_dst++; + } + unsigned char *small_src = (unsigned char *)big_src; + unsigned char *small_dst = (unsigned char *)big_dst; + for (size_t i = 0; i < small_steps; i++) { + unsigned char const x = *small_src; + *small_dst = ~x; + small_src++; + small_dst++; + } +} diff --git a/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs b/plutus-core/plutus-core/src/Bitwise/Internal.hs similarity index 66% rename from plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs rename to plutus-core/plutus-core/src/Bitwise/Internal.hs index ecc2db1fec1..4f712ac31c6 100644 --- a/plutus-core/plutus-core/src/Bitwise/ChunkZipWith.hs +++ b/plutus-core/plutus-core/src/Bitwise/Internal.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeApplications #-} -module Bitwise.ChunkZipWith ( +module Bitwise.Internal ( chunkZipWith2, - chunkZipWith3 + chunkMap2, + chunkZipWith3, + packZipWithBinary ) where import Data.ByteString (ByteString) @@ -16,10 +19,72 @@ import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (peekElemOff, pokeElemOff, sizeOf) import System.IO.Unsafe (unsafeDupablePerformIO) --- We must ensure that both function arguments behave identically on their --- respective inputs. Essentially, the two function arguments should be the same --- function. -{-# NOINLINE chunkZipWith2 #-} +-- Replicate packZipWith from newer bytestring +{-# INLINE packZipWithBinary #-} +packZipWithBinary :: + (Word8 -> Word8 -> Word8) -> + ByteString -> + ByteString -> + Maybe ByteString +packZipWithBinary f bs bs' + | BS.length bs /= BS.length bs' = Nothing + | otherwise = pure go + where + go :: ByteString + go = unsafeDupablePerformIO $ + unsafeUseAsCStringLen bs $ \(srcPtr, len) -> + unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do + dstPtr <- castPtr <$> mallocBytes len + traverse_ (step (castPtr srcPtr) (castPtr srcPtr') dstPtr) [0 .. len - 1] + unsafePackMallocCStringLen (castPtr dstPtr, len) + step :: + Ptr Word8 -> + Ptr Word8 -> + Ptr Word8 -> + Int -> + IO () + step src src' dst offset = do + res <- f <$> peekElemOff src offset <*> + peekElemOff src' offset + pokeElemOff dst offset res + +-- For all the functionality below, all the function arguments must behave +-- identically on their respective inputs; essentially, the function arguments +-- should be the same function, modulo polymorphism. + +{-# INLINE chunkMap2 #-} +chunkMap2 :: + (Word8 -> Word8) -> + (Word64 -> Word64) -> + ByteString -> + ByteString +chunkMap2 smallF bigF bs = + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do + dst <- mallocBytes len + let bigStepSize = sizeOf @Word64 undefined + let (bigSteps, smallSteps) = len `quotRem` bigStepSize + traverse_ (bigStep (castPtr src) (castPtr dst)) [0 .. bigSteps - 1] + let firstSmallPosition = bigSteps * bigStepSize + traverse_ (smallStep (castPtr src) (castPtr dst)) + [firstSmallPosition, firstSmallPosition + 1 .. firstSmallPosition + smallSteps - 1] + unsafePackMallocCStringLen (dst, len) + where + bigStep :: + Ptr Word64 -> + Ptr Word64 -> + Int -> + IO () + bigStep src dst offset = + peekElemOff src offset >>= pokeElemOff dst offset . bigF + smallStep :: + Ptr Word8 -> + Ptr Word8 -> + Int -> + IO () + smallStep src dst offset = + peekElemOff src offset >>= pokeElemOff dst offset . smallF + +{-# INLINE chunkZipWith2 #-} chunkZipWith2 :: (Word8 -> Word8 -> Word8) -> (Word64 -> Word64 -> Word64) -> @@ -64,8 +129,7 @@ chunkZipWith2 smallF bigF bs bs' peekElemOff src' offset pokeElemOff dst offset res --- Same as above -{-# NOINLINE chunkZipWith3 #-} +{-# INLINE chunkZipWith3 #-} chunkZipWith3 :: (Word8 -> Word8 -> Word8) -> (Word64 -> Word64 -> Word64) -> @@ -130,4 +194,3 @@ chunkZipWith3 smallF bigF biggestF bs bs' peekElemOff src' offset pokeElemOff dst offset res - diff --git a/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs b/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs deleted file mode 100644 index 5c8e221137d..00000000000 --- a/plutus-core/plutus-core/src/Bitwise/PackZipWith.hs +++ /dev/null @@ -1,42 +0,0 @@ -module Bitwise.PackZipWith ( - packZipWithBinary - ) where - -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) -import Data.Foldable (traverse_) -import Data.Word (Word8) -import Foreign.Marshal.Alloc (mallocBytes) -import Foreign.Ptr (Ptr, castPtr) -import Foreign.Storable (peekElemOff, pokeElemOff) -import System.IO.Unsafe (unsafeDupablePerformIO) - --- Replicate packZipWith from newer bytestring -{-# NOINLINE packZipWithBinary #-} -packZipWithBinary :: - (Word8 -> Word8 -> Word8) -> - ByteString -> - ByteString -> - Maybe ByteString -packZipWithBinary f bs bs' - | BS.length bs /= BS.length bs' = Nothing - | otherwise = pure go - where - go :: ByteString - go = unsafeDupablePerformIO $ - unsafeUseAsCStringLen bs $ \(srcPtr, len) -> - unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do - dstPtr <- castPtr <$> mallocBytes len - traverse_ (step (castPtr srcPtr) (castPtr srcPtr') dstPtr) [0 .. len - 1] - unsafePackMallocCStringLen (castPtr dstPtr, len) - step :: - Ptr Word8 -> - Ptr Word8 -> - Ptr Word8 -> - Int -> - IO () - step src src' dst offset = do - res <- f <$> peekElemOff src offset <*> - peekElemOff src' offset - pokeElemOff dst offset res From 1040977092de96db1951867f6fd440d055cc9037 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 2 Aug 2022 13:36:06 +1200 Subject: [PATCH 34/73] Popcount benchmarks --- plutus-core/plutus-core/bench/bitwise/Main.hs | 28 +++++++++-- .../plutus-core/src/Bitwise/Internal.hs | 48 ++++++++++++++++++- 2 files changed, 71 insertions(+), 5 deletions(-) diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 1ef66688e49..d076c775e25 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -5,9 +5,9 @@ module Main (main) where -import Bitwise.Internal (chunkMap2, chunkZipWith2, chunkZipWith3, packZipWithBinary) +import Bitwise.Internal (chunkMap2, chunkPopCount2, chunkPopCount3, chunkZipWith2, chunkZipWith3, packZipWithBinary) import Control.Monad (replicateM) -import Data.Bits (complement, (.&.)) +import Data.Bits (complement, popCount, (.&.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) @@ -28,18 +28,38 @@ main = do setLocaleEncoding utf8 defaultMain [ bgroup bcompLabel . fmap (complementBench bcompLabel) $ sizes, - bgroup bandLabel . fmap (andBench bandLabel) $ sizes + bgroup bandLabel . fmap (andBench bandLabel) $ sizes, + bgroup popCountLabel . fmap (popCountBench popCountLabel) $ sizes ] where sizes :: [Int] - sizes = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047] + sizes = [1, 3, 7, 15, 29, 30, 31, 32, 33, 63, 127, 255, 511, 1023, 2047] bandLabel :: String bandLabel = "Bitwise AND" bcompLabel :: String bcompLabel = "Bitwise complement" + popCountLabel :: String + popCountLabel = "Popcount" -- Benchmarks +popCountBench :: + String -> + Int -> + Benchmark +popCountBench mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let fLabel = "foldl'" + cpLabel2 = "chunkPopCount2" + cpLabel3 = "chunkPopCount3" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> fLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench fLabel . nfIO $ BS.foldl' (\acc w8 -> acc + popCount w8) 0 <$> xs, + bcompare matchLabel . bench cpLabel2 . nfIO $ chunkPopCount2 <$> xs, + bcompare matchLabel . bench cpLabel3 . nfIO $ chunkPopCount3 <$> xs + ] + complementBench :: String -> Int -> diff --git a/plutus-core/plutus-core/src/Bitwise/Internal.hs b/plutus-core/plutus-core/src/Bitwise/Internal.hs index 4f712ac31c6..01a84e95147 100644 --- a/plutus-core/plutus-core/src/Bitwise/Internal.hs +++ b/plutus-core/plutus-core/src/Bitwise/Internal.hs @@ -5,9 +5,13 @@ module Bitwise.Internal ( chunkZipWith2, chunkMap2, chunkZipWith3, - packZipWithBinary + packZipWithBinary, + chunkPopCount2, + chunkPopCount3, ) where +import Control.Monad (foldM) +import Data.Bits (popCount) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) @@ -19,6 +23,48 @@ import Foreign.Ptr (Ptr, castPtr) import Foreign.Storable (peekElemOff, pokeElemOff, sizeOf) import System.IO.Unsafe (unsafeDupablePerformIO) +{-# INLINE chunkPopCount2 #-} +chunkPopCount2 :: ByteString -> Int +chunkPopCount2 bs = unsafeDupablePerformIO $ unsafeUseAsCStringLen bs $ \(src, len) -> do + let bigStepSize = sizeOf @Word64 undefined + let (bigSteps, smallSteps) = len `quotRem` bigStepSize + !bigCount <- foldM (bigStep (castPtr src)) 0 [0 .. bigSteps - 1] + let firstSmallPosition = bigSteps * bigStepSize + foldM (smallStep (castPtr src)) bigCount [firstSmallPosition .. firstSmallPosition + smallSteps - 1] + where + bigStep :: Ptr Word64 -> Int -> Int -> IO Int + bigStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset + smallStep :: Ptr Word8 -> Int -> Int -> IO Int + smallStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset + +{-# INLINE chunkPopCount3 #-} +chunkPopCount3 :: ByteString -> Int +chunkPopCount3 bs = unsafeDupablePerformIO $ unsafeUseAsCStringLen bs $ \(src, len) -> do + let bigStepSize = sizeOf @Word64 undefined + let biggestStepSize = sizeOf @Word256 undefined + let (biggestSteps, rest) = len `quotRem` biggestStepSize + let (bigSteps, smallSteps) = rest `quotRem` bigStepSize + !biggestCount <- foldM (biggestStep (castPtr src)) 0 [0 .. biggestSteps - 1] + -- We now have to compute a Word64 offset corresponding to + -- biggestSteps. This will be four times larger, as Word64 is + -- one-quarter the width of a Word256. + let firstBigPosition = biggestSteps * 4 + !bigCount <- foldM (bigStep (castPtr src)) + biggestCount + [firstBigPosition .. firstBigPosition + bigSteps - 1] + -- Same again, but now we have to multiply by 8 for similar reasons + let firstSmallPosition = (firstBigPosition + bigSteps) * 8 + foldM (smallStep (castPtr src)) + bigCount + [firstSmallPosition .. firstSmallPosition + smallSteps - 1] + where + biggestStep :: Ptr Word256 -> Int -> Int -> IO Int + biggestStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset + bigStep :: Ptr Word64 -> Int -> Int -> IO Int + bigStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset + smallStep :: Ptr Word8 -> Int -> Int -> IO Int + smallStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset + -- Replicate packZipWith from newer bytestring {-# INLINE packZipWithBinary #-} packZipWithBinary :: From 0a9f7e3ee15ab7738d890bd858af863c56d5e412 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 4 Aug 2022 14:33:43 +1200 Subject: [PATCH 35/73] Refactor bench implementations, add rotation benches --- plutus-core/plutus-core.cabal | 7 +- .../bitwise/Implementations.hs} | 154 +++++++++++++++++- plutus-core/plutus-core/bench/bitwise/Main.hs | 53 +++++- .../bench/bitwise/cbits/implementation.c | 144 ++++++++-------- 4 files changed, 269 insertions(+), 89 deletions(-) rename plutus-core/plutus-core/{src/Bitwise/Internal.hs => bench/bitwise/Implementations.hs} (60%) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index b276ef0ac5d..269ccf8bd34 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -50,7 +50,6 @@ library import: lang exposed-modules: Bitwise - Bitwise.Internal Crypto Data.ByteString.Hash Data.Either.Extras @@ -318,7 +317,6 @@ library , time , transformers , unordered-containers - , wide-word , witherable , word-array @@ -794,15 +792,16 @@ benchmark bitwise hs-source-dirs: plutus-core/bench/bitwise default-language: Haskell2010 main-is: Main.hs + other-modules: Implementations include-dirs: plutus-core/bench/bitwise/cbits c-sources: plutus-core/bench/bitwise/cbits/implementation.c - cc-options: -O2 + cc-options: -O3 -msse2 build-depends: , base , bytestring - , plutus-core , random , tasty , tasty-bench + , wide-word ghc-options: -O2 -rtsopts "-with-rtsopts=-A32m --nonmoving-gc -T" diff --git a/plutus-core/plutus-core/src/Bitwise/Internal.hs b/plutus-core/plutus-core/bench/bitwise/Implementations.hs similarity index 60% rename from plutus-core/plutus-core/src/Bitwise/Internal.hs rename to plutus-core/plutus-core/bench/bitwise/Implementations.hs index 01a84e95147..034bd5dfc13 100644 --- a/plutus-core/plutus-core/src/Bitwise/Internal.hs +++ b/plutus-core/plutus-core/bench/bitwise/Implementations.hs @@ -1,26 +1,31 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeApplications #-} -module Bitwise.Internal ( +module Implementations ( chunkZipWith2, chunkMap2, + chunkMap3, chunkZipWith3, packZipWithBinary, chunkPopCount2, chunkPopCount3, + rotateBS, + rotateBSFast, ) where -import Control.Monad (foldM) -import Data.Bits (popCount) +import Control.Monad (foldM, void) +import Data.Bits (bit, popCount, rotate, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) -import Data.Foldable (traverse_) +import Data.Foldable (foldl', for_, traverse_) import Data.WideWord.Word256 (Word256) import Data.Word (Word64, Word8) +import Foreign.C.Types (CSize) import Foreign.Marshal.Alloc (mallocBytes) -import Foreign.Ptr (Ptr, castPtr) -import Foreign.Storable (peekElemOff, pokeElemOff, sizeOf) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (peek, peekElemOff, poke, pokeElemOff, sizeOf) +import GHC.IO.Handle.Text (memcpy) import System.IO.Unsafe (unsafeDupablePerformIO) {-# INLINE chunkPopCount2 #-} @@ -130,6 +135,51 @@ chunkMap2 smallF bigF bs = smallStep src dst offset = peekElemOff src offset >>= pokeElemOff dst offset . smallF +{-# INLINE chunkMap3 #-} +chunkMap3 :: + (Word8 -> Word8) -> + (Word64 -> Word64) -> + (Word256 -> Word256) -> + ByteString -> + ByteString +chunkMap3 smallF bigF biggestF bs = + unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do + dst <- mallocBytes len + let bigStepSize = sizeOf @Word64 undefined + let biggestStepSize = sizeOf @Word256 undefined + let (biggestSteps, rest) = len `quotRem` biggestStepSize + let (bigSteps, smallSteps) = rest `quotRem` bigStepSize + traverse_ (biggestStep (castPtr src) (castPtr dst)) [0 .. biggestSteps - 1] + let firstBigPosition = biggestSteps * 4 + traverse_ (bigStep (castPtr src) (castPtr dst)) + [firstBigPosition .. firstBigPosition + bigSteps - 1] + let firstSmallPosition = (firstBigPosition + bigSteps) * 8 + traverse_ (smallStep (castPtr src) (castPtr dst)) + [firstSmallPosition .. firstSmallPosition + smallSteps - 1] + unsafePackMallocCStringLen (dst, len) + where + biggestStep :: + Ptr Word256 -> + Ptr Word256 -> + Int -> + IO () + biggestStep src dst offset = + peekElemOff src offset >>= pokeElemOff dst offset . biggestF + bigStep :: + Ptr Word64 -> + Ptr Word64 -> + Int -> + IO () + bigStep src dst offset = + peekElemOff src offset >>= pokeElemOff dst offset . bigF + smallStep :: + Ptr Word8 -> + Ptr Word8 -> + Int -> + IO () + smallStep src dst offset = + peekElemOff src offset >>= pokeElemOff dst offset . smallF + {-# INLINE chunkZipWith2 #-} chunkZipWith2 :: (Word8 -> Word8 -> Word8) -> @@ -240,3 +290,95 @@ chunkZipWith3 smallF bigF biggestF bs bs' peekElemOff src' offset pokeElemOff dst offset res +-- Clone of rotation logic without any prechecks +rotateBS :: ByteString -> Int -> ByteString +rotateBS bs i = case i `rem` bitLen of + 0 -> bs + magnitude -> overPtrLen bs $ \ptr len -> go ptr len magnitude + where + bitLen :: Int + bitLen = BS.length bs * 8 + go :: Ptr Word8 -> Int -> Int -> IO (Ptr Word8) + go _ len displacement = do + dst <- mallocBytes len + for_ [0 .. len - 1] $ \j -> do + let start = (len - 1 - j) * 8 + let dstByte = foldl' (addBit start displacement) zeroBits [0 .. 7] + poke (plusPtr dst j) dstByte + pure dst + addBit :: Int -> Int -> Word8 -> Int -> Word8 + addBit start displacement acc offset = + let oldIx = (offset + start + bitLen - displacement) `rem` bitLen in + if dangerousRead bs oldIx + then acc .|. bit offset + else acc + +-- Precheck and block optimizations +rotateBSFast :: ByteString -> Int -> ByteString +rotateBSFast bs i = case i `rem` bitLen of + 0 -> bs + magnitude -> overPtrLen bs $ \ptr len -> go ptr len magnitude + where + bitLen :: Int + bitLen = BS.length bs * 8 + go :: Ptr Word8 -> Int -> Int -> IO (Ptr Word8) + go src len displacement = do + dst <- mallocBytes len + case len of + -- If we only have one byte, we an borrow from the Bits instance for + -- Word8. + 1 -> do + srcByte <- peek src + let srcByte' = srcByte `rotate` displacement + poke dst srcByte' + -- If we rotate by a multiple of 8, we only need to move around whole + -- bytes, rather than individual bits. Because we only move contiguous + -- blocks (regardless of rotation direction), we can do this using + -- memcpy, which is must faster, especially on larger ByteStrings. + _ -> case displacement `quotRem` 8 of + (bigMove, 0) -> do + let mainLen :: CSize = fromIntegral . abs $ bigMove + let restLen :: CSize = fromIntegral len - mainLen + void $ case signum bigMove of + 1 -> memcpy (plusPtr dst . fromIntegral $ restLen) src mainLen >> + memcpy dst (plusPtr src . fromIntegral $ mainLen) restLen + _ -> memcpy (plusPtr dst . fromIntegral $ mainLen) src restLen >> + memcpy dst (plusPtr src . fromIntegral $ restLen) mainLen + -- If we don't rotate by a multiple of 8, we have to construct new + -- bytes, rather than just copying over old ones. We do this in two + -- steps: + -- + -- 1. Compute the 'read offset' into the source ByteString based on + -- the rotation magnitude and direction. + -- 2. Use that read offset to perform an (unchecked) bit lookup for an + -- entire 8-bit block, then construct the byte that results. + -- + -- We can do the bytes in the result in any order using this method: + -- we choose to do it in traversal order. + _ -> for_ [0 .. len - 1] $ \j -> do + let start = (len - 1 - j) * 8 + let dstByte = foldl' (addBit start displacement) zeroBits [0 .. 7] + poke (plusPtr dst j) dstByte + pure dst + addBit :: Int -> Int -> Word8 -> Int -> Word8 + addBit start displacement acc offset = + let oldIx = (offset + start + bitLen - displacement) `rem` bitLen in + if dangerousRead bs oldIx + then acc .|. bit offset + else acc + +-- Helpers + +overPtrLen :: ByteString -> (Ptr Word8 -> Int -> IO (Ptr Word8)) -> ByteString +overPtrLen bs f = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ + \(ptr, len) -> f (castPtr ptr) len >>= \p -> + unsafePackMallocCStringLen (castPtr p, len) + +dangerousRead :: ByteString -> Int -> Bool +dangerousRead bs i = + let (bigOffset, smallOffset) = i `quotRem` 8 + bigIx = BS.length bs - bigOffset - 1 + mask = bit smallOffset in + case mask .&. BS.index bs bigIx of + 0 -> False + _ -> True diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index d076c775e25..4e41040ea45 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -5,9 +5,8 @@ module Main (main) where -import Bitwise.Internal (chunkMap2, chunkPopCount2, chunkPopCount3, chunkZipWith2, chunkZipWith3, packZipWithBinary) import Control.Monad (replicateM) -import Data.Bits (complement, popCount, (.&.)) +import Data.Bits (complement, popCount, zeroBits, (.&.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) @@ -18,6 +17,8 @@ import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr) import GHC.Exts (fromListN) import GHC.IO.Encoding (setLocaleEncoding, utf8) +import Implementations (chunkMap2, chunkMap3, chunkPopCount2, chunkPopCount3, chunkZipWith2, chunkZipWith3, + packZipWithBinary, rotateBS, rotateBSFast) import System.IO.Unsafe (unsafeDupablePerformIO) import System.Random.Stateful (mkStdGen, randomM, runStateGen_) import Test.Tasty (withResource) @@ -29,20 +30,60 @@ main = do defaultMain [ bgroup bcompLabel . fmap (complementBench bcompLabel) $ sizes, bgroup bandLabel . fmap (andBench bandLabel) $ sizes, - bgroup popCountLabel . fmap (popCountBench popCountLabel) $ sizes + bgroup popCountLabel . fmap (popCountBench popCountLabel) $ sizes, + bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, + bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes ] where sizes :: [Int] - sizes = [1, 3, 7, 15, 29, 30, 31, 32, 33, 63, 127, 255, 511, 1023, 2047] + sizes = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047] bandLabel :: String bandLabel = "Bitwise AND" bcompLabel :: String bcompLabel = "Bitwise complement" popCountLabel :: String popCountLabel = "Popcount" + rotateLabel :: String + rotateLabel = "Slow rotate versus prescan" + rotateLabel' :: String + rotateLabel' = "Bitwise rotate versus block rotate" -- Benchmarks +rotateFastVsSlow :: + String -> + Int -> + Benchmark +rotateFastVsSlow mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let rLabel = "rotate (bit-by-bit)" + rLabel' = "rotate (block-optimized)" + -- Next highest multiple of 8 of half our length, rounded down + rotation = ((len `quot` 2) + 7) .&. negate 8 + testLabel = mainLabel <> ", length " <> show len <> ", rotation by " <> show rotation + matchLabel = "$NF == \"" <> rLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench rLabel . nfIO $ rotateBS <$> xs <*> pure rotation, + bcompare matchLabel . bench rLabel' . nfIO $ rotateBSFast <$> xs <*> pure rotation + ] + +rotateVsPrescanBench :: + String -> + Int -> + Benchmark +rotateVsPrescanBench mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let rLabel = "rotate (bit-by-bit)" + pLabel = "prescan (naive)" + rotation = len `quot` 2 + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> rLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench rLabel . nfIO $ rotateBS <$> xs <*> pure rotation, + bcompare matchLabel . bench pLabel . nfIO $ (||) <$> (BS.all (== zeroBits) <$> xs) <*> + (BS.all (== complement zeroBits) <$> xs) + ] + popCountBench :: String -> Int -> @@ -69,12 +110,14 @@ complementBench mainLabel len = let mLabel = "map" cmLabel2 = "chunkedMap (2 blocks)" cmLabel2' = "chunkedMap (2 blocks, C)" + cmLabel3 = "chunkMap (3 blocks)" testLabel = mainLabel <> ", length " <> show len matchLabel = "$NF == \"" <> mLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ bench mLabel . nfIO $ BS.map complement <$> xs, bcompare matchLabel . bench cmLabel2 . nfIO $ chunkMap2 complement complement <$> xs, - bcompare matchLabel . bench cmLabel2' . nfIO $ ccomplement <$> xs + bcompare matchLabel . bench cmLabel2' . nfIO $ ccomplement <$> xs, + bcompare matchLabel . bench cmLabel3 . nfIO $ chunkMap3 complement complement complement <$> xs ] andBench :: diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c index 0e9f86215b9..156aae932ff 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c @@ -2,85 +2,81 @@ void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, unsigned char const *src2, size_t const len) { - if (len != 0) { - size_t const big_step_size = sizeof(unsigned long long); - size_t const biggest_step_size = big_step_size * 4; // four-way unroll - size_t const biggest_steps = len / biggest_step_size; - size_t const rest = len % biggest_step_size; - size_t const big_steps = rest / big_step_size; - size_t const small_steps = rest % big_step_size; - unsigned long long *big_ptr1 = (unsigned long long *)src1; - unsigned long long *big_ptr2 = (unsigned long long *)src2; - unsigned long long *big_dst = (unsigned long long *)dst; - for (size_t i = 0; i < biggest_steps; i++) { - // We have to do this as GCC is unreliable at unrolling, even if the loop - // has fixed length, we have enough registers _and_ we turn on O2. - unsigned long long const x1 = *big_ptr1; - unsigned long long const x2 = *(big_ptr1 + 1); - unsigned long long const x3 = *(big_ptr1 + 2); - unsigned long long const x4 = *(big_ptr1 + 3); - unsigned long long const y1 = *big_ptr2; - unsigned long long const y2 = *(big_ptr2 + 1); - unsigned long long const y3 = *(big_ptr2 + 2); - unsigned long long const y4 = *(big_ptr2 + 3); - *big_dst = x1 & y1; - *(big_dst + 1) = x2 & y2; - *(big_dst + 2) = x3 & y3; - *(big_dst + 3) = x4 & y4; - big_ptr1 += 4; - big_ptr2 += 4; - big_dst += 4; - } - for (size_t i = 0; i < big_steps; i++) { - unsigned long long const x = *big_ptr1; - unsigned long long const y = *big_ptr2; - *big_dst = x & y; - big_ptr1++; - big_ptr2++; - big_dst++; - } - unsigned char *small_ptr1 = (unsigned char *)big_ptr1; - unsigned char *small_ptr2 = (unsigned char *)big_ptr2; - unsigned char *small_dst = (unsigned char *)big_dst; - for (size_t i = 0; i < small_steps; i++) { - unsigned char const x = *small_ptr1; - unsigned char const y = *small_ptr2; - *small_dst = x & y; - small_ptr1++; - small_ptr2++; - small_dst++; - } + size_t const big_step_size = sizeof(unsigned long long); + size_t const biggest_step_size = big_step_size * 4; // four-way unroll + size_t const biggest_steps = len / biggest_step_size; + size_t const rest = len % biggest_step_size; + size_t const big_steps = rest / big_step_size; + size_t const small_steps = rest % big_step_size; + unsigned long long *big_ptr1 = (unsigned long long *)src1; + unsigned long long *big_ptr2 = (unsigned long long *)src2; + unsigned long long *big_dst = (unsigned long long *)dst; + for (size_t i = 0; i < biggest_steps; i++) { + // We have to do this as GCC is unreliable at unrolling, even if the loop + // has fixed length, we have enough registers _and_ we turn on O2. + unsigned long long const x1 = *big_ptr1; + unsigned long long const x2 = *(big_ptr1 + 1); + unsigned long long const x3 = *(big_ptr1 + 2); + unsigned long long const x4 = *(big_ptr1 + 3); + unsigned long long const y1 = *big_ptr2; + unsigned long long const y2 = *(big_ptr2 + 1); + unsigned long long const y3 = *(big_ptr2 + 2); + unsigned long long const y4 = *(big_ptr2 + 3); + *big_dst = x1 & y1; + *(big_dst + 1) = x2 & y2; + *(big_dst + 2) = x3 & y3; + *(big_dst + 3) = x4 & y4; + big_ptr1 += 4; + big_ptr2 += 4; + big_dst += 4; + } + for (size_t i = 0; i < big_steps; i++) { + unsigned long long const x = *big_ptr1; + unsigned long long const y = *big_ptr2; + *big_dst = x & y; + big_ptr1++; + big_ptr2++; + big_dst++; + } + unsigned char *small_ptr1 = (unsigned char *)big_ptr1; + unsigned char *small_ptr2 = (unsigned char *)big_ptr2; + unsigned char *small_dst = (unsigned char *)big_dst; + for (size_t i = 0; i < small_steps; i++) { + unsigned char const x = *small_ptr1; + unsigned char const y = *small_ptr2; + *small_dst = x & y; + small_ptr1++; + small_ptr2++; + small_dst++; } } void c_and_implementation(unsigned char *dst, unsigned char const *src1, unsigned char const *src2, size_t const len) { - if (len != 0) { - size_t const big_step_size = sizeof(unsigned long long); - size_t const big_steps = len / big_step_size; - size_t const small_steps = len % big_step_size; - unsigned long long *big_ptr1 = (unsigned long long *)src1; - unsigned long long *big_ptr2 = (unsigned long long *)src2; - unsigned long long *big_dst = (unsigned long long *)dst; - for (size_t i = 0; i < big_steps; i++) { - unsigned long long const x = *big_ptr1; - unsigned long long const y = *big_ptr2; - *big_dst = x & y; - big_ptr1++; - big_ptr2++; - big_dst++; - } - unsigned char *small_ptr1 = (unsigned char *)big_ptr1; - unsigned char *small_ptr2 = (unsigned char *)big_ptr2; - unsigned char *small_dst = (unsigned char *)big_dst; - for (size_t i = 0; i < small_steps; i++) { - unsigned char const x = *small_ptr1; - unsigned char const y = *small_ptr2; - *small_dst = x & y; - small_ptr1++; - small_ptr2++; - small_dst++; - } + size_t const big_step_size = sizeof(unsigned long long); + size_t const big_steps = len / big_step_size; + size_t const small_steps = len % big_step_size; + unsigned long long *big_ptr1 = (unsigned long long *)src1; + unsigned long long *big_ptr2 = (unsigned long long *)src2; + unsigned long long *big_dst = (unsigned long long *)dst; + for (size_t i = 0; i < big_steps; i++) { + unsigned long long const x = *big_ptr1; + unsigned long long const y = *big_ptr2; + *big_dst = x & y; + big_ptr1++; + big_ptr2++; + big_dst++; + } + unsigned char *small_ptr1 = (unsigned char *)big_ptr1; + unsigned char *small_ptr2 = (unsigned char *)big_ptr2; + unsigned char *small_dst = (unsigned char *)big_dst; + for (size_t i = 0; i < small_steps; i++) { + unsigned char const x = *small_ptr1; + unsigned char const y = *small_ptr2; + *small_dst = x & y; + small_ptr1++; + small_ptr2++; + small_dst++; } } From 04f15317af5cc7384df4922bc3450ab4ad4b1542 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 5 Aug 2022 11:28:47 +1200 Subject: [PATCH 36/73] Start benchmark writeup --- .../plutus-core/bench/bitwise/BENCHES.md | 669 ++++++++++++++++++ plutus-core/plutus-core/bench/bitwise/Main.hs | 34 +- 2 files changed, 701 insertions(+), 2 deletions(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/BENCHES.md diff --git a/plutus-core/plutus-core/bench/bitwise/BENCHES.md b/plutus-core/plutus-core/bench/bitwise/BENCHES.md new file mode 100644 index 00000000000..1ad77c4978c --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/BENCHES.md @@ -0,0 +1,669 @@ +# Benchmarks of bitwise operations for Plutus core + +## Introduction + +## Conventions + +We use _kilobyte_ (_KiB_ for short) to mean $2^{10}$ (1024) bytes. + +We assume versions of Haskell libraries as defined by Plutus and determined by +`cabal new-freeze`. In particular, the following library versions are assumed to +be in use: + +* `bytestring-0.10.12.0` +* `wide-word-0.1.1.2` + +An operation is _bit-parallel_ if it treats its inputs as vectors of bits and +assumes no other structure. For example [bitwise logical +AND](https://en.wikipedia.org/wiki/Bitwise_operation#AND) is bit-parallel, while +a [bitwise +rotation](https://en.wikipedia.org/wiki/Bitwise_operation#Circular_shift) isn't. +This extends the definition of right-to-left computability defined in [Hacker's +Delight](https://en.wikipedia.org/wiki/Hacker%27s_Delight), but is stricter. + +## Background + +Plutus Core, which is designed to be executed on-chain, has unusual limitations +regarding performance. Specifically, the size of its possible arguments is +_significantly_ bounded: according to +[CIP-0009](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0009), the +current on-chain transaction size limit is 16384 bytes (16KiB), which includes +both script sources and arguments. While this limit could rise in the future, +currently, it means that `ByteString` arguments larger than about 2KiB aren't +practical. This implies that: + +* Asymptotically-optimal solutions may not be worthwhile if their 'ramp-up' + requires inputs approaching, or larger than, 2KiB; and +* Small inputs must be considered the norm. + +### Spatial and temporal locality + +## Implementation + +### Bitwise binary operations + +The naive approach (and our first) uses a combination of `fromListN` and `zip` +together with the operator in question; in essence, this streams both arguments +into a list of `Word8`s, combines them with the given operator, then 'repacks' +into a `ByteString`. This approach, while easy to implement, is likely to be +fairly slow once the size of its arguments becomes even moderately large. We +enumerate the reasons for this hypothesis below; many of these are based on the +reasoning described in [the spatial and temporal locality](#spatial-and-temporal-locality) +section. + +* The `ByteString` library + [does not use the size hint](https://hackage.haskell.org/package/bytestring-0.10.12.0/docs/src/Data.ByteString.Internal.html#line-194) + given to `fromListN`. This requires a traversal of the input list, which + forces it, making any stream fusion from GHC ineffective. +* Haskell linked lists lack spatial locality, and due to the above, we have to + force spatially local data into a spatially non-local form, only to then + immediately convert it _back_ to a spatially local form again. This not only + requires copying the data, it also means that we lose the benefits of spatial + locality for no reason. +* Haskell linked lists full of `Word8` lack temporal locality: even though a + modern machine can fit eight `Word8`s into a single register, if the data is + in a list, this cannot be done. + +These concerns were seen as sufficient to warrant the introduction of +`packZipWith`, which [avoids creating an intermediate list](https://github.com/haskell/bytestring/pull/295). +This operation amounts to creating an empty `ByteString` of the right length, +then performing the 'zipping' in-place. This avoids the problems of spatial +locality, and in theory could also avoid problems of temporal locality if the +operation being performed is bit-parallel. However, in general, 'zipping' +operations on `Word8`s cannot be assumed to be bit-parallel, which requires a +more conservative, 'byte-at-a-time' approach. Furthermore, `packZipWith` only +became available in the `bytestring` library as of [release +0.11.1.0](https://hackage.haskell.org/package/bytestring-0.11.1.0/changelog). +Thus, we replicate it for our second approach. + +All of our bitwise binary operations are bit-parallel by their definition; this +allows an implementation where we exploit temporal locality to process eight +bytes at a time. This essentially mirrors what the second approach does, but +instead first takes a maximal number of 'big steps' (eight bytes at a time), +followed by any remaining inputs being processed one byte at a time. We take +this as our third approach. We also attempt a fourth approach, where we take +even larger steps, using the `Word256` type from `wide-word`: this amounts to a +four-way [loop unroll](https://en.wikipedia.org/wiki/Loop_unrolling), as GHC +cannot currently generate SIMD instructions, even for bit-parallel operations. +This can, in theory, still be beneficial, due to +[ILP](https://en.wikipedia.org/wiki/Instruction-level_parallelism) being +available on most modern CPUs. More specifically, the third approach works as +follows: + +1. Allocate an empty `ByteString` of the correct length. +2. While at least eight bytes of both inputs are remaining, perform the bitwise + operation on an eight-byte chunk of both inputs, then write the result to the + corresponding part of the empty `ByteString` from 1. +3. For the remaining bytes, perform the bitwise operation on each of the + corresponding bytes of the input, writing them to the empty `ByteString` from + 1. + +The fourth approach works as follows: + +1. Allocate an empty `ByteString` of the correct length. +2. While at least 32 bytes of both inputs are remaining, perform the bitwise + operation on a 32-byte chunk of both inputs, then write the result to the + corresponding part of the empty `ByteString` from 1. +3. While at least eight bytes of both inputs are remaining, perform the bitwise + operation on an eight-byte chunk of both inputs, then write the result to the + corresponding part of the empty `ByteString` from 1. +4. For the remaining bytes, perform the bitwise operation on each of the + corresponding bytes of the input, writing them to the empty `ByteString` from + 1. + +### Bitwise complement + +A naive (and our first) approach would use `map` from `bytestring`: this is +implemented as a [loop over a preconstructed empty +`bytestring`](https://hackage.haskell.org/package/bytestring-0.10.12.0/docs/src/Data.ByteString.html#map), +and thus has good spatial locality. In theory, if given a bit-parallel +operation, it could make use of temporal locality by operating on larger widths +(such as whole machine words), but as `Word8` operations cannot be assumed to be +bit-parallel in general, it must work 'byte-at-a-time'. In our case, bitwise +complement _is_ bit-parallel, so our second approach attempts to make use of +this fact, essentially doing the following: + +1. Allocate an empty `ByteString` the same length as the input. +2. While at least eight bytes of the input remains, determine the bitwise + complement of an eight-byte chunk of the input, then write it to the + corresponding part of the empty `ByteString` from 1. +3. For the remaining bytes, perfor the bitwise complement on each of the + corresponding bytes of the input, writing them to the empty `ByteString` from + 1. + +We also define a third approach which takes even larger steps, using the +`Word256` type from `wide-word`. This amounts to a four-way loop unroll, as GHC +cannot currently generate SIMD instructions, even for bit-parallel operations. +This can, in theory, still be beneficial, due to ILP being available on most +modern CPUs. More specifically, the third approach works as follows: + +1. Allocate an empty `ByteString` the same length as the input. +2. While at least 32 bytes of of the input remains, determine the bitwise + complement of a 32-byte chunk of the input, then write it to the + corresponding part of the empty `ByteString` from 1. +3. While at least eight bytes of the input remains, determine the bitwise + complement of an eight-byte chunk of the input, then write it to the + corresponding part of the empty `ByteString` from 1. +4. For the remaining bytes, perfor the bitwise complement on each of the + corresponding bytes of the input, writing them to the empty `ByteString` from + 1. + +## Methodology + +### Bitwise binary operations + +We benchmark only bitwise AND, as the other operations do not differ +structurally, are also bit-parallel, and given a fixed width of inputs, are +constant time relative that width. We implement all four approaches; for the +third and fourth approaches, we implement them both in Haskell and in C, which +is called via the FFI. This allows us to see if any overheads are being +introduced by GHC. + +We use pairs of inputs of the following lengths: + +* 1 +* 3 +* 7 +* 15 +* 31 +* 63 +* 127 +* 255 +* 511 +* 1023 +* 2047 + +We choose these values to disadvantage the third and fourth approaches as much +as possible, as values that are one less than a power of 2 in length would +require them to do the most work in their last step. + +We compare all approaches to the first (that is, naive) one. + +### Bitwise complement + +We implement all three approaches; for the second approach, we implement it both +in Haskell and in C, which is called via the FFI. This is to determine whether +any overheads are being introduced by GHC. + +We use inputs of the following lengths: + +* 1 +* 3 +* 7 +* 15 +* 31 +* 63 +* 127 +* 255 +* 511 +* 1023 +* 2047 + +We choose these values to disadvantage the second and third approaches as much +as possible, as values that are one less than a power of 2 in length would +require them to do the most work in their last step. + +We compare all approaches to the first (that is, naive) one. + +### Bitwise complement + +## Results + +Throughout, we run benchmarks (implemented with `tasty-bench`) with `--stdev=1 +--timeout=200` to ensure minimal interference and accurate readings, while +avoiding timeouts due to the increased time required to get accurate readings. + +### Bitwise binary operations + +The results of our benchmarks given the methodology we describe are below. +Throughout, `zipWith` refers to the first approach, `packZipWith` to the second +approach, `chunkedZipWith (2 blocks)` to the third approach, and `chunkedZipWith +(3 blocks)` to the fourth approach. We also mark the C implementations of the +third and fourth approach. All multipliers are shows as multiples of the running +time of the first approach on the same length of data. + +``` +All + Bitwise AND + Bitwise AND, length 1 + zipWith: OK (0.86s) + 46.2 ns ± 864 ps, 254 B allocated, 0 B copied, 45 MB peak memory + packZipWith: OK (5.96s) + 177 ns ± 2.3 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 3.83x + chunkedZipWith (2 blocks): OK (6.00s) + 178 ns ± 1.0 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 3.85x + chunkedZipWith (2 blocks, C): OK (12.14s) + 180 ns ± 904 ps, 359 B allocated, 95 B copied, 52 MB peak memory, 3.89x + chunkedZipWith (3 blocks): OK (3.15s) + 184 ns ± 2.1 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 3.99x + chunkedZipWith (3 blocks, C): OK (0.78s) + 180 ns ± 3.5 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 3.90x + Bitwise AND, length 3 + zipWith: OK (1.85s) + 54.3 ns ± 530 ps, 350 B allocated, 0 B copied, 52 MB peak memory + packZipWith: OK (0.78s) + 181 ns ± 3.2 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 3.33x + chunkedZipWith (2 blocks): OK (6.28s) + 186 ns ± 1.3 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 3.43x + chunkedZipWith (2 blocks, C): OK (0.79s) + 184 ns ± 3.5 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 3.39x + chunkedZipWith (3 blocks): OK (6.39s) + 189 ns ± 3.7 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 3.47x + chunkedZipWith (3 blocks, C): OK (100.97s) + 187 ns ± 3.1 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 3.45x + Bitwise AND, length 7 + zipWith: OK (1.18s) + 68.2 ns ± 1.0 ns, 508 B allocated, 0 B copied, 52 MB peak memory + packZipWith: OK (0.78s) + 182 ns ± 3.2 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 2.67x + chunkedZipWith (2 blocks): OK (3.25s) + 191 ns ± 942 ps, 358 B allocated, 95 B copied, 52 MB peak memory, 2.80x + chunkedZipWith (2 blocks, C): OK (3.17s) + 188 ns ± 1.2 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 2.75x + chunkedZipWith (3 blocks): OK (3.27s) + 194 ns ± 966 ps, 358 B allocated, 95 B copied, 52 MB peak memory, 2.85x + chunkedZipWith (3 blocks, C): OK (3.28s) + 193 ns ± 2.4 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 2.83x + Bitwise AND, length 15 + zipWith: OK (0.91s) + 106 ns ± 1.7 ns, 844 B allocated, 0 B copied, 52 MB peak memory + packZipWith: OK (3.23s) + 191 ns ± 2.7 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 1.80x + chunkedZipWith (2 blocks): OK (1.68s) + 198 ns ± 3.4 ns, 353 B allocated, 94 B copied, 52 MB peak memory, 1.87x + chunkedZipWith (2 blocks, C): OK (1.69s) + 196 ns ± 2.6 ns, 353 B allocated, 94 B copied, 52 MB peak memory, 1.85x + chunkedZipWith (3 blocks): OK (13.48s) + 201 ns ± 1.2 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 1.90x + chunkedZipWith (3 blocks, C): OK (3.40s) + 200 ns ± 1.2 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 1.88x + Bitwise AND, length 31 + zipWith: OK (1.69s) + 199 ns ± 1.9 ns, 1.5 KB allocated, 0 B copied, 52 MB peak memory + packZipWith: OK (6.10s) + 182 ns ± 1.4 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 0.91x + chunkedZipWith (2 blocks): OK (3.15s) + 186 ns ± 2.0 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.93x + chunkedZipWith (2 blocks, C): OK (0.80s) + 184 ns ± 3.4 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.92x + chunkedZipWith (3 blocks): OK (6.55s) + 194 ns ± 1.6 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 0.97x + chunkedZipWith (3 blocks, C): OK (3.28s) + 194 ns ± 3.4 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.97x + Bitwise AND, length 63 + zipWith: OK (0.79s) + 371 ns ± 6.4 ns, 2.8 KB allocated, 0 B copied, 52 MB peak memory + packZipWith: OK (7.81s) + 233 ns ± 918 ps, 359 B allocated, 95 B copied, 52 MB peak memory, 0.63x + chunkedZipWith (2 blocks): OK (3.84s) + 228 ns ± 2.2 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.61x + chunkedZipWith (2 blocks, C): OK (0.93s) + 215 ns ± 3.2 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.58x + chunkedZipWith (3 blocks): OK (3.84s) + 226 ns ± 2.7 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.61x + chunkedZipWith (3 blocks, C): OK (0.96s) + 223 ns ± 3.5 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.60x + Bitwise AND, length 127 + zipWith: OK (1.43s) + 665 ns ± 11 ns, 5.4 KB allocated, 1 B copied, 52 MB peak memory + packZipWith: OK (0.91s) + 209 ns ± 3.8 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.31x + chunkedZipWith (2 blocks): OK (0.82s) + 181 ns ± 2.8 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.27x + chunkedZipWith (2 blocks, C): OK (52.40s) + 196 ns ± 2.6 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 0.29x + chunkedZipWith (3 blocks): OK (0.87s) + 191 ns ± 3.0 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.29x + chunkedZipWith (3 blocks, C): OK (3.26s) + 190 ns ± 2.6 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.29x + Bitwise AND, length 255 + zipWith: OK (0.75s) + 1.38 μs ± 22 ns, 11 KB allocated, 3 B copied, 52 MB peak memory + packZipWith: OK (4.49s) + 263 ns ± 898 ps, 358 B allocated, 95 B copied, 52 MB peak memory, 0.19x + chunkedZipWith (2 blocks): OK (1.77s) + 204 ns ± 3.5 ns, 353 B allocated, 94 B copied, 52 MB peak memory, 0.15x + chunkedZipWith (2 blocks, C): OK (1.81s) + 208 ns ± 3.6 ns, 353 B allocated, 94 B copied, 52 MB peak memory, 0.15x + chunkedZipWith (3 blocks): OK (14.16s) + 210 ns ± 940 ps, 359 B allocated, 95 B copied, 52 MB peak memory, 0.15x + chunkedZipWith (3 blocks, C): OK (3.41s) + 197 ns ± 2.1 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.14x + Bitwise AND, length 511 + zipWith: OK (1.42s) + 2.67 μs ± 43 ns, 21 KB allocated, 2 B copied, 52 MB peak memory + packZipWith: OK (1.48s) + 332 ns ± 3.1 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.12x + chunkedZipWith (2 blocks): OK (1.94s) + 219 ns ± 3.0 ns, 353 B allocated, 94 B copied, 52 MB peak memory, 0.08x + chunkedZipWith (2 blocks, C): OK (3.74s) + 217 ns ± 2.2 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.08x + chunkedZipWith (3 blocks): OK (1.04s) + 230 ns ± 2.7 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.09x + chunkedZipWith (3 blocks, C): OK (1.90s) + 214 ns ± 2.9 ns, 353 B allocated, 94 B copied, 52 MB peak memory, 0.08x + Bitwise AND, length 1023 + zipWith: OK (0.78s) + 5.68 μs ± 100 ns, 42 KB allocated, 55 B copied, 52 MB peak memory + packZipWith: OK (1.13s) + 499 ns ± 7.9 ns, 341 B allocated, 91 B copied, 52 MB peak memory, 0.09x + chunkedZipWith (2 blocks): OK (1.28s) + 282 ns ± 3.7 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.05x + chunkedZipWith (2 blocks, C): OK (1.29s) + 280 ns ± 3.9 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.05x + chunkedZipWith (3 blocks): OK (1.38s) + 297 ns ± 4.7 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.05x + chunkedZipWith (3 blocks, C): OK (1.29s) + 283 ns ± 3.2 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.05x + Bitwise AND, length 2047 + zipWith: OK (0.78s) + 11.2 μs ± 170 ns, 85 KB allocated, 88 B copied, 52 MB peak memory + packZipWith: OK (3.50s) + 798 ns ± 4.1 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.07x + chunkedZipWith (2 blocks): OK (1.76s) + 385 ns ± 3.5 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.03x + chunkedZipWith (2 blocks, C): OK (6.57s) + 379 ns ± 1.6 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.03x + chunkedZipWith (3 blocks): OK (1.88s) + 414 ns ± 4.8 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.04x + chunkedZipWith (3 blocks, C): OK (1.78s) + 395 ns ± 3.1 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.04x +``` + +We observe that, up to length 15, the first approach comes out ahead, especially +on smaller inputs. However, at around length 30, a 'phase transition' occurs, +where the other approaches win out, with this becoming increasingly apparent as +we get to the limits of our sizes. In particular, in the middle of the size +range (between 63 and 511 bytes inclusive), other approaches beat out the naive +one by a factor of between 2 and 10, which is not insignificant. We also note +that the first approach allocates substantially more than the others, likely due +to lists it cannot fuse away; all other approaches have fixed allocations. + +It is not clear from the above whether the second, third or fourth approaches +are better in general; to this end, we ran only these in isolation, comparing +the third and fourth approaches to the second: + +``` +All + Packed bitwise AND + Packed bitwise AND, length 31 + packZipWith: OK (3.34s) + 390 ns ± 2.8 ns, 3.0 KB allocated, 0 B copied, 45 MB peak memory + chunkedZipWith (2 blocks): OK (6.21s) + 184 ns ± 2.7 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 0.47x + chunkedZipWith (2 blocks, C): OK (1.57s) + 184 ns ± 1.5 ns, 427 B allocated, 95 B copied, 52 MB peak memory, 0.47x + chunkedZipWith (3 blocks): OK (3.20s) + 189 ns ± 1.7 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.48x + chunkedZipWith (3 blocks, C): OK (1.62s) + 190 ns ± 2.8 ns, 427 B allocated, 95 B copied, 52 MB peak memory, 0.49x + Packed bitwise AND, length 63 + packZipWith: OK (0.74s) + 679 ns ± 12 ns, 5.8 KB allocated, 0 B copied, 52 MB peak memory + chunkedZipWith (2 blocks): OK (6.91s) + 208 ns ± 2.2 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 0.31x + chunkedZipWith (2 blocks, C): OK (3.93s) + 236 ns ± 1.3 ns, 430 B allocated, 95 B copied, 52 MB peak memory, 0.35x + chunkedZipWith (3 blocks): OK (8.05s) + 239 ns ± 796 ps, 359 B allocated, 95 B copied, 52 MB peak memory, 0.35x + chunkedZipWith (3 blocks, C): OK (8.10s) + 242 ns ± 2.2 ns, 431 B allocated, 95 B copied, 52 MB peak memory, 0.36x + Packed bitwise AND, length 127 + packZipWith: OK (0.73s) + 1.40 μs ± 22 ns, 11 KB allocated, 1 B copied, 52 MB peak memory + chunkedZipWith (2 blocks): OK (50.76s) + 188 ns ± 2.6 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 0.13x + chunkedZipWith (2 blocks, C): OK (1.67s) + 191 ns ± 2.4 ns, 427 B allocated, 95 B copied, 52 MB peak memory, 0.14x + chunkedZipWith (3 blocks): OK (0.84s) + 193 ns ± 3.5 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.14x + chunkedZipWith (3 blocks, C): OK (0.84s) + 191 ns ± 3.1 ns, 424 B allocated, 94 B copied, 52 MB peak memory, 0.14x + Packed bitwise AND, length 255 + packZipWith: OK (2.85s) + 2.69 μs ± 22 ns, 23 KB allocated, 7 B copied, 52 MB peak memory + chunkedZipWith (2 blocks): OK (6.91s) + 204 ns ± 1.7 ns, 359 B allocated, 95 B copied, 52 MB peak memory, 0.08x + chunkedZipWith (2 blocks, C): OK (0.87s) + 199 ns ± 2.9 ns, 424 B allocated, 94 B copied, 52 MB peak memory, 0.07x + chunkedZipWith (3 blocks): OK (3.61s) + 213 ns ± 1.4 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.08x + chunkedZipWith (3 blocks, C): OK (1.73s) + 201 ns ± 2.5 ns, 427 B allocated, 95 B copied, 52 MB peak memory, 0.07x + Packed bitwise AND, length 511 + packZipWith: OK (23.36s) + 5.60 μs ± 89 ns, 45 KB allocated, 11 B copied, 52 MB peak memory + chunkedZipWith (2 blocks): OK (1.92s) + 221 ns ± 4.2 ns, 353 B allocated, 94 B copied, 52 MB peak memory, 0.04x + chunkedZipWith (2 blocks, C): OK (14.52s) + 215 ns ± 3.8 ns, 431 B allocated, 95 B copied, 52 MB peak memory, 0.04x + chunkedZipWith (3 blocks): OK (2.05s) + 233 ns ± 4.3 ns, 353 B allocated, 94 B copied, 52 MB peak memory, 0.04x + chunkedZipWith (3 blocks, C): OK (7.27s) + 214 ns ± 1.5 ns, 431 B allocated, 95 B copied, 52 MB peak memory, 0.04x + Packed bitwise AND, length 1023 + packZipWith: OK (0.74s) + 11.2 μs ± 170 ns, 90 KB allocated, 30 B copied, 52 MB peak memory + chunkedZipWith (2 blocks): OK (4.85s) + 282 ns ± 1.8 ns, 358 B allocated, 95 B copied, 52 MB peak memory, 0.03x + chunkedZipWith (2 blocks, C): OK (4.84s) + 280 ns ± 752 ps, 430 B allocated, 95 B copied, 52 MB peak memory, 0.02x + chunkedZipWith (3 blocks): OK (1.36s) + 305 ns ± 3.0 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.03x + chunkedZipWith (3 blocks, C): OK (2.49s) + 283 ns ± 3.3 ns, 427 B allocated, 95 B copied, 52 MB peak memory, 0.03x + Packed bitwise AND, length 2047 + packZipWith: OK (2.95s) + 22.3 μs ± 350 ns, 181 KB allocated, 114 B copied, 52 MB peak memory + chunkedZipWith (2 blocks): OK (1.79s) + 394 ns ± 2.7 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.02x + chunkedZipWith (2 blocks, C): OK (3.43s) + 390 ns ± 6.4 ns, 427 B allocated, 95 B copied, 52 MB peak memory, 0.02x + chunkedZipWith (3 blocks): OK (1.87s) + 410 ns ± 5.8 ns, 347 B allocated, 92 B copied, 52 MB peak memory, 0.02x + chunkedZipWith (3 blocks, C): OK (0.94s) + 392 ns ± 5.5 ns, 405 B allocated, 90 B copied, 52 MB peak memory, 0.02x +``` + +We observe that the third and fourth approaches beat out the second by a factor +of at least 2, with said factor increasing to ~50 towards the largest inputs. +However, there doesn't appear to be much difference between the third and fourth +approaches. Additionally, the C-implemented versions do not out-perform their +Haskell equivalents by a worthwhile margin, while marginally increasing +allocations. + +### Bitwise complement + +The results of our benchmarks given the methodology we describe are below. +Throughout, `map` refers to the first approach, `chunkedMap (2 blocks)` refers +to the second approach, and `chunkMap (3 blocks)` refers to the third approach. +We also mark the C implementation of the second approach. All multipliers are +shown as multiples of the running time of the first approach on the same length +of data. + +``` +All + Bitwise complement + Bitwise complement, length 1 + map: OK (26.39s) + 24.0 ns ± 464 ps, 111 B allocated, 0 B copied, 45 MB peak memory + chunkedMap (2 blocks): OK (26.34s) + 199 ns ± 3.7 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 8.31x + chunkedMap (2 blocks, C): OK (3.47s) + 205 ns ± 1.4 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 8.56x + chunkMap (3 blocks): OK (1.77s) + 206 ns ± 4.1 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 8.60x + Bitwise complement, length 3 + map: OK (0.97s) + 28.0 ns ± 334 ps, 119 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (3.53s) + 209 ns ± 1.4 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 7.46x + chunkedMap (2 blocks, C): OK (3.54s) + 210 ns ± 2.9 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 7.47x + chunkMap (3 blocks): OK (3.62s) + 214 ns ± 2.5 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 7.62x + Bitwise complement, length 7 + map: OK (1.03s) + 29.8 ns ± 410 ps, 119 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (1.76s) + 207 ns ± 1.5 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 6.93x + chunkedMap (2 blocks, C): OK (7.16s) + 213 ns ± 1.2 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 7.14x + chunkMap (3 blocks): OK (3.61s) + 214 ns ± 4.0 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 7.18x + Bitwise complement, length 15 + map: OK (2.26s) + 33.4 ns ± 222 ps, 127 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (3.61s) + 214 ns ± 1.6 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 6.40x + chunkedMap (2 blocks, C): OK (7.34s) + 219 ns ± 2.7 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 6.54x + chunkMap (3 blocks): OK (123.63s) + 234 ns ± 12 ns, 343 B allocated, 96 B copied, 53 MB peak memory, 7.01x + Bitwise complement, length 31 + map: OK (1.36s) + 40.3 ns ± 548 ps, 143 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (122.95s) + 232 ns ± 806 ps, 343 B allocated, 96 B copied, 53 MB peak memory, 5.75x + chunkedMap (2 blocks, C): OK (8.32s) + 247 ns ± 3.4 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 6.13x + chunkMap (3 blocks): OK (2.08s) + 245 ns ± 4.3 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 6.09x + Bitwise complement, length 63 + map: OK (0.94s) + 54.2 ns ± 748 ps, 173 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (144.17s) + 276 ns ± 6.8 ns, 343 B allocated, 96 B copied, 53 MB peak memory, 5.10x + chunkedMap (2 blocks, C): OK (1.17s) + 270 ns ± 4.2 ns, 330 B allocated, 92 B copied, 53 MB peak memory, 4.99x + chunkMap (3 blocks): OK (2.40s) + 281 ns ± 2.2 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 5.19x + Bitwise complement, length 127 + map: OK (0.69s) + 78.7 ns ± 1.4 ns, 235 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (5.88s) + 174 ns ± 1.4 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 2.21x + chunkedMap (2 blocks, C): OK (5.73s) + 169 ns ± 2.9 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 2.15x + chunkMap (3 blocks): OK (2.89s) + 169 ns ± 2.0 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 2.15x + Bitwise complement, length 255 + map: OK (0.96s) + 111 ns ± 1.4 ns, 362 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (1.55s) + 176 ns ± 2.1 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 1.58x + chunkedMap (2 blocks, C): OK (2.90s) + 166 ns ± 2.5 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 1.49x + chunkMap (3 blocks): OK (2.98s) + 173 ns ± 1.5 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 1.56x + Bitwise complement, length 511 + map: OK (0.77s) + 175 ns ± 3.4 ns, 611 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (0.89s) + 195 ns ± 2.7 ns, 330 B allocated, 92 B copied, 53 MB peak memory, 1.11x + chunkedMap (2 blocks, C): OK (12.96s) + 191 ns ± 186 ps, 343 B allocated, 95 B copied, 53 MB peak memory, 1.09x + chunkMap (3 blocks): OK (1.70s) + 192 ns ± 3.7 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 1.10x + Bitwise complement, length 1023 + map: OK (1.34s) + 311 ns ± 2.8 ns, 1.1 KB allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (2.19s) + 246 ns ± 2.0 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 0.79x + chunkedMap (2 blocks, C): OK (8.14s) + 236 ns ± 2.8 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 0.76x + chunkMap (3 blocks): OK (2.23s) + 248 ns ± 4.5 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 0.80x + Bitwise complement, length 2047 + map: OK (0.66s) + 592 ns ± 11 ns, 2.1 KB allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (92.07s) + 342 ns ± 568 ps, 343 B allocated, 96 B copied, 53 MB peak memory, 0.58x + chunkedMap (2 blocks, C): OK (21.84s) + 318 ns ± 780 ps, 343 B allocated, 95 B copied, 53 MB peak memory, 0.54x + chunkMap (3 blocks): OK (6.18s) + 354 ns ± 6.3 ns, 341 B allocated, 95 B copied, 53 MB peak memory, 0.60x +``` + +These results show that until the input length becomes significantly long +(around 1KiB), the first approach is much better (as much as a factor of 8). We +do see some improvement at the upper end of our sizes, but this amounts to about +a factor of 2 at most. The C implementation of the second approach does not seem +to give significant speedups; the third approach appears slower than the second +for all tested sizes. + +To establish where the 'phase transition' between the first and second +approaches happens, we ran further benchmarks, limiting our sizes to the space +between 511 and 1023 bytes: + +``` +All + Bitwise complement probe + Bitwise complement probe, length 511 + map: OK (4.99s) + 147 ns ± 2.2 ns, 621 B allocated, 0 B copied, 45 MB peak memory + chunkedMap (2 blocks): OK (1.64s) + 182 ns ± 2.5 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 1.24x + chunkedMap (2 blocks, C): OK (1.61s) + 181 ns ± 1.3 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 1.23x + chunkMap (3 blocks): OK (0.84s) + 183 ns ± 3.1 ns, 330 B allocated, 92 B copied, 53 MB peak memory, 1.25x + Bitwise complement probe, length 767 + map: OK (0.88s) + 205 ns ± 2.7 ns, 875 B allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (0.95s) + 206 ns ± 2.6 ns, 330 B allocated, 92 B copied, 53 MB peak memory, 1.00x + chunkedMap (2 blocks, C): OK (6.91s) + 202 ns ± 1.1 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 0.99x + chunkMap (3 blocks): OK (1.85s) + 208 ns ± 3.1 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 1.02x + Bitwise complement probe, length 1023 + map: OK (1.26s) + 295 ns ± 4.5 ns, 1.1 KB allocated, 0 B copied, 53 MB peak memory + chunkedMap (2 blocks): OK (63.98s) + 238 ns ± 292 ps, 343 B allocated, 95 B copied, 53 MB peak memory, 0.81x + chunkedMap (2 blocks, C): OK (7.89s) + 228 ns ± 3.2 ns, 343 B allocated, 95 B copied, 53 MB peak memory, 0.77x + chunkMap (3 blocks): OK (2.15s) + 242 ns ± 1.5 ns, 339 B allocated, 94 B copied, 53 MB peak memory, 0.82x +``` + +We note that at 767 bytes (exactly mid-way), the 'phase transition' has already +occurred. + +## Conclusion and recommendations + +We do not believe the use of the FFI and implementing any operations in +(portable C) to be worthwhile; there appear to be no significant gains in speed, +and GHC appears able to generate code competitive with the C compiler. + +For bitwise binary operations, we recommend a 'hybrid' approach: for smaller +input lengths (less than 30 items), we use the first (naive) approach, while for +anything larger, we use the third approach (with `Word64`-width +bit-parallelism). This would give us good performance on both small and large +inputs, and would not require a significant overhead, as we have to verify that +the lengths of our inputs match anyway. + +For bitwise complement, we also recommend a 'hybrid' approach: for input lengths +less than 760 bytes, we use the first (naive) approach, while for anything +larger, we use the second approach (with `Word64`-width bit-parallelism). While +this would require some overhead for a length check, we believe that it's +worthwhile, as the length of an input `ByteString` is statically known. However, +if we consider inputs of this length unlikely relative the extra code path, +using the first approach in all cases is acceptable; however, we don't believe +that the extra code represents significant maintenance or runtime overheads, and +while inputs of this size would be unlikely, they're not impossible. + +## Future work + +Many, if not most, of the operations here can be significantly accelerated using +[SIMD +instructions](https://en.wikipedia.org/wiki/Single_instruction,_multiple_data). +This is because many of the operations are bit-parallel or monoidal (bitwise +binary operations and population counting) while others can benefit from +instruction-level parallelism and wider words, as well as specialized +instructions. Given that this code will be run on Cardano nodes, which are +likely to be x86-64 machines with recent instruction sets, the gains are +potentially significant; at the same time, this would require significant extra +build-time checks, as well as fallbacks when said instructions are not +available. diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 4e41040ea45..2ca9eb67839 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} module Main (main) where @@ -32,15 +31,25 @@ main = do bgroup bandLabel . fmap (andBench bandLabel) $ sizes, bgroup popCountLabel . fmap (popCountBench popCountLabel) $ sizes, bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, - bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes + bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes, + bgroup bandLabel' . fmap (packedAndBench bandLabel') $ largerSizes, + bgroup bcompLabel' . fmap (complementBench bcompLabel') $ probingSizes ] where sizes :: [Int] sizes = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047] + largerSizes :: [Int] + largerSizes = [31, 63, 127, 255, 511, 1023, 2047] + probingSizes :: [Int] + probingSizes = [511, 767, 1023] bandLabel :: String bandLabel = "Bitwise AND" + bandLabel' :: String + bandLabel' = "Packed bitwise AND" bcompLabel :: String bcompLabel = "Bitwise complement" + bcompLabel' :: String + bcompLabel' = "Bitwise complement probe" popCountLabel :: String popCountLabel = "Popcount" rotateLabel :: String @@ -50,6 +59,27 @@ main = do -- Benchmarks +packedAndBench :: + String -> + Int -> + Benchmark +packedAndBench mainLabel len = + withResource (mkBinaryArgs len) noCleanup $ \xs -> + let pzwLabel = "packZipWith" + czwLabel2 = "chunkedZipWith (2 blocks)" + czwLabel2' = "chunkedZipWith (2 blocks, C)" + czwLabel3 = "chunkedZipWith (3 blocks)" + czwLabel3' = "chunkedZipWith (3 blocks, C)" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> pzwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench pzwLabel . nfIO $ uncurry (zipWithBinary (.&.)) <$> xs, + bcompare matchLabel . bench czwLabel2 . nfIO $ uncurry (chunkZipWith2 (.&.) (.&.)) <$> xs, + bcompare matchLabel . bench czwLabel2' . nfIO $ uncurry candBinary2 <$> xs, + bcompare matchLabel . bench czwLabel3 . nfIO $ uncurry (chunkZipWith3 (.&.) (.&.) (.&.)) <$> xs, + bcompare matchLabel . bench czwLabel3' . nfIO $ uncurry candBinary3 <$> xs + ] + rotateFastVsSlow :: String -> Int -> From 09dd2dd5468946926b5ddb52f7958d1611354c0d Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 8 Aug 2022 13:19:42 +1200 Subject: [PATCH 37/73] Writeup for popcount, another narrow bench --- .../plutus-core/bench/bitwise/BENCHES.md | 237 +++++++++++++++++- .../bench/bitwise/Implementations.hs | 1 + plutus-core/plutus-core/bench/bitwise/Main.hs | 19 ++ 3 files changed, 254 insertions(+), 3 deletions(-) diff --git a/plutus-core/plutus-core/bench/bitwise/BENCHES.md b/plutus-core/plutus-core/bench/bitwise/BENCHES.md index 1ad77c4978c..0a1dcc5ce1e 100644 --- a/plutus-core/plutus-core/bench/bitwise/BENCHES.md +++ b/plutus-core/plutus-core/bench/bitwise/BENCHES.md @@ -21,6 +21,9 @@ rotation](https://en.wikipedia.org/wiki/Bitwise_operation#Circular_shift) isn't. This extends the definition of right-to-left computability defined in [Hacker's Delight](https://en.wikipedia.org/wiki/Hacker%27s_Delight), but is stricter. +We use _population count_ to mean the number of 1 bits. We use this term with +individual bytes, words, or sequences of either. + ## Background Plutus Core, which is designed to be executed on-chain, has unusual limitations @@ -148,6 +151,43 @@ modern CPUs. More specifically, the third approach works as follows: corresponding bytes of the input, writing them to the empty `ByteString` from 1. +### Population count + +A naive approach would involve a fold over the `Word8`s in the argument, summing +the result of `popCount`. This forms our first approach, using the `foldl'` +function provided by `bytestring`. This approach makes good use of spatial +locality, but not particularly good use of temporal locality: each `Word8` we +load into a register to population count still requires a memory transfer, but +we only population count 8 bits, rather than the 64 bits that could fit into the +register. Moreover, x86_64 platforms have efficient instructions dedicated to +population counting, which can easily count a whole register's worth of bits. +Thu, our second approach makes use of this capability by doing two 'phases' of +counting: firstly, we count eight-byte chunks, then finish what remains one byte +at a time. Specifically, we do the following: + +1. Initialize a counter to 0. +2. While at least eight bytes of the input remains, population count an + eight-byte chunk, then add the result to the counter. +3. While any bytes of the input remain, population count one byte, then add the + result to the counter. +4. Return the counter. + +We also define a third approach which takes even larger chunks, using the +`Word256` type from `wide-word`. This amounts to a four-way loop unroll, as +there are no specialized instructions for population counting chunks larger than +eight bytes on any current architectures supported by GHC. This can, in theory, +still be beneficial, due to ILP being available on most modern CPUs. More +specifically, the third approach works as follows: + +1. Initialize a counter to 0. +2. While at least 32 bytes of input remains, population count a 32-byte chunk, + then add the result to the counter. +3. While at least eight bytes of the input remains, population count an + eight-byte chunk, then add the result to the counter. +4. While any bytes of the input remain, population count one byte, then add the + result to the counter. +5. Return the counter. + ## Methodology ### Bitwise binary operations @@ -205,7 +245,25 @@ require them to do the most work in their last step. We compare all approaches to the first (that is, naive) one. -### Bitwise complement +### Population count + +We implement all three approaches. We use inputs of the following lengths: + +* 1 +* 3 +* 7 +* 15 +* 31 +* 63 +* 127 +* 255 +* 511 +* 1023 +* 2047 + +We choose these values to disadvantage the second and third approaches as much +as possible, as values that are one less than a power of 2 in length would +require them to do the most work in their second-to-last step. ## Results @@ -215,7 +273,7 @@ avoiding timeouts due to the increased time required to get accurate readings. ### Bitwise binary operations -The results of our benchmarks given the methodology we describe are below. +The results of our benchmarks given the methodology we described are below. Throughout, `zipWith` refers to the first approach, `packZipWith` to the second approach, `chunkedZipWith (2 blocks)` to the third approach, and `chunkedZipWith (3 blocks)` to the fourth approach. We also mark the C implementations of the @@ -474,7 +532,7 @@ allocations. ### Bitwise complement -The results of our benchmarks given the methodology we describe are below. +The results of our benchmarks given the methodology we described are below. Throughout, `map` refers to the first approach, `chunkedMap (2 blocks)` refers to the second approach, and `chunkMap (3 blocks)` refers to the third approach. We also mark the C implementation of the second approach. All multipliers are @@ -631,6 +689,172 @@ All We note that at 767 bytes (exactly mid-way), the 'phase transition' has already occurred. +### Population count + +The results of our benchmark given the methodology we described are below. +Throughout, `foldl'` refers to the first approach, `chunkPopCount2 to the second +approach, and `chunkPopCount3` to the third approach. All multipliers are shown +as multiples of the running time of the first approach on the same length of +data. + +``` +All + Popcount + Popcount, length 1 + foldl': OK (49.30s) + 22.9 ns ± 348 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (3.17s) + 23.3 ns ± 456 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 1.02x + chunkPopCount3: OK (0.81s) + 24.1 ns ± 330 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 1.05x + Popcount, length 3 + foldl': OK (0.92s) + 27.1 ns ± 372 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (113.34s) + 26.7 ns ± 64 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.98x + chunkPopCount3: OK (0.91s) + 26.8 ns ± 372 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.99x + Popcount, length 7 + foldl': OK (4.05s) + 30.3 ns ± 226 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (8.52s) + 31.9 ns ± 40 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 1.05x + chunkPopCount3: OK (1.05s) + 31.2 ns ± 322 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 1.03x + Popcount, length 15 + foldl': OK (0.69s) + 40.4 ns ± 682 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (4.39s) + 32.8 ns ± 100 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.81x + chunkPopCount3: OK (0.57s) + 33.6 ns ± 638 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.83x + Popcount, length 31 + foldl': OK (2.08s) + 61.9 ns ± 420 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (81.00s) + 37.8 ns ± 222 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.61x + chunkPopCount3: OK (0.64s) + 37.6 ns ± 688 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.61x + Popcount, length 63 + foldl': OK (0.83s) + 99.5 ns ± 1.8 ns, 38 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (0.77s) + 45.2 ns ± 778 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.45x + chunkPopCount3: OK (0.75s) + 44.7 ns ± 666 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.45x + Popcount, length 127 + foldl': OK (0.68s) + 161 ns ± 2.7 ns, 31 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (1.09s) + 64.0 ns ± 650 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.40x + chunkPopCount3: OK (1.12s) + 66.7 ns ± 696 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.41x + Popcount, length 255 + foldl': OK (0.60s) + 287 ns ± 5.7 ns, 25 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (0.89s) + 104 ns ± 1.7 ns, 38 B allocated, 0 B copied, 47 MB peak memory, 0.36x + chunkPopCount3: OK (0.86s) + 101 ns ± 1.6 ns, 38 B allocated, 0 B copied, 47 MB peak memory, 0.35x + Popcount, length 511 + foldl': OK (0.58s) + 538 ns ± 11 ns, 0 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (0.77s) + 181 ns ± 2.9 ns, 31 B allocated, 0 B copied, 47 MB peak memory, 0.34x + chunkPopCount3: OK (0.72s) + 167 ns ± 2.8 ns, 31 B allocated, 0 B copied, 47 MB peak memory, 0.31x + Popcount, length 1023 + foldl': OK (1.11s) + 1.04 μs ± 11 ns, 0 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (0.73s) + 341 ns ± 5.3 ns, 25 B allocated, 0 B copied, 47 MB peak memory, 0.33x + chunkPopCount3: OK (1.28s) + 301 ns ± 2.7 ns, 31 B allocated, 0 B copied, 47 MB peak memory, 0.29x + Popcount, length 2047 + foldl': OK (1.09s) + 2.05 μs ± 28 ns, 0 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount2: OK (0.69s) + 649 ns ± 12 ns, 0 B allocated, 0 B copied, 47 MB peak memory, 0.32x + chunkPopCount3: OK (1.20s) + 568 ns ± 6.7 ns, 25 B allocated, 0 B copied, 47 MB peak memory, 0.28x +``` + +We observe that, even for short inputs, the time required by the second and +third approach is not significantly worse than the first: the difference is at +most 5%, which at the scale being measured is barely distinct from noise. Once +the length reaches 15, there is about a 20% improvement in running time when +using the second and third approaches relative the first, and for lengths larger +than this, the increase only continues. Overall, the third approach does not +appear significantly better than the second until the input size reaches 511, +but isn't significantly worse at lengths above 15. To more clearly see the +difference, we also ran the same inputs, but compared the second approach to the +third: + +``` +All + Block popcount + Block popcount, length 1 + chunkPopCount2: OK (0.74s) + 20.5 ns ± 404 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (3.12s) + 23.3 ns ± 312 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 1.14x + Block popcount, length 3 + chunkPopCount2: OK (3.31s) + 25.1 ns ± 134 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (1.70s) + 25.4 ns ± 352 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 1.01x + Block popcount, length 7 + chunkPopCount2: OK (1.02s) + 30.2 ns ± 456 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (1.08s) + 32.2 ns ± 432 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 1.07x + Block popcount, length 15 + chunkPopCount2: OK (1.09s) + 32.2 ns ± 366 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (1.06s) + 31.1 ns ± 400 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.97x + Block popcount, length 31 + chunkPopCount2: OK (0.60s) + 35.2 ns ± 684 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (0.61s) + 36.3 ns ± 642 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 1.03x + Block popcount, length 63 + chunkPopCount2: OK (0.76s) + 45.0 ns ± 772 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (2.96s) + 44.1 ns ± 174 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.98x + Block popcount, length 127 + chunkPopCount2: OK (1.05s) + 62.0 ns ± 740 ps, 39 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (1.00s) + 59.3 ns ± 986 ps, 39 B allocated, 0 B copied, 47 MB peak memory, 0.96x + Block popcount, length 255 + chunkPopCount2: OK (0.85s) + 100 ns ± 1.3 ns, 38 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (0.80s) + 93.4 ns ± 1.3 ns, 38 B allocated, 0 B copied, 47 MB peak memory, 0.93x + Block popcount, length 511 + chunkPopCount2: OK (0.75s) + 175 ns ± 2.7 ns, 31 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (0.68s) + 160 ns ± 2.7 ns, 31 B allocated, 0 B copied, 47 MB peak memory, 0.91x + Block popcount, length 1023 + chunkPopCount2: OK (0.70s) + 330 ns ± 5.2 ns, 25 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (0.63s) + 294 ns ± 5.5 ns, 25 B allocated, 0 B copied, 47 MB peak memory, 0.89x + Block popcount, length 2047 + chunkPopCount2: OK (1.32s) + 624 ns ± 5.6 ns, 25 B allocated, 0 B copied, 47 MB peak memory + chunkPopCount3: OK (0.60s) + 562 ns ± 10 ns, 0 B allocated, 0 B copied, 47 MB peak memory, 0.90x +``` + +We can see that the benefits of the third approach versus the second amount to +10% better performance at most, and even that only occurs at length 511 and +higher. At the same time, for lengths below 15, there can be up to a 15% penalty +for using the third approach over the second. + ## Conclusion and recommendations We do not believe the use of the FFI and implementing any operations in @@ -654,6 +878,13 @@ using the first approach in all cases is acceptable; however, we don't believe that the extra code represents significant maintenance or runtime overheads, and while inputs of this size would be unlikely, they're not impossible. +Popcount should be implemented using the second (`Word64`-width bit-parallel) +approach only. The first (naive) approach is not significantly better at any +length, and the third (`Word256`-width bit parallel) approach only out-performs +the second by a small margin for large inputs. While a 'hybrid' approach for +this operation may be possible in theory, the benefits relative the extra code +and its maintenance don't appear worthwhile. + ## Future work Many, if not most, of the operations here can be significantly accelerated using diff --git a/plutus-core/plutus-core/bench/bitwise/Implementations.hs b/plutus-core/plutus-core/bench/bitwise/Implementations.hs index 034bd5dfc13..60048185ec2 100644 --- a/plutus-core/plutus-core/bench/bitwise/Implementations.hs +++ b/plutus-core/plutus-core/bench/bitwise/Implementations.hs @@ -1,3 +1,4 @@ +-- editorconfig-checker-disable-file {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeApplications #-} diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 2ca9eb67839..838dcaa7dbb 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -1,3 +1,4 @@ +-- editorconfig-checker-disable-file {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} @@ -30,6 +31,7 @@ main = do bgroup bcompLabel . fmap (complementBench bcompLabel) $ sizes, bgroup bandLabel . fmap (andBench bandLabel) $ sizes, bgroup popCountLabel . fmap (popCountBench popCountLabel) $ sizes, + bgroup popCountLabel' . fmap (popCountBlockBench popCountLabel') $ sizes, bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes, bgroup bandLabel' . fmap (packedAndBench bandLabel') $ largerSizes, @@ -52,6 +54,8 @@ main = do bcompLabel' = "Bitwise complement probe" popCountLabel :: String popCountLabel = "Popcount" + popCountLabel' :: String + popCountLabel' = "Block popcount" rotateLabel :: String rotateLabel = "Slow rotate versus prescan" rotateLabel' :: String @@ -59,6 +63,21 @@ main = do -- Benchmarks +popCountBlockBench :: + String -> + Int -> + Benchmark +popCountBlockBench mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let cpLabel2 = "chunkPopCount2" + cpLabel3 = "chunkPopCount3" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> cpLabel2 <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench cpLabel2 . nfIO $ chunkPopCount2 <$> xs, + bcompare matchLabel . bench cpLabel3 . nfIO $ chunkPopCount3 <$> xs + ] + packedAndBench :: String -> Int -> From 812672c65e5d6e777d3eaad0c1bb35f88a959eaf Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 9 Aug 2022 14:16:47 +1200 Subject: [PATCH 38/73] Implement more options for bigger inputs, make benches bigger --- plutus-core/plutus-core.cabal | 8 ++- plutus-core/plutus-core/bench/bitwise/Main.hs | 57 ++++++++++++++++++- .../plutus-core/bench/bitwise/cbits/cbits.h | 9 +++ .../bench/bitwise/cbits/implementation.c | 31 ++++++++++ 4 files changed, 102 insertions(+), 3 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index cf4cb1b1898..1cd3ef7a57b 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -794,7 +794,13 @@ benchmark bitwise other-modules: Implementations include-dirs: plutus-core/bench/bitwise/cbits c-sources: plutus-core/bench/bitwise/cbits/implementation.c - cc-options: -O3 -msse2 + + if arch(x86_64) + cc-options: -O3 -mtune=intel + + else + cc-options: -O3 + build-depends: , base , bytestring diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 838dcaa7dbb..7d890bd2048 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -39,9 +39,9 @@ main = do ] where sizes :: [Int] - sizes = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047] + sizes = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767] largerSizes :: [Int] - largerSizes = [31, 63, 127, 255, 511, 1023, 2047] + largerSizes = [31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767] probingSizes :: [Int] probingSizes = [511, 767, 1023] bandLabel :: String @@ -85,6 +85,7 @@ packedAndBench :: packedAndBench mainLabel len = withResource (mkBinaryArgs len) noCleanup $ \xs -> let pzwLabel = "packZipWith" + pzwLabel' = "packZipWith (C)" czwLabel2 = "chunkedZipWith (2 blocks)" czwLabel2' = "chunkedZipWith (2 blocks, C)" czwLabel3 = "chunkedZipWith (3 blocks)" @@ -93,6 +94,7 @@ packedAndBench mainLabel len = matchLabel = "$NF == \"" <> pzwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ bench pzwLabel . nfIO $ uncurry (zipWithBinary (.&.)) <$> xs, + bcompare matchLabel . bench pzwLabel' . nfIO $ uncurry candBinaryNaive <$> xs, bcompare matchLabel . bench czwLabel2 . nfIO $ uncurry (chunkZipWith2 (.&.) (.&.)) <$> xs, bcompare matchLabel . bench czwLabel2' . nfIO $ uncurry candBinary2 <$> xs, bcompare matchLabel . bench czwLabel3 . nfIO $ uncurry (chunkZipWith3 (.&.) (.&.) (.&.)) <$> xs, @@ -140,12 +142,14 @@ popCountBench :: popCountBench mainLabel len = withResource (mkUnaryArg len) noCleanup $ \xs -> let fLabel = "foldl'" + fLabel' = "foldl' (C)" cpLabel2 = "chunkPopCount2" cpLabel3 = "chunkPopCount3" testLabel = mainLabel <> ", length " <> show len matchLabel = "$NF == \"" <> fLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ bench fLabel . nfIO $ BS.foldl' (\acc w8 -> acc + popCount w8) 0 <$> xs, + bcompare matchLabel . bench fLabel' . nfIO $ popcountNaive <$> xs, bcompare matchLabel . bench cpLabel2 . nfIO $ chunkPopCount2 <$> xs, bcompare matchLabel . bench cpLabel3 . nfIO $ chunkPopCount3 <$> xs ] @@ -157,6 +161,7 @@ complementBench :: complementBench mainLabel len = withResource (mkUnaryArg len) noCleanup $ \xs -> let mLabel = "map" + mLabel' = "map (C)" cmLabel2 = "chunkedMap (2 blocks)" cmLabel2' = "chunkedMap (2 blocks, C)" cmLabel3 = "chunkMap (3 blocks)" @@ -164,6 +169,7 @@ complementBench mainLabel len = matchLabel = "$NF == \"" <> mLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ bench mLabel . nfIO $ BS.map complement <$> xs, + bcompare matchLabel . bench mLabel' . nfIO $ ccomplementNaive <$> xs, bcompare matchLabel . bench cmLabel2 . nfIO $ chunkMap2 complement complement <$> xs, bcompare matchLabel . bench cmLabel2' . nfIO $ ccomplement <$> xs, bcompare matchLabel . bench cmLabel3 . nfIO $ chunkMap3 complement complement complement <$> xs @@ -177,6 +183,7 @@ andBench mainLabel len = withResource (mkBinaryArgs len) noCleanup $ \xs -> let zwLabel = "zipWith" pzwLabel = "packZipWith" + pzwLabel' = "packZipWith (C)" czwLabel2 = "chunkedZipWith (2 blocks)" czwLabel2' = "chunkedZipWith (2 blocks, C)" czwLabel3 = "chunkedZipWith (3 blocks)" @@ -186,6 +193,7 @@ andBench mainLabel len = bgroup testLabel [ bench zwLabel . nfIO $ uncurry (zipWithBinary (.&.)) <$> xs, bcompare matchLabel . bench pzwLabel . nfIO $ uncurry (packZipWithBinary (.&.)) <$> xs, + bcompare matchLabel . bench pzwLabel' . nfIO $ uncurry candBinaryNaive <$> xs, bcompare matchLabel . bench czwLabel2 . nfIO $ uncurry (chunkZipWith2 (.&.) (.&.)) <$> xs, bcompare matchLabel . bench czwLabel2' . nfIO $ uncurry candBinary2 <$> xs, bcompare matchLabel . bench czwLabel3 . nfIO $ uncurry (chunkZipWith3 (.&.) (.&.) (.&.)) <$> xs, @@ -243,6 +251,17 @@ candBinary3 bs bs' candImplementation3 dst (castPtr src) (castPtr src') (fromIntegral len) unsafePackMallocCStringLen (castPtr dst, len) +-- Same as above, but as obvious as possible +candBinaryNaive :: ByteString -> ByteString -> Maybe ByteString +candBinaryNaive bs bs' + | BS.length bs /= BS.length bs' = Nothing + | otherwise = pure . unsafeDupablePerformIO . + unsafeUseAsCStringLen bs $ \(src, len) -> + unsafeUseAsCStringLen bs' $ \(src', _) -> do + dst <- mallocBytes len + candImplementationNaive dst (castPtr src) (castPtr src') (fromIntegral len) + unsafePackMallocCStringLen (castPtr dst, len) + -- Wrapper for raw C bitwise complement ccomplement :: ByteString -> ByteString ccomplement bs = unsafeDupablePerformIO . @@ -251,6 +270,27 @@ ccomplement bs = unsafeDupablePerformIO . ccomplementImplementation dst (castPtr src) (fromIntegral len) unsafePackMallocCStringLen (castPtr dst, len) +ccomplementNaive :: ByteString -> ByteString +ccomplementNaive bs = unsafeDupablePerformIO . + unsafeUseAsCStringLen bs $ \(src, len) -> do + dst <- mallocBytes len + ccomplementImplementationNaive dst (castPtr src) (fromIntegral len) + unsafePackMallocCStringLen (castPtr dst, len) + +popcountNaive :: ByteString -> Int +popcountNaive bs = unsafeDupablePerformIO . + unsafeUseAsCStringLen bs $ \(src, len) -> do + let res = cpopcountNaive (castPtr src) (fromIntegral len) + pure . fromIntegral $ res + +foreign import ccall unsafe "cbits.h c_and_implementation_naive" + candImplementationNaive :: + Ptr CUChar -> + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () + foreign import ccall unsafe "cbits.h c_and_implementation" candImplementation2 :: Ptr CUChar -> @@ -273,3 +313,16 @@ foreign import ccall unsafe "cbits.h c_complement_implementation" Ptr CUChar -> CSize -> IO () + +foreign import ccall unsafe "cbits.h c_complement_implementation_naive" + ccomplementImplementationNaive :: + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () + +foreign import ccall unsafe "cbits.h c_popcount_naive" + cpopcountNaive :: + Ptr CUChar -> + CSize -> + CSize diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index f65369d27f0..b209f615a95 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -3,6 +3,11 @@ #include +size_t c_popcount_naive(unsigned char const *src, size_t const len); + +void c_and_implementation_naive(unsigned char *dst, unsigned char const *src1, + unsigned char const *src2, size_t const len); + void c_and_implementation(unsigned char *dst, unsigned char const *src1, unsigned char const *src2, size_t const len); @@ -12,4 +17,8 @@ void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, void c_complement_implementation(unsigned char *dst, unsigned char const *src, size_t const len); +void c_complement_implementation_naive(unsigned char *dst, + unsigned char const *src, + size_t const len); + #endif /* CBITS_H */ diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c index 156aae932ff..5913cc71d49 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c @@ -1,5 +1,14 @@ #include "cbits.h" +size_t c_popcount_naive(unsigned char const *src, size_t const len) { + size_t total = 0; + for (size_t i = 0; i < len; i++) { + total += __builtin_popcount(*src); + src++; + } + return total; +} + void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, unsigned char const *src2, size_t const len) { size_t const big_step_size = sizeof(unsigned long long); @@ -80,6 +89,18 @@ void c_and_implementation(unsigned char *dst, unsigned char const *src1, } } +void c_and_implementation_naive(unsigned char *dst, unsigned char const *src1, + unsigned char const *src2, size_t const len) { + for (size_t i = 0; i < len; i++) { + unsigned char const x = *src1; + unsigned char const y = *src2; + *dst = x & y; + src1++; + src2++; + dst++; + } +} + void c_complement_implementation(unsigned char *dst, unsigned char const *src, size_t const len) { size_t const big_step_size = sizeof(unsigned long long); @@ -102,3 +123,13 @@ void c_complement_implementation(unsigned char *dst, unsigned char const *src, small_dst++; } } + +void c_complement_implementation_naive(unsigned char *dst, + unsigned char const *src, + size_t const len) { + for (size_t i = 0; i < len; i++) { + *dst = ~(*src); + src++; + dst++; + } +} From c6b6ba9d3f850dcbe1a503891ec8762f86f05bc0 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 11 Aug 2022 07:36:35 +1200 Subject: [PATCH 39/73] Tune FFI settings, more AND benches --- plutus-core/plutus-core.cabal | 8 +------ plutus-core/plutus-core/bench/bitwise/Main.hs | 22 ++++++++++++++++++- 2 files changed, 22 insertions(+), 8 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 1cd3ef7a57b..5a279eb0132 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -794,13 +794,7 @@ benchmark bitwise other-modules: Implementations include-dirs: plutus-core/bench/bitwise/cbits c-sources: plutus-core/bench/bitwise/cbits/implementation.c - - if arch(x86_64) - cc-options: -O3 -mtune=intel - - else - cc-options: -O3 - + cc-options: -O3 build-depends: , base , bytestring diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 7d890bd2048..890b7653b71 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -35,7 +35,8 @@ main = do bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes, bgroup bandLabel' . fmap (packedAndBench bandLabel') $ largerSizes, - bgroup bcompLabel' . fmap (complementBench bcompLabel') $ probingSizes + bgroup bcompLabel' . fmap (complementBench bcompLabel') $ probingSizes, + bgroup bandCOnlyLabel . fmap (andCOnlyBench bandCOnlyLabel) $ sizes ] where sizes :: [Int] @@ -60,6 +61,8 @@ main = do rotateLabel = "Slow rotate versus prescan" rotateLabel' :: String rotateLabel' = "Bitwise rotate versus block rotate" + bandCOnlyLabel :: String + bandCOnlyLabel = "C bitwise AND" -- Benchmarks @@ -78,6 +81,23 @@ popCountBlockBench mainLabel len = bcompare matchLabel . bench cpLabel3 . nfIO $ chunkPopCount3 <$> xs ] +andCOnlyBench :: + String -> + Int -> + Benchmark +andCOnlyBench mainLabel len = + withResource (mkBinaryArgs len) noCleanup $ \xs -> + let pzwLabel' = "packZipWith (C)" + czwLabel2' = "chunkedZipWith (2 blocks, C)" + czwLabel3' = "chunkedZipWith (3 blocks, C)" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> pzwLabel' <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench pzwLabel' . nfIO $ uncurry candBinaryNaive <$> xs, + bcompare matchLabel . bench czwLabel2' . nfIO $ uncurry candBinary2 <$> xs, + bcompare matchLabel . bench czwLabel3' . nfIO $ uncurry candBinary3 <$> xs + ] + packedAndBench :: String -> Int -> From e6166c790d253aaab2d328296557973b36850931 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 12 Aug 2022 11:19:29 +1200 Subject: [PATCH 40/73] Refactor popcount benchmarks --- plutus-core/plutus-core.cabal | 15 +++- .../bench/bitwise/Benches/Popcount.hs | 85 +++++++++++++++++++ .../plutus-core/bench/bitwise/DataGen.hs | 35 ++++++++ plutus-core/plutus-core/bench/bitwise/Main.hs | 84 ++---------------- .../plutus-core/bench/bitwise/cbits/cbits.h | 10 ++- .../bench/bitwise/cbits/implementation.c | 9 -- .../bench/bitwise/cbits/popcount.c | 63 ++++++++++++++ 7 files changed, 214 insertions(+), 87 deletions(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/Popcount.hs create mode 100644 plutus-core/plutus-core/bench/bitwise/DataGen.hs create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/popcount.c diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 5a279eb0132..0599c12bec7 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -791,10 +791,21 @@ benchmark bitwise hs-source-dirs: plutus-core/bench/bitwise default-language: Haskell2010 main-is: Main.hs - other-modules: Implementations + other-modules: + Benches.Popcount + DataGen + Implementations + include-dirs: plutus-core/bench/bitwise/cbits - c-sources: plutus-core/bench/bitwise/cbits/implementation.c + c-sources: + plutus-core/bench/bitwise/cbits/implementation.c + plutus-core/bench/bitwise/cbits/popcount.c + cc-options: -O3 + + if arch(x86_64) + cc-options: -mpopcnt + build-depends: , base , bytestring diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Popcount.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Popcount.hs new file mode 100644 index 00000000000..71572160ac5 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Popcount.hs @@ -0,0 +1,85 @@ +-- editorconfig-checker-disable-file +module Benches.Popcount ( + benches, + cBenches + ) where + +import Data.Bits (popCount) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import DataGen (mkUnaryArg, noCleanup, sizes) +import Foreign.C.Types (CSize (CSize), CUChar) +import Foreign.Ptr (Ptr, castPtr) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Basic popcount" $ benchBasic "Basic popcount" <$> sizes + +cBenches :: Benchmark +cBenches = bgroup "C popcount" $ benchC "C popcount" <$> sizes + +-- Helpers + +-- Benchmark a naive Haskell implementation against all the C ones +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let naiveLabel = "foldl'" + cnaiveLabel = "naive C" + cblockLabel = "block C" + cblockUnrollLabel = "block unrolled C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench naiveLabel . nfIO $ BS.foldl' (\acc w8 -> acc + popCount w8) 0 <$> xs, + bcompare matchLabel . bench cnaiveLabel . nfIO $ xs >>= wrapping cPopcountNaive, + bcompare matchLabel . bench cblockLabel . nfIO $ xs >>= wrapping cPopcountBlock, + bcompare matchLabel . bench cblockUnrollLabel . nfIO $ xs >>= wrapping cPopcountBlockUnroll + ] + +-- Benchmark naive C against the other C ones +benchC :: + String -> + Int -> + Benchmark +benchC mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let cnaiveLabel = "naive C" + cblockLabel = "block C" + cblockUnrollLabel = "block unrolled C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> cnaiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench cnaiveLabel . nfIO $ xs >>= wrapping cPopcountNaive, + bcompare matchLabel . bench cblockLabel . nfIO $ xs >>= wrapping cPopcountBlock, + bcompare matchLabel . bench cblockUnrollLabel . nfIO $ xs >>= wrapping cPopcountBlockUnroll + ] + + +-- Avoids having to rewrap C popcount ops tediously each time +wrapping :: (Ptr CUChar -> CSize -> CSize) -> ByteString -> IO CSize +wrapping f bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> + pure $ f (castPtr ptr) (fromIntegral len) + +foreign import ccall unsafe "cbits.h c_popcount_naive" + cPopcountNaive :: + Ptr CUChar -> + CSize -> + CSize + +foreign import ccall unsafe "cbits.h c_popcount_block" + cPopcountBlock :: + Ptr CUChar -> + CSize -> + CSize + +foreign import ccall unsafe "cbits.h c_popcount_block_unroll" + cPopcountBlockUnroll :: + Ptr CUChar -> + CSize -> + CSize diff --git a/plutus-core/plutus-core/bench/bitwise/DataGen.hs b/plutus-core/plutus-core/bench/bitwise/DataGen.hs new file mode 100644 index 00000000000..bc7f8485fb5 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/DataGen.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module DataGen ( + mkUnaryArg, + mkBinaryArgs, + sizes, + noCleanup, + ) where + +import Control.Monad (replicateM) +import Data.ByteString (ByteString) +import Data.Kind (Type) +import GHC.Exts (fromListN) +import System.Random.Stateful (mkStdGen, randomM, runStateGen_) + +-- Generate a ByteString of a given length +mkUnaryArg :: Int -> IO ByteString +mkUnaryArg len = pure . runStateGen_ (mkStdGen 42) $ \gen -> + fromListN len <$> replicateM len (randomM gen) + +-- Generate two ByteStrings, both of a given length +mkBinaryArgs :: Int -> IO (ByteString, ByteString) +mkBinaryArgs len = pure . runStateGen_ (mkStdGen 42) $ \gen -> + (,) <$> (fromListN len <$> replicateM len (randomM gen)) <*> + (fromListN len <$> replicateM len (randomM gen)) + +-- We work in IO only to avoid interference, so thus, a cleanup isn't needed for +-- withResource. This function is designed to indicate that fact. +noCleanup :: forall (a :: Type) . a -> IO () +noCleanup = const (pure ()) + +-- Basic set of sizes (in bytes) +sizes :: [Int] +sizes = [((2 :: Int) ^ (i :: Int) - 1) | i <- [1 .. 15]] diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 890b7653b71..2a153bc833d 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -5,33 +5,33 @@ module Main (main) where -import Control.Monad (replicateM) -import Data.Bits (complement, popCount, zeroBits, (.&.)) +import Benches.Popcount qualified as Popcount +import Data.Bits (complement, zeroBits, (.&.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) -import Data.Kind (Type) import Data.Word (Word8) +import DataGen (mkBinaryArgs, mkUnaryArg, noCleanup, sizes) import Foreign.C.Types (CSize (CSize), CUChar) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr) import GHC.Exts (fromListN) import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Implementations (chunkMap2, chunkMap3, chunkPopCount2, chunkPopCount3, chunkZipWith2, chunkZipWith3, - packZipWithBinary, rotateBS, rotateBSFast) +import Implementations (chunkMap2, chunkMap3, chunkZipWith2, chunkZipWith3, packZipWithBinary, rotateBS, rotateBSFast) import System.IO.Unsafe (unsafeDupablePerformIO) -import System.Random.Stateful (mkStdGen, randomM, runStateGen_) -import Test.Tasty (withResource) +import Test.Tasty (testGroup, withResource) import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nfIO) main :: IO () main = do setLocaleEncoding utf8 defaultMain [ + testGroup "Popcount" [ + Popcount.benches, + Popcount.cBenches + ], bgroup bcompLabel . fmap (complementBench bcompLabel) $ sizes, bgroup bandLabel . fmap (andBench bandLabel) $ sizes, - bgroup popCountLabel . fmap (popCountBench popCountLabel) $ sizes, - bgroup popCountLabel' . fmap (popCountBlockBench popCountLabel') $ sizes, bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes, bgroup bandLabel' . fmap (packedAndBench bandLabel') $ largerSizes, @@ -39,8 +39,6 @@ main = do bgroup bandCOnlyLabel . fmap (andCOnlyBench bandCOnlyLabel) $ sizes ] where - sizes :: [Int] - sizes = [1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767] largerSizes :: [Int] largerSizes = [31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767] probingSizes :: [Int] @@ -53,10 +51,6 @@ main = do bcompLabel = "Bitwise complement" bcompLabel' :: String bcompLabel' = "Bitwise complement probe" - popCountLabel :: String - popCountLabel = "Popcount" - popCountLabel' :: String - popCountLabel' = "Block popcount" rotateLabel :: String rotateLabel = "Slow rotate versus prescan" rotateLabel' :: String @@ -66,21 +60,6 @@ main = do -- Benchmarks -popCountBlockBench :: - String -> - Int -> - Benchmark -popCountBlockBench mainLabel len = - withResource (mkUnaryArg len) noCleanup $ \xs -> - let cpLabel2 = "chunkPopCount2" - cpLabel3 = "chunkPopCount3" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> cpLabel2 <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench cpLabel2 . nfIO $ chunkPopCount2 <$> xs, - bcompare matchLabel . bench cpLabel3 . nfIO $ chunkPopCount3 <$> xs - ] - andCOnlyBench :: String -> Int -> @@ -155,25 +134,6 @@ rotateVsPrescanBench mainLabel len = (BS.all (== complement zeroBits) <$> xs) ] -popCountBench :: - String -> - Int -> - Benchmark -popCountBench mainLabel len = - withResource (mkUnaryArg len) noCleanup $ \xs -> - let fLabel = "foldl'" - fLabel' = "foldl' (C)" - cpLabel2 = "chunkPopCount2" - cpLabel3 = "chunkPopCount3" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> fLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench fLabel . nfIO $ BS.foldl' (\acc w8 -> acc + popCount w8) 0 <$> xs, - bcompare matchLabel . bench fLabel' . nfIO $ popcountNaive <$> xs, - bcompare matchLabel . bench cpLabel2 . nfIO $ chunkPopCount2 <$> xs, - bcompare matchLabel . bench cpLabel3 . nfIO $ chunkPopCount3 <$> xs - ] - complementBench :: String -> Int -> @@ -220,22 +180,8 @@ andBench mainLabel len = bcompare matchLabel . bench czwLabel3' . nfIO $ uncurry candBinary3 <$> xs ] --- Generators - -mkUnaryArg :: Int -> IO ByteString -mkUnaryArg len = pure . runStateGen_ (mkStdGen 42) $ \gen -> - fromListN len <$> replicateM len (randomM gen) - -mkBinaryArgs :: Int -> IO (ByteString, ByteString) -mkBinaryArgs len = pure . runStateGen_ (mkStdGen 42) $ \gen -> - (,) <$> (fromListN len <$> replicateM len (randomM gen)) <*> - (fromListN len <$> replicateM len (randomM gen)) - -- Helpers -noCleanup :: forall (a :: Type) . a -> IO () -noCleanup = const (pure ()) - -- Naive implementations for comparison zipWithBinary :: (Word8 -> Word8 -> Word8) -> @@ -297,12 +243,6 @@ ccomplementNaive bs = unsafeDupablePerformIO . ccomplementImplementationNaive dst (castPtr src) (fromIntegral len) unsafePackMallocCStringLen (castPtr dst, len) -popcountNaive :: ByteString -> Int -popcountNaive bs = unsafeDupablePerformIO . - unsafeUseAsCStringLen bs $ \(src, len) -> do - let res = cpopcountNaive (castPtr src) (fromIntegral len) - pure . fromIntegral $ res - foreign import ccall unsafe "cbits.h c_and_implementation_naive" candImplementationNaive :: Ptr CUChar -> @@ -340,9 +280,3 @@ foreign import ccall unsafe "cbits.h c_complement_implementation_naive" Ptr CUChar -> CSize -> IO () - -foreign import ccall unsafe "cbits.h c_popcount_naive" - cpopcountNaive :: - Ptr CUChar -> - CSize -> - CSize diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index b209f615a95..859900cdace 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -3,7 +3,15 @@ #include -size_t c_popcount_naive(unsigned char const *src, size_t const len); +// Popcount + +size_t c_popcount_naive(unsigned char const *restrict src, size_t const len); + +size_t c_popcount_block(unsigned char const *restrict src, size_t len); + +size_t c_popcount_block_unroll(unsigned char const *restrict src, size_t len); + +// Others void c_and_implementation_naive(unsigned char *dst, unsigned char const *src1, unsigned char const *src2, size_t const len); diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c index 5913cc71d49..e80bc17f8d0 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c @@ -1,14 +1,5 @@ #include "cbits.h" -size_t c_popcount_naive(unsigned char const *src, size_t const len) { - size_t total = 0; - for (size_t i = 0; i < len; i++) { - total += __builtin_popcount(*src); - src++; - } - return total; -} - void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, unsigned char const *src2, size_t const len) { size_t const big_step_size = sizeof(unsigned long long); diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/popcount.c b/plutus-core/plutus-core/bench/bitwise/cbits/popcount.c new file mode 100644 index 00000000000..90d549d8e86 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/popcount.c @@ -0,0 +1,63 @@ +#include "cbits.h" + +size_t c_popcount_naive(unsigned char const *restrict src, size_t const len) { + size_t total = 0; + for (size_t i = 0; i < len; i++) { + total += __builtin_popcount(src[i]); + } + return total; +} + +/* + * We take advantage of the fact that a single POPCNT instruction can count an + * entire register's worth of bits, rather than a single byte. To aid GCC in + * doing this, we do a classic strip mine: first count at unsigned long long + * width, then finish off with byte-at-a-time. + * + * Strip mining: + * http://physics.ujep.cz/~zmoravec/prga/main_for/mergedProjects/optaps_for/common/optaps_vec_mine.htm + */ +size_t c_popcount_block(unsigned char const *restrict src, size_t len) { + size_t total = 0; + while (len >= sizeof(unsigned long long)) { + total += __builtin_popcountll(*(unsigned long long const *restrict)src); + src += sizeof(unsigned long long); + len -= sizeof(unsigned long long); + } + while (len > 0) { + total += __builtin_popcount(*src); + src++; + len--; + } + return total; +} + +/* + * We further extend the popcount_block method by manually two-way unrolling + * the loop. This can take advantage of high throughput for the POPCNT + * instruction on modern x86 CPUs, as they can issue four POPCNT instructions + * simultaneously if data is available. + * + * Loop unrolling: + * https://en.wikipedia.org/wiki/Loop_unrolling#Static/manual_loop_unrolling + * Instruction tables for x86: + * https://www.agner.org/optimize/instruction_tables.pdf ILP (including + * multiple-issue): https://en.wikipedia.org/wiki/Instruction-level_parallelism + * Data dependency: https://en.wikipedia.org/wiki/Data_dependency + */ +size_t c_popcount_block_unroll(unsigned char const *restrict src, size_t len) { + size_t total = 0; + while (len >= 2 * sizeof(unsigned long long)) { + total += __builtin_popcountll(*(unsigned long long const *restrict)src); + total += __builtin_popcountll(*( + unsigned long long const *restrict)(src + sizeof(unsigned long long))); + src += 2 * sizeof(unsigned long long); + len -= 2 * sizeof(unsigned long long); + } + while (len > 0) { + total += __builtin_popcount(*src); + src++; + len--; + } + return total; +} From 87e21f97a336b743366f5f35c81ad3c8417c869a Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 12 Aug 2022 12:04:17 +1200 Subject: [PATCH 41/73] Refactor complement benches --- plutus-core/plutus-core.cabal | 2 + .../bench/bitwise/Benches/Complement.hs | 51 +++++++++++++++ plutus-core/plutus-core/bench/bitwise/Main.hs | 64 ++----------------- .../plutus-core/bench/bitwise/cbits/cbits.h | 12 ++-- .../bench/bitwise/cbits/complement.c | 8 +++ .../bench/bitwise/cbits/implementation.c | 33 ---------- 6 files changed, 71 insertions(+), 99 deletions(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/Complement.hs create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/complement.c diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 0599c12bec7..03254f8f34e 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -792,12 +792,14 @@ benchmark bitwise default-language: Haskell2010 main-is: Main.hs other-modules: + Benches.Complement Benches.Popcount DataGen Implementations include-dirs: plutus-core/bench/bitwise/cbits c-sources: + plutus-core/bench/bitwise/cbits/complement.c plutus-core/bench/bitwise/cbits/implementation.c plutus-core/bench/bitwise/cbits/popcount.c diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Complement.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Complement.hs new file mode 100644 index 00000000000..edc26420ef4 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Complement.hs @@ -0,0 +1,51 @@ +-- editorconfig-checker-disable-file +module Benches.Complement ( + benches + ) where + +import Data.Bits (complement) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Internal (fromForeignPtr, mallocByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import DataGen (mkUnaryArg, noCleanup, sizes) +import Foreign.C.Types (CSize (CSize), CUChar) +import Foreign.ForeignPtr (castForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, castPtr) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Basic complement" $ benchBasic "Basic complement" <$> sizes + +-- Helpers + +-- Benchmark a naive Haskell implementation against the C one +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let naiveLabel = "map" + cnaiveLabel = "naive C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench naiveLabel . nfIO $ BS.map complement <$> xs, + bcompare matchLabel . bench cnaiveLabel . nfIO $ xs >>= wrapping cComplementNaive + ] + +-- Avoids having to rewrap C complement ops tediously each time +wrapping :: (Ptr CUChar -> Ptr CUChar -> CSize -> IO ()) -> ByteString -> IO ByteString +wrapping f bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do + fp <- mallocByteString len + withForeignPtr fp $ \dst -> f dst (castPtr ptr) (fromIntegral len) + pure . fromForeignPtr (castForeignPtr fp) 0 $ len + +foreign import ccall unsafe "cbits.h c_complement_naive" + cComplementNaive :: + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 2a153bc833d..2fa9b9f7fca 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -5,6 +5,7 @@ module Main (main) where +import Benches.Complement qualified as Complement import Benches.Popcount qualified as Popcount import Data.Bits (complement, zeroBits, (.&.)) import Data.ByteString (ByteString) @@ -17,7 +18,7 @@ import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr) import GHC.Exts (fromListN) import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Implementations (chunkMap2, chunkMap3, chunkZipWith2, chunkZipWith3, packZipWithBinary, rotateBS, rotateBSFast) +import Implementations (chunkZipWith2, chunkZipWith3, packZipWithBinary, rotateBS, rotateBSFast) import System.IO.Unsafe (unsafeDupablePerformIO) import Test.Tasty (testGroup, withResource) import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nfIO) @@ -30,27 +31,22 @@ main = do Popcount.benches, Popcount.cBenches ], - bgroup bcompLabel . fmap (complementBench bcompLabel) $ sizes, + testGroup "Complement" [ + Complement.benches + ], bgroup bandLabel . fmap (andBench bandLabel) $ sizes, bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes, bgroup bandLabel' . fmap (packedAndBench bandLabel') $ largerSizes, - bgroup bcompLabel' . fmap (complementBench bcompLabel') $ probingSizes, bgroup bandCOnlyLabel . fmap (andCOnlyBench bandCOnlyLabel) $ sizes ] where largerSizes :: [Int] largerSizes = [31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767] - probingSizes :: [Int] - probingSizes = [511, 767, 1023] bandLabel :: String bandLabel = "Bitwise AND" bandLabel' :: String bandLabel' = "Packed bitwise AND" - bcompLabel :: String - bcompLabel = "Bitwise complement" - bcompLabel' :: String - bcompLabel' = "Bitwise complement probe" rotateLabel :: String rotateLabel = "Slow rotate versus prescan" rotateLabel' :: String @@ -134,27 +130,6 @@ rotateVsPrescanBench mainLabel len = (BS.all (== complement zeroBits) <$> xs) ] -complementBench :: - String -> - Int -> - Benchmark -complementBench mainLabel len = - withResource (mkUnaryArg len) noCleanup $ \xs -> - let mLabel = "map" - mLabel' = "map (C)" - cmLabel2 = "chunkedMap (2 blocks)" - cmLabel2' = "chunkedMap (2 blocks, C)" - cmLabel3 = "chunkMap (3 blocks)" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> mLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench mLabel . nfIO $ BS.map complement <$> xs, - bcompare matchLabel . bench mLabel' . nfIO $ ccomplementNaive <$> xs, - bcompare matchLabel . bench cmLabel2 . nfIO $ chunkMap2 complement complement <$> xs, - bcompare matchLabel . bench cmLabel2' . nfIO $ ccomplement <$> xs, - bcompare matchLabel . bench cmLabel3 . nfIO $ chunkMap3 complement complement complement <$> xs - ] - andBench :: String -> Int -> @@ -228,21 +203,6 @@ candBinaryNaive bs bs' candImplementationNaive dst (castPtr src) (castPtr src') (fromIntegral len) unsafePackMallocCStringLen (castPtr dst, len) --- Wrapper for raw C bitwise complement -ccomplement :: ByteString -> ByteString -ccomplement bs = unsafeDupablePerformIO . - unsafeUseAsCStringLen bs $ \(src, len) -> do - dst <- mallocBytes len - ccomplementImplementation dst (castPtr src) (fromIntegral len) - unsafePackMallocCStringLen (castPtr dst, len) - -ccomplementNaive :: ByteString -> ByteString -ccomplementNaive bs = unsafeDupablePerformIO . - unsafeUseAsCStringLen bs $ \(src, len) -> do - dst <- mallocBytes len - ccomplementImplementationNaive dst (castPtr src) (fromIntegral len) - unsafePackMallocCStringLen (castPtr dst, len) - foreign import ccall unsafe "cbits.h c_and_implementation_naive" candImplementationNaive :: Ptr CUChar -> @@ -266,17 +226,3 @@ foreign import ccall unsafe "cbits.h c_and_implementation_3" Ptr CUChar -> CSize -> IO () - -foreign import ccall unsafe "cbits.h c_complement_implementation" - ccomplementImplementation :: - Ptr CUChar -> - Ptr CUChar -> - CSize -> - IO () - -foreign import ccall unsafe "cbits.h c_complement_implementation_naive" - ccomplementImplementationNaive :: - Ptr CUChar -> - Ptr CUChar -> - CSize -> - IO () diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index 859900cdace..24715fbe549 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -11,6 +11,11 @@ size_t c_popcount_block(unsigned char const *restrict src, size_t len); size_t c_popcount_block_unroll(unsigned char const *restrict src, size_t len); +// Complement + +void c_complement_naive(unsigned char *restrict dst, + unsigned char const *restrict src, size_t const len); + // Others void c_and_implementation_naive(unsigned char *dst, unsigned char const *src1, @@ -22,11 +27,4 @@ void c_and_implementation(unsigned char *dst, unsigned char const *src1, void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, unsigned char const *src2, size_t const len); -void c_complement_implementation(unsigned char *dst, unsigned char const *src, - size_t const len); - -void c_complement_implementation_naive(unsigned char *dst, - unsigned char const *src, - size_t const len); - #endif /* CBITS_H */ diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/complement.c b/plutus-core/plutus-core/bench/bitwise/cbits/complement.c new file mode 100644 index 00000000000..f3e5e90f9d2 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/complement.c @@ -0,0 +1,8 @@ +#include "cbits.h" + +void c_complement_naive(unsigned char *restrict dst, + unsigned char const *restrict src, size_t const len) { + for (size_t i = 0; i < len; i++) { + dst[i] = ~(src[i]); + } +} diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c index e80bc17f8d0..77b5fab55e4 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c @@ -91,36 +91,3 @@ void c_and_implementation_naive(unsigned char *dst, unsigned char const *src1, dst++; } } - -void c_complement_implementation(unsigned char *dst, unsigned char const *src, - size_t const len) { - size_t const big_step_size = sizeof(unsigned long long); - size_t const big_steps = len / big_step_size; - size_t const small_steps = len % big_step_size; - unsigned long long *big_src = (unsigned long long *)src; - unsigned long long *big_dst = (unsigned long long *)dst; - for (size_t i = 0; i < big_steps; i++) { - unsigned long long const x = *big_src; - *big_dst = ~x; - big_src++; - big_dst++; - } - unsigned char *small_src = (unsigned char *)big_src; - unsigned char *small_dst = (unsigned char *)big_dst; - for (size_t i = 0; i < small_steps; i++) { - unsigned char const x = *small_src; - *small_dst = ~x; - small_src++; - small_dst++; - } -} - -void c_complement_implementation_naive(unsigned char *dst, - unsigned char const *src, - size_t const len) { - for (size_t i = 0; i < len; i++) { - *dst = ~(*src); - src++; - dst++; - } -} From 0b82ca5bb139e386d202866a45699c0ead273d7c Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Tue, 16 Aug 2022 14:44:20 +1200 Subject: [PATCH 42/73] More benches for popcount, complement --- plutus-core/plutus-core.cabal | 2 +- plutus-core/plutus-core/bench/bitwise/cbits/complement.c | 1 + plutus-core/plutus-core/bench/bitwise/cbits/popcount.c | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 03254f8f34e..fd793536f05 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -806,7 +806,7 @@ benchmark bitwise cc-options: -O3 if arch(x86_64) - cc-options: -mpopcnt + cc-options: -mpopcnt -mbmi build-depends: , base diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/complement.c b/plutus-core/plutus-core/bench/bitwise/cbits/complement.c index f3e5e90f9d2..3395957de6d 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/complement.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/complement.c @@ -1,4 +1,5 @@ #include "cbits.h" +#include void c_complement_naive(unsigned char *restrict dst, unsigned char const *restrict src, size_t const len) { diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/popcount.c b/plutus-core/plutus-core/bench/bitwise/cbits/popcount.c index 90d549d8e86..0bcf714c8af 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/popcount.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/popcount.c @@ -1,4 +1,5 @@ #include "cbits.h" +#include size_t c_popcount_naive(unsigned char const *restrict src, size_t const len) { size_t total = 0; From 581924f350f89f44f718ee61190cda5a50936150 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 17 Aug 2022 14:34:40 +1200 Subject: [PATCH 43/73] Benches for homogeneity testing --- plutus-core/plutus-core.cabal | 2 + .../bench/bitwise/Benches/Homogenous.hs | 56 +++++++++++++++++++ .../plutus-core/bench/bitwise/DataGen.hs | 7 +++ plutus-core/plutus-core/bench/bitwise/Main.hs | 4 ++ .../plutus-core/bench/bitwise/cbits/cbits.h | 11 ++++ .../bench/bitwise/cbits/homogenous.c | 31 ++++++++++ 6 files changed, 111 insertions(+) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/Homogenous.hs create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/homogenous.c diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index fd793536f05..677f267f4ab 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -793,6 +793,7 @@ benchmark bitwise main-is: Main.hs other-modules: Benches.Complement + Benches.Homogenous Benches.Popcount DataGen Implementations @@ -800,6 +801,7 @@ benchmark bitwise include-dirs: plutus-core/bench/bitwise/cbits c-sources: plutus-core/bench/bitwise/cbits/complement.c + plutus-core/bench/bitwise/cbits/homogenous.c plutus-core/bench/bitwise/cbits/implementation.c plutus-core/bench/bitwise/cbits/popcount.c diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Homogenous.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Homogenous.hs new file mode 100644 index 00000000000..bd93b26fd4a --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Homogenous.hs @@ -0,0 +1,56 @@ +module Benches.Homogenous ( + benches + ) where + +import Data.Bits (zeroBits) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Word (Word8) +import DataGen (mkHomogenousArg, noCleanup, sizes) +import Foreign.C.Types (CBool (CBool), CSize (CSize), CUChar) +import Foreign.Ptr (Ptr, castPtr) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Basic homogeneity" $ benchBasic "Basic homogeneity" <$> sizes + +-- Helpers + +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkHomogenousArg len zeroBits) noCleanup $ \xs -> + let naiveLabel = "all" + cnaiveLabel = "naive C" + cslidingLabel = "sliding window C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench naiveLabel . nfIO $ BS.all (== zeroBits) <$> xs, + bcompare matchLabel . bench cnaiveLabel . nfIO $ xs >>= wrapping (cHomogenousNaive zeroBits), + bcompare matchLabel . bench cslidingLabel . nfIO $ xs >>= wrapping (cHomogenousSlidingWindow zeroBits) + ] + +-- Avoids having to rewrap C ops tediously each time +wrapping :: (Ptr CUChar -> CSize -> CBool) -> ByteString -> IO Bool +wrapping f bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do + let (CBool res) = f (castPtr ptr) (fromIntegral len) + pure $ res /= 0 + +foreign import ccall unsafe "cbits.h c_homogenous_naive" + cHomogenousNaive :: + Word8 -> + Ptr CUChar -> + CSize -> + CBool + +foreign import ccall unsafe "cbits.h c_homogenous_sliding_window" + cHomogenousSlidingWindow :: + Word8 -> + Ptr CUChar -> + CSize -> + CBool diff --git a/plutus-core/plutus-core/bench/bitwise/DataGen.hs b/plutus-core/plutus-core/bench/bitwise/DataGen.hs index bc7f8485fb5..1fbab3696f4 100644 --- a/plutus-core/plutus-core/bench/bitwise/DataGen.hs +++ b/plutus-core/plutus-core/bench/bitwise/DataGen.hs @@ -3,6 +3,7 @@ module DataGen ( mkUnaryArg, + mkHomogenousArg, mkBinaryArgs, sizes, noCleanup, @@ -10,7 +11,9 @@ module DataGen ( import Control.Monad (replicateM) import Data.ByteString (ByteString) +import Data.ByteString qualified as BS import Data.Kind (Type) +import Data.Word (Word8) import GHC.Exts (fromListN) import System.Random.Stateful (mkStdGen, randomM, runStateGen_) @@ -19,6 +22,10 @@ mkUnaryArg :: Int -> IO ByteString mkUnaryArg len = pure . runStateGen_ (mkStdGen 42) $ \gen -> fromListN len <$> replicateM len (randomM gen) +-- Generate a ByteString of a given length full of the given byte +mkHomogenousArg :: Int -> Word8 -> IO ByteString +mkHomogenousArg len = pure . BS.replicate len + -- Generate two ByteStrings, both of a given length mkBinaryArgs :: Int -> IO (ByteString, ByteString) mkBinaryArgs len = pure . runStateGen_ (mkStdGen 42) $ \gen -> diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 2fa9b9f7fca..ad175b8151b 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -6,6 +6,7 @@ module Main (main) where import Benches.Complement qualified as Complement +import Benches.Homogenous qualified as Homogenous import Benches.Popcount qualified as Popcount import Data.Bits (complement, zeroBits, (.&.)) import Data.ByteString (ByteString) @@ -34,6 +35,9 @@ main = do testGroup "Complement" [ Complement.benches ], + testGroup "Homogenous" [ + Homogenous.benches + ], bgroup bandLabel . fmap (andBench bandLabel) $ sizes, bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes, diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index 24715fbe549..d48bb935f45 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -1,6 +1,7 @@ #ifndef CBITS_H #define CBITS_H +#include #include // Popcount @@ -16,6 +17,16 @@ size_t c_popcount_block_unroll(unsigned char const *restrict src, size_t len); void c_complement_naive(unsigned char *restrict dst, unsigned char const *restrict src, size_t const len); +// Homogeneity + +bool c_homogenous_naive(unsigned char const needle, + unsigned char const *restrict haystack, + size_t const len); + +bool c_homogenous_sliding_window(unsigned char const needle, + unsigned char const *restrict haystack, + size_t len); + // Others void c_and_implementation_naive(unsigned char *dst, unsigned char const *src1, diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/homogenous.c b/plutus-core/plutus-core/bench/bitwise/cbits/homogenous.c new file mode 100644 index 00000000000..cdc28ef873d --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/homogenous.c @@ -0,0 +1,31 @@ +#include "cbits.h" +#include + +bool c_homogenous_naive(unsigned char const needle, + unsigned char const *restrict haystack, + size_t const len) { + bool homogenous = true; + for (size_t i = 0; i < len; i++) { + if (haystack[i] != needle) { + homogenous = false; + break; + } + } + return homogenous; +} + +bool c_homogenous_sliding_window(unsigned char const needle, + unsigned char const *restrict haystack, + size_t len) { + for (size_t i = 0; i < 16; i++) { + if (len == 0) { + return true; + } + if (haystack[0] != needle) { + return false; + } + haystack++; + len--; + } + return (memcmp(haystack - 16, haystack, len) == 0); +} From 996fe3cc73b0ce7d634f288ab1092e3ffc099358 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 18 Aug 2022 14:25:27 +1200 Subject: [PATCH 44/73] Better AND benches, CLZ benches --- plutus-core/plutus-core.cabal | 8 +- .../bench/bitwise/Benches/Binary.hs | 88 ++++++ .../bitwise/Benches/CountLeadingZeroes.hs | 66 ++++ .../plutus-core/bench/bitwise/DataGen.hs | 5 + .../bench/bitwise/Implementations.hs | 283 +----------------- plutus-core/plutus-core/bench/bitwise/Main.hs | 169 +---------- .../plutus-core/bench/bitwise/cbits/binary.c | 8 + .../plutus-core/bench/bitwise/cbits/cbits.h | 16 +- .../plutus-core/bench/bitwise/cbits/clz.c | 69 +++++ .../bench/bitwise/cbits/implementation.c | 93 ------ 10 files changed, 266 insertions(+), 539 deletions(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/Binary.hs create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/CountLeadingZeroes.hs create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/binary.c create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/clz.c delete mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/implementation.c diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 677f267f4ab..cd63796b95d 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -792,7 +792,9 @@ benchmark bitwise default-language: Haskell2010 main-is: Main.hs other-modules: + Benches.Binary Benches.Complement + Benches.CountLeadingZeroes Benches.Homogenous Benches.Popcount DataGen @@ -800,15 +802,16 @@ benchmark bitwise include-dirs: plutus-core/bench/bitwise/cbits c-sources: + plutus-core/bench/bitwise/cbits/binary.c + plutus-core/bench/bitwise/cbits/clz.c plutus-core/bench/bitwise/cbits/complement.c plutus-core/bench/bitwise/cbits/homogenous.c - plutus-core/bench/bitwise/cbits/implementation.c plutus-core/bench/bitwise/cbits/popcount.c cc-options: -O3 if arch(x86_64) - cc-options: -mpopcnt -mbmi + cc-options: -mpopcnt -mabm build-depends: , base @@ -816,6 +819,5 @@ benchmark bitwise , random , tasty , tasty-bench - , wide-word ghc-options: -O2 -rtsopts "-with-rtsopts=-A32m --nonmoving-gc -T" diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Binary.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Binary.hs new file mode 100644 index 00000000000..9150ee42436 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Binary.hs @@ -0,0 +1,88 @@ +module Benches.Binary ( + benches + ) where + +import Control.Monad (guard) +import Data.Bits ((.&.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Internal (fromForeignPtr, mallocByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Foldable (for_) +import Data.Word (Word8) +import DataGen (mkBinaryArgs, noCleanup, sizes) +import Foreign.C.Types (CSize (CSize), CUChar) +import Foreign.ForeignPtr (castForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, castPtr) +import Foreign.Storable (peekByteOff, pokeByteOff) +import GHC.Exts (fromList) +import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Basic AND" $ benchBasic "Basic AND" <$> sizes + +-- Helpers + +-- Benchmark a naive Haskell implementation against a clone of packZipWith and a +-- naive C one. +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkBinaryArgs len) noCleanup $ \xs -> + let naiveLabel = "zipWith" + packedLabel = "packedZipWith" + cnaiveLabel = "naive C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench naiveLabel . nfIO $ wrap usingZW <$> xs, + bcompare matchLabel . bench packedLabel . nfIO $ wrap usingPZW <$> xs, + bcompare matchLabel . bench cnaiveLabel . nfIO $ wrap usingCNaive <$> xs + ] + +-- Saves repeatedly doing the same thing +wrap :: + (ByteString -> ByteString -> ByteString) -> + (ByteString, ByteString) -> + Maybe ByteString +wrap f (bs1, bs2) = do + guard (BS.length bs2 == len) + pure . f bs1 $ bs2 + where + len :: Int + len = BS.length bs1 + +usingZW :: ByteString -> ByteString -> ByteString +usingZW bs = fromList . BS.zipWith (.&.) bs + +usingPZW :: ByteString -> ByteString -> ByteString +usingPZW bs1 bs2 = unsafeDupablePerformIO . + unsafeUseAsCStringLen bs1 $ \(ptr1, len) -> + unsafeUseAsCStringLen bs2 $ \(ptr2, _) -> do + fp <- mallocByteString len + withForeignPtr fp $ \dst -> for_ [0 .. len - 1] $ \i -> do + b1 :: Word8 <- peekByteOff ptr1 i + b2 <- peekByteOff ptr2 i + pokeByteOff dst i $ b1 .&. b2 + pure . fromForeignPtr (castForeignPtr fp) 0 $ len + +usingCNaive :: ByteString -> ByteString -> ByteString +usingCNaive bs1 bs2 = unsafeDupablePerformIO . + unsafeUseAsCStringLen bs1 $ \(ptr1, len) -> + unsafeUseAsCStringLen bs2 $ \(ptr2, _) -> do + fp <- mallocByteString len + withForeignPtr fp $ \dst -> + cAndNaive dst (castPtr ptr1) (castPtr ptr2) (fromIntegral len) + pure . fromForeignPtr (castForeignPtr fp) 0 $ len + +foreign import ccall unsafe "cbits.h c_and_naive" + cAndNaive :: + Ptr CUChar -> + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/CountLeadingZeroes.hs b/plutus-core/plutus-core/bench/bitwise/Benches/CountLeadingZeroes.hs new file mode 100644 index 00000000000..35906002ea3 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/CountLeadingZeroes.hs @@ -0,0 +1,66 @@ +module Benches.CountLeadingZeroes ( + benches + ) where + +import Data.Bits (countLeadingZeros, zeroBits) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Maybe (fromMaybe) +import DataGen (mkZeroesOne, noCleanup, sizes) +import Foreign.C.Types (CSize (CSize), CUChar) +import Foreign.Ptr (Ptr, castPtr) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Basic CLZ" $ benchBasic "CLZ" <$> sizes + +-- Helpers + +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkZeroesOne len) noCleanup $ \xs -> + let naiveLabel = "ByteString ops" + cnaiveLabel = "naive C" + cblockLabel = "block C" + cunrolledLabel = "unrolled C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench naiveLabel . nfIO $ naiveClz <$> xs, + bcompare matchLabel . bench cnaiveLabel . nfIO $ xs >>= wrapping cClzNaive, + bcompare matchLabel . bench cblockLabel . nfIO $ xs >>= wrapping cClzBlock, + bcompare matchLabel . bench cunrolledLabel . nfIO $ xs >>= wrapping cClzBlockUnrolled + ] + +naiveClz :: ByteString -> Int +naiveClz bs = fromMaybe (BS.length bs * 8) $ do + ix <- BS.findIndex (/= zeroBits) bs + pure $ ix * 8 + countLeadingZeros (BS.index bs ix) + +-- Avoids having to rewrap C ops tediously each time +wrapping :: (Ptr CUChar -> CSize -> CSize) -> ByteString -> IO Int +wrapping f bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> + pure . fromIntegral . f (castPtr ptr) . fromIntegral $ len + +foreign import ccall unsafe "cbits.h c_clz_naive" + cClzNaive :: + Ptr CUChar -> + CSize -> + CSize + +foreign import ccall unsafe "cbits.h c_clz_block" + cClzBlock :: + Ptr CUChar -> + CSize -> + CSize + +foreign import ccall unsafe "cbits.h c_clz_block_unrolled" + cClzBlockUnrolled :: + Ptr CUChar -> + CSize -> + CSize diff --git a/plutus-core/plutus-core/bench/bitwise/DataGen.hs b/plutus-core/plutus-core/bench/bitwise/DataGen.hs index 1fbab3696f4..5a7e5253966 100644 --- a/plutus-core/plutus-core/bench/bitwise/DataGen.hs +++ b/plutus-core/plutus-core/bench/bitwise/DataGen.hs @@ -5,6 +5,7 @@ module DataGen ( mkUnaryArg, mkHomogenousArg, mkBinaryArgs, + mkZeroesOne, sizes, noCleanup, ) where @@ -26,6 +27,10 @@ mkUnaryArg len = pure . runStateGen_ (mkStdGen 42) $ \gen -> mkHomogenousArg :: Int -> Word8 -> IO ByteString mkHomogenousArg len = pure . BS.replicate len +-- Generates n - 1 zeroes, followed by a one byte +mkZeroesOne :: Int -> IO ByteString +mkZeroesOne len = pure $ BS.snoc (BS.replicate (len - 1) 0x00) 0x01 + -- Generate two ByteStrings, both of a given length mkBinaryArgs :: Int -> IO (ByteString, ByteString) mkBinaryArgs len = pure . runStateGen_ (mkStdGen 42) $ \gen -> diff --git a/plutus-core/plutus-core/bench/bitwise/Implementations.hs b/plutus-core/plutus-core/bench/bitwise/Implementations.hs index 60048185ec2..8dfceb1f81f 100644 --- a/plutus-core/plutus-core/bench/bitwise/Implementations.hs +++ b/plutus-core/plutus-core/bench/bitwise/Implementations.hs @@ -1,296 +1,23 @@ -- editorconfig-checker-disable-file -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeApplications #-} - module Implementations ( - chunkZipWith2, - chunkMap2, - chunkMap3, - chunkZipWith3, - packZipWithBinary, - chunkPopCount2, - chunkPopCount3, rotateBS, rotateBSFast, ) where -import Control.Monad (foldM, void) -import Data.Bits (bit, popCount, rotate, zeroBits, (.&.), (.|.)) +import Control.Monad (void) +import Data.Bits (bit, rotate, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) -import Data.Foldable (foldl', for_, traverse_) -import Data.WideWord.Word256 (Word256) -import Data.Word (Word64, Word8) +import Data.Foldable (foldl', for_) +import Data.Word (Word8) import Foreign.C.Types (CSize) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (peek, peekElemOff, poke, pokeElemOff, sizeOf) +import Foreign.Storable (peek, poke) import GHC.IO.Handle.Text (memcpy) import System.IO.Unsafe (unsafeDupablePerformIO) -{-# INLINE chunkPopCount2 #-} -chunkPopCount2 :: ByteString -> Int -chunkPopCount2 bs = unsafeDupablePerformIO $ unsafeUseAsCStringLen bs $ \(src, len) -> do - let bigStepSize = sizeOf @Word64 undefined - let (bigSteps, smallSteps) = len `quotRem` bigStepSize - !bigCount <- foldM (bigStep (castPtr src)) 0 [0 .. bigSteps - 1] - let firstSmallPosition = bigSteps * bigStepSize - foldM (smallStep (castPtr src)) bigCount [firstSmallPosition .. firstSmallPosition + smallSteps - 1] - where - bigStep :: Ptr Word64 -> Int -> Int -> IO Int - bigStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset - smallStep :: Ptr Word8 -> Int -> Int -> IO Int - smallStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset - -{-# INLINE chunkPopCount3 #-} -chunkPopCount3 :: ByteString -> Int -chunkPopCount3 bs = unsafeDupablePerformIO $ unsafeUseAsCStringLen bs $ \(src, len) -> do - let bigStepSize = sizeOf @Word64 undefined - let biggestStepSize = sizeOf @Word256 undefined - let (biggestSteps, rest) = len `quotRem` biggestStepSize - let (bigSteps, smallSteps) = rest `quotRem` bigStepSize - !biggestCount <- foldM (biggestStep (castPtr src)) 0 [0 .. biggestSteps - 1] - -- We now have to compute a Word64 offset corresponding to - -- biggestSteps. This will be four times larger, as Word64 is - -- one-quarter the width of a Word256. - let firstBigPosition = biggestSteps * 4 - !bigCount <- foldM (bigStep (castPtr src)) - biggestCount - [firstBigPosition .. firstBigPosition + bigSteps - 1] - -- Same again, but now we have to multiply by 8 for similar reasons - let firstSmallPosition = (firstBigPosition + bigSteps) * 8 - foldM (smallStep (castPtr src)) - bigCount - [firstSmallPosition .. firstSmallPosition + smallSteps - 1] - where - biggestStep :: Ptr Word256 -> Int -> Int -> IO Int - biggestStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset - bigStep :: Ptr Word64 -> Int -> Int -> IO Int - bigStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset - smallStep :: Ptr Word8 -> Int -> Int -> IO Int - smallStep src !acc offset = (acc +) . popCount <$> peekElemOff src offset - --- Replicate packZipWith from newer bytestring -{-# INLINE packZipWithBinary #-} -packZipWithBinary :: - (Word8 -> Word8 -> Word8) -> - ByteString -> - ByteString -> - Maybe ByteString -packZipWithBinary f bs bs' - | BS.length bs /= BS.length bs' = Nothing - | otherwise = pure go - where - go :: ByteString - go = unsafeDupablePerformIO $ - unsafeUseAsCStringLen bs $ \(srcPtr, len) -> - unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do - dstPtr <- castPtr <$> mallocBytes len - traverse_ (step (castPtr srcPtr) (castPtr srcPtr') dstPtr) [0 .. len - 1] - unsafePackMallocCStringLen (castPtr dstPtr, len) - step :: - Ptr Word8 -> - Ptr Word8 -> - Ptr Word8 -> - Int -> - IO () - step src src' dst offset = do - res <- f <$> peekElemOff src offset <*> - peekElemOff src' offset - pokeElemOff dst offset res - --- For all the functionality below, all the function arguments must behave --- identically on their respective inputs; essentially, the function arguments --- should be the same function, modulo polymorphism. - -{-# INLINE chunkMap2 #-} -chunkMap2 :: - (Word8 -> Word8) -> - (Word64 -> Word64) -> - ByteString -> - ByteString -chunkMap2 smallF bigF bs = - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do - dst <- mallocBytes len - let bigStepSize = sizeOf @Word64 undefined - let (bigSteps, smallSteps) = len `quotRem` bigStepSize - traverse_ (bigStep (castPtr src) (castPtr dst)) [0 .. bigSteps - 1] - let firstSmallPosition = bigSteps * bigStepSize - traverse_ (smallStep (castPtr src) (castPtr dst)) - [firstSmallPosition, firstSmallPosition + 1 .. firstSmallPosition + smallSteps - 1] - unsafePackMallocCStringLen (dst, len) - where - bigStep :: - Ptr Word64 -> - Ptr Word64 -> - Int -> - IO () - bigStep src dst offset = - peekElemOff src offset >>= pokeElemOff dst offset . bigF - smallStep :: - Ptr Word8 -> - Ptr Word8 -> - Int -> - IO () - smallStep src dst offset = - peekElemOff src offset >>= pokeElemOff dst offset . smallF - -{-# INLINE chunkMap3 #-} -chunkMap3 :: - (Word8 -> Word8) -> - (Word64 -> Word64) -> - (Word256 -> Word256) -> - ByteString -> - ByteString -chunkMap3 smallF bigF biggestF bs = - unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do - dst <- mallocBytes len - let bigStepSize = sizeOf @Word64 undefined - let biggestStepSize = sizeOf @Word256 undefined - let (biggestSteps, rest) = len `quotRem` biggestStepSize - let (bigSteps, smallSteps) = rest `quotRem` bigStepSize - traverse_ (biggestStep (castPtr src) (castPtr dst)) [0 .. biggestSteps - 1] - let firstBigPosition = biggestSteps * 4 - traverse_ (bigStep (castPtr src) (castPtr dst)) - [firstBigPosition .. firstBigPosition + bigSteps - 1] - let firstSmallPosition = (firstBigPosition + bigSteps) * 8 - traverse_ (smallStep (castPtr src) (castPtr dst)) - [firstSmallPosition .. firstSmallPosition + smallSteps - 1] - unsafePackMallocCStringLen (dst, len) - where - biggestStep :: - Ptr Word256 -> - Ptr Word256 -> - Int -> - IO () - biggestStep src dst offset = - peekElemOff src offset >>= pokeElemOff dst offset . biggestF - bigStep :: - Ptr Word64 -> - Ptr Word64 -> - Int -> - IO () - bigStep src dst offset = - peekElemOff src offset >>= pokeElemOff dst offset . bigF - smallStep :: - Ptr Word8 -> - Ptr Word8 -> - Int -> - IO () - smallStep src dst offset = - peekElemOff src offset >>= pokeElemOff dst offset . smallF - -{-# INLINE chunkZipWith2 #-} -chunkZipWith2 :: - (Word8 -> Word8 -> Word8) -> - (Word64 -> Word64 -> Word64) -> - ByteString -> - ByteString -> - Maybe ByteString -chunkZipWith2 smallF bigF bs bs' - | BS.length bs /= BS.length bs' = Nothing - | otherwise = pure go - where - go :: ByteString - go = unsafeDupablePerformIO $ - unsafeUseAsCStringLen bs $ \(srcPtr, len) -> - unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do - dstPtr :: Ptr Word8 <- mallocBytes len - let bigStepSize = sizeOf @Word64 undefined - let (bigSteps, smallSteps) = len `quotRem` bigStepSize - traverse_ (bigStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) - [0 .. bigSteps - 1] - let firstSmallPosition = bigSteps * bigStepSize - traverse_ (smallStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) - [firstSmallPosition, firstSmallPosition + 1 .. firstSmallPosition + smallSteps - 1] - unsafePackMallocCStringLen (castPtr dstPtr, len) - bigStep :: - Ptr Word64 -> - Ptr Word64 -> - Ptr Word64 -> - Int -> - IO () - bigStep src src' dst offset = do - res <- bigF <$> peekElemOff src offset <*> - peekElemOff src' offset - pokeElemOff dst offset res - smallStep :: - Ptr Word8 -> - Ptr Word8 -> - Ptr Word8 -> - Int -> - IO () - smallStep src src' dst offset = do - res <- smallF <$> peekElemOff src offset <*> - peekElemOff src' offset - pokeElemOff dst offset res - -{-# INLINE chunkZipWith3 #-} -chunkZipWith3 :: - (Word8 -> Word8 -> Word8) -> - (Word64 -> Word64 -> Word64) -> - (Word256 -> Word256 -> Word256) -> - ByteString -> - ByteString -> - Maybe ByteString -chunkZipWith3 smallF bigF biggestF bs bs' - | BS.length bs /= BS.length bs' = Nothing - | otherwise = pure go - where - go :: ByteString - go = unsafeDupablePerformIO $ - unsafeUseAsCStringLen bs $ \(srcPtr, len) -> - unsafeUseAsCStringLen bs' $ \(srcPtr', _) -> do - dstPtr :: Ptr Word8 <- mallocBytes len - let bigStepSize = sizeOf @Word64 undefined - let biggestStepSize = sizeOf @Word256 undefined - let (biggestSteps, rest) = len `quotRem` biggestStepSize - let (bigSteps, smallSteps) = rest `quotRem` bigStepSize - traverse_ (biggestStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) - [0 .. biggestSteps - 1] - -- We now have to compute a Word64 offset corresponding to - -- biggestSteps. This will be four times larger, as Word64 is - -- one-quarter the width of a Word256. - let firstBigPosition = biggestSteps * 4 - traverse_ (bigStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) - [firstBigPosition, firstBigPosition + 1 .. firstBigPosition + bigSteps - 1] - -- Same again, but now we have to multiply by 8 for similar reasons. - let firstSmallPosition = (firstBigPosition + bigSteps) * 8 - traverse_ (smallStep (castPtr srcPtr) (castPtr srcPtr') (castPtr dstPtr)) - [firstSmallPosition, firstSmallPosition + 1 .. firstSmallPosition + smallSteps - 1] - unsafePackMallocCStringLen (castPtr dstPtr, len) - biggestStep :: - Ptr Word256 -> - Ptr Word256 -> - Ptr Word256 -> - Int -> - IO () - biggestStep src src' dst offset = do - res <- biggestF <$> peekElemOff src offset <*> - peekElemOff src' offset - pokeElemOff dst offset res - bigStep :: - Ptr Word64 -> - Ptr Word64 -> - Ptr Word64 -> - Int -> - IO () - bigStep src src' dst offset = do - res <- bigF <$> peekElemOff src offset <*> - peekElemOff src' offset - pokeElemOff dst offset res - smallStep :: - Ptr Word8 -> - Ptr Word8 -> - Ptr Word8 -> - Int -> - IO () - smallStep src src' dst offset = do - res <- smallF <$> peekElemOff src offset <*> - peekElemOff src' offset - pokeElemOff dst offset res - -- Clone of rotation logic without any prechecks rotateBS :: ByteString -> Int -> ByteString rotateBS bs i = case i `rem` bitLen of diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index ad175b8151b..ab709f0cf86 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -5,22 +5,16 @@ module Main (main) where +import Benches.Binary qualified as Binary import Benches.Complement qualified as Complement +import Benches.CountLeadingZeroes qualified as CountLeadingZeroes import Benches.Homogenous qualified as Homogenous import Benches.Popcount qualified as Popcount import Data.Bits (complement, zeroBits, (.&.)) -import Data.ByteString (ByteString) import Data.ByteString qualified as BS -import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) -import Data.Word (Word8) -import DataGen (mkBinaryArgs, mkUnaryArg, noCleanup, sizes) -import Foreign.C.Types (CSize (CSize), CUChar) -import Foreign.Marshal.Alloc (mallocBytes) -import Foreign.Ptr (Ptr, castPtr) -import GHC.Exts (fromListN) +import DataGen (mkUnaryArg, noCleanup, sizes) import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Implementations (chunkZipWith2, chunkZipWith3, packZipWithBinary, rotateBS, rotateBSFast) -import System.IO.Unsafe (unsafeDupablePerformIO) +import Implementations (rotateBS, rotateBSFast) import Test.Tasty (testGroup, withResource) import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nfIO) @@ -38,68 +32,23 @@ main = do testGroup "Homogenous" [ Homogenous.benches ], - bgroup bandLabel . fmap (andBench bandLabel) $ sizes, + testGroup "Binary" [ + Binary.benches + ], + testGroup "Count leading zeroes" [ + CountLeadingZeroes.benches + ], bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, - bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes, - bgroup bandLabel' . fmap (packedAndBench bandLabel') $ largerSizes, - bgroup bandCOnlyLabel . fmap (andCOnlyBench bandCOnlyLabel) $ sizes + bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes ] where - largerSizes :: [Int] - largerSizes = [31, 63, 127, 255, 511, 1023, 2047, 4095, 8191, 16383, 32767] - bandLabel :: String - bandLabel = "Bitwise AND" - bandLabel' :: String - bandLabel' = "Packed bitwise AND" rotateLabel :: String rotateLabel = "Slow rotate versus prescan" rotateLabel' :: String rotateLabel' = "Bitwise rotate versus block rotate" - bandCOnlyLabel :: String - bandCOnlyLabel = "C bitwise AND" -- Benchmarks -andCOnlyBench :: - String -> - Int -> - Benchmark -andCOnlyBench mainLabel len = - withResource (mkBinaryArgs len) noCleanup $ \xs -> - let pzwLabel' = "packZipWith (C)" - czwLabel2' = "chunkedZipWith (2 blocks, C)" - czwLabel3' = "chunkedZipWith (3 blocks, C)" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> pzwLabel' <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench pzwLabel' . nfIO $ uncurry candBinaryNaive <$> xs, - bcompare matchLabel . bench czwLabel2' . nfIO $ uncurry candBinary2 <$> xs, - bcompare matchLabel . bench czwLabel3' . nfIO $ uncurry candBinary3 <$> xs - ] - -packedAndBench :: - String -> - Int -> - Benchmark -packedAndBench mainLabel len = - withResource (mkBinaryArgs len) noCleanup $ \xs -> - let pzwLabel = "packZipWith" - pzwLabel' = "packZipWith (C)" - czwLabel2 = "chunkedZipWith (2 blocks)" - czwLabel2' = "chunkedZipWith (2 blocks, C)" - czwLabel3 = "chunkedZipWith (3 blocks)" - czwLabel3' = "chunkedZipWith (3 blocks, C)" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> pzwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench pzwLabel . nfIO $ uncurry (zipWithBinary (.&.)) <$> xs, - bcompare matchLabel . bench pzwLabel' . nfIO $ uncurry candBinaryNaive <$> xs, - bcompare matchLabel . bench czwLabel2 . nfIO $ uncurry (chunkZipWith2 (.&.) (.&.)) <$> xs, - bcompare matchLabel . bench czwLabel2' . nfIO $ uncurry candBinary2 <$> xs, - bcompare matchLabel . bench czwLabel3 . nfIO $ uncurry (chunkZipWith3 (.&.) (.&.) (.&.)) <$> xs, - bcompare matchLabel . bench czwLabel3' . nfIO $ uncurry candBinary3 <$> xs - ] - rotateFastVsSlow :: String -> Int -> @@ -134,99 +83,3 @@ rotateVsPrescanBench mainLabel len = (BS.all (== complement zeroBits) <$> xs) ] -andBench :: - String -> - Int -> - Benchmark -andBench mainLabel len = - withResource (mkBinaryArgs len) noCleanup $ \xs -> - let zwLabel = "zipWith" - pzwLabel = "packZipWith" - pzwLabel' = "packZipWith (C)" - czwLabel2 = "chunkedZipWith (2 blocks)" - czwLabel2' = "chunkedZipWith (2 blocks, C)" - czwLabel3 = "chunkedZipWith (3 blocks)" - czwLabel3' = "chunkedZipWith (3 blocks, C)" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> zwLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench zwLabel . nfIO $ uncurry (zipWithBinary (.&.)) <$> xs, - bcompare matchLabel . bench pzwLabel . nfIO $ uncurry (packZipWithBinary (.&.)) <$> xs, - bcompare matchLabel . bench pzwLabel' . nfIO $ uncurry candBinaryNaive <$> xs, - bcompare matchLabel . bench czwLabel2 . nfIO $ uncurry (chunkZipWith2 (.&.) (.&.)) <$> xs, - bcompare matchLabel . bench czwLabel2' . nfIO $ uncurry candBinary2 <$> xs, - bcompare matchLabel . bench czwLabel3 . nfIO $ uncurry (chunkZipWith3 (.&.) (.&.) (.&.)) <$> xs, - bcompare matchLabel . bench czwLabel3' . nfIO $ uncurry candBinary3 <$> xs - ] - --- Helpers - --- Naive implementations for comparison -zipWithBinary :: - (Word8 -> Word8 -> Word8) -> - ByteString -> - ByteString -> - Maybe ByteString -zipWithBinary f bs bs' - | len /= BS.length bs' = Nothing - | otherwise = pure . fromListN len . BS.zipWith f bs $ bs' - where - len :: Int - len = BS.length bs - --- Wrapper for raw C bitwise AND -candBinary2 :: ByteString -> ByteString -> Maybe ByteString -candBinary2 bs bs' - | BS.length bs /= BS.length bs' = Nothing - | otherwise = pure . unsafeDupablePerformIO . - unsafeUseAsCStringLen bs $ \(src, len) -> - unsafeUseAsCStringLen bs' $ \(src', _) -> do - dst <- mallocBytes len - candImplementation2 dst (castPtr src) (castPtr src') (fromIntegral len) - unsafePackMallocCStringLen (castPtr dst, len) - --- Same as above, but 3-fold unroll -candBinary3 :: ByteString -> ByteString -> Maybe ByteString -candBinary3 bs bs' - | BS.length bs /= BS.length bs' = Nothing - | otherwise = pure . unsafeDupablePerformIO . - unsafeUseAsCStringLen bs $ \(src, len) -> - unsafeUseAsCStringLen bs' $ \(src', _) -> do - dst <- mallocBytes len - candImplementation3 dst (castPtr src) (castPtr src') (fromIntegral len) - unsafePackMallocCStringLen (castPtr dst, len) - --- Same as above, but as obvious as possible -candBinaryNaive :: ByteString -> ByteString -> Maybe ByteString -candBinaryNaive bs bs' - | BS.length bs /= BS.length bs' = Nothing - | otherwise = pure . unsafeDupablePerformIO . - unsafeUseAsCStringLen bs $ \(src, len) -> - unsafeUseAsCStringLen bs' $ \(src', _) -> do - dst <- mallocBytes len - candImplementationNaive dst (castPtr src) (castPtr src') (fromIntegral len) - unsafePackMallocCStringLen (castPtr dst, len) - -foreign import ccall unsafe "cbits.h c_and_implementation_naive" - candImplementationNaive :: - Ptr CUChar -> - Ptr CUChar -> - Ptr CUChar -> - CSize -> - IO () - -foreign import ccall unsafe "cbits.h c_and_implementation" - candImplementation2 :: - Ptr CUChar -> - Ptr CUChar -> - Ptr CUChar -> - CSize -> - IO () - -foreign import ccall unsafe "cbits.h c_and_implementation_3" - candImplementation3 :: - Ptr CUChar -> - Ptr CUChar -> - Ptr CUChar -> - CSize -> - IO () diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/binary.c b/plutus-core/plutus-core/bench/bitwise/cbits/binary.c new file mode 100644 index 00000000000..aee1a1b5f83 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/binary.c @@ -0,0 +1,8 @@ +#include "cbits.h" + +void c_and_naive(unsigned char *dst, unsigned char const *src1, + unsigned char const *src2, size_t const len) { + for (size_t i = 0; i < len; i++) { + dst[i] = src1[i] & src2[i]; + } +} diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index d48bb935f45..cc26e7eb2e0 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -27,15 +27,17 @@ bool c_homogenous_sliding_window(unsigned char const needle, unsigned char const *restrict haystack, size_t len); -// Others +// Binary ops -void c_and_implementation_naive(unsigned char *dst, unsigned char const *src1, - unsigned char const *src2, size_t const len); +void c_and_naive(unsigned char *restrict dst, unsigned char const *src1, + unsigned char const *src2, size_t const len); -void c_and_implementation(unsigned char *dst, unsigned char const *src1, - unsigned char const *src2, size_t const len); +// CLZ -void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, - unsigned char const *src2, size_t const len); +size_t c_clz_naive(unsigned char const *restrict src, size_t const len); + +size_t c_clz_block(unsigned char const *restrict src, size_t len); + +size_t c_clz_block_unrolled(unsigned char const *restrict src, size_t len); #endif /* CBITS_H */ diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/clz.c b/plutus-core/plutus-core/bench/bitwise/cbits/clz.c new file mode 100644 index 00000000000..23bb56eacd8 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/clz.c @@ -0,0 +1,69 @@ +#include "cbits.h" + +size_t c_clz_naive(unsigned char const *src, size_t const len) { + size_t leading_zeroes = 0; + for (size_t i = 0; i < len; i++) { + // Necessary because __builtin_clz has an undefined outcome if its argument + // is zero. + if (src[i] != 0) { + // This is necessary because GCC will sign-extend the ith byte whether we + // like it or not. Thus, we have to compensate. + size_t offset = (sizeof(unsigned int) - 1) * 8; + return leading_zeroes + (__builtin_clz(src[i]) - offset); + } + leading_zeroes += 8; + } + return leading_zeroes; +} + +size_t c_clz_block(unsigned char const *restrict src, size_t len) { + size_t leading_zeroes = 0; + while (len >= sizeof(unsigned long long)) { + unsigned long long x = *((unsigned long long const *restrict)src); + if (x != 0) { + return leading_zeroes + __builtin_clzll(x); + } + leading_zeroes += (sizeof(unsigned long long) * 8); + src += sizeof(unsigned long long); + len -= sizeof(unsigned long long); + } + while (len > 0) { + if ((*src) != 0) { + // Same necessity as before + size_t offset = (sizeof(unsigned int) - 1) * 8; + return leading_zeroes + (__builtin_clz(*src) - offset); + } + leading_zeroes += 8; + src++; + len--; + } + return leading_zeroes; +} + +size_t c_clz_block_unrolled(unsigned char const *restrict src, size_t len) { + size_t leading_zeroes = 0; + while (len >= 2 * sizeof(unsigned long long)) { + unsigned long long x = ((unsigned long long const *restrict)src)[0]; + unsigned long long y = ((unsigned long long const *restrict)src)[1]; + if (x != 0) { + return leading_zeroes + __builtin_clzll(x); + } + if (y != 0) { + return leading_zeroes + sizeof(unsigned long long) + __builtin_clzll(y); + } + leading_zeroes += (sizeof(unsigned long long) * 16); + src += 2 * sizeof(unsigned long long); + len -= 2 * sizeof(unsigned long long); + } + while (len > 0) { + if ((*src) != 0) { + // Same necessity as before + size_t offset = (sizeof(unsigned int) - 1) * 8; + return leading_zeroes + (__builtin_clz(*src) - offset); + } + leading_zeroes += 8; + src++; + len--; + } + return leading_zeroes; +} diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c b/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c deleted file mode 100644 index 77b5fab55e4..00000000000 --- a/plutus-core/plutus-core/bench/bitwise/cbits/implementation.c +++ /dev/null @@ -1,93 +0,0 @@ -#include "cbits.h" - -void c_and_implementation_3(unsigned char *dst, unsigned char const *src1, - unsigned char const *src2, size_t const len) { - size_t const big_step_size = sizeof(unsigned long long); - size_t const biggest_step_size = big_step_size * 4; // four-way unroll - size_t const biggest_steps = len / biggest_step_size; - size_t const rest = len % biggest_step_size; - size_t const big_steps = rest / big_step_size; - size_t const small_steps = rest % big_step_size; - unsigned long long *big_ptr1 = (unsigned long long *)src1; - unsigned long long *big_ptr2 = (unsigned long long *)src2; - unsigned long long *big_dst = (unsigned long long *)dst; - for (size_t i = 0; i < biggest_steps; i++) { - // We have to do this as GCC is unreliable at unrolling, even if the loop - // has fixed length, we have enough registers _and_ we turn on O2. - unsigned long long const x1 = *big_ptr1; - unsigned long long const x2 = *(big_ptr1 + 1); - unsigned long long const x3 = *(big_ptr1 + 2); - unsigned long long const x4 = *(big_ptr1 + 3); - unsigned long long const y1 = *big_ptr2; - unsigned long long const y2 = *(big_ptr2 + 1); - unsigned long long const y3 = *(big_ptr2 + 2); - unsigned long long const y4 = *(big_ptr2 + 3); - *big_dst = x1 & y1; - *(big_dst + 1) = x2 & y2; - *(big_dst + 2) = x3 & y3; - *(big_dst + 3) = x4 & y4; - big_ptr1 += 4; - big_ptr2 += 4; - big_dst += 4; - } - for (size_t i = 0; i < big_steps; i++) { - unsigned long long const x = *big_ptr1; - unsigned long long const y = *big_ptr2; - *big_dst = x & y; - big_ptr1++; - big_ptr2++; - big_dst++; - } - unsigned char *small_ptr1 = (unsigned char *)big_ptr1; - unsigned char *small_ptr2 = (unsigned char *)big_ptr2; - unsigned char *small_dst = (unsigned char *)big_dst; - for (size_t i = 0; i < small_steps; i++) { - unsigned char const x = *small_ptr1; - unsigned char const y = *small_ptr2; - *small_dst = x & y; - small_ptr1++; - small_ptr2++; - small_dst++; - } -} - -void c_and_implementation(unsigned char *dst, unsigned char const *src1, - unsigned char const *src2, size_t const len) { - size_t const big_step_size = sizeof(unsigned long long); - size_t const big_steps = len / big_step_size; - size_t const small_steps = len % big_step_size; - unsigned long long *big_ptr1 = (unsigned long long *)src1; - unsigned long long *big_ptr2 = (unsigned long long *)src2; - unsigned long long *big_dst = (unsigned long long *)dst; - for (size_t i = 0; i < big_steps; i++) { - unsigned long long const x = *big_ptr1; - unsigned long long const y = *big_ptr2; - *big_dst = x & y; - big_ptr1++; - big_ptr2++; - big_dst++; - } - unsigned char *small_ptr1 = (unsigned char *)big_ptr1; - unsigned char *small_ptr2 = (unsigned char *)big_ptr2; - unsigned char *small_dst = (unsigned char *)big_dst; - for (size_t i = 0; i < small_steps; i++) { - unsigned char const x = *small_ptr1; - unsigned char const y = *small_ptr2; - *small_dst = x & y; - small_ptr1++; - small_ptr2++; - small_dst++; - } -} - -void c_and_implementation_naive(unsigned char *dst, unsigned char const *src1, - unsigned char const *src2, size_t const len) { - for (size_t i = 0; i < len; i++) { - unsigned char const x = *src1; - unsigned char const y = *src2; - *dst = x & y; - src1++; - src2++; - dst++; - } -} From 3ad984ef5ee7ba1c730bc4aa1a671e1c21d68a7d Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 19 Aug 2022 12:05:29 +1200 Subject: [PATCH 45/73] Benches for bit access, compare CLZ C implementations --- plutus-core/plutus-core.cabal | 2 + .../bench/bitwise/Benches/BitRead.hs | 64 +++++++++++++++++++ .../bitwise/Benches/CountLeadingZeroes.hs | 23 ++++++- plutus-core/plutus-core/bench/bitwise/Main.hs | 7 +- .../bench/bitwise/cbits/bit-access.c | 8 +++ .../plutus-core/bench/bitwise/cbits/cbits.h | 5 ++ .../plutus-core/bench/bitwise/cbits/clz.c | 1 + 7 files changed, 108 insertions(+), 2 deletions(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/BitRead.hs create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/bit-access.c diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index cd63796b95d..d3ac0d649a8 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -793,6 +793,7 @@ benchmark bitwise main-is: Main.hs other-modules: Benches.Binary + Benches.BitRead Benches.Complement Benches.CountLeadingZeroes Benches.Homogenous @@ -803,6 +804,7 @@ benchmark bitwise include-dirs: plutus-core/bench/bitwise/cbits c-sources: plutus-core/bench/bitwise/cbits/binary.c + plutus-core/bench/bitwise/cbits/bit-access.c plutus-core/bench/bitwise/cbits/clz.c plutus-core/bench/bitwise/cbits/complement.c plutus-core/bench/bitwise/cbits/homogenous.c diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/BitRead.hs b/plutus-core/plutus-core/bench/bitwise/Benches/BitRead.hs new file mode 100644 index 00000000000..0340c0312a7 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/BitRead.hs @@ -0,0 +1,64 @@ +module Benches.BitRead ( + benches + ) where + +import Control.Monad (guard) +import Data.Bits (shiftR, testBit) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import DataGen (mkUnaryArg, noCleanup, sizes) +import Foreign.C.Types (CBool (CBool), CSize (CSize), CUChar) +import Foreign.Ptr (Ptr, castPtr) +import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Basic bit read" $ benchBasic "Basic bit read" <$> sizes + +-- Helpers + +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let naiveLabel = "ByteString ops" + cLabel = "C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench naiveLabel . nfIO $ bitAt (len - 1) <$> xs, + bcompare matchLabel . bench cLabel . nfIO $ wrapper (len - 1) <$> xs + ] + +bitAt :: Int -> ByteString -> Maybe Bool +bitAt ix bs = do + guard (ix >= 0) + guard (ix < bitLength) + let (bigIx, smallIx) = ix `quotRem` 8 + let byte = BS.index bs bigIx + pure . testBit byte $ shiftR 0x80 smallIx + where + bitLength :: Int + bitLength = BS.length bs * 8 + +wrapper :: Int -> ByteString -> Maybe Bool +wrapper ix bs = do + guard (ix >= 0) + guard (ix <= bitLength) + let CBool res = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> + pure . cBitAt (fromIntegral ix) (castPtr ptr) . fromIntegral $ len + pure $ res /= 0 + where + bitLength :: Int + bitLength = BS.length bs * 8 + +foreign import ccall unsafe "cbits.h c_bit_at" + cBitAt :: + CSize -> + Ptr CUChar -> + CSize -> + CBool diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/CountLeadingZeroes.hs b/plutus-core/plutus-core/bench/bitwise/Benches/CountLeadingZeroes.hs index 35906002ea3..bbbaec25a13 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/CountLeadingZeroes.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/CountLeadingZeroes.hs @@ -1,5 +1,6 @@ module Benches.CountLeadingZeroes ( - benches + benches, + cBenches, ) where import Data.Bits (countLeadingZeros, zeroBits) @@ -16,6 +17,9 @@ import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) benches :: Benchmark benches = bgroup "Basic CLZ" $ benchBasic "CLZ" <$> sizes +cBenches :: Benchmark +cBenches = bgroup "C CLZ" $ benchC "C CLZ" <$> sizes + -- Helpers benchBasic :: @@ -37,6 +41,23 @@ benchBasic mainLabel len = bcompare matchLabel . bench cunrolledLabel . nfIO $ xs >>= wrapping cClzBlockUnrolled ] +benchC :: + String -> + Int -> + Benchmark +benchC mainLabel len = + withResource (mkZeroesOne len) noCleanup $ \xs -> + let cnaiveLabel = "naive C" + cblockLabel = "block C" + cunrolledLabel = "unrolled C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> cnaiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench cnaiveLabel . nfIO $ xs >>= wrapping cClzNaive, + bcompare matchLabel . bench cblockLabel . nfIO $ xs >>= wrapping cClzBlock, + bcompare matchLabel . bench cunrolledLabel . nfIO $ xs >>= wrapping cClzBlockUnrolled + ] + naiveClz :: ByteString -> Int naiveClz bs = fromMaybe (BS.length bs * 8) $ do ix <- BS.findIndex (/= zeroBits) bs diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index ab709f0cf86..c52436a61b7 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -6,6 +6,7 @@ module Main (main) where import Benches.Binary qualified as Binary +import Benches.BitRead qualified as BitRead import Benches.Complement qualified as Complement import Benches.CountLeadingZeroes qualified as CountLeadingZeroes import Benches.Homogenous qualified as Homogenous @@ -36,7 +37,11 @@ main = do Binary.benches ], testGroup "Count leading zeroes" [ - CountLeadingZeroes.benches + CountLeadingZeroes.benches, + CountLeadingZeroes.cBenches + ], + testGroup "Bit read" [ + BitRead.benches ], bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/bit-access.c b/plutus-core/plutus-core/bench/bitwise/cbits/bit-access.c new file mode 100644 index 00000000000..c89219fe190 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/bit-access.c @@ -0,0 +1,8 @@ +#include "cbits.h" + +bool c_bit_at(size_t const ix, unsigned char *const restrict src, + size_t const len) { + size_t big_len = ix / 8; + size_t small_len = ix % 8; + return src[big_len] & (0x80 >> small_len); +} diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index cc26e7eb2e0..41ef0766bb0 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -32,6 +32,11 @@ bool c_homogenous_sliding_window(unsigned char const needle, void c_and_naive(unsigned char *restrict dst, unsigned char const *src1, unsigned char const *src2, size_t const len); +// Bit reading and writing + +bool c_bit_at(size_t const ix, unsigned char *const restrict src, + size_t const len); + // CLZ size_t c_clz_naive(unsigned char const *restrict src, size_t const len); diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/clz.c b/plutus-core/plutus-core/bench/bitwise/cbits/clz.c index 23bb56eacd8..9941c8da3a0 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/clz.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/clz.c @@ -1,4 +1,5 @@ #include "cbits.h" +#include size_t c_clz_naive(unsigned char const *src, size_t const len) { size_t leading_zeroes = 0; From 03bc299cfa646519b3537553e9af6192429e839a Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Mon, 22 Aug 2022 10:45:29 +1200 Subject: [PATCH 46/73] Bit write benches --- plutus-core/plutus-core.cabal | 1 + .../bench/bitwise/Benches/BitRead.hs | 5 +- .../bench/bitwise/Benches/BitWrite.hs | 97 +++++++++++++++++++ plutus-core/plutus-core/bench/bitwise/Main.hs | 4 + .../bench/bitwise/cbits/bit-access.c | 39 +++++++- .../plutus-core/bench/bitwise/cbits/cbits.h | 10 +- 6 files changed, 146 insertions(+), 10 deletions(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index d3ac0d649a8..4d6eaefb07c 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -794,6 +794,7 @@ benchmark bitwise other-modules: Benches.Binary Benches.BitRead + Benches.BitWrite Benches.Complement Benches.CountLeadingZeroes Benches.Homogenous diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/BitRead.hs b/plutus-core/plutus-core/bench/bitwise/Benches/BitRead.hs index 0340c0312a7..19a576d83f3 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/BitRead.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/BitRead.hs @@ -49,8 +49,8 @@ wrapper :: Int -> ByteString -> Maybe Bool wrapper ix bs = do guard (ix >= 0) guard (ix <= bitLength) - let CBool res = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> - pure . cBitAt (fromIntegral ix) (castPtr ptr) . fromIntegral $ len + let CBool res = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, _) -> + pure . cBitAt (fromIntegral ix) . castPtr $ ptr pure $ res /= 0 where bitLength :: Int @@ -60,5 +60,4 @@ foreign import ccall unsafe "cbits.h c_bit_at" cBitAt :: CSize -> Ptr CUChar -> - CSize -> CBool diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs b/plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs new file mode 100644 index 00000000000..b817a3b81cd --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs @@ -0,0 +1,97 @@ +module Benches.BitWrite ( + benches + ) where + +import Control.Monad (guard) +import Data.Bits (clearBit, setBit, shiftR) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Internal (fromForeignPtr, mallocByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Word (Word8) +import DataGen (mkUnaryArg, noCleanup, sizes) +import Foreign.C.Types (CBool (CBool), CSize (CSize), CUChar) +import Foreign.ForeignPtr (castForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, castPtr) +import GHC.Exts (fromList, toList) +import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Worst-case bit write" $ benchBasic "Worst-case bit write" <$> sizes + +-- Helpers + +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let naiveLabel = "ByteString ops" + cnaiveLabel = "Naive C" + cmemcpyLabel = "Memcpy C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench naiveLabel . nfIO $ bitSet False (len - 1) <$> xs, + bcompare matchLabel . bench cnaiveLabel . nfIO $ wrapper cBitSetNaive False (len - 1) <$> xs, + bcompare matchLabel . bench cmemcpyLabel . nfIO $ wrapper cBitSetMemcpy False (len - 1) <$> xs + ] + +bitSet :: Bool -> Int -> ByteString -> Maybe ByteString +bitSet b ix bs = do + guard (ix >= 0) + guard (ix < bitLength) + pure . fromList . fmap (uncurry go) . zip [0 ..] . toList $ bs + where + go :: Int -> Word8 -> Word8 + go candidateIx w8 + | candidateIx /= bigIx = w8 + | b = setBit w8 $ shiftR 0x80 smallIx + | otherwise = clearBit w8 $ shiftR 0x80 smallIx + bitLength :: Int + bitLength = BS.length bs * 8 + bigIx :: Int + bigIx = ix `quot` 8 + smallIx :: Int + smallIx = ix `rem` 8 + +wrapper :: + (CBool -> CSize -> Ptr CUChar -> Ptr CUChar -> CSize -> IO ()) -> + Bool -> + Int -> + ByteString -> + Maybe ByteString +wrapper f b ix bs = do + guard (ix >= 0) + guard (ix < bitLength) + pure . unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do + fp <- mallocByteString len + withForeignPtr fp $ \dst -> + if b + then f (CBool 1) (fromIntegral ix) dst (castPtr src) . fromIntegral $ len + else f (CBool 0) (fromIntegral ix) dst (castPtr src) . fromIntegral $ len + pure . fromForeignPtr (castForeignPtr fp) 0 $ len + where + bitLength :: Int + bitLength = BS.length bs * 8 + +foreign import ccall unsafe "cbits.h c_bit_set_naive" + cBitSetNaive :: + CBool -> + CSize -> + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () + +foreign import ccall unsafe "cbits.h c_bit_set_memcpy" + cBitSetMemcpy :: + CBool -> + CSize -> + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index c52436a61b7..8c7c700a44d 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -7,6 +7,7 @@ module Main (main) where import Benches.Binary qualified as Binary import Benches.BitRead qualified as BitRead +import Benches.BitWrite qualified as BitWrite import Benches.Complement qualified as Complement import Benches.CountLeadingZeroes qualified as CountLeadingZeroes import Benches.Homogenous qualified as Homogenous @@ -43,6 +44,9 @@ main = do testGroup "Bit read" [ BitRead.benches ], + testGroup "Bit write" [ + BitWrite.benches + ], bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes ] diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/bit-access.c b/plutus-core/plutus-core/bench/bitwise/cbits/bit-access.c index c89219fe190..41b6383cb12 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/bit-access.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/bit-access.c @@ -1,8 +1,37 @@ #include "cbits.h" +#include -bool c_bit_at(size_t const ix, unsigned char *const restrict src, - size_t const len) { - size_t big_len = ix / 8; - size_t small_len = ix % 8; - return src[big_len] & (0x80 >> small_len); +bool c_bit_at(size_t const ix, unsigned char *const restrict src) { + size_t big_ix = ix / 8; + size_t small_ix = ix % 8; + return src[big_ix] & (0x80 >> small_ix); +} + +void c_bit_set_naive(bool const b, size_t const ix, unsigned char *restrict dst, + unsigned char const *restrict src, size_t const len) { + size_t big_ix = ix / 8; + size_t small_ix = ix % 8; + for (size_t i = 0; i < len; i++) { + dst[i] = src[i]; + } + if (b == true) { + dst[big_ix] = src[big_ix] | (0x80 >> small_ix); + } else { + dst[big_ix] = src[big_ix] & (~(0x80 >> small_ix)); + } +} + +void c_bit_set_memcpy(bool const b, size_t const ix, + unsigned char *restrict dst, + unsigned char const *restrict src, size_t const len) { + size_t big_ix = ix / 8; + size_t small_ix = ix % 8; + // Copy entirety of src + memcpy(dst, src, len); + // Set our desired bit + if (b == true) { + dst[big_ix] = src[big_ix] | (0x80 >> small_ix); + } else { + dst[big_ix] = src[big_ix] & (~(0x80 >> small_ix)); + } } diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index 41ef0766bb0..3795c33bcb2 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -34,8 +34,14 @@ void c_and_naive(unsigned char *restrict dst, unsigned char const *src1, // Bit reading and writing -bool c_bit_at(size_t const ix, unsigned char *const restrict src, - size_t const len); +bool c_bit_at(size_t const ix, unsigned char *const restrict src); + +void c_bit_set_naive(bool const b, size_t const ix, unsigned char *restrict dst, + unsigned char const *restrict src, size_t const len); + +void c_bit_set_memcpy(bool const b, size_t const ix, + unsigned char *restrict dst, + unsigned char const *restrict src, size_t const len); // CLZ From 78dcf10e5a7ffc27f1baee312673694c8904b412 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 24 Aug 2022 13:39:38 +1200 Subject: [PATCH 47/73] Bitwise shift bench preliminary --- plutus-core/plutus-core.cabal | 1 + .../bench/bitwise/Benches/Shift.hs | 132 ++++++++++++++++++ plutus-core/plutus-core/bench/bitwise/Main.hs | 6 + 3 files changed, 139 insertions(+) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 4d6eaefb07c..226dd1a2d40 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -799,6 +799,7 @@ benchmark bitwise Benches.CountLeadingZeroes Benches.Homogenous Benches.Popcount + Benches.Shift DataGen Implementations diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs new file mode 100644 index 00000000000..45b80fbb634 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs @@ -0,0 +1,132 @@ +module Benches.Shift ( + benches, + overlongBenches, + byteStepBenches, + ) where + +import Data.Bits (bit, shiftR, testBit, zeroBits, (.|.)) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Foldable (foldl') +import Data.Word (Word8) +import DataGen (mkUnaryArg, noCleanup, sizes) +import GHC.Exts (fromList) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Basic bitwise shift" $ benchBasic "Basic bitwise shift" <$> sizes + +overlongBenches :: Benchmark +overlongBenches = bgroup "Overlong bitwise shift" $ benchOverlong "Overlong bitwise shift" <$> sizes + +byteStepBenches :: Benchmark +byteStepBenches = bgroup "Byte bitwise shift" $ benchByteShift "Byte bitwise shift" <$> sizes + +-- Helpers + +benchByteShift :: + String -> + Int -> + Benchmark +benchByteShift mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let noPrecheckByteLabel = "No precheck, byte shift" + noPrecheckNotLabel = "No precheck, non-byte shift" + precheckByteLabel = "Precheck, byte shift" + precheckNotLabel = "Precheck, non-byte shift" + testLabel = mainLabel <> ", length " <> show len + matchLabelByte = "$NF == \"" <> noPrecheckByteLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" + matchLabelNot = "$NF == \"" <> noPrecheckNotLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench noPrecheckByteLabel . nfIO $ bitShift ((len - 1) * 8) <$> xs, + bench noPrecheckNotLabel . nfIO $ bitShift (len * 4 - 1) <$> xs, + bcompare matchLabelByte . bench precheckByteLabel . nfIO $ precheckByte bitShift ((len - 1) * 8) <$> xs, + bcompare matchLabelNot . bench precheckNotLabel . nfIO $ precheckByte bitShift (len * 4 - 1) <$> xs + ] + +benchOverlong :: + String -> + Int -> + Benchmark +benchOverlong mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let noPrecheckOverlongLabel = "No precheck, overlong" + noPrecheckNotLabel = "No precheck, not overlong" + precheckOverlongLabel = "Precheck, overlong" + precheckNotLabel = "Precheck, not overlong" + testLabel = mainLabel <> ", length " <> show len + matchLabelOverlong = "$NF == \"" <> noPrecheckOverlongLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" + matchLabelNot = "$NF == \"" <> noPrecheckNotLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench noPrecheckOverlongLabel . nfIO $ bitShift (len * 16) <$> xs, + bench noPrecheckNotLabel . nfIO $ bitShift (len * 4) <$> xs, + bcompare matchLabelOverlong . bench precheckOverlongLabel . nfIO $ precheckOverlong bitShift (len * 16) <$> xs, + bcompare matchLabelNot . bench precheckNotLabel . nfIO $ precheckOverlong bitShift (len * 4) <$> xs + ] + +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let naiveLabel = "ByteString ops" + testLabel = mainLabel <> ", length " <> show len in + bgroup testLabel [ + bench naiveLabel . nfIO $ bitShift (len * 4) <$> xs + ] + +precheckByte :: + (Int -> ByteString -> ByteString) -> + Int -> + ByteString -> + ByteString +precheckByte f i bs = case i `quotRem` 8 of + (i', 0) -> fromList $ go . (`subtract` i') <$> [0 .. len - 1] + _ -> f i bs + where + go :: Int -> Word8 + go readIx + | readIx < 0 = zeroBits + | readIx >= len = zeroBits + | otherwise = BS.index bs readIx + len :: Int + len = BS.length bs + +precheckOverlong :: + (Int -> ByteString -> ByteString) -> + Int -> + ByteString -> + ByteString +precheckOverlong f i bs + | abs i >= bitLen = BS.replicate len zeroBits + | otherwise = f i bs + where + len :: Int + len = BS.length bs + bitLen :: Int + bitLen = len * 8 + +bitShift :: Int -> ByteString -> ByteString +bitShift i bs = case signum i of + 0 -> bs + _ -> fromList $ go <$> [0 .. BS.length bs - 1] + where + go :: Int -> Word8 + go byteIx = let bitIxes = (\ix -> 8 * byteIx - i + ix) <$> [0 .. 7] + bits = bitAtClipping bs <$> bitIxes + zipped = zip [7, 6 .. 0] bits in + foldl' (\acc (pos, b) -> acc .|. bool zeroBits (bit pos) b) zeroBits zipped + +bitAtClipping :: ByteString -> Int -> Bool +bitAtClipping bs i + | i < 0 = False + | i >= bitLength = False + | otherwise = let (bigIx, smallIx) = i `quotRem` 8 + byte = BS.index bs bigIx in + testBit byte $ shiftR 0x80 smallIx + where + bitLength :: Int + bitLength = BS.length bs * 8 diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 8c7c700a44d..48b7d3a7714 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -12,6 +12,7 @@ import Benches.Complement qualified as Complement import Benches.CountLeadingZeroes qualified as CountLeadingZeroes import Benches.Homogenous qualified as Homogenous import Benches.Popcount qualified as Popcount +import Benches.Shift qualified as Shift import Data.Bits (complement, zeroBits, (.&.)) import Data.ByteString qualified as BS import DataGen (mkUnaryArg, noCleanup, sizes) @@ -47,6 +48,11 @@ main = do testGroup "Bit write" [ BitWrite.benches ], + testGroup "Bit shift" [ + Shift.benches, + Shift.overlongBenches, + Shift.byteStepBenches + ], bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes ] From 4cdd39ba714857de263b87ce24b1d1ca6b9172ce Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 24 Aug 2022 14:26:40 +1200 Subject: [PATCH 48/73] Define and bench a faster byte-size shift --- plutus-core/plutus-core.cabal | 1 + .../bench/bitwise/Benches/Shift.hs | 32 ++++++++++++++++++- .../plutus-core/bench/bitwise/cbits/cbits.h | 5 +++ .../plutus-core/bench/bitwise/cbits/shift.c | 14 ++++++++ 4 files changed, 51 insertions(+), 1 deletion(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/shift.c diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 226dd1a2d40..0c62d593c35 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -811,6 +811,7 @@ benchmark bitwise plutus-core/bench/bitwise/cbits/complement.c plutus-core/bench/bitwise/cbits/homogenous.c plutus-core/bench/bitwise/cbits/popcount.c + plutus-core/bench/bitwise/cbits/shift.c cc-options: -O3 diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs index 45b80fbb634..77242d967f5 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs @@ -8,10 +8,16 @@ import Data.Bits (bit, shiftR, testBit, zeroBits, (.|.)) import Data.Bool (bool) import Data.ByteString (ByteString) import Data.ByteString qualified as BS +import Data.ByteString.Internal (fromForeignPtr, mallocByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Foldable (foldl') import Data.Word (Word8) import DataGen (mkUnaryArg, noCleanup, sizes) +import Foreign.C.Types (CInt (CInt), CSize (CSize), CUChar) +import Foreign.ForeignPtr (castForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, castPtr) import GHC.Exts (fromList) +import System.IO.Unsafe (unsafeDupablePerformIO) import Test.Tasty (withResource) import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) @@ -36,6 +42,8 @@ benchByteShift mainLabel len = noPrecheckNotLabel = "No precheck, non-byte shift" precheckByteLabel = "Precheck, byte shift" precheckNotLabel = "Precheck, non-byte shift" + precheckCByteLabel = "Precheck in C, byte shift" + precheckCNotLabel = "Precheck in C, non-byte shift" testLabel = mainLabel <> ", length " <> show len matchLabelByte = "$NF == \"" <> noPrecheckByteLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" matchLabelNot = "$NF == \"" <> noPrecheckNotLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in @@ -43,7 +51,9 @@ benchByteShift mainLabel len = bench noPrecheckByteLabel . nfIO $ bitShift ((len - 1) * 8) <$> xs, bench noPrecheckNotLabel . nfIO $ bitShift (len * 4 - 1) <$> xs, bcompare matchLabelByte . bench precheckByteLabel . nfIO $ precheckByte bitShift ((len - 1) * 8) <$> xs, - bcompare matchLabelNot . bench precheckNotLabel . nfIO $ precheckByte bitShift (len * 4 - 1) <$> xs + bcompare matchLabelNot . bench precheckNotLabel . nfIO $ precheckByte bitShift (len * 4 - 1) <$> xs, + bcompare matchLabelByte . bench precheckCByteLabel . nfIO $ precheckByteC bitShift ((len - 1) * 8) <$> xs, + bcompare matchLabelNot . bench precheckCNotLabel . nfIO $ precheckByteC bitShift (len * 4 - 1) <$> xs ] benchOverlong :: @@ -95,6 +105,18 @@ precheckByte f i bs = case i `quotRem` 8 of len :: Int len = BS.length bs +precheckByteC :: + (Int -> ByteString -> ByteString) -> + Int -> + ByteString -> + ByteString +precheckByteC f i bs = case i `quotRem` 8 of + (i', 0) -> unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do + fp <- mallocByteString len + withForeignPtr fp $ \dst -> cShiftBytes (fromIntegral i') dst (castPtr src) . fromIntegral $ len + pure . fromForeignPtr (castForeignPtr fp) 0 $ len + _ -> f i bs + precheckOverlong :: (Int -> ByteString -> ByteString) -> Int -> @@ -130,3 +152,11 @@ bitAtClipping bs i where bitLength :: Int bitLength = BS.length bs * 8 + +foreign import ccall unsafe "cbits.h c_shift_bytes" + cShiftBytes :: + CInt -> + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index 3795c33bcb2..12f6c3b0590 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -51,4 +51,9 @@ size_t c_clz_block(unsigned char const *restrict src, size_t len); size_t c_clz_block_unrolled(unsigned char const *restrict src, size_t len); +// Shift + +void c_shift_bytes(int shift, unsigned char *restrict dst, + unsigned char const *restrict src, size_t const len); + #endif /* CBITS_H */ diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/shift.c b/plutus-core/plutus-core/bench/bitwise/cbits/shift.c new file mode 100644 index 00000000000..70e9b7ca2dc --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/shift.c @@ -0,0 +1,14 @@ +#include "cbits.h" +#include + +void c_shift_bytes(int shift, unsigned char *restrict dst, + unsigned char const *restrict src, size_t const len) { + if (shift < 0) { + int const abs_shift = abs(shift); + memcpy(dst, src + abs_shift, len - abs_shift); + memset(dst + abs_shift, 0x00, abs_shift); + } else { + memset(dst, 0x00, shift); + memcpy(dst + shift, src, len - shift); + } +} From 87b659b978c384a7f793d560327bfb1868309f91 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 24 Aug 2022 15:37:02 +1200 Subject: [PATCH 49/73] Much faster shift in C --- .../bench/bitwise/Benches/Shift.hs | 114 +++--------------- plutus-core/plutus-core/bench/bitwise/Main.hs | 4 +- .../plutus-core/bench/bitwise/cbits/cbits.h | 4 +- .../plutus-core/bench/bitwise/cbits/shift.c | 61 ++++++++-- 4 files changed, 71 insertions(+), 112 deletions(-) diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs index 77242d967f5..bc1216bd53b 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs @@ -1,7 +1,5 @@ module Benches.Shift ( benches, - overlongBenches, - byteStepBenches, ) where import Data.Bits (bit, shiftR, testBit, zeroBits, (.|.)) @@ -24,58 +22,8 @@ import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) benches :: Benchmark benches = bgroup "Basic bitwise shift" $ benchBasic "Basic bitwise shift" <$> sizes -overlongBenches :: Benchmark -overlongBenches = bgroup "Overlong bitwise shift" $ benchOverlong "Overlong bitwise shift" <$> sizes - -byteStepBenches :: Benchmark -byteStepBenches = bgroup "Byte bitwise shift" $ benchByteShift "Byte bitwise shift" <$> sizes - -- Helpers -benchByteShift :: - String -> - Int -> - Benchmark -benchByteShift mainLabel len = - withResource (mkUnaryArg len) noCleanup $ \xs -> - let noPrecheckByteLabel = "No precheck, byte shift" - noPrecheckNotLabel = "No precheck, non-byte shift" - precheckByteLabel = "Precheck, byte shift" - precheckNotLabel = "Precheck, non-byte shift" - precheckCByteLabel = "Precheck in C, byte shift" - precheckCNotLabel = "Precheck in C, non-byte shift" - testLabel = mainLabel <> ", length " <> show len - matchLabelByte = "$NF == \"" <> noPrecheckByteLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" - matchLabelNot = "$NF == \"" <> noPrecheckNotLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench noPrecheckByteLabel . nfIO $ bitShift ((len - 1) * 8) <$> xs, - bench noPrecheckNotLabel . nfIO $ bitShift (len * 4 - 1) <$> xs, - bcompare matchLabelByte . bench precheckByteLabel . nfIO $ precheckByte bitShift ((len - 1) * 8) <$> xs, - bcompare matchLabelNot . bench precheckNotLabel . nfIO $ precheckByte bitShift (len * 4 - 1) <$> xs, - bcompare matchLabelByte . bench precheckCByteLabel . nfIO $ precheckByteC bitShift ((len - 1) * 8) <$> xs, - bcompare matchLabelNot . bench precheckCNotLabel . nfIO $ precheckByteC bitShift (len * 4 - 1) <$> xs - ] - -benchOverlong :: - String -> - Int -> - Benchmark -benchOverlong mainLabel len = - withResource (mkUnaryArg len) noCleanup $ \xs -> - let noPrecheckOverlongLabel = "No precheck, overlong" - noPrecheckNotLabel = "No precheck, not overlong" - precheckOverlongLabel = "Precheck, overlong" - precheckNotLabel = "Precheck, not overlong" - testLabel = mainLabel <> ", length " <> show len - matchLabelOverlong = "$NF == \"" <> noPrecheckOverlongLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" - matchLabelNot = "$NF == \"" <> noPrecheckNotLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench noPrecheckOverlongLabel . nfIO $ bitShift (len * 16) <$> xs, - bench noPrecheckNotLabel . nfIO $ bitShift (len * 4) <$> xs, - bcompare matchLabelOverlong . bench precheckOverlongLabel . nfIO $ precheckOverlong bitShift (len * 16) <$> xs, - bcompare matchLabelNot . bench precheckNotLabel . nfIO $ precheckOverlong bitShift (len * 4) <$> xs - ] - benchBasic :: String -> Int -> @@ -83,54 +31,14 @@ benchBasic :: benchBasic mainLabel len = withResource (mkUnaryArg len) noCleanup $ \xs -> let naiveLabel = "ByteString ops" - testLabel = mainLabel <> ", length " <> show len in + cLabel = "C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ - bench naiveLabel . nfIO $ bitShift (len * 4) <$> xs + bench naiveLabel . nfIO $ bitShift (len * 4) <$> xs, + bcompare matchLabel . bench cLabel . nfIO $ bitShiftC (len * 4) <$> xs ] -precheckByte :: - (Int -> ByteString -> ByteString) -> - Int -> - ByteString -> - ByteString -precheckByte f i bs = case i `quotRem` 8 of - (i', 0) -> fromList $ go . (`subtract` i') <$> [0 .. len - 1] - _ -> f i bs - where - go :: Int -> Word8 - go readIx - | readIx < 0 = zeroBits - | readIx >= len = zeroBits - | otherwise = BS.index bs readIx - len :: Int - len = BS.length bs - -precheckByteC :: - (Int -> ByteString -> ByteString) -> - Int -> - ByteString -> - ByteString -precheckByteC f i bs = case i `quotRem` 8 of - (i', 0) -> unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do - fp <- mallocByteString len - withForeignPtr fp $ \dst -> cShiftBytes (fromIntegral i') dst (castPtr src) . fromIntegral $ len - pure . fromForeignPtr (castForeignPtr fp) 0 $ len - _ -> f i bs - -precheckOverlong :: - (Int -> ByteString -> ByteString) -> - Int -> - ByteString -> - ByteString -precheckOverlong f i bs - | abs i >= bitLen = BS.replicate len zeroBits - | otherwise = f i bs - where - len :: Int - len = BS.length bs - bitLen :: Int - bitLen = len * 8 - bitShift :: Int -> ByteString -> ByteString bitShift i bs = case signum i of 0 -> bs @@ -142,6 +50,14 @@ bitShift i bs = case signum i of zipped = zip [7, 6 .. 0] bits in foldl' (\acc (pos, b) -> acc .|. bool zeroBits (bit pos) b) zeroBits zipped +bitShiftC :: Int -> ByteString -> ByteString +bitShiftC i bs = case signum i of + 0 -> bs + _ -> unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do + fp <- mallocByteString len + withForeignPtr fp $ \dst -> cShiftBits (fromIntegral i) dst (castPtr src) . fromIntegral $ len + pure . fromForeignPtr (castForeignPtr fp) 0 $ len + bitAtClipping :: ByteString -> Int -> Bool bitAtClipping bs i | i < 0 = False @@ -153,8 +69,8 @@ bitAtClipping bs i bitLength :: Int bitLength = BS.length bs * 8 -foreign import ccall unsafe "cbits.h c_shift_bytes" - cShiftBytes :: +foreign import ccall unsafe "cbits.h c_shift_bits" + cShiftBits :: CInt -> Ptr CUChar -> Ptr CUChar -> diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 48b7d3a7714..9031c58da78 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -49,9 +49,7 @@ main = do BitWrite.benches ], testGroup "Bit shift" [ - Shift.benches, - Shift.overlongBenches, - Shift.byteStepBenches + Shift.benches ], bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index 12f6c3b0590..81da5124cc6 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -53,7 +53,7 @@ size_t c_clz_block_unrolled(unsigned char const *restrict src, size_t len); // Shift -void c_shift_bytes(int shift, unsigned char *restrict dst, - unsigned char const *restrict src, size_t const len); +void c_shift_bits(int bit_shift, unsigned char *restrict dst, + unsigned char const *restrict src, size_t len); #endif /* CBITS_H */ diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/shift.c b/plutus-core/plutus-core/bench/bitwise/cbits/shift.c index 70e9b7ca2dc..9b50d18d689 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/shift.c +++ b/plutus-core/plutus-core/bench/bitwise/cbits/shift.c @@ -1,14 +1,59 @@ #include "cbits.h" +#include #include -void c_shift_bytes(int shift, unsigned char *restrict dst, - unsigned char const *restrict src, size_t const len) { - if (shift < 0) { - int const abs_shift = abs(shift); - memcpy(dst, src + abs_shift, len - abs_shift); - memset(dst + abs_shift, 0x00, abs_shift); +void c_shift_bits(int bit_shift, unsigned char *restrict dst, + unsigned char const *restrict src, size_t len) { + if (bit_shift > 0) { + size_t infill_bytes = bit_shift / 8; + size_t const bit_head_len = bit_shift % 8; + if (infill_bytes > len) { + infill_bytes = len; + } + memset(dst, 0x00, infill_bytes); + if (bit_head_len == 0) { + memcpy(dst + infill_bytes, src, len - infill_bytes); + } else { + size_t read_pos = 0; + size_t write_pos = infill_bytes; + unsigned char const hi_mask = (0x01 << bit_head_len) - 1; + unsigned char const lo_mask = ~hi_mask; + while (write_pos < len) { + if (read_pos == 0) { + dst[write_pos] = hi_mask & src[read_pos]; + } else { + dst[write_pos] = + (lo_mask & src[read_pos - 1]) | (hi_mask & src[read_pos]); + } + write_pos++; + read_pos++; + } + } } else { - memset(dst, 0x00, shift); - memcpy(dst + shift, src, len - shift); + size_t const abs_bit_shift = abs(bit_shift); + size_t infill_bytes = abs_bit_shift / 8; + size_t const bit_tail_len = abs_bit_shift % 8; + if (infill_bytes > len) { + infill_bytes = len; + } + if (bit_tail_len == 0) { + memcpy(dst, src + infill_bytes, len - infill_bytes); + } else { + size_t read_pos = infill_bytes; + size_t write_pos = 0; + unsigned char const hi_mask = (0x01 << bit_tail_len) - 1; + unsigned char const lo_mask = ~hi_mask; + while (read_pos < len) { + if (read_pos == (len - 1)) { + dst[write_pos] = lo_mask & src[read_pos]; + } else { + dst[write_pos] = + (lo_mask & src[read_pos]) | (hi_mask & src[read_pos + 1]); + } + write_pos++; + read_pos++; + } + } + memset(dst + (len - infill_bytes), 0x00, infill_bytes); } } From 4a9c80b3ce1ba0827af3847e3786a2fc61eec00b Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 25 Aug 2022 09:55:36 +1200 Subject: [PATCH 50/73] Remove Implementation module, bitwise rotation benches --- plutus-core/plutus-core.cabal | 2 +- .../bench/bitwise/Benches/Rotate.hs | 56 +++++++++ .../bench/bitwise/Implementations.hs | 112 ------------------ plutus-core/plutus-core/bench/bitwise/Main.hs | 56 +-------- 4 files changed, 63 insertions(+), 163 deletions(-) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/Rotate.hs delete mode 100644 plutus-core/plutus-core/bench/bitwise/Implementations.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index c0b6c45ad54..b61dd87f990 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -798,9 +798,9 @@ benchmark bitwise Benches.CountLeadingZeroes Benches.Homogenous Benches.Popcount + Benches.Rotate Benches.Shift DataGen - Implementations include-dirs: plutus-core/bench/bitwise/cbits c-sources: diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Rotate.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Rotate.hs new file mode 100644 index 00000000000..15b90680819 --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Rotate.hs @@ -0,0 +1,56 @@ +module Benches.Rotate ( + benches, + ) where + +import Data.Bits (bit, shiftR, testBit, zeroBits, (.|.)) +import Data.Bool (bool) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.Foldable (foldl') +import Data.Word (Word8) +import DataGen (mkUnaryArg, noCleanup, sizes) +import GHC.Exts (fromList) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bench, bgroup, nfIO) + +benches :: Benchmark +benches = bgroup "Basic bitwise rotate" $ benchBasic "Basic bitwise rotate" <$> sizes + +-- Helpers + +benchBasic :: + String -> + Int -> + Benchmark +benchBasic mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let naiveLabel = "ByteString ops" + testLabel = mainLabel <> ", length " <> show len in + bgroup testLabel [ + bench naiveLabel . nfIO $ bitRotate (len * 4) <$> xs + ] + +bitRotate :: Int -> ByteString -> ByteString +bitRotate i bs + | bitLen == 0 = bs + | otherwise = case i `rem` bitLen of + 0 -> bs -- nothing to do + j -> fromList $ go j <$> [0 .. BS.length bs - 1] + where + bitLen :: Int + bitLen = BS.length bs * 8 + go :: Int -> Int -> Word8 + go j byteIx = let bitIxes = (\ix -> 8 * byteIx - j + ix) <$> [0 .. 7] + bits = bitAtWraparound bs <$> bitIxes + zipped = zip [7, 6 .. 0] bits in + foldl' (\acc (pos, b) -> acc .|. bool zeroBits (bit pos) b) zeroBits zipped + +bitAtWraparound :: ByteString -> Int -> Bool +bitAtWraparound bs i + | i < 0 = bitAtWraparound bs (i + bitLength) + | otherwise = let (bigIx, smallIx) = i `quotRem` 8 + byte = BS.index bs bigIx in + testBit byte $ shiftR 0x80 smallIx + where + bitLength :: Int + bitLength = BS.length bs * 8 diff --git a/plutus-core/plutus-core/bench/bitwise/Implementations.hs b/plutus-core/plutus-core/bench/bitwise/Implementations.hs deleted file mode 100644 index 8dfceb1f81f..00000000000 --- a/plutus-core/plutus-core/bench/bitwise/Implementations.hs +++ /dev/null @@ -1,112 +0,0 @@ --- editorconfig-checker-disable-file -module Implementations ( - rotateBS, - rotateBSFast, - ) where - -import Control.Monad (void) -import Data.Bits (bit, rotate, zeroBits, (.&.), (.|.)) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCStringLen) -import Data.Foldable (foldl', for_) -import Data.Word (Word8) -import Foreign.C.Types (CSize) -import Foreign.Marshal.Alloc (mallocBytes) -import Foreign.Ptr (Ptr, castPtr, plusPtr) -import Foreign.Storable (peek, poke) -import GHC.IO.Handle.Text (memcpy) -import System.IO.Unsafe (unsafeDupablePerformIO) - --- Clone of rotation logic without any prechecks -rotateBS :: ByteString -> Int -> ByteString -rotateBS bs i = case i `rem` bitLen of - 0 -> bs - magnitude -> overPtrLen bs $ \ptr len -> go ptr len magnitude - where - bitLen :: Int - bitLen = BS.length bs * 8 - go :: Ptr Word8 -> Int -> Int -> IO (Ptr Word8) - go _ len displacement = do - dst <- mallocBytes len - for_ [0 .. len - 1] $ \j -> do - let start = (len - 1 - j) * 8 - let dstByte = foldl' (addBit start displacement) zeroBits [0 .. 7] - poke (plusPtr dst j) dstByte - pure dst - addBit :: Int -> Int -> Word8 -> Int -> Word8 - addBit start displacement acc offset = - let oldIx = (offset + start + bitLen - displacement) `rem` bitLen in - if dangerousRead bs oldIx - then acc .|. bit offset - else acc - --- Precheck and block optimizations -rotateBSFast :: ByteString -> Int -> ByteString -rotateBSFast bs i = case i `rem` bitLen of - 0 -> bs - magnitude -> overPtrLen bs $ \ptr len -> go ptr len magnitude - where - bitLen :: Int - bitLen = BS.length bs * 8 - go :: Ptr Word8 -> Int -> Int -> IO (Ptr Word8) - go src len displacement = do - dst <- mallocBytes len - case len of - -- If we only have one byte, we an borrow from the Bits instance for - -- Word8. - 1 -> do - srcByte <- peek src - let srcByte' = srcByte `rotate` displacement - poke dst srcByte' - -- If we rotate by a multiple of 8, we only need to move around whole - -- bytes, rather than individual bits. Because we only move contiguous - -- blocks (regardless of rotation direction), we can do this using - -- memcpy, which is must faster, especially on larger ByteStrings. - _ -> case displacement `quotRem` 8 of - (bigMove, 0) -> do - let mainLen :: CSize = fromIntegral . abs $ bigMove - let restLen :: CSize = fromIntegral len - mainLen - void $ case signum bigMove of - 1 -> memcpy (plusPtr dst . fromIntegral $ restLen) src mainLen >> - memcpy dst (plusPtr src . fromIntegral $ mainLen) restLen - _ -> memcpy (plusPtr dst . fromIntegral $ mainLen) src restLen >> - memcpy dst (plusPtr src . fromIntegral $ restLen) mainLen - -- If we don't rotate by a multiple of 8, we have to construct new - -- bytes, rather than just copying over old ones. We do this in two - -- steps: - -- - -- 1. Compute the 'read offset' into the source ByteString based on - -- the rotation magnitude and direction. - -- 2. Use that read offset to perform an (unchecked) bit lookup for an - -- entire 8-bit block, then construct the byte that results. - -- - -- We can do the bytes in the result in any order using this method: - -- we choose to do it in traversal order. - _ -> for_ [0 .. len - 1] $ \j -> do - let start = (len - 1 - j) * 8 - let dstByte = foldl' (addBit start displacement) zeroBits [0 .. 7] - poke (plusPtr dst j) dstByte - pure dst - addBit :: Int -> Int -> Word8 -> Int -> Word8 - addBit start displacement acc offset = - let oldIx = (offset + start + bitLen - displacement) `rem` bitLen in - if dangerousRead bs oldIx - then acc .|. bit offset - else acc - --- Helpers - -overPtrLen :: ByteString -> (Ptr Word8 -> Int -> IO (Ptr Word8)) -> ByteString -overPtrLen bs f = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ - \(ptr, len) -> f (castPtr ptr) len >>= \p -> - unsafePackMallocCStringLen (castPtr p, len) - -dangerousRead :: ByteString -> Int -> Bool -dangerousRead bs i = - let (bigOffset, smallOffset) = i `quotRem` 8 - bigIx = BS.length bs - bigOffset - 1 - mask = bit smallOffset in - case mask .&. BS.index bs bigIx of - 0 -> False - _ -> True diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 9031c58da78..2a254b101db 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -12,14 +12,11 @@ import Benches.Complement qualified as Complement import Benches.CountLeadingZeroes qualified as CountLeadingZeroes import Benches.Homogenous qualified as Homogenous import Benches.Popcount qualified as Popcount +import Benches.Rotate qualified as Rotate import Benches.Shift qualified as Shift -import Data.Bits (complement, zeroBits, (.&.)) -import Data.ByteString qualified as BS -import DataGen (mkUnaryArg, noCleanup, sizes) import GHC.IO.Encoding (setLocaleEncoding, utf8) -import Implementations (rotateBS, rotateBSFast) -import Test.Tasty (testGroup, withResource) -import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, defaultMain, nfIO) +import Test.Tasty (testGroup) +import Test.Tasty.Bench (defaultMain) main :: IO () main = do @@ -51,48 +48,7 @@ main = do testGroup "Bit shift" [ Shift.benches ], - bgroup rotateLabel . fmap (rotateVsPrescanBench rotateLabel) $ sizes, - bgroup rotateLabel' . fmap (rotateFastVsSlow rotateLabel') $ sizes + testGroup "Bit rotate" [ + Rotate.benches + ] ] - where - rotateLabel :: String - rotateLabel = "Slow rotate versus prescan" - rotateLabel' :: String - rotateLabel' = "Bitwise rotate versus block rotate" - --- Benchmarks - -rotateFastVsSlow :: - String -> - Int -> - Benchmark -rotateFastVsSlow mainLabel len = - withResource (mkUnaryArg len) noCleanup $ \xs -> - let rLabel = "rotate (bit-by-bit)" - rLabel' = "rotate (block-optimized)" - -- Next highest multiple of 8 of half our length, rounded down - rotation = ((len `quot` 2) + 7) .&. negate 8 - testLabel = mainLabel <> ", length " <> show len <> ", rotation by " <> show rotation - matchLabel = "$NF == \"" <> rLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench rLabel . nfIO $ rotateBS <$> xs <*> pure rotation, - bcompare matchLabel . bench rLabel' . nfIO $ rotateBSFast <$> xs <*> pure rotation - ] - -rotateVsPrescanBench :: - String -> - Int -> - Benchmark -rotateVsPrescanBench mainLabel len = - withResource (mkUnaryArg len) noCleanup $ \xs -> - let rLabel = "rotate (bit-by-bit)" - pLabel = "prescan (naive)" - rotation = len `quot` 2 - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> rLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench rLabel . nfIO $ rotateBS <$> xs <*> pure rotation, - bcompare matchLabel . bench pLabel . nfIO $ (||) <$> (BS.all (== zeroBits) <$> xs) <*> - (BS.all (== complement zeroBits) <$> xs) - ] - From c4d9af9b4a632fcb9b45e3de2247a28863e3137c Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 25 Aug 2022 10:51:14 +1200 Subject: [PATCH 51/73] C bitwise rotation, clear away un-needed benches and implementations --- plutus-core/plutus-core.cabal | 3 +- .../bench/bitwise/Benches/Homogenous.hs | 56 ------------------- .../bench/bitwise/Benches/Rotate.hs | 37 +++++++++++- .../bench/bitwise/Benches/Shift.hs | 3 +- plutus-core/plutus-core/bench/bitwise/Main.hs | 4 -- .../plutus-core/bench/bitwise/cbits/cbits.h | 15 ++--- .../bench/bitwise/cbits/homogenous.c | 31 ---------- .../plutus-core/bench/bitwise/cbits/rotate.c | 25 +++++++++ 8 files changed, 67 insertions(+), 107 deletions(-) delete mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/Homogenous.hs delete mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/homogenous.c create mode 100644 plutus-core/plutus-core/bench/bitwise/cbits/rotate.c diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index b61dd87f990..b827e2f69b8 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -796,7 +796,6 @@ benchmark bitwise Benches.BitWrite Benches.Complement Benches.CountLeadingZeroes - Benches.Homogenous Benches.Popcount Benches.Rotate Benches.Shift @@ -808,8 +807,8 @@ benchmark bitwise plutus-core/bench/bitwise/cbits/bit-access.c plutus-core/bench/bitwise/cbits/clz.c plutus-core/bench/bitwise/cbits/complement.c - plutus-core/bench/bitwise/cbits/homogenous.c plutus-core/bench/bitwise/cbits/popcount.c + plutus-core/bench/bitwise/cbits/rotate.c plutus-core/bench/bitwise/cbits/shift.c cc-options: -O3 diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Homogenous.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Homogenous.hs deleted file mode 100644 index bd93b26fd4a..00000000000 --- a/plutus-core/plutus-core/bench/bitwise/Benches/Homogenous.hs +++ /dev/null @@ -1,56 +0,0 @@ -module Benches.Homogenous ( - benches - ) where - -import Data.Bits (zeroBits) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Unsafe (unsafeUseAsCStringLen) -import Data.Word (Word8) -import DataGen (mkHomogenousArg, noCleanup, sizes) -import Foreign.C.Types (CBool (CBool), CSize (CSize), CUChar) -import Foreign.Ptr (Ptr, castPtr) -import Test.Tasty (withResource) -import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) - -benches :: Benchmark -benches = bgroup "Basic homogeneity" $ benchBasic "Basic homogeneity" <$> sizes - --- Helpers - -benchBasic :: - String -> - Int -> - Benchmark -benchBasic mainLabel len = - withResource (mkHomogenousArg len zeroBits) noCleanup $ \xs -> - let naiveLabel = "all" - cnaiveLabel = "naive C" - cslidingLabel = "sliding window C" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench naiveLabel . nfIO $ BS.all (== zeroBits) <$> xs, - bcompare matchLabel . bench cnaiveLabel . nfIO $ xs >>= wrapping (cHomogenousNaive zeroBits), - bcompare matchLabel . bench cslidingLabel . nfIO $ xs >>= wrapping (cHomogenousSlidingWindow zeroBits) - ] - --- Avoids having to rewrap C ops tediously each time -wrapping :: (Ptr CUChar -> CSize -> CBool) -> ByteString -> IO Bool -wrapping f bs = unsafeUseAsCStringLen bs $ \(ptr, len) -> do - let (CBool res) = f (castPtr ptr) (fromIntegral len) - pure $ res /= 0 - -foreign import ccall unsafe "cbits.h c_homogenous_naive" - cHomogenousNaive :: - Word8 -> - Ptr CUChar -> - CSize -> - CBool - -foreign import ccall unsafe "cbits.h c_homogenous_sliding_window" - cHomogenousSlidingWindow :: - Word8 -> - Ptr CUChar -> - CSize -> - CBool diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Rotate.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Rotate.hs index 15b90680819..5123fb1a01d 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/Rotate.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Rotate.hs @@ -6,12 +6,18 @@ import Data.Bits (bit, shiftR, testBit, zeroBits, (.|.)) import Data.Bool (bool) import Data.ByteString (ByteString) import Data.ByteString qualified as BS +import Data.ByteString.Internal (fromForeignPtr, mallocByteString) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Foldable (foldl') import Data.Word (Word8) import DataGen (mkUnaryArg, noCleanup, sizes) +import Foreign.C.Types (CInt (CInt), CSize (CSize), CUChar) +import Foreign.ForeignPtr (castForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, castPtr) import GHC.Exts (fromList) +import System.IO.Unsafe (unsafeDupablePerformIO) import Test.Tasty (withResource) -import Test.Tasty.Bench (Benchmark, bench, bgroup, nfIO) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) benches :: Benchmark benches = bgroup "Basic bitwise rotate" $ benchBasic "Basic bitwise rotate" <$> sizes @@ -25,9 +31,12 @@ benchBasic :: benchBasic mainLabel len = withResource (mkUnaryArg len) noCleanup $ \xs -> let naiveLabel = "ByteString ops" - testLabel = mainLabel <> ", length " <> show len in + cLabel = "C" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ - bench naiveLabel . nfIO $ bitRotate (len * 4) <$> xs + bench naiveLabel . nfIO $ bitRotate (len * 4) <$> xs, + bcompare matchLabel . bench cLabel . nfIO $ bitRotateC (len * 4) <$> xs ] bitRotate :: Int -> ByteString -> ByteString @@ -45,6 +54,20 @@ bitRotate i bs zipped = zip [7, 6 .. 0] bits in foldl' (\acc (pos, b) -> acc .|. bool zeroBits (bit pos) b) zeroBits zipped +bitRotateC :: Int -> ByteString -> ByteString +bitRotateC i bs + | bitLen == 0 = bs + | otherwise = case i `rem` bitLen of + 0 -> bs -- nothing to do + j -> unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do + fp <- mallocByteString len + withForeignPtr fp $ \dst -> + cRotateBits (fromIntegral j) dst (castPtr src) . fromIntegral $ len + pure . fromForeignPtr (castForeignPtr fp) 0 $ len + where + bitLen :: Int + bitLen = BS.length bs * 8 + bitAtWraparound :: ByteString -> Int -> Bool bitAtWraparound bs i | i < 0 = bitAtWraparound bs (i + bitLength) @@ -54,3 +77,11 @@ bitAtWraparound bs i where bitLength :: Int bitLength = BS.length bs * 8 + +foreign import ccall unsafe "cbits.h c_rotate_bits" + cRotateBits :: + CInt -> + Ptr CUChar -> + Ptr CUChar -> + CSize -> + IO () diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs index bc1216bd53b..98b204fe697 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Shift.hs @@ -55,7 +55,8 @@ bitShiftC i bs = case signum i of 0 -> bs _ -> unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(src, len) -> do fp <- mallocByteString len - withForeignPtr fp $ \dst -> cShiftBits (fromIntegral i) dst (castPtr src) . fromIntegral $ len + withForeignPtr fp $ \dst -> + cShiftBits (fromIntegral i) dst (castPtr src) . fromIntegral $ len pure . fromForeignPtr (castForeignPtr fp) 0 $ len bitAtClipping :: ByteString -> Int -> Bool diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index 2a254b101db..b5683163b39 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -10,7 +10,6 @@ import Benches.BitRead qualified as BitRead import Benches.BitWrite qualified as BitWrite import Benches.Complement qualified as Complement import Benches.CountLeadingZeroes qualified as CountLeadingZeroes -import Benches.Homogenous qualified as Homogenous import Benches.Popcount qualified as Popcount import Benches.Rotate qualified as Rotate import Benches.Shift qualified as Shift @@ -29,9 +28,6 @@ main = do testGroup "Complement" [ Complement.benches ], - testGroup "Homogenous" [ - Homogenous.benches - ], testGroup "Binary" [ Binary.benches ], diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h index 81da5124cc6..8c6f025f484 100644 --- a/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h +++ b/plutus-core/plutus-core/bench/bitwise/cbits/cbits.h @@ -17,16 +17,6 @@ size_t c_popcount_block_unroll(unsigned char const *restrict src, size_t len); void c_complement_naive(unsigned char *restrict dst, unsigned char const *restrict src, size_t const len); -// Homogeneity - -bool c_homogenous_naive(unsigned char const needle, - unsigned char const *restrict haystack, - size_t const len); - -bool c_homogenous_sliding_window(unsigned char const needle, - unsigned char const *restrict haystack, - size_t len); - // Binary ops void c_and_naive(unsigned char *restrict dst, unsigned char const *src1, @@ -56,4 +46,9 @@ size_t c_clz_block_unrolled(unsigned char const *restrict src, size_t len); void c_shift_bits(int bit_shift, unsigned char *restrict dst, unsigned char const *restrict src, size_t len); +// Rotate + +void c_rotate_bits(int bit_rotation, unsigned char *restrict dst, + unsigned char const *restrict src, size_t len); + #endif /* CBITS_H */ diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/homogenous.c b/plutus-core/plutus-core/bench/bitwise/cbits/homogenous.c deleted file mode 100644 index cdc28ef873d..00000000000 --- a/plutus-core/plutus-core/bench/bitwise/cbits/homogenous.c +++ /dev/null @@ -1,31 +0,0 @@ -#include "cbits.h" -#include - -bool c_homogenous_naive(unsigned char const needle, - unsigned char const *restrict haystack, - size_t const len) { - bool homogenous = true; - for (size_t i = 0; i < len; i++) { - if (haystack[i] != needle) { - homogenous = false; - break; - } - } - return homogenous; -} - -bool c_homogenous_sliding_window(unsigned char const needle, - unsigned char const *restrict haystack, - size_t len) { - for (size_t i = 0; i < 16; i++) { - if (len == 0) { - return true; - } - if (haystack[0] != needle) { - return false; - } - haystack++; - len--; - } - return (memcmp(haystack - 16, haystack, len) == 0); -} diff --git a/plutus-core/plutus-core/bench/bitwise/cbits/rotate.c b/plutus-core/plutus-core/bench/bitwise/cbits/rotate.c new file mode 100644 index 00000000000..df82cf660ab --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/cbits/rotate.c @@ -0,0 +1,25 @@ +#include "cbits.h" + +void c_rotate_bits(int bit_rotation, unsigned char *restrict dst, + unsigned char const *restrict src, size_t len) { + if (bit_rotation > 0) { + size_t read_pos = bit_rotation / 8; + size_t bit_tail_len = bit_rotation % 8; + size_t write_pos = 0; + unsigned char const tail_mask = (0x01 << bit_tail_len) - 1; + unsigned char const head_mask = ~tail_mask; + while (write_pos < len) { + if (read_pos == len - 1) { + dst[write_pos] = (head_mask & src[read_pos]) | (tail_mask & src[0]); + read_pos = 0; + } else { + dst[write_pos] = + (head_mask & src[read_pos]) | (tail_mask & src[read_pos + 1]); + read_pos++; + } + write_pos++; + } + } else { + c_rotate_bits((len * 8) + bit_rotation, dst, src, len); + } +} From d0fcc9e4478e8f8e2d355029c5263b7bb520a105 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Thu, 25 Aug 2022 14:29:35 +1200 Subject: [PATCH 52/73] Benches for BS to Integer conversion --- plutus-core/plutus-core.cabal | 1 + .../bench/bitwise/Benches/Convert.hs | 151 ++++++++++++++++++ plutus-core/plutus-core/bench/bitwise/Main.hs | 5 + 3 files changed, 157 insertions(+) create mode 100644 plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index b827e2f69b8..6c2508979cf 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -795,6 +795,7 @@ benchmark bitwise Benches.BitRead Benches.BitWrite Benches.Complement + Benches.Convert Benches.CountLeadingZeroes Benches.Popcount Benches.Rotate diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs new file mode 100644 index 00000000000..e7125b9852b --- /dev/null +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE BangPatterns #-} + +module Benches.Convert ( + benchesBSToI, + benchesBSToIBlock, + ) where + +import Control.Monad (guard) +import Data.Bits (unsafeShiftL) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import Data.Word (Word16, Word32, Word64, Word8) +import DataGen (mkUnaryArg, noCleanup, sizes) +import Foreign.C.Types (CChar) +import Foreign.Ptr (Ptr) +import Foreign.Storable (peekByteOff) +import System.IO.Unsafe (unsafeDupablePerformIO) +import Test.Tasty (withResource) +import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) + +benchesBSToI :: Benchmark +benchesBSToI = bgroup "Basic ByteString to Integer conversion" $ + benchBSToI "Basic ByteString to Integer conversion" <$> sizes + +benchesBSToIBlock :: Benchmark +benchesBSToIBlock = bgroup "Block ByteString to Integer conversion" $ + benchBSToIBlock "Block ByteString to Integer conversion" <$> sizes + +-- Helpers + +benchBSToIBlock :: + String -> + Int -> + Benchmark +benchBSToIBlock mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let shiftLabel = "scan backwards with shifts" + blockLabel = "scan backwards in blocks with shifts" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> shiftLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench shiftLabel . nfIO $ bsToIShift <$> xs, + bcompare matchLabel . bench blockLabel . nfIO $ bsToIShiftBlock <$> xs + ] + +benchBSToI :: + String -> + Int -> + Benchmark +benchBSToI mainLabel len = + withResource (mkUnaryArg len) noCleanup $ \xs -> + let naiveLabel = "scan backwards" + forwardsLabel = "scan forwards" + shiftLabel = "scan backwards with shifts" + forwardsShiftLabel = "scan forwards with shifts" + testLabel = mainLabel <> ", length " <> show len + matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in + bgroup testLabel [ + bench naiveLabel . nfIO $ bsToI <$> xs, + bcompare matchLabel . bench forwardsLabel . nfIO $ bsToIForward <$> xs, + bcompare matchLabel . bench shiftLabel . nfIO $ bsToIShift <$> xs, + bcompare matchLabel . bench forwardsShiftLabel . nfIO $ bsToIShiftForward <$> xs + ] + +-- Implementations + +bsToI :: ByteString -> Maybe Integer +bsToI bs = do + guard (len > 0) + pure . go 0 1 $ len - 1 + where + len :: Int + len = BS.length bs + go :: Integer -> Integer -> Int -> Integer + go !acc !mult !ix = let limb :: Integer = fromIntegral . BS.index bs $ ix + limbValue = limb * mult + acc' = acc + limbValue in + if ix == 0 + then acc' + else go acc' (mult * 256) $ ix - 1 + +bsToIForward :: ByteString -> Maybe Integer +bsToIForward bs = do + guard (len > 0) + pure . snd . BS.foldl' go (256 ^ (len - 1), 0) $ bs + where + len :: Int + len = BS.length bs + go :: (Integer, Integer) -> Word8 -> (Integer, Integer) + go (mult, acc) w8 = let limbValue = fromIntegral w8 * mult in + (mult `quot` 256, acc + limbValue) + +bsToIShift :: ByteString -> Maybe Integer +bsToIShift bs = do + guard (len > 0) + pure . go 0 0 $ len - 1 + where + len :: Int + len = BS.length bs + go :: Integer -> Int -> Int -> Integer + go !acc !shift !ix = let limb :: Integer = fromIntegral . BS.index bs $ ix + limbValue = limb `unsafeShiftL` shift + acc' = acc + limbValue in + if ix == 0 + then acc' + else go acc' (shift + 8) $ ix - 1 + +bsToIShiftBlock :: ByteString -> Maybe Integer +bsToIShiftBlock bs = do + guard (len > 0) + pure . unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(p, _) -> do + go p 0 0 $ len - 1 + where + len :: Int + len = BS.length bs + go :: Ptr CChar -> Integer -> Int -> Int -> IO Integer + go p !acc !shift !ix + | ix >= 7 = do + w64 :: Word64 <- peekByteOff p (ix - 7) + let limb :: Integer = fromIntegral w64 + let limbValue = limb `unsafeShiftL` shift + go p (acc + limbValue) (shift + 64) $ ix - 8 + | ix >= 3 = do + w32 :: Word32 <- peekByteOff p (ix - 3) + let limb :: Integer = fromIntegral w32 + let limbValue = limb `unsafeShiftL` shift + go p (acc + limbValue) (shift + 32) $ ix - 4 + | ix >= 1 = do + w16 :: Word16 <- peekByteOff p (ix - 1) + let limb :: Integer = fromIntegral w16 + let limbValue = limb `unsafeShiftL` shift + go p (acc + limbValue) (shift + 16) $ ix - 2 + | ix == 0 = do + w8 :: Word8 <- peekByteOff p ix + let limb :: Integer = fromIntegral w8 + let limbValue = limb `unsafeShiftL` shift + pure $ acc + limbValue + | otherwise = pure acc + +bsToIShiftForward :: ByteString -> Maybe Integer +bsToIShiftForward bs = do + guard (len > 0) + pure . snd . BS.foldl' go ((len - 1) * 8, 0) $ bs + where + len :: Int + len = BS.length bs + go :: (Int, Integer) -> Word8 -> (Int, Integer) + go (shift, acc) w8 = let limbValue = fromIntegral w8 `unsafeShiftL` shift in + (shift - 8, acc + limbValue) + diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index b5683163b39..fb1233d4c57 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -9,6 +9,7 @@ import Benches.Binary qualified as Binary import Benches.BitRead qualified as BitRead import Benches.BitWrite qualified as BitWrite import Benches.Complement qualified as Complement +import Benches.Convert qualified as Convert import Benches.CountLeadingZeroes qualified as CountLeadingZeroes import Benches.Popcount qualified as Popcount import Benches.Rotate qualified as Rotate @@ -46,5 +47,9 @@ main = do ], testGroup "Bit rotate" [ Rotate.benches + ], + testGroup "Conversions" [ + Convert.benchesBSToI, + Convert.benchesBSToIBlock ] ] From 2a258a534913e13e2f69d82b8286c9c737587001 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 26 Aug 2022 10:24:59 +1200 Subject: [PATCH 53/73] Merge block converter with other benches --- .../bench/bitwise/Benches/Convert.hs | 24 +++---------------- plutus-core/plutus-core/bench/bitwise/Main.hs | 3 +-- 2 files changed, 4 insertions(+), 23 deletions(-) diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs index e7125b9852b..5ea9b7c98ca 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs @@ -2,7 +2,6 @@ module Benches.Convert ( benchesBSToI, - benchesBSToIBlock, ) where import Control.Monad (guard) @@ -23,27 +22,8 @@ benchesBSToI :: Benchmark benchesBSToI = bgroup "Basic ByteString to Integer conversion" $ benchBSToI "Basic ByteString to Integer conversion" <$> sizes -benchesBSToIBlock :: Benchmark -benchesBSToIBlock = bgroup "Block ByteString to Integer conversion" $ - benchBSToIBlock "Block ByteString to Integer conversion" <$> sizes - -- Helpers -benchBSToIBlock :: - String -> - Int -> - Benchmark -benchBSToIBlock mainLabel len = - withResource (mkUnaryArg len) noCleanup $ \xs -> - let shiftLabel = "scan backwards with shifts" - blockLabel = "scan backwards in blocks with shifts" - testLabel = mainLabel <> ", length " <> show len - matchLabel = "$NF == \"" <> shiftLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in - bgroup testLabel [ - bench shiftLabel . nfIO $ bsToIShift <$> xs, - bcompare matchLabel . bench blockLabel . nfIO $ bsToIShiftBlock <$> xs - ] - benchBSToI :: String -> Int -> @@ -53,6 +33,7 @@ benchBSToI mainLabel len = let naiveLabel = "scan backwards" forwardsLabel = "scan forwards" shiftLabel = "scan backwards with shifts" + blockLabel = "scan backwards in blocks with shifts" forwardsShiftLabel = "scan forwards with shifts" testLabel = mainLabel <> ", length " <> show len matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in @@ -60,7 +41,8 @@ benchBSToI mainLabel len = bench naiveLabel . nfIO $ bsToI <$> xs, bcompare matchLabel . bench forwardsLabel . nfIO $ bsToIForward <$> xs, bcompare matchLabel . bench shiftLabel . nfIO $ bsToIShift <$> xs, - bcompare matchLabel . bench forwardsShiftLabel . nfIO $ bsToIShiftForward <$> xs + bcompare matchLabel . bench forwardsShiftLabel . nfIO $ bsToIShiftForward <$> xs, + bcompare matchLabel . bench blockLabel . nfIO $ bsToIShiftBlock <$> xs ] -- Implementations diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index fb1233d4c57..fc74c95357f 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -49,7 +49,6 @@ main = do Rotate.benches ], testGroup "Conversions" [ - Convert.benchesBSToI, - Convert.benchesBSToIBlock + Convert.benchesBSToI ] ] From c6a675c535f05efc9ff2982c96275ae162fff3e1 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Fri, 26 Aug 2022 12:02:40 +1200 Subject: [PATCH 54/73] Integer to ByteString conversion benches --- plutus-core/plutus-core.cabal | 1 + .../bench/bitwise/Benches/Convert.hs | 35 +++++++++++++++++-- .../plutus-core/bench/bitwise/DataGen.hs | 22 ++++++++++-- plutus-core/plutus-core/bench/bitwise/Main.hs | 3 +- 4 files changed, 56 insertions(+), 5 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 6c2508979cf..9060604108b 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -820,6 +820,7 @@ benchmark bitwise build-depends: , base , bytestring + , mtl , random , tasty , tasty-bench diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs b/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs index 5ea9b7c98ca..711fa92e18e 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/Convert.hs @@ -2,18 +2,20 @@ module Benches.Convert ( benchesBSToI, + benchesIToBS, ) where import Control.Monad (guard) -import Data.Bits (unsafeShiftL) +import Data.Bits (unsafeShiftL, zeroBits) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Data.Word (Word16, Word32, Word64, Word8) -import DataGen (mkUnaryArg, noCleanup, sizes) +import DataGen (mkInteger, mkUnaryArg, noCleanup, sizes) import Foreign.C.Types (CChar) import Foreign.Ptr (Ptr) import Foreign.Storable (peekByteOff) +import GHC.Exts (fromList) import System.IO.Unsafe (unsafeDupablePerformIO) import Test.Tasty (withResource) import Test.Tasty.Bench (Benchmark, bcompare, bench, bgroup, nfIO) @@ -22,6 +24,10 @@ benchesBSToI :: Benchmark benchesBSToI = bgroup "Basic ByteString to Integer conversion" $ benchBSToI "Basic ByteString to Integer conversion" <$> sizes +benchesIToBS :: Benchmark +benchesIToBS = bgroup "Basic Integer to ByteString conversion" $ + benchIToBS "Basic Integer to ByteString conversion" <$> sizes + -- Helpers benchBSToI :: @@ -45,8 +51,33 @@ benchBSToI mainLabel len = bcompare matchLabel . bench blockLabel . nfIO $ bsToIShiftBlock <$> xs ] +benchIToBS :: + String -> + Int -> + Benchmark +benchIToBS mainLabel len = + withResource (mkInteger len) noCleanup $ \i -> + let naiveLabel = "naive" + testLabel = mainLabel <> ", length " <> show len in + bgroup testLabel [ + bench naiveLabel . nfIO $ iToBS <$> i + ] + -- Implementations +iToBS :: Integer -> Maybe ByteString +iToBS i = case signum i of + (-1) -> Nothing + 0 -> pure . BS.singleton $ zeroBits + _ -> pure $ if i < 256 + then BS.singleton . fromIntegral $ i + else fromList . go [] $ i + where + go :: [Word8] -> Integer -> [Word8] + go acc !j = case j `quotRem` 256 of + (0, r) -> fromIntegral r : acc -- we're done + (d, r) -> go (fromIntegral r : acc) d + bsToI :: ByteString -> Maybe Integer bsToI bs = do guard (len > 0) diff --git a/plutus-core/plutus-core/bench/bitwise/DataGen.hs b/plutus-core/plutus-core/bench/bitwise/DataGen.hs index 5a7e5253966..21ce2cac7e9 100644 --- a/plutus-core/plutus-core/bench/bitwise/DataGen.hs +++ b/plutus-core/plutus-core/bench/bitwise/DataGen.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,18 +6,35 @@ module DataGen ( mkUnaryArg, mkHomogenousArg, mkBinaryArgs, + mkInteger, mkZeroesOne, sizes, noCleanup, ) where import Control.Monad (replicateM) +import Control.Monad.State.Strict (State) +import Data.Bits (unsafeShiftL) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Kind (Type) import Data.Word (Word8) import GHC.Exts (fromListN) -import System.Random.Stateful (mkStdGen, randomM, runStateGen_) +import System.Random.Stateful (StateGenM, StdGen, mkStdGen, randomM, runStateGen_, uniformWord8) + +-- Generate an Integer that will require a representation of this many bytes +mkInteger :: Int -> IO Integer +mkInteger len = pure . runStateGen_ (mkStdGen 42) $ \gen -> + go gen 0 0 + where + go :: StateGenM StdGen -> Int -> Integer -> State StdGen Integer + go !gen !place !acc + | place == len = pure acc + -- we generate non-zero bytes to ensure we don't get truncations + | otherwise = do + block <- uniformWord8 gen + let result = fromIntegral $ if block == 0 then block + 1 else block + go gen (place + 1) $ acc + result `unsafeShiftL` (place * 8) -- Generate a ByteString of a given length mkUnaryArg :: Int -> IO ByteString @@ -44,4 +62,4 @@ noCleanup = const (pure ()) -- Basic set of sizes (in bytes) sizes :: [Int] -sizes = [((2 :: Int) ^ (i :: Int) - 1) | i <- [1 .. 15]] +sizes = [(2 :: Int) ^ (i :: Int) - 1 | i <- [1 .. 15]] diff --git a/plutus-core/plutus-core/bench/bitwise/Main.hs b/plutus-core/plutus-core/bench/bitwise/Main.hs index fc74c95357f..3dc911b270c 100644 --- a/plutus-core/plutus-core/bench/bitwise/Main.hs +++ b/plutus-core/plutus-core/bench/bitwise/Main.hs @@ -49,6 +49,7 @@ main = do Rotate.benches ], testGroup "Conversions" [ - Convert.benchesBSToI + Convert.benchesBSToI, + Convert.benchesIToBS ] ] From 4134f2c73a059a93ac02431871fd2528356ce2f0 Mon Sep 17 00:00:00 2001 From: Las Safin Date: Tue, 7 Mar 2023 15:22:28 +0000 Subject: [PATCH 55/73] Style fixes --- plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs | 6 ++++-- .../test/Evaluation/Builtins/Definition.hs | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs b/plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs index b817a3b81cd..5d2180ac5d5 100644 --- a/plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs +++ b/plutus-core/plutus-core/bench/bitwise/Benches/BitWrite.hs @@ -36,8 +36,10 @@ benchBasic mainLabel len = matchLabel = "$NF == \"" <> naiveLabel <> "\" && $(NF - 1) == \"" <> testLabel <> "\"" in bgroup testLabel [ bench naiveLabel . nfIO $ bitSet False (len - 1) <$> xs, - bcompare matchLabel . bench cnaiveLabel . nfIO $ wrapper cBitSetNaive False (len - 1) <$> xs, - bcompare matchLabel . bench cmemcpyLabel . nfIO $ wrapper cBitSetMemcpy False (len - 1) <$> xs + bcompare matchLabel . bench cnaiveLabel . nfIO + $ wrapper cBitSetNaive False (len - 1) <$> xs, + bcompare matchLabel . bench cmemcpyLabel . nfIO + $ wrapper cBitSetMemcpy False (len - 1) <$> xs ] bitSet :: Bool -> Int -> ByteString -> Maybe ByteString 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 b805c7b58d6..673517ea991 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -56,8 +56,8 @@ import PlutusCore.StdLib.Data.ScottList qualified as Scott import PlutusCore.StdLib.Data.Unit (unitval) import PlutusPrelude (Word8, def, isRight) import Test.Tasty (TestTree, adjustOption, testGroup) -import Test.Tasty.HUnit (Assertion, assertBool, testCase, (@=?), (@?=)) import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit), testPropertyNamed) +import Test.Tasty.HUnit (Assertion, assertBool, testCase, (@=?), (@?=)) type DefaultFunExt = Either DefaultFun ExtensionFun From d8fede415421806137c6bb5a304afcae1193c31c Mon Sep 17 00:00:00 2001 From: Las Safin Date: Thu, 9 Mar 2023 20:35:42 +0000 Subject: [PATCH 56/73] Fix issues from the previous merge --- plutus-core/plutus-core.cabal | 2 ++ .../test/Evaluation/Builtins/Definition.hs | 12 ++++++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 87f905b776b..b4ae7d29082 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -169,6 +169,7 @@ library UntypedPlutusCore.Rename other-modules: + Bitwise Data.Aeson.Flatten Data.Aeson.THReader Data.Functor.Foldable.Monadic @@ -358,6 +359,7 @@ test-suite untyped-plutus-core-test DeBruijn.Spec DeBruijn.UnDeBruijnify Evaluation.Builtins + Evaluation.Builtins.Bitwise Evaluation.Builtins.Common Evaluation.Builtins.Definition Evaluation.Builtins.MakeRead 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 673517ea991..2b16b731215 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -26,7 +26,8 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b popCountSingleByte, rotateHomogenous, rotateIdentity, rotateIndexMotion, rotateSum, shiftHomogenous, shiftIdentity, shiftIndexMotion, shiftSum, testBitAppend, testBitEmpty, testBitSingleByte, writeBitAgreement, writeBitDouble, writeBitRead) -import Evaluation.Builtins.Common (typecheckEvaluateCek, typecheckEvaluateCekNoEmit, typecheckReadKnownCek) +import Evaluation.Builtins.Common (typecheckEvaluateCek, typecheckEvaluateCekNoEmit, typecheckReadKnownCek, + unsafeEvaluateCekNoEmit) import Evaluation.Builtins.SignatureVerification (ecdsaSecp256k1Prop, ed25519_V1Prop, ed25519_V2Prop, schnorrSecp256k1Prop) import Hedgehog hiding (Opaque, Size, Var) @@ -38,13 +39,15 @@ import PlutusCore (Contains, Term (Builtin, LamAbs, Var), TyName (TyName), Type (TyApp, TyForall, TyFun, TyVar), Unique (Unique), freshName, mapFun, runQuote) import PlutusCore.Builtin (CostingPart, toTypeAst, typeOfBuiltinFunction) +import PlutusCore.Compiler.Erase (eraseTerm) import PlutusCore.Data (Data (B, Constr, I, List, Map)) import PlutusCore.Default (BuiltinVersion (DefaultFunV1, DefaultFunV2)) -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModel) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModel, defaultCekMachineCosts) +import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (CostModel), mkMachineParameters) import PlutusCore.Examples.Builtins (BuiltinErrorCall (BuiltinErrorCall), BuiltinVersion (ExtensionFunV0, PairV), - ExtensionFun (Const, ExpensivePlus, ExpensiveSucc, ExtensionVersion, Factorial, FailingPlus, FailingSucc, Id, IdFInteger, IdList, IdRank2, Swap)) + ExtensionFun (Const, ExpensivePlus, ExpensiveSucc, ExtensionVersion, Factorial, FailingPlus, FailingSucc, ForallFortyTwo, Id, IdFInteger, IdList, IdRank2, ScottToMetaUnit, Swap)) import PlutusCore.Examples.Data.Data (ofoldrData) -import PlutusCore.Generators.Interesting (factorial) +import PlutusCore.Generators.Hedgehog.Interesting (factorial) import PlutusCore.MkPlc hiding (error) import PlutusCore.StdLib.Data.Bool (bool, false, true) import PlutusCore.StdLib.Data.Data (caseData, dataTy) @@ -53,6 +56,7 @@ import PlutusCore.StdLib.Data.Integer (integer) import PlutusCore.StdLib.Data.List qualified as Builtin import PlutusCore.StdLib.Data.Pair (pair) import PlutusCore.StdLib.Data.ScottList qualified as Scott +import PlutusCore.StdLib.Data.ScottUnit qualified as Scott import PlutusCore.StdLib.Data.Unit (unitval) import PlutusPrelude (Word8, def, isRight) import Test.Tasty (TestTree, adjustOption, testGroup) From e44b1484982efba1f5d88aeb33662c0b032a7f9a Mon Sep 17 00:00:00 2001 From: Las Safin Date: Fri, 10 Mar 2023 00:16:45 +0000 Subject: [PATCH 57/73] Fix `integerToByteString` and its inverse according to spec They were incorrect before in two ways: - They were big-endian instead of little-endian. - They supported negative integers instead of only naturals. In addition, the implementation was cleaned up and heavily optimised. --- plutus-core/plutus-core.cabal | 1 + plutus-core/plutus-core/src/Bitwise.hs | 106 ++---------------- .../src/PlutusCore/Default/Builtins.hs | 10 +- .../test/Evaluation/Builtins/Bitwise.hs | 65 ++--------- .../test/Evaluation/Builtins/Definition.hs | 13 +-- 5 files changed, 38 insertions(+), 157 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index b4ae7d29082..11d5a92ebae 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -266,6 +266,7 @@ library , filepath , flat <0.5 , free + , ghc-bignum ^>=1.2 , ghc-prim , hashable >=1.4 , hedgehog >=1.0 diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 27d78fafe9b..21ab0c73cb9 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} @@ -23,11 +24,10 @@ module Bitwise ( rotateByteString, ) where -import Control.Monad (foldM, when) -import Control.Monad.State.Strict (State, evalState, get, modify, put) import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shift, shiftL, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS +import Data.ByteString.Short qualified as SBS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, unsafeUseAsCStringLen) import Data.Foldable (foldl', for_) import Data.Functor (void) @@ -38,8 +38,9 @@ import Foreign.C.Types (CChar, CSize) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (Storable (peek, poke, sizeOf)) -import GHC.Exts (fromList, fromListN) import GHC.IO.Handle.Text (memcpy) +import GHC.Num.Integer (Integer (IN), integerFromByteArray, integerToBigNatClamp#, integerToInt#, integerToWord#) +import GHC.Prim (int2Word#, sizeofByteArray#) import PlutusCore.Builtin.Emitter (Emitter, emit) import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure)) import System.IO.Unsafe (unsafeDupablePerformIO) @@ -223,49 +224,15 @@ writeBitByteString bs i b poke (castPtr . plusPtr dst $ bigIx) byte' unsafePackMallocCStringLen (dst, len) -integerToByteString :: Integer -> ByteString -integerToByteString i = case signum i of - 0 -> BS.singleton zeroBits - (-1) -> twosCompToNegative . fromList . go . abs $ i - _ -> fromList . go $ i - where - -- We encode into Word8-sized 'limbs', using a stack to ensure that their - -- ordering is little-endian. Effectively, we encode as a base-256 number, - -- where the least significant digit is at the end. - go :: Integer -> [Word8] - go = \case - 0 -> [] - pos -> case pos `quotRem` 256 of - (d, r) -> go d <> [fromIntegral r] +{-# INLINE integerToByteString #-} +integerToByteString :: Integer -> Maybe ByteString +integerToByteString (IN _) = Nothing +integerToByteString n = Just $ fst $ BS.spanEnd (== 0) $ SBS.fromShort $ SBS.SBS (integerToBigNatClamp# n) +{-# INLINE byteStringToInteger #-} byteStringToInteger :: ByteString -> Integer -byteStringToInteger bs = case BS.uncons bs of - Nothing -> 0 - -- We have to take some care with representations of exact powers of 256, as - -- the two's complement in such a case is the identity function. Therefore, if - -- we find an 'unpadded' power, we have to presume that it's positive; if we - -- find a leading 0x80, but _something_ else is not a zero byte, we assume - -- it's negative instead. - Just (w8, bs') -> - let len = BS.length bs - f x = evalState (foldM (go x) 0 [len - 1, len - 2 .. 0]) 1 in - if | isPositivePowerOf256 w8 bs' -> f bs - | bit 7 .&. w8 == zeroBits -> f bs - | otherwise -> negate . f . twosCompToPositive $ bs - where - -- This is essentially the opposite to encoding. However, because - -- ByteStrings can be indexed from the end in constant time, we don't need - -- to use something like a stack: instead, we start from the end, and - -- accumulate the radix base as we go, increasing the further along we get. - -- This is more efficient, as we'd otherwise first have to compute the - -- largest power of 256 we need, then divide down, essentially doing the - -- work _twice_. - go :: ByteString -> Integer -> Int -> State Integer Integer - go bs' acc i = do - mult <- get - let byte = BS.index bs' i - modify (256 *) - pure $ acc + (fromIntegral byte * mult) +byteStringToInteger bs = case SBS.toShort bs of + SBS.SBS arr -> integerFromByteArray (int2Word# (sizeofByteArray# arr)) arr (integerToWord# 0) (integerToInt# 0) {-# NOINLINE popCountByteString #-} popCountByteString :: ByteString -> Integer @@ -375,9 +342,6 @@ complementByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \( -- Helpers -isPositivePowerOf256 :: Word8 -> ByteString -> Bool -isPositivePowerOf256 w8 bs = w8 == 0x80 && BS.all (== zeroBits) bs - -- We compute the read similarly to how we determine the change when we write. -- The only difference is that the mask is used on the input to read it, rather -- than to modify anything. @@ -409,54 +373,6 @@ overPtrLen bs f = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> f (castPtr ptr) len >>= \p -> unsafePackMallocCStringLen (castPtr p, len) --- Two's complement in a signed, unbounded representation is somewhat --- problematic: in our particular case, we hit this issue on exact powers of --- 256. This issue stems from such values (or rather, the ByteString --- representations of such) having a two's complement identical to themselves, --- as well as a trailing 1. This means that we can't distinguish between a --- _negative_ and a _positive_ power from representation alone, and must default --- one way or the other. --- --- Thus, when we want to produce a negative representation, we have to ensure --- that we 'mark' the result in a way that ensures we can detect that it was --- negative. We do this by padding with trailing ones. -twosCompToNegative :: ByteString -> ByteString -twosCompToNegative bs = case twosComp bs of - bs' -> if bs == bs' - then BS.cons (complement zeroBits) bs' - else bs' - --- If we're taking a two's complement to produce a positive representation, --- padding doesn't matter, as any trailing ones become trailing zeroes. -twosCompToPositive :: ByteString -> ByteString -twosCompToPositive = twosComp - --- This is a fused version of the 'standard' definition of two's complement: --- 'flip all bits then add one'. We do this in one pass to avoid having to --- produce two ByteStrings, only to throw one away. This is done by tracking --- the add carry manually, and walking over the representation from the highest --- byte index downward: if the carry is still present, we attempt an 'add one' --- there and then. This can cause the carry to become 'absorbed', in which case --- we no longer need to track it; otherwise, we continue on, tracking the carry. --- --- This operation has to be done byte-wise, as bigger blocks would make carry --- tracking too difficult, which would probably dwarf any performance --- improvements. Furthermore, it's not even clear if a 'big step, small step' --- approach would even help here, as we're reading backwards (against prefetch --- order), and likely from unaligned memory to boot (as GHC only guarantees --- alignment from the _start_, not the _end_). -twosComp :: ByteString -> ByteString -twosComp bs = let len = BS.length bs in - evalState (fromListN len <$> foldM go [] [len - 1, len - 2 .. 0]) False - where - go :: [Word8] -> Int -> State Bool [Word8] - go acc i = do - let byte = BS.index bs i - added <- get - let byte' = if added then complement byte else complement byte + 1 - when (byte /= byte') (put True) - pure $ byte' : acc - mismatchedLengthError :: forall (a :: Type) . Text -> ByteString -> diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index ea2d1b2bf8d..b1bd808a0d0 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1380,7 +1380,15 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where (runCostingFunOneArgument . paramMkNilPairData) -- Bitwise toBuiltinMeaning _ver IntegerToByteString = - makeBuiltinMeaning integerToByteString mempty + makeBuiltinMeaning integerToByteStringPlc mempty + where + integerToByteStringPlc :: SomeConstant uni Integer -> EvaluationResult BS.ByteString + integerToByteStringPlc (SomeConstant (Some (ValueOf uni n))) = do + DefaultUniInteger <- pure uni + case integerToByteString n of + Just bs -> pure $ bs + Nothing -> fail "negative integer passed to integerByteString" + {-# INLINE integerToByteStringPlc #-} toBuiltinMeaning _ver ByteStringToInteger = makeBuiltinMeaning byteStringToInteger mempty toBuiltinMeaning _ver AndByteString = diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index 25f215f0ff9..dc1a7460fdd 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -43,7 +43,6 @@ module Evaluation.Builtins.Bitwise ( shiftSum, iToBsRoundtrip, bsToITrailing, - bsToIHomogenous, ) where @@ -541,7 +540,7 @@ shiftSum = do iToBsRoundtrip :: PropertyT IO () iToBsRoundtrip = do - i <- forAllWith ppShow . Gen.integral $ indexRange + i <- forAllWith ppShow . Gen.integral $ integerRange let comp = mkIterApp () (builtin () ByteStringToInteger) [ mkIterApp () (builtin () IntegerToByteString) [ mkConstant @Integer () i @@ -554,14 +553,11 @@ iToBsRoundtrip = do bsToITrailing :: PropertyT IO () bsToITrailing = do - testCase <- forAllWith ppShow genBsToITrailingCase - cover 45 "negative representation" . isNegativeCase $ testCase - cover 45 "non-negative representation" . not . isNegativeCase $ testCase - let (extension, bs) = getBsToITrailingArgs testCase + BsToITrailingCase extension bs <- forAllWith ppShow genBsToITrailingCase let comp = mkIterApp () (builtin () ByteStringToInteger) [ mkIterApp () (builtin () AppendByteString) [ - mkConstant @ByteString () extension, - mkConstant @ByteString () bs + mkConstant @ByteString () bs, + mkConstant @ByteString () extension ] ] let comp' = mkIterApp () (builtin () ByteStringToInteger) [ @@ -572,41 +568,11 @@ bsToITrailing = do (EvaluationSuccess res, EvaluationSuccess res') -> res === res' _ -> failure -bsToIHomogenous :: PropertyT IO () -bsToIHomogenous = do - w8 <- forAllWith ppShow . Gen.element $ [zeroBits, complement zeroBits] - len <- forAllWith ppShow . Gen.integral $ integerRange - cover 45 "all zeroes" $ w8 == zeroBits - cover 45 "all ones" $ w8 == complement zeroBits - let bs = BS.replicate len w8 - let comp = mkIterApp () (builtin () ByteStringToInteger) [ - mkConstant @ByteString () bs - ] - outcome <- cekEval comp - case outcome of - EvaluationSuccess res -> - res === (mkConstant @Integer () $ if | len == 0 -> 0 - | w8 == zeroBits -> 0 - | otherwise -> (-1)) - _ -> failure - -- Helpers -data BsToITrailingCase = - BsToINonNegative ByteString ByteString | - BsToINegative ByteString ByteString +data BsToITrailingCase = BsToITrailingCase ByteString ByteString deriving stock (Eq, Show) -isNegativeCase :: BsToITrailingCase -> Bool -isNegativeCase = \case - BsToINegative{} -> True - _ -> False - -getBsToITrailingArgs :: BsToITrailingCase -> (ByteString, ByteString) -getBsToITrailingArgs = \case - BsToINegative bs bs' -> (bs, bs') - BsToINonNegative bs bs' -> (bs, bs') - data WriteBitAgreementCase = WriteBitReadSame Int Integer | WriteBitReadDifferent Int Integer Integer @@ -932,22 +898,13 @@ cekEval' = typecheckEvaluateCek def defaultBuiltinCostModel -- Generators genBsToITrailingCase :: Gen BsToITrailingCase -genBsToITrailingCase = Gen.choice [negative, nonNegative] +genBsToITrailingCase = go where - negative :: Gen BsToITrailingCase - negative = do - len <- Gen.integral byteBoundRange - extLen <- Gen.integral byteBoundRange - w8 <- Gen.element [129 :: Word8 .. 255] - bs <- Gen.bytes . Range.singleton $ len - pure . - BsToINegative (BS.replicate extLen . complement $ zeroBits) . - BS.cons w8 $ bs - nonNegative :: Gen BsToITrailingCase - nonNegative = do + go :: Gen BsToITrailingCase + go = do len <- Gen.integral byteBoundRange extLen <- Gen.integral byteBoundRange - BsToINonNegative (BS.replicate extLen zeroBits) <$> + BsToITrailingCase (BS.replicate extLen zeroBits) <$> case len of 0 -> pure BS.empty _ -> Gen.choice [pure . powerOf2 $ len, notPowerOf2 len] @@ -1154,5 +1111,5 @@ indexRangeOf lim = Range.constantFrom 0 (negate lim) (lim - 1) indexRangeFor :: Integer -> Range Integer indexRangeFor i = Range.constant 0 (i - 1) -integerRange :: Range Int -integerRange = Range.linear 0 8 +integerRange :: Range Integer +integerRange = Range.linear 0 200 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 2b16b731215..cad1250c06a 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -21,11 +21,11 @@ import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, b bitwiseAndIdentity, bitwiseAndSelf, bitwiseComplementSelfInverts, bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, - bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, bsToIHomogenous, - bsToITrailing, ffsAppend, ffsSingleByte, iToBsRoundtrip, popCountAppend, - popCountSingleByte, rotateHomogenous, rotateIdentity, rotateIndexMotion, rotateSum, - shiftHomogenous, shiftIdentity, shiftIndexMotion, shiftSum, testBitAppend, - testBitEmpty, testBitSingleByte, writeBitAgreement, writeBitDouble, writeBitRead) + bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, bsToITrailing, ffsAppend, + ffsSingleByte, iToBsRoundtrip, popCountAppend, popCountSingleByte, rotateHomogenous, + rotateIdentity, rotateIndexMotion, rotateSum, shiftHomogenous, shiftIdentity, + shiftIndexMotion, shiftSum, testBitAppend, testBitEmpty, testBitSingleByte, + writeBitAgreement, writeBitDouble, writeBitRead) import Evaluation.Builtins.Common (typecheckEvaluateCek, typecheckEvaluateCekNoEmit, typecheckReadKnownCek, unsafeEvaluateCekNoEmit) import Evaluation.Builtins.SignatureVerification (ecdsaSecp256k1Prop, ed25519_V1Prop, ed25519_V2Prop, @@ -774,8 +774,7 @@ testIntegerToByteString = testGroup "IntegerToByteString" [ -- Tests for conversion into Integer from ByteString testByteStringToInteger :: TestTree testByteStringToInteger = testGroup "ByteStringToInteger" [ - testPropertyNamed "all zeroes give 0, all ones give -1" "bs_to_i_homogenous" . property $ bsToIHomogenous, - testPropertyNamed "trailing ones ignored for negative, trailing zeroes for positive" "bs_to_i_trailing" . property $ bsToITrailing + testPropertyNamed "trailing zeros ignored" "bs_to_i_trailing" . property $ bsToITrailing ] test_definition :: TestTree From db8d52d0c132fd5fbb092f2c3c65cd5566d56adb Mon Sep 17 00:00:00 2001 From: Las Safin Date: Fri, 10 Mar 2023 00:53:20 +0000 Subject: [PATCH 58/73] Reduce one copy of the input in `byteStringToInteger` --- plutus-core/plutus-core/src/Bitwise.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 21ab0c73cb9..511ddb75494 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -27,6 +27,7 @@ module Bitwise ( import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shift, shiftL, xor, zeroBits, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS +import Data.ByteString.Internal (toForeignPtr0) import Data.ByteString.Short qualified as SBS import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, unsafeUseAsCStringLen) import Data.Foldable (foldl', for_) @@ -38,9 +39,11 @@ import Foreign.C.Types (CChar, CSize) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Ptr (Ptr, castPtr, plusPtr) import Foreign.Storable (Storable (peek, poke, sizeOf)) +import GHC.ForeignPtr (ForeignPtr (ForeignPtr)) import GHC.IO.Handle.Text (memcpy) -import GHC.Num.Integer (Integer (IN), integerFromByteArray, integerToBigNatClamp#, integerToInt#, integerToWord#) -import GHC.Prim (int2Word#, sizeofByteArray#) +import GHC.Num.Integer (Integer (IN), integerFromAddr, integerToBigNatClamp#) +import GHC.Prim (int2Word#) +import GHC.Types (Int (I#)) import PlutusCore.Builtin.Emitter (Emitter, emit) import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure)) import System.IO.Unsafe (unsafeDupablePerformIO) @@ -231,8 +234,9 @@ integerToByteString n = Just $ fst $ BS.spanEnd (== 0) $ SBS.fromShort $ SB {-# INLINE byteStringToInteger #-} byteStringToInteger :: ByteString -> Integer -byteStringToInteger bs = case SBS.toShort bs of - SBS.SBS arr -> integerFromByteArray (int2Word# (sizeofByteArray# arr)) arr (integerToWord# 0) (integerToInt# 0) +byteStringToInteger bs = + case toForeignPtr0 bs of + (ForeignPtr addr _, I# len) -> unsafeDupablePerformIO $ integerFromAddr (int2Word# len) addr (case 0 of I# n -> n) {-# NOINLINE popCountByteString #-} popCountByteString :: ByteString -> Integer From d0497d430a969f17f011af6cd441b973194cea25 Mon Sep 17 00:00:00 2001 From: Las Safin Date: Fri, 10 Mar 2023 15:12:24 +0000 Subject: [PATCH 59/73] Make plutus-tx compile again --- plutus-core/plutus-core.cabal | 2 +- plutus-core/plutus-core/src/Bitwise.hs | 1 + plutus-tx/src/PlutusTx/Builtins/Internal.hs | 3 ++- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index 11d5a92ebae..a2e38f4a5eb 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -71,6 +71,7 @@ common lang library import: lang exposed-modules: + Bitwise Crypto Data.ByteString.Hash Data.Either.Extras @@ -169,7 +170,6 @@ library UntypedPlutusCore.Rename other-modules: - Bitwise Data.Aeson.Flatten Data.Aeson.THReader Data.Functor.Foldable.Monadic diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 511ddb75494..5fe78b29b55 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedSums #-} +-- FIXME: Should be its own library module Bitwise ( integerToByteString, byteStringToInteger, diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 017cb7aa5ff..99c0db4b6f3 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/plutus-tx/src/PlutusTx/Builtins/Internal.hs @@ -28,6 +28,7 @@ import Data.Data import Data.Foldable qualified as Foldable import Data.Hashable (Hashable (..)) import Data.Kind (Type) +import Data.Maybe (fromJust) import Data.Text as Text (Text, empty) import Data.Text.Encoding as Text (decodeUtf8, encodeUtf8) import PlutusCore.Builtin.Emitter (Emitter (Emitter)) @@ -296,7 +297,7 @@ decodeUtf8 (BuiltinByteString b) = BuiltinString $ Text.decodeUtf8 b {-# NOINLINE integerToByteString #-} integerToByteString :: BuiltinInteger -> BuiltinByteString -integerToByteString = BuiltinByteString . Bitwise.integerToByteString +integerToByteString = BuiltinByteString . fromJust . Bitwise.integerToByteString {-# NOINLINE byteStringToInteger #-} byteStringToInteger :: BuiltinByteString -> BuiltinInteger From 266ac1efba98601bc33c3b39d7b6fde1d2341e42 Mon Sep 17 00:00:00 2001 From: Las Safin Date: Fri, 10 Mar 2023 17:25:00 +0000 Subject: [PATCH 60/73] Improve documentation, remove unnececessary pragmata, slightly clean code up --- plutus-core/plutus-core/src/Bitwise.hs | 52 +++--- plutus-tx/src/PlutusTx/Builtins.hs | 244 +++---------------------- 2 files changed, 59 insertions(+), 237 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 5fe78b29b55..06b7615bc0e 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -8,6 +8,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedSums #-} +{-# OPTIONS_GHC -fexpose-all-unfoldings #-} -- FIXME: Should be its own library module Bitwise ( @@ -49,7 +50,7 @@ import PlutusCore.Builtin.Emitter (Emitter, emit) import PlutusCore.Evaluation.Result (EvaluationResult (EvaluationFailure)) import System.IO.Unsafe (unsafeDupablePerformIO) -{-# NOINLINE rotateByteString #-} +-- | See 'PlutusTx.Builtins.rotateByteString'. rotateByteString :: ByteString -> Integer -> ByteString rotateByteString bs i -- If a ByteString is completely homogenous, rotating won't change it. This @@ -57,17 +58,18 @@ rotateByteString bs i | isAllZero bs || isAllOne bs = bs -- Rotating by more than the number of bits in a ByteString 'wraps around', -- so we're only interested in the rotation modulo the number of bits. - | otherwise = case i `rem` bitLen of + | otherwise = case i `mod` bitLen of -- Means we have a multiple of the bit count, so nothing to do. - 0 -> bs - magnitude -> overPtrLen bs $ \ptr len -> go ptr len magnitude + 0 -> bs + displacement -> overPtrLen bs $ \ptr len -> go ptr len displacement where + -- not recursive! go :: Ptr Word8 -> Int -> Integer -> IO (Ptr Word8) go src len displacement = do dst <- mallocBytes len case len of - -- If we only have one byte, we an borrow from the Bits instance for - -- Word8. + -- If we only have one byte, we can borrow from the Bits instance for + -- Word8, since it rotates in the same direction that we want. 1 -> do srcByte <- peek src let srcByte' = srcByte `rotate` fromIntegral displacement @@ -75,16 +77,16 @@ rotateByteString bs i -- If we rotate by a multiple of 8, we only need to move around whole -- bytes, rather than individual bits. Because we only move contiguous -- blocks (regardless of rotation direction), we can do this using - -- memcpy, which is must faster, especially on larger ByteStrings. + -- memcpy, which is much faster, especially on larger ByteStrings. _ -> case displacement `quotRem` 8 of (bigMove, 0) -> do - let mainLen :: CSize = fromIntegral . abs $ bigMove + let mainLen :: CSize = fromIntegral $ bigMove let restLen :: CSize = fromIntegral len - mainLen - void $ case signum bigMove of - 1 -> memcpy (plusPtr dst . fromIntegral $ restLen) src mainLen >> - memcpy dst (plusPtr src . fromIntegral $ mainLen) restLen - _ -> memcpy (plusPtr dst . fromIntegral $ mainLen) src restLen >> - memcpy dst (plusPtr src . fromIntegral $ restLen) mainLen + -- Copy the portion [..mainLen] to [restLen..], + -- and the portion [mainLen..] to [..restLen]. + _ <- memcpy (plusPtr dst (fromIntegral restLen)) src mainLen + _ <- memcpy dst (plusPtr src (fromIntegral mainLen)) restLen + pure () -- If we don't rotate by a multiple of 8, we have to construct new -- bytes, rather than just copying over old ones. We do this in two -- steps: @@ -110,7 +112,7 @@ rotateByteString bs i then acc .|. (bit . fromIntegral $ offset) else acc -{-# NOINLINE shiftByteString #-} +-- | See 'PlutusTx.Builtins.shiftByteString. shiftByteString :: ByteString -> Integer -> ByteString shiftByteString bs i -- Shifting by the number of bits, or more, would zero everything anyway, @@ -128,8 +130,8 @@ shiftByteString bs i go src len = do dst <- mallocBytes len case len of - -- If we only have one byte, we an borrow from the Bits instance for - -- Word8. + -- If we only have one byte, we can borrow from the Bits instance for + -- Word8, since it shifts in the same direction that we want. 1 -> do srcByte <- peek src let srcByte' = srcByte `shift` fromIntegral i @@ -168,6 +170,7 @@ shiftByteString bs i | dangerousRead bs possibleIx -> acc .|. (bit . fromIntegral $ offset) | otherwise -> acc +-- | See 'PlutusTx.Builtins.findFirstSetByteString'. findFirstSetByteString :: ByteString -> Integer findFirstSetByteString bs = foldl' go (-1) [0 .. len - 1] where @@ -180,6 +183,7 @@ findFirstSetByteString bs = foldl' go (-1) [0 .. len - 1] len :: Int len = BS.length bs +-- | See 'PlutusTx.Builtins.testBitByteString. testBitByteString :: ByteString -> Integer -> Emitter (EvaluationResult Bool) testBitByteString bs i | i < 0 || i >= bitLen = indexOutOfBoundsError "testBitByteString" bitLen i @@ -188,7 +192,7 @@ testBitByteString bs i bitLen :: Integer bitLen = fromIntegral $ BS.length bs * 8 -{-# NOINLINE writeBitByteString #-} +-- | See 'PlutusTx.Builtins.writeBitByteString. writeBitByteString :: ByteString -> Integer -> Bool -> Emitter (EvaluationResult ByteString) writeBitByteString bs i b | i < 0 || i >= bitLen = indexOutOfBoundsError "writeBitByteString" bitLen i @@ -228,18 +232,20 @@ writeBitByteString bs i b poke (castPtr . plusPtr dst $ bigIx) byte' unsafePackMallocCStringLen (dst, len) +-- | See 'PlutusTx.Builtins.integerToByteString. {-# INLINE integerToByteString #-} integerToByteString :: Integer -> Maybe ByteString integerToByteString (IN _) = Nothing integerToByteString n = Just $ fst $ BS.spanEnd (== 0) $ SBS.fromShort $ SBS.SBS (integerToBigNatClamp# n) +-- | See 'PlutusTx.Builtins.byteStringToInteger. {-# INLINE byteStringToInteger #-} byteStringToInteger :: ByteString -> Integer byteStringToInteger bs = case toForeignPtr0 bs of (ForeignPtr addr _, I# len) -> unsafeDupablePerformIO $ integerFromAddr (int2Word# len) addr (case 0 of I# n -> n) -{-# NOINLINE popCountByteString #-} +-- | See 'PlutusTx.Builtins.popCountByteString. popCountByteString :: ByteString -> Integer popCountByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go where @@ -292,7 +298,7 @@ popCountByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ go -- only option was to 'zip out' into a list, then rebuild. This is not only -- inefficient (as you can't do a 'big step, little step' approach to this in -- general), it also copies too much. -{-# NOINLINE andByteString #-} +-- | See 'PlutusTx.Builtins.andByteString. andByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) andByteString bs bs' | BS.length bs /= BS.length bs' = mismatchedLengthError "andByteString" bs bs' @@ -300,7 +306,7 @@ andByteString bs bs' unsafeUseAsCString bs' $ \ptr' -> zipBuild (.&.) ptr ptr' len >>= (unsafePackMallocCStringLen . (,len)) -{-# NOINLINE iorByteString #-} +-- | See 'PlutusTx.Builtins.iorByteString. iorByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) iorByteString bs bs' | BS.length bs /= BS.length bs' = mismatchedLengthError "iorByteString" bs bs' @@ -308,7 +314,7 @@ iorByteString bs bs' unsafeUseAsCString bs' $ \ptr' -> zipBuild (.|.) ptr ptr' len >>= (unsafePackMallocCStringLen . (,len)) -{-# NOINLINE xorByteString #-} +-- | See 'PlutusTx.Builtins.xorByteString. xorByteString :: ByteString -> ByteString -> Emitter (EvaluationResult ByteString) xorByteString bs bs' | BS.length bs /= BS.length bs' = mismatchedLengthError "xorByteString" bs bs' @@ -321,7 +327,7 @@ xorByteString bs bs' -- two. Similar reasoning applies to why we made this choice as to the -- previous operations. -{-# NOINLINE complementByteString #-} +-- | See 'PlutusTx.Builtins.complementByteString. complementByteString :: ByteString -> ByteString complementByteString bs = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> do resPtr <- mallocBytes len @@ -378,6 +384,7 @@ overPtrLen bs f = unsafeDupablePerformIO . unsafeUseAsCStringLen bs $ \(ptr, len) -> f (castPtr ptr) len >>= \p -> unsafePackMallocCStringLen (castPtr p, len) +-- Error used when lengths of inputs aren't equal. mismatchedLengthError :: forall (a :: Type) . Text -> ByteString -> @@ -390,6 +397,7 @@ mismatchedLengthError loc bs bs' = do emit $ "Length of second argument: " <> (pack . show . BS.length $ bs') pure EvaluationFailure +-- Error used when an out of bounds index is used to index a bytestring. indexOutOfBoundsError :: forall (a :: Type) . Text -> Integer -> diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 484ed02693c..db9031f3027 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -257,264 +257,78 @@ verifySchnorrSecp256k1Signature verifySchnorrSecp256k1Signature vk msg sig = fromBuiltin (BI.verifySchnorrSecp256k1Signature vk msg sig) --- | Converts an 'Integer' into its 'BuiltinByteString' representation. --- --- = Notes --- --- Throughout, let @maxInteger@ be the maximum function for 'Integer's, --- and @absInteger@ be the absolute value function for 'Integer's. --- We define @zeroes :: 'Integer' -> 'BuiltinByteString'@ be the --- function which, given input @i@, produces a 'BuiltinByteString' @bs@ such --- that: --- --- * @'lengthByteString' bs@ @=@ @'maxInteger' 0 i@; and --- * For all @j :: 'Integer'@ such that @'greaterThanEqualsInteger' j 0@, --- @'indexByteString' bs j = 0@; --- --- We define @ones :: 'Integer' -> 'BuiltinByteString'@ identically to @zeroes@, --- except that @'indexByteString' bs j = 255@ instead. --- --- == Laws --- --- 'integerToByteString' must roundtrip via 'byteStringToInteger'. Specifically, --- for all @i :: 'Integer'@, we must have: --- --- @'byteStringToInteger '.' 'integerToByteString' '$' i@ @=@ @i@ --- --- Furthermore, the length of any result of 'integerToByteString' must be --- strictly positive: --- --- @'greaterThanInteger' ('lengthByteString' '.' 'integerToByteString' i) 0@ @=@ --- @True@ --- --- Lastly, the result /must/ be encoded as defined in the Encoding section --- below. --- --- == Encoding --- --- 'integerToByteString' follows the encoding we describe below; let @i :: --- 'Integer'@. If @i@ is zero, @'integerToByteString' i@ @=@ @zeroes 1@; --- we call this the /zero representation/. If @i@ is non-zero, the encoding --- depends on the sign of @i@. --- --- If @i@ is positive, @'integerToByteString' i@ @=@ @bs@ such that the --- following hold: --- --- * @'greaterThanInteger' ('byteStringLength' bs) 0@ @=@ @True@; --- * Let @polyQuotientInteger :: 'Integer' -> 'Integer' -> --- 'Integer' -> 'Integer'@ be defined such that --- @polyQuotientInteger i j reps@ be a repeat application of 'quotientInteger' --- with @j@ as its second argument @'maxInteger' 0 reps@ times to @i@. Let --- @ix :: 'BuiltinInteger'@ such that @'greaterThanEqualsInteger' ix 0@ and --- @'lessThanInteger' ix k@. Then, @'indexByteString' bs ix@ @=@ --- @'remainderInteger' (polyQuotientInteger i 256 ('subtractInteger' ('subtractInteger' k 1) ix)) 256@ --- --- We call this a /positive representation/. --- --- If @i@ is negative, there are two cases: --- --- * If the absolute value of @i@ is /not/ an exact power of 256, then --- @'integerToByteString' i@ is the [two's --- complement](https://en.wikipedia.org/wiki/Two%27s_complement) of the positive --- representation of @'absInteger' i@. --- * Otherwise, let @bs@ be the two's complement of the positive representation --- of @'absInteger' i@. Then, @'integerToByteString' i@ is @'appendByteString' --- (ones 1) bs@. --- --- We call this a /negative representation/. We need to introduce the special --- second case (with the \'ones padding\') for negative representations as exact --- powers of 256 are their own two's complement: thus, we have to distinguish --- positive cases from negative ones. We choose to do this by \'padding\', as --- this makes the decode direction easier. +-- | Converts a non-negative 'Integer' into its base-256 'BuiltinByteString' representation. +-- The format is little-endian, i.e. the first byte is the least significant. +-- The inverse of this is 'byteStringToInteger'. +-- The output does not contain any trailing zero-bytes, hence zeros are empty bytestrings. +-- If the input is negative, this function errs. {-# INLINEABLE integerToByteString #-} integerToByteString :: Integer -> BuiltinByteString integerToByteString i = BI.integerToByteString (toBuiltin i) --- | Converts a 'BuiltinByteString' into its 'Integer' representation. --- --- = Notes --- --- We inherit all definitions described for 'integerToByteString'. --- --- == Laws --- --- In addition to the roundtrip requirements specified by the laws of --- 'integerToByteString', we also add the following requirements. Throughout, --- let @i :: Integer@ and @j :: Integer@ such that @'greaterThanInteger' j 0@. --- --- * /Padding/: If @bs@ is a zero representation or --- a positive representation, then @'byteStringToInteger' bs@ @=@ --- @'byteStringToInteger' ('appendByteString' (zeroes i) bs)@; otherwise, --- @'byteStringToInteger' bs@ @=@ @'byteStringToInteger' ('appendByteString' --- (ones i) bs)@. --- * /Zero homogeneity/: @'byteStringToInteger' (zeroes i)@ @=@ @0@. --- * /One homogeneity/: @'byteStringToInteger' (ones j)@ @=@ @(-1)@. --- --- A theorem of zero homogeneity is that @'byteStringToInteger' ""@ @=@ @0@. --- --- == Redundant encodings --- --- Unfortunately, the padding, zero homogeneity and one homogeneity laws mean --- that the combination of 'byteStringToInteger' and 'integerToByteString' --- cannot be an isomorphism. This is unavoidable: we either have to make --- 'byteStringToInteger' partial, or allow redundant encodings. We chose the --- second option as it is harmless, and as long as 'integerToByteString' --- produces non-redundant encodings, shouldn't cause issues. +-- | Converts a base-256 'BuiltinByteString' into its 'Integer' representation. +-- The format is little-endian, i.e. the first byte is the least significant. +-- The inverse of this is 'integerToByteString'. +-- The input can contain trailing zero-bytes. {-# INLINEABLE byteStringToInteger #-} byteStringToInteger :: BuiltinByteString -> Integer byteStringToInteger bs = fromBuiltin (BI.byteStringToInteger bs) --- | If given arguments of identical length, constructs their bitwise logical --- AND, erroring otherwise. --- --- = Notes --- --- We inherit all definitions described for 'integerToByteString'. --- --- == Laws --- --- 'andByteString' follows these laws: --- --- * /Commutativity/: @'andByteString' bs1 bs2@ @=@ @'andByteString' bs2 bs1@ --- * /Associativity/: @'andByteString' bs1 ('andByteString' bs2 bs3)@ @=@ --- @'andByteString' ('andByteString' bs1 bs2) bs3@ --- * /Identity/: @'andByteString' bs (ones '.' 'lengthByteString' '$' bs)@ @=@ --- @bs@ --- * /Absorbtion/: @'andByteString' bs (zeroes '.' 'lengthByteString' '$' bs)@ --- @=@ @zeroes '.' 'lengthByteString' '$' bs@ --- * /De Morgan's law for AND/: @'complementByteString' ('andByteString' bs1 --- bs2)@ @=@ @'iorByteString' ('complementByteString' bs1) --- ('complementByteString' bs2)@ --- * /Idempotence/: @'andByteString' bs bs@ @=@ @bs@ +-- | If given bytestrings of equal length, constructs their bitwise logical +-- AND, erring otherwise. {-# INLINEABLE andByteString #-} andByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString andByteString = BI.andByteString --- | If given arguments of identical length, constructs their bitwise logical --- IOR, erroring otherwise. --- --- = Notes --- --- We inherit all definitions described for 'integerToByteString'. --- --- == Laws --- --- 'iorByteString' follows these laws: --- --- * /Commutativity/: @'iorByteString' bs1 bs2@ @=@ @'iorByteString' bs2 bs1@ --- * /Associativity/: @'iorByteString' bs1 ('iorByteString' bs2 bs3)@ @=@ --- @'iorByteString' ('iorByteString' bs1 bs2) bs3@ --- * /Identity/: @'iorByteString' bs (zeroes '.' 'lengthByteString' '$' bs)@ @=@ --- @bs@ --- * /Absorbtion/: @'iorByteString' bs (ones '.' 'lengthByteString' '$' bs)@ --- @=@ @ones '.' 'lengthByteString' '$' bs@ --- * /De Morgan's law for IOR/: @'complementByteString' ('iorByteString' bs1 --- bs2)@ @=@ @'andByteString' ('complementByteString' bs1) --- ('complementByteString' bs2)@ --- * /Idempotence/: @'iorByteString' bs bs@ @=@ @bs@ +-- | If given bytestrings of equal length, constructs their bitwise logical +-- OR, erring otherwise. {-# INLINEABLE iorByteString #-} iorByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString iorByteString = BI.iorByteString --- | If given arguments of identical length, constructs their bitwise logical +-- | If given bytestrings of equal length, constructs their bitwise logical -- XOR, erroring otherwise. --- --- = Notes --- --- We inherit all definitions described for 'integerToByteString'. --- --- == Laws --- --- 'xorByteString' follows these laws: --- --- * /Commutativity/: @'xorByteString' bs1 bs2@ @=@ @'xorByteString' bs2 bs1@ --- * /Associativity/: @'xorByteString' bs1 ('xorByteString' bs2 bs3)@ @=@ --- @'xorByteString' ('xorByteString' bs1 bs2) bs3@ --- * /Identity/: @'xorByteString' bs (zeroes '.' 'lengthByteString' '$' bs)@ @=@ --- @bs@ --- * /Complementarity/: @'xorByteString' bs (ones '.' 'lengthByteString' '$' --- bs)@ @=@ @'complementByteString' bs@ --- * /Self-absorbtion/: @'xorByteString' bs bs@ @=@ @zeroes '.' --- 'lengthByteString' '$' bs@ {-# INLINEABLE xorByteString #-} xorByteString :: BuiltinByteString -> BuiltinByteString -> BuiltinByteString xorByteString = BI.xorByteString --- | Constructs the [one's complement](https://en.wikipedia.org/wiki/Ones%27_complement) --- of its argument. --- --- = Laws --- --- `complementByteString` is self-inverting: specifically, we have --- @'complementByteString' '.' 'complementByteString' '$' bs@ @=@ @bs@. +-- | If given bytestrings of equal length, constructs the flipped bytestring, +-- i.e. each bit is flipped. {-# INLINEABLE complementByteString #-} complementByteString :: BuiltinByteString -> BuiltinByteString complementByteString = BI.complementByteString --- | Shifts the 'BuiltinByteString' argument. More precisely, constructs a new --- 'BuiltinByteString' by \'adjusting\' the bit indexes of the --- 'BuiltinByteString' argument by the 'Integer' argument; if this would cause --- an \'out-of-bounds\', that bit is 0 instead. --- --- = Notes --- --- We inherit all definitions described for 'integerToByteString'. --- --- == Laws --- --- 'shiftByteString' follows these laws: --- --- * /Identity/: @'shiftByteString' bs 0@ @=@ @bs@ --- * /Decomposition/: Let @i, j :: 'Integer'@ such that either at least one of --- @i@, @j@ is zero or @i@ and @j@ have the same sign. Then @'shiftByteString' --- bs ('addInteger' i j)@ @=@ @'shiftByteString' ('shiftByteString' bs i) j@ --- * /Erasure/: If @greaterThanEqualsInteger ('absInteger' i) '.' 'lengthByteString' '$' bs@, --- then @'shiftByteString' bs i@ @=@ @zeroes '.' 'lengthByteString' '$' bs@ +-- | Shifts the input bytestring left by the specified (possibly negative) amount. +-- If positive, shifts left/to higher significance. +-- If negative, shifts right/to lower significance. +-- The shift is **not** arithmetic. You can emulate an arithmetic +-- shift by OR-ing with what is morally -1 left-shifted the appropriate amount. +-- The output is not trimmed, hence trailing zero-bytes may remain. {-# INLINEABLE shiftByteString #-} shiftByteString :: BuiltinByteString -> Integer -> BuiltinByteString shiftByteString bs i = BI.shiftByteString bs (toBuiltin i) --- | Rotates the 'BuiltinByteString' argument. More precisely, constructs a new --- 'BuiltinByteString' by \'adjusting\' the bit indexes of the --- 'BuiltinByteString' argument by the 'Integer' argument; if this would cause --- an \'out-of-bounds\', we \'wrap around\'. --- --- = Laws --- --- 'rotateByteString' follows these laws: --- --- * /Identity/: @'rotateByteString' bs 0@ @=@ @bs@ --- * /Decomposition/: @'rotateByteString' bs ('addInteger' i j)@ @=@ --- @'rotateByteString' ('rotateByteString' bs i) j@ --- * /Wraparound/: Let @i :: Integer@ be nonzero. Then @'rotateByteString' bs i@ --- @=@ @'rotateByteString' bs ('remainderInteger' i ('timesInteger' 8 '.' --- 'lengthByteString' '$' bs))@ +-- | Rotates the input bytestring left by the specified (possibly negative) amount. +-- If positive, rotates left/to higher significance. +-- If negative, rotates right/to lower significance. {-# INLINEABLE rotateByteString #-} rotateByteString :: BuiltinByteString -> Integer -> BuiltinByteString rotateByteString bs i = BI.rotateByteString bs (toBuiltin i) -- | Counts the number of 1 bits in the argument. --- --- = Laws --- --- 'popCountByteString' follows these laws: --- --- * @'popCountByteString' ""@ @=@ @0@ --- * @'popCountByteString' ('appendByteString' bs1 bs2)@ @=@ --- @'addInteger' ('popCountByteString' bs1) ('popCountByteString' bs2)@ {-# INLINEABLE popCountByteString #-} popCountByteString :: BuiltinByteString -> Integer popCountByteString bs = fromBuiltin (BI.popCountByteString bs) --- | Bitwise indexing operation. Errors when given an index that's not --- in-bounds: specifically, indexes that are either negative or greater than or +-- | Bitwise indexing operation. Errs when given an index that's not +-- in-bounds: specifically, indices that are either negative or greater than or -- equal to the number of bits in the 'BuiltinByteString' argument. {-# INLINEABLE testBitByteString #-} testBitByteString :: BuiltinByteString -> Integer -> Bool testBitByteString bs i = fromBuiltin (BI.testBitByteString bs (toBuiltin i)) --- | Bitwise modification at an index. Errors when given an index that's not --- in-bounds: specifically, indexes that are either negative or greater than +-- | Bitwise modification at an index. Errs when given an index that's not +-- in-bounds: specifically, indices that are either negative or greater than -- or equal to the number of bits in the 'BuiltinByteString' argument. {-# INLINEABLE writeBitByteString #-} writeBitByteString :: BuiltinByteString -> Integer -> Bool -> BuiltinByteString From 689522308ed4a6116d0bd7bd98d8bbce87aab6a0 Mon Sep 17 00:00:00 2001 From: kwxm Date: Fri, 30 Jun 2023 02:54:56 +0100 Subject: [PATCH 61/73] Complete merge --- plutus-core/plutus-core.cabal | 5 +-- .../src/PlutusCore/Default/Builtins.hs | 41 ++++++++++--------- .../PlutusIR/Transform/CommuteFnWithConst.hs | 13 ++++++ 3 files changed, 36 insertions(+), 23 deletions(-) diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index c41687aa66e..946315675d5 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -72,7 +72,6 @@ library import: lang exposed-modules: Bitwise - Crypto Data.ByteString.Hash Data.Either.Extras Data.List.Extras @@ -283,7 +282,7 @@ library , filepath , flat ^>=0.6 , free - , ghc-bignum ^>=1.2 + , ghc-bignum ^>=1.3 , ghc-prim , hashable >=1.4 , hedgehog >=1.0 @@ -386,10 +385,10 @@ test-suite untyped-plutus-core-test DeBruijn.Spec DeBruijn.UnDeBruijnify Evaluation.Builtins + Evaluation.Builtins.Bitwise Evaluation.Builtins.BLS12_381 Evaluation.Builtins.BLS12_381.TestClasses Evaluation.Builtins.BLS12_381.Utils - Evaluation.Builtins.Bitwise Evaluation.Builtins.Common Evaluation.Builtins.Costing Evaluation.Builtins.Definition diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 8e04b3af751..c50d6f16db1 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -20,19 +20,15 @@ import PlutusCore.Builtin import PlutusCore.Data import PlutusCore.Default.Universe import PlutusCore.Evaluation.Machine.BuiltinCostModel +import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (ExBudget)) import PlutusCore.Evaluation.Machine.ExBudgetStream import PlutusCore.Evaluation.Machine.ExMemoryUsage import PlutusCore.Evaluation.Result import PlutusCore.Pretty -import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 -import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 -import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing -import PlutusCore.Crypto.Ed25519 (verifyEd25519Signature_V1, verifyEd25519Signature_V2) -import PlutusCore.Crypto.Secp256k1 (verifyEcdsaSecp256k1Signature, verifySchnorrSecp256k1Signature) -import Bitwise (andByteString, byteStringToInteger, complementByteString, findFirstSetByteString, integerToByteString, - iorByteString, popCountByteString, rotateByteString, shiftByteString, testBitByteString, - writeBitByteString, xorByteString) +import Bitwise (andByteString, byteStringToInteger, complementByteString, findFirstSetByteString, + integerToByteString, iorByteString, popCountByteString, rotateByteString, + shiftByteString, testBitByteString, writeBitByteString, xorByteString) import Codec.Serialise (serialise) import Data.ByteString qualified as BS import Data.ByteString.Hash qualified as Hash @@ -44,6 +40,11 @@ import Data.Text.Encoding (decodeUtf8', encodeUtf8) import Flat hiding (from, to) import Flat.Decoder import Flat.Encoder as Flat +import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 +import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 +import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing +import PlutusCore.Crypto.Ed25519 (verifyEd25519Signature_V1, verifyEd25519Signature_V2) +import PlutusCore.Crypto.Secp256k1 (verifyEcdsaSecp256k1Signature, verifySchnorrSecp256k1Signature) import Prettyprinter (viaShow) -- See Note [Pattern matching on built-in types]. @@ -1484,7 +1485,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where (runCostingFunTwoArguments . paramBls12_381_finalVerify) -- Bitwise toBuiltinMeaning _ver IntegerToByteString = - makeBuiltinMeaning integerToByteStringPlc mempty + makeBuiltinMeaning integerToByteStringPlc (\_ _ -> ExBudgetLast $ ExBudget 0 0) where integerToByteStringPlc :: SomeConstant uni Integer -> EvaluationResult BS.ByteString integerToByteStringPlc (SomeConstant (Some (ValueOf uni n))) = do @@ -1494,27 +1495,27 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where Nothing -> fail "negative integer passed to integerByteString" {-# INLINE integerToByteStringPlc #-} toBuiltinMeaning _ver ByteStringToInteger = - makeBuiltinMeaning byteStringToInteger mempty + makeBuiltinMeaning byteStringToInteger (\_ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver AndByteString = - makeBuiltinMeaning andByteString mempty + makeBuiltinMeaning andByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver IorByteString = - makeBuiltinMeaning iorByteString mempty + makeBuiltinMeaning iorByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver XorByteString = - makeBuiltinMeaning xorByteString mempty + makeBuiltinMeaning xorByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver ComplementByteString = - makeBuiltinMeaning complementByteString mempty + makeBuiltinMeaning complementByteString (\_ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver ShiftByteString = - makeBuiltinMeaning shiftByteString mempty + makeBuiltinMeaning shiftByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver RotateByteString = - makeBuiltinMeaning rotateByteString mempty + makeBuiltinMeaning rotateByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver PopCountByteString = - makeBuiltinMeaning popCountByteString mempty + makeBuiltinMeaning popCountByteString (\_ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver TestBitByteString = - makeBuiltinMeaning testBitByteString mempty + makeBuiltinMeaning testBitByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver WriteBitByteString = - makeBuiltinMeaning writeBitByteString mempty + makeBuiltinMeaning writeBitByteString (\_ _ _ _ -> ExBudgetLast $ ExBudget 0 0) toBuiltinMeaning _ver FindFirstSetByteString = - makeBuiltinMeaning findFirstSetByteString mempty + makeBuiltinMeaning findFirstSetByteString (\_ _ -> ExBudgetLast $ ExBudget 0 0) -- See Note [Inlining meanings of builtins]. {-# INLINE toBuiltinMeaning #-} diff --git a/plutus-core/plutus-ir/src/PlutusIR/Transform/CommuteFnWithConst.hs b/plutus-core/plutus-ir/src/PlutusIR/Transform/CommuteFnWithConst.hs index 43d6ea91165..16b3a456c70 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Transform/CommuteFnWithConst.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Transform/CommuteFnWithConst.hs @@ -145,3 +145,16 @@ isCommutative = \case MkPairData -> False MkNilData -> False MkNilPairData -> False + -- Bitwise operations + IntegerToByteString -> False + ByteStringToInteger -> False + AndByteString -> True + IorByteString -> True + XorByteString -> True + ComplementByteString -> False + ShiftByteString -> False + RotateByteString -> False + PopCountByteString -> False + TestBitByteString -> False + WriteBitByteString -> False + FindFirstSetByteString -> False From 371a26d3eb31fcc100d111d38a6788688b42d64b Mon Sep 17 00:00:00 2001 From: kwxm Date: Fri, 30 Jun 2023 03:23:59 +0100 Subject: [PATCH 62/73] Fix some more merge problems --- .../test/Evaluation/Builtins/Bitwise.hs | 137 +++++++++--------- .../test/Evaluation/Builtins/Definition.hs | 55 +------ 2 files changed, 76 insertions(+), 116 deletions(-) diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs index dc1a7460fdd..8f1b9cce42d 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Bitwise.hs @@ -49,20 +49,23 @@ module Evaluation.Builtins.Bitwise ( import Control.Lens.Fold (Fold, folding, has, hasn't, preview) import Control.Monad (guard) import Data.Bitraversable (bitraverse) -import Data.Bits (bit, complement, countTrailingZeros, popCount, shiftL, xor, zeroBits, (.&.), (.|.)) +import Data.Bits (bit, complement, countTrailingZeros, popCount, shiftL, xor, zeroBits, (.&.), + (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.Text (Text) import Data.Word (Word8) import Evaluation.Builtins.Common (typecheckEvaluateCek) import GHC.Exts (fromListN, toList) -import Hedgehog (Gen, PropertyT, Range, annotate, annotateShow, cover, evalEither, failure, forAllWith, success, (===)) +import Hedgehog (Gen, PropertyT, Range, annotate, annotateShow, cover, evalEither, failure, + forAllWith, success, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import PlutusCore (DefaultFun (AddInteger, AndByteString, AppendByteString, ByteStringToInteger, ComplementByteString, FindFirstSetByteString, IntegerToByteString, IorByteString, PopCountByteString, RotateByteString, ShiftByteString, TestBitByteString, WriteBitByteString, XorByteString), - DefaultUni, Error, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, Term) + DefaultUni, Error, EvaluationResult (EvaluationFailure, EvaluationSuccess), Name, + Term) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModel) -import PlutusCore.MkPlc (builtin, mkConstant, mkIterApp) +import PlutusCore.MkPlc (builtin, mkConstant, mkIterAppNoAnn) import PlutusPrelude (def) import Text.Show.Pretty (ppShow) import UntypedPlutusCore qualified as Untyped @@ -109,14 +112,14 @@ bitwiseXorComplement = do goXor leftArg rightArg = do let leftArg' = mkConstant @ByteString () leftArg let rightArg' = mkConstant @ByteString () rightArg - let comp = mkIterApp () (builtin () XorByteString) [leftArg', rightArg'] + let comp = mkIterAppNoAnn (builtin () XorByteString) [leftArg', rightArg'] cekEval comp goComplement :: ByteString -> PropertyT IO (EvaluationResult (Untyped.Term Name DefaultUni DefaultFun ())) goComplement bs = do let bs' = mkConstant @ByteString () bs - let comp = mkIterApp () (builtin () ComplementByteString) [bs'] + let comp = mkIterAppNoAnn (builtin () ComplementByteString) [bs'] cekEval comp bitwiseAndSelf :: PropertyT IO () @@ -131,7 +134,7 @@ bitwiseXorSelf = do let len = BS.length bs let bs' = mkConstant @ByteString () bs let expected = mkConstant @ByteString () . BS.replicate len $ zeroBits - let comp = mkIterApp () (builtin () XorByteString) [bs', bs'] + let comp = mkIterAppNoAnn (builtin () XorByteString) [bs', bs'] outcome <- cekEval comp case outcome of EvaluationSuccess res -> res === expected @@ -150,8 +153,8 @@ bitwiseComplementSelfInverts :: PropertyT IO () bitwiseComplementSelfInverts = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange let bs' = mkConstant @ByteString () bs - let comp = mkIterApp () (builtin () ComplementByteString) [ - mkIterApp () (builtin () ComplementByteString) [bs'] + let comp = mkIterAppNoAnn (builtin () ComplementByteString) [ + mkIterAppNoAnn (builtin () ComplementByteString) [bs'] ] outcome <- cekEval comp case outcome of @@ -169,7 +172,7 @@ popCountSingleByte = do w8 <- forAllWith ppShow Gen.enumBounded let bs = BS.singleton w8 let expected :: Integer = fromIntegral . popCount $ w8 - let comp = mkIterApp () (builtin () PopCountByteString) [ + let comp = mkIterAppNoAnn (builtin () PopCountByteString) [ mkConstant @ByteString () bs ] outcome <- cekEval comp @@ -183,12 +186,12 @@ popCountAppend = do bs' <- forAllWith ppShow . Gen.bytes $ byteBoundRange let arg1 = mkConstant @ByteString () bs let arg2 = mkConstant @ByteString () bs' - let comp1 = mkIterApp () (builtin () PopCountByteString) [ - mkIterApp () (builtin () AppendByteString) [arg1, arg2] + let comp1 = mkIterAppNoAnn (builtin () PopCountByteString) [ + mkIterAppNoAnn (builtin () AppendByteString) [arg1, arg2] ] - let comp2 = mkIterApp () (builtin () AddInteger) [ - mkIterApp () (builtin () PopCountByteString) [arg1], - mkIterApp () (builtin () PopCountByteString) [arg2] + let comp2 = mkIterAppNoAnn (builtin () AddInteger) [ + mkIterAppNoAnn (builtin () PopCountByteString) [arg1], + mkIterAppNoAnn (builtin () PopCountByteString) [arg2] ] outcome <- bitraverse cekEval cekEval (comp1, comp2) case outcome of @@ -199,7 +202,7 @@ testBitEmpty :: PropertyT IO () testBitEmpty = do ix <- forAllWith ppShow . Gen.integral $ indexRange let arg = mkConstant @ByteString () "" - let comp = mkIterApp () (builtin () TestBitByteString) [ + let comp = mkIterAppNoAnn (builtin () TestBitByteString) [ arg, mkConstant @Integer () ix ] @@ -216,7 +219,7 @@ testBitSingleByte = do cover 45 "out of bounds" $ ix < 0 || ix >= 8 cover 45 "in-bounds" $ 0 <= ix && ix < 8 let expected = bitAt w8 ix - let comp = mkIterApp () (builtin () TestBitByteString) [ + let comp = mkIterAppNoAnn (builtin () TestBitByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () ix ] @@ -236,8 +239,8 @@ testBitAppend = do let arg1 = mkConstant @ByteString () x let arg2 = mkConstant @ByteString () y let argIx = mkConstant @Integer () ix - let comp = mkIterApp () (builtin () TestBitByteString) [ - mkIterApp () (builtin () AppendByteString) [arg1, arg2], + let comp = mkIterAppNoAnn (builtin () TestBitByteString) [ + mkIterAppNoAnn (builtin () AppendByteString) [arg1, arg2], argIx ] let comp' = go x y ix @@ -257,11 +260,11 @@ testBitAppend = do Term Untyped.TyName Name DefaultUni DefaultFun () go bs bs' ix = let len' = fromIntegral $ 8 * BS.length bs' in case compare ix len' of - LT -> mkIterApp () (builtin () TestBitByteString) [ + LT -> mkIterAppNoAnn (builtin () TestBitByteString) [ mkConstant @ByteString () bs', mkConstant @Integer () ix ] - _ -> mkIterApp () (builtin () TestBitByteString) [ + _ -> mkIterAppNoAnn (builtin () TestBitByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () (ix - len') ] @@ -276,8 +279,8 @@ writeBitRead = do let bs' = mkConstant @ByteString () bs let ix' = mkConstant @Integer () ix let b' = mkConstant @Bool () b - let comp = mkIterApp () (builtin () TestBitByteString) [ - mkIterApp () (builtin () WriteBitByteString) [bs', ix', b'], + let comp = mkIterAppNoAnn (builtin () TestBitByteString) [ + mkIterAppNoAnn (builtin () WriteBitByteString) [bs', ix', b'], ix' ] outcome <- cekEval comp @@ -295,12 +298,12 @@ writeBitDouble = do b' <- forAllWith ppShow Gen.enumBounded let bs' = mkConstant @ByteString () bs let ix' = mkConstant @Integer () ix - let writeTwice = mkIterApp () (builtin () WriteBitByteString) [ - mkIterApp () (builtin () WriteBitByteString) [bs', ix', mkConstant @Bool () b], + let writeTwice = mkIterAppNoAnn (builtin () WriteBitByteString) [ + mkIterAppNoAnn (builtin () WriteBitByteString) [bs', ix', mkConstant @Bool () b], ix', mkConstant @Bool () b' ] - let writeOnce = mkIterApp () (builtin () WriteBitByteString) [ + let writeOnce = mkIterAppNoAnn (builtin () WriteBitByteString) [ bs', ix', mkConstant @Bool () b' @@ -317,8 +320,8 @@ writeBitAgreement = do let (bs, writeIx, readIx) = getWriteBitAgreementArgs testCase cover 45 "read known zero" $ writeIx /= readIx cover 45 "read known one" $ writeIx == readIx - let comp = mkIterApp () (builtin () TestBitByteString) [ - mkIterApp () (builtin () WriteBitByteString) [ + let comp = mkIterAppNoAnn (builtin () TestBitByteString) [ + mkIterAppNoAnn (builtin () WriteBitByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () writeIx, mkConstant @Bool () True @@ -340,7 +343,7 @@ ffsSingleByte = do let expected = case w8 of 0 -> (-1) _ -> fromIntegral . countTrailingZeros $ w8 - let comp = mkIterApp () (builtin () FindFirstSetByteString) [ + let comp = mkIterAppNoAnn (builtin () FindFirstSetByteString) [ mkConstant @ByteString () bs ] outcome <- cekEval comp @@ -356,8 +359,8 @@ ffsAppend = do cover 30 "second argument zero" $ which == ZeroSecond cover 30 "second argument nonzero" $ which == NotZeroSecond let (bs, bs') = getFFSAppendArgs testCase - let comp = mkIterApp () (builtin () FindFirstSetByteString) [ - mkIterApp () (builtin () AppendByteString) [ + let comp = mkIterAppNoAnn (builtin () FindFirstSetByteString) [ + mkIterAppNoAnn (builtin () AppendByteString) [ mkConstant @ByteString () bs, mkConstant @ByteString () bs' ] @@ -365,13 +368,13 @@ ffsAppend = do let comp' = case which of ZeroBoth -> mkConstant @Integer () (-1) ZeroSecond -> let bitLen' = fromIntegral $ 8 * BS.length bs' in - mkIterApp () (builtin () AddInteger) [ - mkIterApp () (builtin () FindFirstSetByteString) [ + mkIterAppNoAnn (builtin () AddInteger) [ + mkIterAppNoAnn (builtin () FindFirstSetByteString) [ mkConstant @ByteString () bs ], mkConstant @Integer () bitLen' ] - NotZeroSecond -> mkIterApp () (builtin () FindFirstSetByteString) [ + NotZeroSecond -> mkIterAppNoAnn (builtin () FindFirstSetByteString) [ mkConstant @ByteString () bs' ] outcome <- bitraverse cekEval cekEval (comp, comp') @@ -382,7 +385,7 @@ ffsAppend = do rotateIdentity :: PropertyT IO () rotateIdentity = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange - let comp = mkIterApp () (builtin () RotateByteString) [ + let comp = mkIterAppNoAnn (builtin () RotateByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () 0 ] @@ -394,7 +397,7 @@ rotateIdentity = do shiftIdentity :: PropertyT IO () shiftIdentity = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange - let comp = mkIterApp () (builtin () ShiftByteString) [ + let comp = mkIterAppNoAnn (builtin () ShiftByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () 0 ] @@ -419,14 +422,14 @@ rotateIndexMotion = do _ -> raw 0 -> readIx _ -> (readIx - i) `rem` bitLen - let comp = mkIterApp () (builtin () TestBitByteString) [ - mkIterApp () (builtin () RotateByteString) [ + let comp = mkIterAppNoAnn (builtin () TestBitByteString) [ + mkIterAppNoAnn (builtin () RotateByteString) [ mkConstant @ByteString () bs', mkConstant @Integer () i ], mkConstant @Integer () readIx ] - let expected = mkIterApp () (builtin () TestBitByteString) [ + let expected = mkIterAppNoAnn (builtin () TestBitByteString) [ mkConstant @ByteString () bs', mkConstant @Integer () expectedReadIx ] @@ -443,8 +446,8 @@ shiftIndexMotion = do let bitLen = fromIntegral $ BS.length bs' * 8 i <- forAllWith ppShow . Gen.integral . indexRangeOf $ bitLen readIx <- forAllWith ppShow . Gen.integral . indexRangeFor $ bitLen - let comp = mkIterApp () (builtin () TestBitByteString) [ - mkIterApp () (builtin () ShiftByteString) [ + let comp = mkIterAppNoAnn (builtin () TestBitByteString) [ + mkIterAppNoAnn (builtin () ShiftByteString) [ mkConstant @ByteString () bs', mkConstant @Integer () i ], @@ -453,7 +456,7 @@ shiftIndexMotion = do let comp' = let expectedIx = readIx - i in if | expectedIx < 0 -> mkConstant @Bool () False | expectedIx >= bitLen -> mkConstant @Bool () False - | otherwise -> mkIterApp () (builtin () TestBitByteString) [ + | otherwise -> mkIterAppNoAnn (builtin () TestBitByteString) [ mkConstant @ByteString () bs', mkConstant @Integer () expectedIx ] @@ -470,7 +473,7 @@ rotateHomogenous = do len <- forAllWith ppShow . Gen.integral $ byteBoundRange let bs = BS.replicate len w8 rotation <- forAllWith ppShow . Gen.integral $ indexRange - let comp = mkIterApp () (builtin () RotateByteString) [ + let comp = mkIterAppNoAnn (builtin () RotateByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () rotation ] @@ -484,7 +487,7 @@ shiftHomogenous = do len <- forAllWith ppShow . Gen.integral $ byteBoundRange i <- forAllWith ppShow . Gen.integral $ indexRange let bs = BS.replicate len zeroBits - let comp = mkIterApp () (builtin () ShiftByteString) [ + let comp = mkIterAppNoAnn (builtin () ShiftByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () i ] @@ -498,16 +501,16 @@ rotateSum = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange i <- forAllWith ppShow . Gen.integral $ indexRange j <- forAllWith ppShow . Gen.integral $ indexRange - let comp1 = mkIterApp () (builtin () RotateByteString) [ - mkIterApp () (builtin () RotateByteString) [ + let comp1 = mkIterAppNoAnn (builtin () RotateByteString) [ + mkIterAppNoAnn (builtin () RotateByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () i ], mkConstant @Integer () j ] - let comp2 = mkIterApp () (builtin () RotateByteString) [ + let comp2 = mkIterAppNoAnn (builtin () RotateByteString) [ mkConstant @ByteString () bs, - mkIterApp () (builtin () AddInteger) [ + mkIterAppNoAnn (builtin () AddInteger) [ mkConstant @Integer () i, mkConstant @Integer () j ] @@ -522,14 +525,14 @@ shiftSum = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange ij <- forAllWith ppShow . Gen.integral $ indexRange (i, j) <- forAllWith ppShow . genSplit $ ij - let comp1 = mkIterApp () (builtin () ShiftByteString) [ - mkIterApp () (builtin () ShiftByteString) [ + let comp1 = mkIterAppNoAnn (builtin () ShiftByteString) [ + mkIterAppNoAnn (builtin () ShiftByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () i ], mkConstant @Integer () j ] - let comp2 = mkIterApp () (builtin () ShiftByteString) [ + let comp2 = mkIterAppNoAnn (builtin () ShiftByteString) [ mkConstant @ByteString () bs, mkConstant @Integer () ij ] @@ -541,8 +544,8 @@ shiftSum = do iToBsRoundtrip :: PropertyT IO () iToBsRoundtrip = do i <- forAllWith ppShow . Gen.integral $ integerRange - let comp = mkIterApp () (builtin () ByteStringToInteger) [ - mkIterApp () (builtin () IntegerToByteString) [ + let comp = mkIterAppNoAnn (builtin () ByteStringToInteger) [ + mkIterAppNoAnn (builtin () IntegerToByteString) [ mkConstant @Integer () i ] ] @@ -554,13 +557,13 @@ iToBsRoundtrip = do bsToITrailing :: PropertyT IO () bsToITrailing = do BsToITrailingCase extension bs <- forAllWith ppShow genBsToITrailingCase - let comp = mkIterApp () (builtin () ByteStringToInteger) [ - mkIterApp () (builtin () AppendByteString) [ + let comp = mkIterAppNoAnn (builtin () ByteStringToInteger) [ + mkIterAppNoAnn (builtin () AppendByteString) [ mkConstant @ByteString () bs, mkConstant @ByteString () extension ] ] - let comp' = mkIterApp () (builtin () ByteStringToInteger) [ + let comp' = mkIterAppNoAnn (builtin () ByteStringToInteger) [ mkConstant @ByteString () bs ] outcome <- bitraverse cekEval cekEval (comp, comp') @@ -678,12 +681,12 @@ demorganing :: demorganing fun fun' x y = do let x' = mkConstant @ByteString () x let y' = mkConstant @ByteString () y - let comp = mkIterApp () (builtin () ComplementByteString) [ - mkIterApp () (builtin () fun) [x', y'] + let comp = mkIterAppNoAnn (builtin () ComplementByteString) [ + mkIterAppNoAnn (builtin () fun) [x', y'] ] - let comp' = mkIterApp () (builtin () fun') [ - mkIterApp () (builtin () ComplementByteString) [x'], - mkIterApp () (builtin () ComplementByteString) [y'] + let comp' = mkIterAppNoAnn (builtin () fun') [ + mkIterAppNoAnn (builtin () ComplementByteString) [x'], + mkIterAppNoAnn (builtin () ComplementByteString) [y'] ] bitraverse cekEval cekEval (comp, comp') @@ -732,13 +735,13 @@ associatively fun x y z = do let x' = mkConstant @ByteString () x let y' = mkConstant @ByteString () y let z' = mkConstant @ByteString () z - let leftAssoc = mkIterApp () (builtin () fun) [ - mkIterApp () (builtin () fun) [x', y'], + let leftAssoc = mkIterAppNoAnn (builtin () fun) [ + mkIterAppNoAnn (builtin () fun) [x', y'], z' ] - let rightAssoc = mkIterApp () (builtin () fun) [ + let rightAssoc = mkIterAppNoAnn (builtin () fun) [ x', - mkIterApp () (builtin () fun) [y', z'] + mkIterAppNoAnn (builtin () fun) [y', z'] ] bitraverse cekEval cekEval (leftAssoc, rightAssoc) @@ -746,7 +749,7 @@ self :: DefaultFun -> PropertyT IO () self b = do bs <- forAllWith ppShow . Gen.bytes $ byteBoundRange let bs' = mkConstant @ByteString () bs - let comp = mkIterApp () (builtin () b) [bs', bs'] + let comp = mkIterAppNoAnn (builtin () b) [bs', bs'] outcome <- cekEval comp case outcome of EvaluationSuccess res -> res === mkConstant @ByteString () bs @@ -882,7 +885,7 @@ commutatively fun leftArg rightArg = do go :: Term Untyped.TyName Name DefaultUni DefaultFun () -> Term Untyped.TyName Name DefaultUni DefaultFun () -> Term Untyped.TyName Name DefaultUni DefaultFun () - go arg1 arg2 = mkIterApp () (builtin () fun) [arg1, arg2] + go arg1 arg2 = mkIterAppNoAnn (builtin () fun) [arg1, arg2] cekEval :: Term Untyped.TyName Name DefaultUni DefaultFun () -> 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 3417256e17d..c44f1e3584b 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -38,66 +38,23 @@ import PlutusCore.StdLib.Data.ScottList qualified as Scott import PlutusCore.StdLib.Data.ScottUnit qualified as Scott import PlutusCore.StdLib.Data.Unit +import Evaluation.Builtins.Bitwise import Evaluation.Builtins.BLS12_381 (test_BLS12_381) import Evaluation.Builtins.Common import Evaluation.Builtins.SignatureVerification (ecdsaSecp256k1Prop, ed25519_V1Prop, ed25519_V2Prop, schnorrSecp256k1Prop) - import Control.Exception import Data.ByteString (ByteString) import Data.DList qualified as DList import Data.Proxy import Data.Text (Text) -import Control.Exception (evaluate, try) -import Data.ByteString (ByteString) -import Data.Proxy (Proxy (Proxy)) -import Data.Text (Text) -import Evaluation.Builtins.Bitwise (bitwiseAndAbsorbing, bitwiseAndAssociates, bitwiseAndCommutes, bitwiseAndDeMorgan, - bitwiseAndIdentity, bitwiseAndSelf, bitwiseComplementSelfInverts, - bitwiseIorAbsorbing, bitwiseIorAssociates, bitwiseIorCommutes, bitwiseIorDeMorgan, - bitwiseIorIdentity, bitwiseIorSelf, bitwiseXorAssociates, bitwiseXorCommutes, - bitwiseXorComplement, bitwiseXorIdentity, bitwiseXorSelf, bsToITrailing, ffsAppend, - ffsSingleByte, iToBsRoundtrip, popCountAppend, popCountSingleByte, rotateHomogenous, - rotateIdentity, rotateIndexMotion, rotateSum, shiftHomogenous, shiftIdentity, - shiftIndexMotion, shiftSum, testBitAppend, testBitEmpty, testBitSingleByte, - writeBitAgreement, writeBitDouble, writeBitRead) -import Evaluation.Builtins.Common (typecheckEvaluateCek, typecheckEvaluateCekNoEmit, typecheckReadKnownCek, - unsafeEvaluateCekNoEmit) -import Evaluation.Builtins.SignatureVerification (ecdsaSecp256k1Prop, ed25519_V1Prop, ed25519_V2Prop, - schnorrSecp256k1Prop) import Hedgehog hiding (Opaque, Size, Var) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore (Contains, - DefaultFun (AddInteger, AppendByteString, AppendString, BData, Blake2b_256, ChooseUnit, ConsByteString, ConstrData, DecodeUtf8, DivideInteger, EncodeUtf8, EqualsByteString, EqualsData, EqualsInteger, EqualsString, FindFirstSetByteString, FstPair, HeadList, IData, IfThenElse, IndexByteString, LengthOfByteString, LessThanByteString, LessThanEqualsInteger, LessThanInteger, ListData, MapData, MkCons, MkNilData, MkNilPairData, ModInteger, MultiplyInteger, NullList, PopCountByteString, QuotientInteger, RemainderInteger, SerialiseData, Sha2_256, Sha3_256, SliceByteString, SndPair, SubtractInteger, TailList, Trace, UnBData, UnConstrData, UnIData, UnListData, UnMapData, VerifyEd25519Signature), - DefaultUni, EvaluationResult (EvaluationFailure, EvaluationSuccess), Kind (Type), Name (Name), - Term (Builtin, LamAbs, Var), TyName (TyName), Type (TyApp, TyForall, TyFun, TyVar), Unique (Unique), - freshName, mapFun, runQuote) -import PlutusCore.Builtin (CostingPart, toTypeAst, typeOfBuiltinFunction) -import PlutusCore.Compiler.Erase (eraseTerm) -import PlutusCore.Data (Data (B, Constr, I, List, Map)) -import PlutusCore.Default (BuiltinVersion (DefaultFunV1, DefaultFunV2)) -import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultBuiltinCostModel, defaultCekMachineCosts) -import PlutusCore.Evaluation.Machine.MachineParameters (CostModel (CostModel), mkMachineParameters) -import PlutusCore.Examples.Builtins (BuiltinErrorCall (BuiltinErrorCall), BuiltinVersion (ExtensionFunV0, PairV), - ExtensionFun (Const, ExpensivePlus, ExpensiveSucc, ExtensionVersion, Factorial, FailingPlus, FailingSucc, ForallFortyTwo, Id, IdFInteger, IdList, IdRank2, ScottToMetaUnit, Swap)) -import PlutusCore.Examples.Data.Data (ofoldrData) -import PlutusCore.Generators.Hedgehog.Interesting (factorial) -import PlutusCore.MkPlc hiding (error) -import PlutusCore.StdLib.Data.Bool (bool, false, true) -import PlutusCore.StdLib.Data.Data (caseData, dataTy) -import PlutusCore.StdLib.Data.Function qualified as Plc -import PlutusCore.StdLib.Data.Integer (integer) -import PlutusCore.StdLib.Data.List qualified as Builtin -import PlutusCore.StdLib.Data.Pair (pair) -import PlutusCore.StdLib.Data.ScottList qualified as Scott -import PlutusCore.StdLib.Data.ScottUnit qualified as Scott -import PlutusCore.StdLib.Data.Unit (unitval) -import PlutusPrelude (Word8, def, isRight) -import Test.Tasty (TestTree, adjustOption, testGroup) -import Test.Tasty.Hedgehog (HedgehogTestLimit (HedgehogTestLimit), testPropertyNamed) -import Test.Tasty.HUnit (Assertion, assertBool, testCase, (@=?), (@?=)) +import Test.Tasty +import Test.Tasty.Hedgehog +import Test.Tasty.HUnit type DefaultFunExt = Either DefaultFun ExtensionFun @@ -826,7 +783,7 @@ testPopCountByteString :: TestTree testPopCountByteString = testGroup "PopCountByteString" [ testCase "popcount of empty ByteString is 0" $ do let arg = mkConstant @ByteString () "" - let comp = mkIterApp () (builtin () PopCountByteString) [ arg ] + let comp = mkIterAppNoAnn (builtin () PopCountByteString) [ arg ] typecheckEvaluateCekNoEmit def defaultBuiltinCostModel comp @?= Right (EvaluationSuccess . mkConstant @Integer () $ 0), testPropertyNamed "popcount of singleton ByteString is correct" "popcount_singleton" . property $ popCountSingleByte, testPropertyNamed "popcount of append is sum of popcounts" "popcount_append_sum" . property $ popCountAppend @@ -853,7 +810,7 @@ testFindFirstSetByteString :: TestTree testFindFirstSetByteString = testGroup "FindFirstSetByteString" [ testCase "find first set of empty Bytestring is -1" $ do let arg = mkConstant @ByteString () "" - let comp = mkIterApp () (builtin () FindFirstSetByteString) [ arg ] + let comp = mkIterAppNoAnn (builtin () FindFirstSetByteString) [ arg ] typecheckEvaluateCekNoEmit def defaultBuiltinCostModel comp @?= Right (EvaluationSuccess . mkConstant @Integer () $ (-1)), testPropertyNamed "find first set on singletons works correctly" "ffs_singleton" . property $ ffsSingleByte, testPropertyNamed "find first set on appended ByteStrings works correctly" "ffs_append" . property $ ffsAppend From 87d8f7330a9bc1afbc9a7b0a3ce873c72e9e53c9 Mon Sep 17 00:00:00 2001 From: kwxm Date: Fri, 30 Jun 2023 03:56:31 +0100 Subject: [PATCH 63/73] Restore missing exports --- plutus-tx/src/PlutusTx/Builtins.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index 4d4fe09fb19..02909f8b219 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/plutus-tx/src/PlutusTx/Builtins.hs @@ -107,6 +107,9 @@ module PlutusTx.Builtins ( , testBitByteString , writeBitByteString , findFirstSetByteString + -- * Conversions + , fromBuiltin + , toBuiltin ) where import PlutusTx.Base (const, uncurry) From 3133777753363f3c20fb54d23ed2d1ffe2bda105 Mon Sep 17 00:00:00 2001 From: kwxm Date: Fri, 30 Jun 2023 05:37:37 +0100 Subject: [PATCH 64/73] WIP: cost model stubs --- .../cost-model/data/builtinCostModel.json | 192 ++++++++++++++++++ plutus-core/cost-model/data/models.R | 30 ++- 2 files changed, 220 insertions(+), 2 deletions(-) diff --git a/plutus-core/cost-model/data/builtinCostModel.json b/plutus-core/cost-model/data/builtinCostModel.json index b15ea8b805d..c4de20bb19a 100644 --- a/plutus-core/cost-model/data/builtinCostModel.json +++ b/plutus-core/cost-model/data/builtinCostModel.json @@ -873,5 +873,197 @@ "arguments": 10, "type": "constant_cost" } + }, + "integerToByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "linear_cost" + }, + "memory": { + "arguments": { + "intercept": 0, + "slope": 1 + }, + "type": "linear_cost" + } + }, + "byteStringToInteger": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "linear_cost" + }, + "memory": { + "arguments": { + "intercept": 1, + "slope": 1 + }, + "type": "linear_cost" + } + }, + "andByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "max_size" + }, + "memory": { + "arguments": { + "intercept": 1, + "slope": 1 + }, + "type": "max_size" + } + }, + "iorByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "max_size" + }, + "memory": { + "arguments": { + "intercept": 1, + "slope": 1 + }, + "type": "max_size" + } + }, + "xorByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "max_size" + }, + "memory": { + "arguments": { + "intercept": 1, + "slope": 1 + }, + "type": "max_size" + } + }, + "complementByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "linear_cost" + }, + "memory": { + "arguments": { + "intercept": 0, + "slope": 1 + }, + "type": "linear_cost" + } + }, + "shiftByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "max_size" + }, + "memory": { + "arguments": { + "intercept": 1, + "slope": 1 + }, + "type": "max_size" + } + }, + "rotateByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "max_size" + }, + "memory": { + "arguments": { + "intercept": 1, + "slope": 1 + }, + "type": "max_size" + } + }, + "popCountByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "linear_cost" + }, + "memory": { + "arguments": { + "intercept": 0, + "slope": 1 + }, + "type": "linear_cost" + } + }, + "testBitByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "linear_in_x" + }, + "memory": { + "arguments": { + "intercept": 0, + "slope": 1 + }, + "type": "linear_in_x" + } + }, + "writeBitByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "linear_in_x" + }, + "memory": { + "arguments": { + "intercept": 0, + "slope": 1 + }, + "type": "linear_in_x" + } + }, + "findFirstSetByteString": { + "cpu": { + "arguments": { + "intercept": 9999999999, + "slope": 9999999999 + }, + "type": "linear_cost" + }, + "memory": { + "arguments": { + "intercept": 0, + "slope": 1 + }, + "type": "linear_cost" + } } } diff --git a/plutus-core/cost-model/data/models.R b/plutus-core/cost-model/data/models.R index a17a7e91d29..94dac194efa 100644 --- a/plutus-core/cost-model/data/models.R +++ b/plutus-core/cost-model/data/models.R @@ -647,6 +647,20 @@ modelFun <- function(path) { bls12_381_mulMlResultModel <- constantModel ("Bls12_381_mulMlResult") bls12_381_finalVerifyModel <- constantModel ("Bls12_381_finalVerify") + ##### Bitwise operations ##### + integerToByteStringModel <- NULL ### FIXME + byteStringToIntegerModel <- NULL + andByteStringModel <- NULL + iorByteStringModel <- NULL + xorByteStringModel <- NULL + complementByteStringModel <- NULL + shiftByteStringModel <- NULL + rotateByteStringModel <- NULL + popCountByteStringModel <- NULL + testBitByteStringModel <- NULL + writeBitByteStringModel <- NULL + findFirstSetByteStringModel <- NULL + list( addIntegerModel = addIntegerModel, subtractIntegerModel = subtractIntegerModel, @@ -718,6 +732,18 @@ modelFun <- function(path) { bls12_381_G2_uncompressModel = bls12_381_G2_uncompressModel, bls12_381_millerLoopModel = bls12_381_millerLoopModel, bls12_381_mulMlResultModel = bls12_381_mulMlResultModel, - bls12_381_finalVerifyModel = bls12_381_finalVerifyModel + bls12_381_finalVerifyModel = bls12_381_finalVerifyModel, + integerToByteStringModel = integerToByteStringModel, + byteStringToIntegerModel = byteStringToIntegerModel, + andByteStringModel = andByteStringModel, + iorByteStringModel = iorByteStringModel, + xorByteStringModel = xorByteStringModel, + complementByteStringModel = complementByteStringModel, + shiftByteStringModel = shiftByteStringModel, + rotateByteStringModel = rotateByteStringModel, + popCountByteStringModel = popCountByteStringModel, + testBitByteStringModel = testBitByteStringModel, + writeBitByteStringModel = writeBitByteStringModel, + findFirstSetByteStringModel = findFirstSetByteStringModel ) -} +} \ No newline at end of file From e98929e5f588186460c2ef4f539b7baa7f8bb2b2 Mon Sep 17 00:00:00 2001 From: kwxm Date: Fri, 30 Jun 2023 05:38:27 +0100 Subject: [PATCH 65/73] WIP: cost model stubs --- .../CreateBuiltinCostModel.hs | 98 ++++++++++++++++++- .../Evaluation/Machine/BuiltinCostModel.hs | 13 +++ .../Evaluation/Machine/ExBudgetingDefaults.hs | 12 +++ 3 files changed, 122 insertions(+), 1 deletion(-) diff --git a/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs b/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs index 81aa6cb25ec..8a160b75fe9 100644 --- a/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs +++ b/plutus-core/cost-model/create-cost-model/CreateBuiltinCostModel.hs @@ -121,6 +121,18 @@ builtinCostModelNames = BuiltinCostModelBase , paramBls12_381_millerLoop = "bls12_381_millerLoopModel" , paramBls12_381_mulMlResult = "bls12_381_mulMlResultModel" , paramBls12_381_finalVerify = "bls12_381_finalVerifyModel" + , paramIntegerToByteString = "integerToByteStringModel" + , paramByteStringToInteger = "byteStringToIntegerModel" + , paramAndByteString = "andByteStringModel" + , paramIorByteString = "iorByteStringModel" + , paramXorByteString = "xorByteStringModel" + , paramComplementByteString = "complementByteStringModel" + , paramShiftByteString = "shiftByteStringModel" + , paramRotateByteString = "rotateByteStringModel" + , paramPopCountByteString = "popCountByteStringModel" + , paramTestBitByteString = "testBitByteStringModel" + , paramWriteBitByteString = "writeBitByteStringModel" + , paramFindFirstSetByteString = "findFirstSetByteStringModel" } @@ -231,6 +243,19 @@ createBuiltinCostModel bmfile rfile = do paramBls12_381_millerLoop <- getParams bls12_381_millerLoop paramBls12_381_millerLoop paramBls12_381_mulMlResult <- getParams bls12_381_mulMlResult paramBls12_381_mulMlResult paramBls12_381_finalVerify <- getParams bls12_381_finalVerify paramBls12_381_finalVerify + -- Bitwise operations + paramIntegerToByteString <- getParams integerToByteString paramIntegerToByteString + paramByteStringToInteger <- getParams byteStringToInteger paramByteStringToInteger + paramAndByteString <- getParams andByteString paramAndByteString + paramIorByteString <- getParams iorByteString paramIorByteString + paramXorByteString <- getParams xorByteString paramXorByteString + paramComplementByteString <- getParams complementByteString paramComplementByteString + paramShiftByteString <- getParams shiftByteString paramShiftByteString + paramRotateByteString <- getParams rotateByteString paramRotateByteString + paramPopCountByteString <- getParams popCountByteString paramPopCountByteString + paramTestBitByteString <- getParams testBitByteString paramTestBitByteString + paramWriteBitByteString <- getParams writeBitByteString paramWriteBitByteString + paramFindFirstSetByteString <- getParams findFirstSetByteString paramFindFirstSetByteString pure $ BuiltinCostModelBase {..} @@ -903,9 +928,80 @@ bls12_381_mulMlResult cpuModelR = do pure $ CostingFun cpuModel memModel bls12_381_finalVerify :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelTwoArguments) -bls12_381_finalVerify cpuModelR= do +bls12_381_finalVerify cpuModelR = do cpuModel <- ModelTwoArgumentsConstantCost <$> readModelConstantCost cpuModelR let memModel = boolMemModel pure $ CostingFun cpuModel memModel +integerToByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelOneArgument) +integerToByteString cpuModelR = do + cpuModel <- ModelOneArgumentLinearCost <$> readModelLinearInX cpuModelR + let memModel = ModelOneArgumentLinearCost $ ModelLinearSize 0 1 + pure $ CostingFun cpuModel memModel + +byteStringToInteger :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelOneArgument) +byteStringToInteger cpuModelR = do + cpuModel <- ModelOneArgumentLinearCost <$> readModelLinearInX cpuModelR + let memModel = ModelOneArgumentLinearCost $ ModelLinearSize 0 1 + pure $ CostingFun cpuModel memModel + +andByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelTwoArguments) +andByteString cpuModelR = do + cpuModel <- ModelTwoArgumentsMaxSize <$> readModelMaxSize cpuModelR + let memModel = ModelTwoArgumentsMaxSize $ ModelMaxSize 0 1 + pure $ CostingFun cpuModel memModel + +iorByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelTwoArguments) +iorByteString cpuModelR = do + cpuModel <- ModelTwoArgumentsMaxSize <$> readModelMaxSize cpuModelR + let memModel = ModelTwoArgumentsMaxSize $ ModelMaxSize 0 1 + pure $ CostingFun cpuModel memModel + +xorByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelTwoArguments) +xorByteString cpuModelR = do + cpuModel <- ModelTwoArgumentsMaxSize <$> readModelMaxSize cpuModelR + let memModel = ModelTwoArgumentsMaxSize $ ModelMaxSize 0 1 + pure $ CostingFun cpuModel memModel + +complementByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelOneArgument) +complementByteString cpuModelR = do + cpuModel <- ModelOneArgumentLinearCost <$> readModelLinearInX cpuModelR + let memModel = ModelOneArgumentLinearCost $ ModelLinearSize 0 1 + pure $ CostingFun cpuModel memModel + +shiftByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelTwoArguments) +shiftByteString cpuModelR = do + cpuModel <- undefined + let memModel = undefined + pure $ CostingFun cpuModel memModel + +rotateByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelTwoArguments) +rotateByteString cpuModelR = do + cpuModel <- undefined -- FIXME + let memModel = undefined -- FIXME + pure $ CostingFun cpuModel memModel + +popCountByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelOneArgument) +popCountByteString cpuModelR = do + cpuModel <- ModelOneArgumentLinearCost <$> readModelLinearInX cpuModelR + let memModel = ModelOneArgumentLinearCost $ ModelLinearSize 0 1 -- FIXME + pure $ CostingFun cpuModel memModel + +testBitByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelTwoArguments) +testBitByteString cpuModelR = do + cpuModel <- undefined -- FIXME + let memModel = ModelTwoArgumentsConstantCost 1 + pure $ CostingFun cpuModel memModel + +writeBitByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelThreeArguments) +writeBitByteString cpuModelR = do + cpuModel <- undefined -- FIXME + let memModel = undefined -- FIXME + pure $ CostingFun cpuModel memModel + +findFirstSetByteString :: MonadR m => (SomeSEXP (Region m)) -> m (CostingFun ModelOneArgument) +findFirstSetByteString cpuModelR = do + cpuModel <- ModelOneArgumentLinearCost <$> readModelLinearInX cpuModelR + let memModel = undefined -- FIXME + pure $ CostingFun cpuModel memModel diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs index a2326264525..b9edad5b637 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/BuiltinCostModel.hs @@ -153,6 +153,19 @@ data BuiltinCostModelBase f = , paramBls12_381_millerLoop :: f ModelTwoArguments , paramBls12_381_mulMlResult :: f ModelTwoArguments , paramBls12_381_finalVerify :: f ModelTwoArguments + -- Bitwise operations + , paramIntegerToByteString :: f ModelOneArgument + , paramByteStringToInteger :: f ModelOneArgument + , paramAndByteString :: f ModelTwoArguments + , paramIorByteString :: f ModelTwoArguments + , paramXorByteString :: f ModelTwoArguments + , paramComplementByteString :: f ModelOneArgument + , paramShiftByteString :: f ModelTwoArguments + , paramRotateByteString :: f ModelTwoArguments + , paramPopCountByteString :: f ModelOneArgument + , paramTestBitByteString :: f ModelTwoArguments + , paramWriteBitByteString :: f ModelThreeArguments + , paramFindFirstSetByteString :: f ModelOneArgument } deriving stock (Generic) deriving anyclass (FunctorB, TraversableB, ConstraintsB) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs index 636dd6e8d83..be5862d2e84 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Machine/ExBudgetingDefaults.hs @@ -195,5 +195,17 @@ unitCostBuiltinCostModel = BuiltinCostModelBase , paramBls12_381_millerLoop = unitCostTwoArguments , paramBls12_381_mulMlResult = unitCostTwoArguments , paramBls12_381_finalVerify = unitCostTwoArguments + , paramIntegerToByteString = unitCostOneArgument + , paramByteStringToInteger = unitCostOneArgument + , paramAndByteString = unitCostTwoArguments + , paramIorByteString = unitCostTwoArguments + , paramXorByteString = unitCostTwoArguments + , paramComplementByteString = unitCostOneArgument + , paramShiftByteString = unitCostTwoArguments + , paramRotateByteString = unitCostTwoArguments + , paramPopCountByteString = unitCostOneArgument + , paramTestBitByteString = unitCostTwoArguments + , paramWriteBitByteString = unitCostThreeArguments + , paramFindFirstSetByteString = unitCostOneArgument } From dc4bdefcbb2570c0f26d7196fcae761d416dd07c Mon Sep 17 00:00:00 2001 From: kwxm Date: Fri, 30 Jun 2023 05:42:36 +0100 Subject: [PATCH 66/73] WIP: cost model stubs --- plutus-core/cost-model/test/TestCostModels.hs | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/plutus-core/cost-model/test/TestCostModels.hs b/plutus-core/cost-model/test/TestCostModels.hs index 25ebb65884d..e9da611c59e 100644 --- a/plutus-core/cost-model/test/TestCostModels.hs +++ b/plutus-core/cost-model/test/TestCostModels.hs @@ -419,5 +419,20 @@ main = , $(genTest 2 "bls12_381_millerLoop") Everywhere , $(genTest 2 "bls12_381_mulMlResult") Everywhere , $(genTest 2 "bls12_381_finalVerify") Everywhere + + -- Bitwise operations + , $(genTest 1 "integerToByteString") + , $(genTest 1 "byteStringToInteger") + , $(genTest 2 "andByteString") Everywhere + , $(genTest 2 "iorByteString") Everywhere + , $(genTest 2 "xorByteString") Everywhere + , $(genTest 1 "complementByteString") + , $(genTest 2 "shiftByteString") Everywhere + , $(genTest 2 "rotateByteString") Everywhere + , $(genTest 1 "popCountByteString") + , $(genTest 2 "testBitByteString") Everywhere + , $(genTest 3 "writeBitByteString") + , $(genTest 1 "findFirstSetByteString") + ] From ee0075c5e65b7252c8c20681fdc625c2456de7e5 Mon Sep 17 00:00:00 2001 From: kwxm Date: Tue, 18 Jul 2023 18:35:46 +0100 Subject: [PATCH 67/73] Update builtin tags --- .../src/PlutusCore/Default/Builtins.hs | 54 ++++++++++--------- 1 file changed, 29 insertions(+), 25 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index c50d6f16db1..ab150a830d2 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1622,18 +1622,21 @@ instance Flat DefaultFun where Bls12_381_mulMlResult -> 69 Bls12_381_finalVerify -> 70 - IntegerToByteString -> 72 - ByteStringToInteger -> 73 - AndByteString -> 74 - IorByteString -> 75 - XorByteString -> 76 - ComplementByteString -> 77 - ShiftByteString -> 78 - RotateByteString -> 79 - PopCountByteString -> 80 - TestBitByteString -> 81 - WriteBitByteString -> 82 - FindFirstSetByteString -> 83 + -- 71 is reserved for Keccak_256 + -- 72 is reserved for Blake2b_224 + + IntegerToByteString -> 73 + ByteStringToInteger -> 74 + AndByteString -> 75 + IorByteString -> 76 + XorByteString -> 77 + ComplementByteString -> 78 + ShiftByteString -> 79 + RotateByteString -> 90 + PopCountByteString -> 81 + TestBitByteString -> 82 + WriteBitByteString -> 83 + FindFirstSetByteString -> 84 decode = go =<< decodeBuiltin where go 0 = pure AddInteger @@ -1707,19 +1710,20 @@ instance Flat DefaultFun where go 68 = pure Bls12_381_millerLoop go 69 = pure Bls12_381_mulMlResult go 70 = pure Bls12_381_finalVerify - go 71 = fail "Reserved" - go 72 = pure IntegerToByteString - go 73 = pure ByteStringToInteger - go 74 = pure AndByteString - go 75 = pure IorByteString - go 76 = pure XorByteString - go 77 = pure ComplementByteString - go 78 = pure ShiftByteString - go 79 = pure RotateByteString - go 80 = pure PopCountByteString - go 81 = pure TestBitByteString - go 82 = pure WriteBitByteString - go 83 = pure FindFirstSetByteString + go 71 = fail "Reserved for Keccak_256" + go 72 = fail "Reserved for Blake2b_224" + go 73 = pure IntegerToByteString + go 74 = pure ByteStringToInteger + go 75 = pure AndByteString + go 76 = pure IorByteString + go 77 = pure XorByteString + go 78 = pure ComplementByteString + go 79 = pure ShiftByteString + go 80 = pure RotateByteString + go 81 = pure PopCountByteString + go 82 = pure TestBitByteString + go 83 = pure WriteBitByteString + go 84 = pure FindFirstSetByteString go t = fail $ "Failed to decode builtin tag, got: " ++ show t size _ n = n + builtinTagWidth From af4fd3e9119580f5e2c2fe7e38145abd6472522f Mon Sep 17 00:00:00 2001 From: kwxm Date: Wed, 19 Jul 2023 19:48:57 +0100 Subject: [PATCH 68/73] Update costing code --- .../src/PlutusCore/Default/Builtins.hs | 44 ++++++++++++++----- 1 file changed, 33 insertions(+), 11 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index ab150a830d2..fb02fd19bef 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1495,27 +1495,49 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where Nothing -> fail "negative integer passed to integerByteString" {-# INLINE integerToByteStringPlc #-} toBuiltinMeaning _ver ByteStringToInteger = - makeBuiltinMeaning byteStringToInteger (\_ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + byteStringToInteger + (runCostingFunOneArgument . paramByteStringToInteger) toBuiltinMeaning _ver AndByteString = - makeBuiltinMeaning andByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + andByteString + (runCostingFunTwoArguments . paramAndByteString) toBuiltinMeaning _ver IorByteString = - makeBuiltinMeaning iorByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + iorByteString + (runCostingFunTwoArguments . paramIorByteString) toBuiltinMeaning _ver XorByteString = - makeBuiltinMeaning xorByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + xorByteString + (runCostingFunTwoArguments . paramXorByteString) toBuiltinMeaning _ver ComplementByteString = - makeBuiltinMeaning complementByteString (\_ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + complementByteString + (runCostingFunOneArgument . paramComplementByteString) toBuiltinMeaning _ver ShiftByteString = - makeBuiltinMeaning shiftByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + shiftByteString + (runCostingFunTwoArguments . paramShiftByteString) toBuiltinMeaning _ver RotateByteString = - makeBuiltinMeaning rotateByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + rotateByteString + (runCostingFunTwoArguments . paramRotateByteString) toBuiltinMeaning _ver PopCountByteString = - makeBuiltinMeaning popCountByteString (\_ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + popCountByteString + (runCostingFunOneArgument . paramPopCountByteString) toBuiltinMeaning _ver TestBitByteString = - makeBuiltinMeaning testBitByteString (\_ _ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + testBitByteString + (runCostingFunTwoArguments . paramTestBitByteString) toBuiltinMeaning _ver WriteBitByteString = - makeBuiltinMeaning writeBitByteString (\_ _ _ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + writeBitByteString + (runCostingFunThreeArguments . paramWriteBitByteString) toBuiltinMeaning _ver FindFirstSetByteString = - makeBuiltinMeaning findFirstSetByteString (\_ _ -> ExBudgetLast $ ExBudget 0 0) + makeBuiltinMeaning + findFirstSetByteString + (runCostingFunOneArgument . paramFindFirstSetByteString) -- See Note [Inlining meanings of builtins]. {-# INLINE toBuiltinMeaning #-} From 181488aa1d3dff86de1625393712d43bd1b44d88 Mon Sep 17 00:00:00 2001 From: kwxm Date: Thu, 20 Jul 2023 11:31:24 +0100 Subject: [PATCH 69/73] _var -> _ver --- .../src/PlutusCore/Default/Builtins.hs | 34 +++++++++---------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index fb02fd19bef..885e5b68a6f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1413,73 +1413,73 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where (\() -> [] @(Data,Data)) (runCostingFunOneArgument . paramMkNilPairData) -- BLS12_381.G1 - toBuiltinMeaning _var Bls12_381_G1_add = + toBuiltinMeaning _ver Bls12_381_G1_add = makeBuiltinMeaning BLS12_381.G1.add (runCostingFunTwoArguments . paramBls12_381_G1_add) - toBuiltinMeaning _var Bls12_381_G1_neg = + toBuiltinMeaning _ver Bls12_381_G1_neg = makeBuiltinMeaning BLS12_381.G1.neg (runCostingFunOneArgument . paramBls12_381_G1_neg) - toBuiltinMeaning _var Bls12_381_G1_scalarMul = + toBuiltinMeaning _ver Bls12_381_G1_scalarMul = makeBuiltinMeaning BLS12_381.G1.scalarMul (runCostingFunTwoArguments . paramBls12_381_G1_scalarMul) - toBuiltinMeaning _var Bls12_381_G1_compress = + toBuiltinMeaning _ver Bls12_381_G1_compress = makeBuiltinMeaning BLS12_381.G1.compress (runCostingFunOneArgument . paramBls12_381_G1_compress) - toBuiltinMeaning _var Bls12_381_G1_uncompress = + toBuiltinMeaning _ver Bls12_381_G1_uncompress = makeBuiltinMeaning (eitherToEmitter . BLS12_381.G1.uncompress) (runCostingFunOneArgument . paramBls12_381_G1_uncompress) - toBuiltinMeaning _var Bls12_381_G1_hashToGroup = + toBuiltinMeaning _ver Bls12_381_G1_hashToGroup = makeBuiltinMeaning (eitherToEmitter .* BLS12_381.G1.hashToGroup) (runCostingFunTwoArguments . paramBls12_381_G1_hashToGroup) - toBuiltinMeaning _var Bls12_381_G1_equal = + toBuiltinMeaning _ver Bls12_381_G1_equal = makeBuiltinMeaning ((==) @BLS12_381.G1.Element) (runCostingFunTwoArguments . paramBls12_381_G1_equal) -- BLS12_381.G2 - toBuiltinMeaning _var Bls12_381_G2_add = + toBuiltinMeaning _ver Bls12_381_G2_add = makeBuiltinMeaning BLS12_381.G2.add (runCostingFunTwoArguments . paramBls12_381_G2_add) - toBuiltinMeaning _var Bls12_381_G2_neg = + toBuiltinMeaning _ver Bls12_381_G2_neg = makeBuiltinMeaning BLS12_381.G2.neg (runCostingFunOneArgument . paramBls12_381_G2_neg) - toBuiltinMeaning _var Bls12_381_G2_scalarMul = + toBuiltinMeaning _ver Bls12_381_G2_scalarMul = makeBuiltinMeaning BLS12_381.G2.scalarMul (runCostingFunTwoArguments . paramBls12_381_G2_scalarMul) - toBuiltinMeaning _var Bls12_381_G2_compress = + toBuiltinMeaning _ver Bls12_381_G2_compress = makeBuiltinMeaning BLS12_381.G2.compress (runCostingFunOneArgument . paramBls12_381_G2_compress) - toBuiltinMeaning _var Bls12_381_G2_uncompress = + toBuiltinMeaning _ver Bls12_381_G2_uncompress = makeBuiltinMeaning (eitherToEmitter . BLS12_381.G2.uncompress) (runCostingFunOneArgument . paramBls12_381_G2_uncompress) - toBuiltinMeaning _var Bls12_381_G2_hashToGroup = + toBuiltinMeaning _ver Bls12_381_G2_hashToGroup = makeBuiltinMeaning (eitherToEmitter .* BLS12_381.G2.hashToGroup) (runCostingFunTwoArguments . paramBls12_381_G2_hashToGroup) - toBuiltinMeaning _var Bls12_381_G2_equal = + toBuiltinMeaning _ver Bls12_381_G2_equal = makeBuiltinMeaning ((==) @BLS12_381.G2.Element) (runCostingFunTwoArguments . paramBls12_381_G2_equal) -- BLS12_381.Pairing - toBuiltinMeaning _var Bls12_381_millerLoop = + toBuiltinMeaning _ver Bls12_381_millerLoop = makeBuiltinMeaning BLS12_381.Pairing.millerLoop (runCostingFunTwoArguments . paramBls12_381_millerLoop) - toBuiltinMeaning _var Bls12_381_mulMlResult = + toBuiltinMeaning _ver Bls12_381_mulMlResult = makeBuiltinMeaning BLS12_381.Pairing.mulMlResult (runCostingFunTwoArguments . paramBls12_381_mulMlResult) - toBuiltinMeaning _var Bls12_381_finalVerify = + toBuiltinMeaning _ver Bls12_381_finalVerify = makeBuiltinMeaning BLS12_381.Pairing.finalVerify (runCostingFunTwoArguments . paramBls12_381_finalVerify) From 3938faf8ec73d84939fd4f813d295ba204a5ac12 Mon Sep 17 00:00:00 2001 From: kwxm Date: Tue, 25 Jul 2023 15:33:57 +0100 Subject: [PATCH 70/73] Fix typo in builtin tags --- plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 885e5b68a6f..b021e885a76 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -1654,7 +1654,7 @@ instance Flat DefaultFun where XorByteString -> 77 ComplementByteString -> 78 ShiftByteString -> 79 - RotateByteString -> 90 + RotateByteString -> 80 PopCountByteString -> 81 TestBitByteString -> 82 WriteBitByteString -> 83 From ac958472d8bc585f5c43c2234f753f80530fefda Mon Sep 17 00:00:00 2001 From: kwxm Date: Tue, 1 Aug 2023 22:58:02 +0100 Subject: [PATCH 71/73] Remove some duplicated imports --- .../plutus-core/src/PlutusCore/Default/Builtins.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index df36e47def8..109f66661de 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs @@ -29,13 +29,6 @@ import PlutusCore.Pretty import Bitwise (andByteString, byteStringToInteger, complementByteString, findFirstSetByteString, integerToByteString, iorByteString, popCountByteString, rotateByteString, shiftByteString, testBitByteString, writeBitByteString, xorByteString) -import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 -import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 -import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing -import PlutusCore.Crypto.Ed25519 (verifyEd25519Signature_V1, verifyEd25519Signature_V2) -import PlutusCore.Crypto.Hash qualified as Hash -import PlutusCore.Crypto.Secp256k1 (verifyEcdsaSecp256k1Signature, verifySchnorrSecp256k1Signature) - import Codec.Serialise (serialise) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL @@ -50,6 +43,7 @@ import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2 import PlutusCore.Crypto.BLS12_381.Pairing qualified as BLS12_381.Pairing import PlutusCore.Crypto.Ed25519 (verifyEd25519Signature_V1, verifyEd25519Signature_V2) +import PlutusCore.Crypto.Hash qualified as Hash import PlutusCore.Crypto.Secp256k1 (verifyEcdsaSecp256k1Signature, verifySchnorrSecp256k1Signature) import Prettyprinter (viaShow) From 7996c8db2f8e2c4f2c0867b6d5fcf34b12d8c4d3 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 9 Aug 2023 09:24:47 +1200 Subject: [PATCH 72/73] Format fix --- plutus-core/plutus-core/src/Bitwise.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/plutus-core/plutus-core/src/Bitwise.hs b/plutus-core/plutus-core/src/Bitwise.hs index 06b7615bc0e..c442ca14ae7 100644 --- a/plutus-core/plutus-core/src/Bitwise.hs +++ b/plutus-core/plutus-core/src/Bitwise.hs @@ -26,12 +26,14 @@ module Bitwise ( rotateByteString, ) where -import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shift, shiftL, xor, zeroBits, (.&.), (.|.)) +import Data.Bits (FiniteBits, bit, complement, popCount, rotate, shift, shiftL, xor, zeroBits, + (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Internal (toForeignPtr0) import Data.ByteString.Short qualified as SBS -import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, unsafeUseAsCStringLen) +import Data.ByteString.Unsafe (unsafePackMallocCStringLen, unsafeUseAsCString, + unsafeUseAsCStringLen) import Data.Foldable (foldl', for_) import Data.Functor (void) import Data.Kind (Type) From 00ffb88a27fc3c0c237b3c0eb79491633629b56e Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 9 Aug 2023 10:34:32 +1200 Subject: [PATCH 73/73] Changelogs for bitwise primops --- .../20230809_093202_koz.ross_bitwise.md | 41 +++++++++++++++++++ 1 file changed, 41 insertions(+) create mode 100644 plutus-core/changelog.d/20230809_093202_koz.ross_bitwise.md diff --git a/plutus-core/changelog.d/20230809_093202_koz.ross_bitwise.md b/plutus-core/changelog.d/20230809_093202_koz.ross_bitwise.md new file mode 100644 index 00000000000..2452d730960 --- /dev/null +++ b/plutus-core/changelog.d/20230809_093202_koz.ross_bitwise.md @@ -0,0 +1,41 @@ + + + +### Added + +- Bitwise primitive operations, according to + [CIP-0058](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0058). + + + + +