module Main where import Control.Applicative import Control.DeepSeq import Control.Exception import Data.Binary qualified as Bin import Data.Binary.Get qualified as Bin import Data.Binary.Put qualified as Bin import Data.Bits import Data.ByteString.Lazy qualified as BL import Data.Coerce import Data.Foldable import Data.Int import Data.Word import GHC.Stack import Numeric.Natural import Test.Tasty.Bench import Data.Binary.SLEB128 qualified as S import Data.Binary.ULEB128 qualified as U import Data.Binary.ZLEB128 qualified as Z -------------------------------------------------------------------------------- interleave :: [a] -> [a] -> [a] interleave (x : xs) (y : ys) = x : y : interleave xs ys interleave [] ys = ys interleave xs [] = xs {-# INLINE interleave #-} enum :: (Num a, Bits a, Enum a) => a -> a -> [a] enum mn mx = interleave (enumFromThenTo mn (mn + 2) (mx - 1)) (enumFromThenTo mx (mx - 2) (mn + 1)) {-# INLINE enum #-} bounded :: (Num a, Bits a, Enum a, Bounded a) => [a] bounded = enum minBound maxBound {-# INLINE bounded #-} runGetFull :: HasCallStack => Bin.Get a -> BL.ByteString -> a runGetFull ga = \b -> case Bin.runGetOrFail ga b of Right (l, _, a) | BL.null l -> a | otherwise -> error "Unexpected leftovers" Left (_, _, e) -> error e -------------------------------------------------------------------------------- takeInts :: Int -> [Int] takeInts = flip take (cycle bounded) takeUInts :: Int -> [Word] takeUInts = flip take (cycle (enum minBound (fromIntegral (maxBound :: Int)))) takeInt8s :: Int -> [Int8] takeInt8s = flip take (cycle bounded) takeUInt8s :: Int -> [Word8] takeUInt8s = flip take (cycle (enum minBound (fromIntegral (maxBound :: Int8)))) takeWords :: Int -> [Word] takeWords = flip take (cycle bounded) takeWord8s :: Int -> [Word8] takeWord8s = flip take (cycle bounded) takeIntegers :: Int -> Int -> [Integer] takeIntegers bits = flip take (cycle (enum (-(2 ^ (bits - 1))) (2 ^ (bits - 1) - 1))) takeUIntegers :: Int -> Int -> [Natural] takeUIntegers bits = flip take (cycle (enum 0 (2 ^ (bits - 1) - 1))) takeNaturals :: Int -> Int -> [Natural] takeNaturals bits = flip take (cycle (enum 0 (2 ^ bits - 1))) -------------------------------------------------------------------------------- putManyU :: forall a. Bin.Binary (U.ULEB128 a) => [a] -> BL.ByteString putManyU = let pa = coerce (Bin.put :: U.ULEB128 a -> Bin.Put) :: a -> Bin.Put in Bin.runPut . traverse_ pa getInt8sU :: BL.ByteString -> [Int8] getInt8sU = runGetFull (some U.getInt8) getIntsU :: BL.ByteString -> [Int] getIntsU = runGetFull (some U.getInt) getIntegersU :: BL.ByteString -> [Integer] getIntegersU = runGetFull (some (U.getInteger 100)) getAllU :: forall a . (HasCallStack, Bin.Binary (U.ULEB128 a)) => BL.ByteString -> [a] getAllU = let ga = coerce (Bin.get :: Bin.Get (U.ULEB128 a)) :: Bin.Get a in runGetFull (some ga) -------------------------------------------------------------------------------- putManyZ :: forall a. Bin.Binary (Z.ZLEB128 a) => [a] -> BL.ByteString putManyZ = let pa = coerce (Bin.put :: Z.ZLEB128 a -> Bin.Put) :: a -> Bin.Put in Bin.runPut . traverse_ pa getAllZ :: forall a . (HasCallStack, Bin.Binary (Z.ZLEB128 a)) => BL.ByteString -> [a] getAllZ = let ga = coerce (Bin.get :: Bin.Get (Z.ZLEB128 a)) :: Bin.Get a in runGetFull (some ga) -------------------------------------------------------------------------------- putManyS :: forall a. Bin.Binary (S.SLEB128 a) => [a] -> BL.ByteString putManyS = let pa = coerce (Bin.put :: S.SLEB128 a -> Bin.Put) :: a -> Bin.Put in Bin.runPut . traverse_ pa getAllS :: forall a . (HasCallStack, Bin.Binary (S.SLEB128 a)) => BL.ByteString -> [a] getAllS = let ga = coerce (Bin.get :: Bin.Get (S.SLEB128 a)) :: Bin.Get a in runGetFull (some ga) -------------------------------------------------------------------------------- ntests :: Int ntests = 1_000_000 envPure :: NFData e => e -> (e -> Benchmark) -> Benchmark envPure e k = env (evaluate (force e)) k main :: IO () main = defaultMain [ bgroup ("Generate " <> show ntests) [ bench "Word8" $ nf takeWord8s ntests , bench "Int8" $ nf takeInt8s ntests , bench "Word" $ nf takeWords ntests , bench "Int" $ nf takeInts ntests , bench "Natural32" $ nf (takeNaturals 32) ntests , bench "Integer32" $ nf (takeIntegers 32) ntests , bench "Natural64" $ nf (takeNaturals 64) ntests , bench "Integer64" $ nf (takeIntegers 64) ntests , bench "Natural256" $ nf (takeNaturals 256) ntests , bench "Integer256" $ nf (takeIntegers 256) ntests ] , bgroup "ULEB128" [ bgroup ("Encode " <> show ntests) [ envPure (takeWord8s ntests) $ \e -> bench "Word8" $ nf (putManyU @Word8) e , envPure (takeWords ntests) $ \e -> bench "Word" $ nf (putManyU @Word) e , envPure (takeNaturals 32 ntests) $ \e -> bench "Natural32" $ nf (putManyU @Natural) e , envPure (takeNaturals 64 ntests) $ \e -> bench "Natural64" $ nf (putManyU @Natural) e , envPure (takeNaturals 256 ntests) $ \e -> bench "Natural256" $ nf (putManyU @Natural) e ] , bgroup ("Decode " <> show ntests) [ envPure (putManyU @Word8 (takeWord8s ntests)) $ \e -> bench "Word8" $ nf (getAllU @Word8) e , envPure (putManyU @Word8 (takeUInt8s ntests)) $ \e -> bench "Int8" $ nf getInt8sU e , envPure (putManyU @Word (takeWords ntests)) $ \e -> bench "Word" $ nf (getAllU @Word) e , envPure (putManyU @Word (takeUInts ntests)) $ \e -> bench "Int" $ nf getIntsU e , envPure (putManyU @Natural (takeNaturals 32 ntests)) $ \e -> bench "Natural32" $ nf (getAllU @Natural) e , envPure (putManyU @Natural (takeUIntegers 32 ntests)) $ \e -> bench "Integer32" $ nf getIntegersU e , envPure (putManyU @Natural (takeNaturals 64 ntests)) $ \e -> bench "Natural64" $ nf (getAllU @Natural) e , envPure (putManyU @Natural (takeUIntegers 64 ntests)) $ \e -> bench "Integer64" $ nf getIntegersU e , envPure (putManyU @Natural (takeNaturals 256 ntests)) $ \e -> bench "Natural256" $ nf (getAllU @Natural) e , envPure (putManyU @Natural (takeUIntegers 256 ntests)) $ \e -> bench "Integer256" $ nf getIntegersU e ] ] , bgroup "ZLEB128" [ bgroup ("Encode " <> show ntests) [ envPure (takeWord8s ntests) $ \e -> bench "Word8" $ nf (putManyZ @Word8) e , envPure (takeInt8s ntests) $ \e -> bench "Int8" $ nf (putManyZ @Int8) e , envPure (takeWords ntests) $ \e -> bench "Word" $ nf (putManyZ @Word) e , envPure (takeInts ntests) $ \e -> bench "Int" $ nf (putManyZ @Int) e , envPure (takeNaturals 32 ntests) $ \e -> bench "Natural32" $ nf (putManyZ @Natural) e , envPure (takeIntegers 32 ntests) $ \e -> bench "Integer32" $ nf (putManyZ @Integer) e , envPure (takeNaturals 64 ntests) $ \e -> bench "Natural64" $ nf (putManyZ @Natural) e , envPure (takeIntegers 64 ntests) $ \e -> bench "Integer64" $ nf (putManyZ @Integer) e , envPure (takeNaturals 256 ntests) $ \e -> bench "Natural256" $ nf (putManyZ @Natural) e , envPure (takeIntegers 256 ntests) $ \e -> bench "Integer256" $ nf (putManyZ @Integer) e ] , bgroup ("Decode " <> show ntests) [ envPure (putManyZ @Word8 (takeWord8s ntests)) $ \e -> bench "Word8" $ nf (getAllZ @Word8) e , envPure (putManyZ @Int8 (takeInt8s ntests)) $ \e -> bench "Int8" $ nf (getAllZ @Int8) e , envPure (putManyZ @Word (takeWords ntests)) $ \e -> bench "Word" $ nf (getAllZ @Word) e , envPure (putManyZ @Int (takeInts ntests)) $ \e -> bench "Int" $ nf (getAllZ @Int) e , envPure (putManyZ @Natural (takeNaturals 32 ntests)) $ \e -> bench "Natural32" $ nf (getAllZ @Natural) e , envPure (putManyZ @Integer (takeIntegers 32 ntests)) $ \e -> bench "Integer32" $ nf (getAllZ @Integer) e , envPure (putManyZ @Natural (takeNaturals 64 ntests)) $ \e -> bench "Natural64" $ nf (getAllZ @Natural) e , envPure (putManyZ @Integer (takeIntegers 64 ntests)) $ \e -> bench "Integer64" $ nf (getAllZ @Integer) e , envPure (putManyZ @Natural (takeNaturals 256 ntests)) $ \e -> bench "Natural256" $ nf (getAllZ @Natural) e , envPure (putManyZ @Integer (takeIntegers 256 ntests)) $ \e -> bench "Integer256" $ nf (getAllZ @Integer) e ] ] , bgroup "SLEB128" [ bgroup ("Encode " <> show ntests) [ envPure (takeWord8s ntests) $ \e -> bench "Word8" $ nf (putManyS @Word8) e , envPure (takeInt8s ntests) $ \e -> bench "Int8" $ nf (putManyS @Int8) e , envPure (takeWords ntests) $ \e -> bench "Word" $ nf (putManyS @Word) e , envPure (takeInts ntests) $ \e -> bench "Int" $ nf (putManyS @Int) e , envPure (takeNaturals 32 ntests) $ \e -> bench "Natural32" $ nf (putManyS @Natural) e , envPure (takeIntegers 32 ntests) $ \e -> bench "Integer32" $ nf (putManyS @Integer) e , envPure (takeNaturals 64 ntests) $ \e -> bench "Natural64" $ nf (putManyS @Natural) e , envPure (takeIntegers 64 ntests) $ \e -> bench "Integer64" $ nf (putManyS @Integer) e , envPure (takeNaturals 256 ntests) $ \e -> bench "Natural256" $ nf (putManyS @Natural) e , envPure (takeIntegers 256 ntests) $ \e -> bench "Integer256" $ nf (putManyS @Integer) e ] , bgroup ("Decode " <> show ntests) [ envPure (putManyS @Word8 (takeWord8s ntests)) $ \e -> bench "Word8" $ nf (getAllS @Word8) e , envPure (putManyS @Int8 (takeInt8s ntests)) $ \e -> bench "Int8" $ nf (getAllS @Int8) e , envPure (putManyS @Word (takeWords ntests)) $ \e -> bench "Word" $ nf (getAllS @Word) e , envPure (putManyS @Int (takeInts ntests)) $ \e -> bench "Int" $ nf (getAllS @Int) e , envPure (putManyS @Natural (takeNaturals 32 ntests)) $ \e -> bench "Natural32" $ nf (getAllS @Natural) e , envPure (putManyS @Integer (takeIntegers 32 ntests)) $ \e -> bench "Integer32" $ nf (getAllS @Integer) e , envPure (putManyS @Natural (takeNaturals 64 ntests)) $ \e -> bench "Natural64" $ nf (getAllS @Natural) e , envPure (putManyS @Integer (takeIntegers 64 ntests)) $ \e -> bench "Integer64" $ nf (getAllS @Integer) e , envPure (putManyS @Natural (takeNaturals 256 ntests)) $ \e -> bench "Natural256" $ nf (getAllS @Natural) e , envPure (putManyS @Integer (takeIntegers 256 ntests)) $ \e -> bench "Integer256" $ nf (getAllS @Integer) e ] ] ]