Skip to content

Commit

Permalink
🌅
Browse files Browse the repository at this point in the history
  • Loading branch information
@hvr
hvr committed May 17, 2020
0 parents commit d36a688
Show file tree
Hide file tree
Showing 7 changed files with 1,204 additions and 0 deletions.
2 changes: 2 additions & 0 deletions .gitignore
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
/dist-newstyle/
*~
339 changes: 339 additions & 0 deletions LICENSE.GPLv2

Large diffs are not rendered by default.

167 changes: 167 additions & 0 deletions src-bench/Main.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,167 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE CApiFFI #-}

{-# OPTIONS_GHC -Wall #-}

-- |
-- Copyright: © 2020 Herbert Valerio Riedel
-- SPDX-License-Identifier: GPL-2.0-or-later
--
module Main
( main
, xor32ByteString'ref
, xor32ByteString'v3
, xor32ByteString'v4
) where

import Control.Exception (assert)
import Control.Monad
import Criterion.Main
import Data.Bits
import qualified Data.ByteString as BS
import Data.ByteString.Internal as BS
import qualified Data.ByteString.Short as SBS
import Data.Word (Word32, Word8)
import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable
import GHC.ByteOrder (ByteOrder (..), targetByteOrder)

import qualified Data.XOR as IUT

main :: IO ()
main = defaultMain benches

benches :: [Benchmark]
benches =
[ doGroup "4k" bs4k
, doGroup "4k1" bs4k1
, doGroup "4k2" bs4k2
, doGroup "4k3" bs4k3
, doGroup "32k" bs32k
, doGroup "256k" bs256k
]
where
doGroup label bs = let sbs = SBS.toShort bs in bgroup label
[ bench "REF" $ whnf (xor32ByteString'ref msk) bs
, bench "IUT" $ whnf (IUT.xor32StrictByteString msk) bs
, bench "IUT/SBS" $ whnf (IUT.xor32ShortByteString msk) sbs
, bench "v3" $ whnf (xor32ByteString'v3 msk) bs
, bench "v4" $ whnf (xor32ByteString'v4 msk) bs
, bench "REF 8bit" $ whnf (xor8StrictByteString'ref msk8) bs
, bench "IUT 8bit" $ whnf (IUT.xor8StrictByteString msk8) bs
]

{-# NOINLINE bs32k #-}
!bs4k = BS.replicate (4*1024) 0x55
!bs4k1 = BS.replicate (4*1024+1) 0x55
!bs4k2 = BS.replicate (4*1024+2) 0x55
!bs4k3 = BS.replicate (4*1024+3) 0x55
!bs32k = BS.replicate (32*1024) 0x55
!bs256k = BS.replicate (256*1024) 0x55

{-# NOINLINE msk #-}
msk = 0x12345678

msk8 = 0x42

----------------------------------------------------------------------------

-- reference impl

{-# NOINLINE xor32ByteString'ref #-}
xor32ByteString'ref :: Word32 -> BS.ByteString -> BS.ByteString
xor32ByteString'ref 0 = id
xor32ByteString'ref msk0 = snd . BS.mapAccumL go msk0
where
go :: Word32 -> Word8 -> (Word32,Word8)
go msk b = let b' = fromIntegral msk' `xor` b
msk' = rotateL msk 8
in b' `seq` (msk',b')


{-# NOINLINE xor8StrictByteString'ref #-}
xor8StrictByteString'ref :: Word8 -> BS.ByteString -> BS.ByteString
xor8StrictByteString'ref 0 = id
xor8StrictByteString'ref msk0 = BS.map (xor msk0)

-- {-# NOINLINE xor32ByteString'v2 #-}
-- xor32ByteString'v2 :: Word32 -> BS.ByteString -> BS.ByteString
-- xor32ByteString'v2 msk0 = snd . BS.mapAccumL go mskstr
-- where
-- mskstr :: [Word8]
-- mskstr = cycle (map fromIntegral (tail (take 5 (iterate rotl8 msk0))))
--
-- rotl8 :: Word32 -> Word32
-- rotl8 = flip rotateL 8
--
-- go (x:xs) b = let !b' = xor x b in (xs,b')

{-# NOINLINE xor32ByteString'v3 #-}
xor32ByteString'v3 :: Word32 -> BS.ByteString -> BS.ByteString
xor32ByteString'v3 0 bs = bs
xor32ByteString'v3 _ bs | BS.null bs = bs
xor32ByteString'v3 msk0 (BS.PS x s l)
= unsafeCreate l $ \p8 ->
withForeignPtr x $ \f -> do
memcpy p8 (f `plusPtr` s) (fromIntegral l)
let p32 = castPtr p8 :: Ptr Word32
l32 = l `quot` 4
p32end = p32 `plusPtr` (l32*4)
unless (alignPtr p32 4 == p32) $ fail "bytestring allocation not aligned"
xor32PtrAligned msk0 p32 (l32*4)
_ <- xor32PtrNonAligned msk0 (castPtr p32end) (l - (l32*4))
return ()

{-# NOINLINE xor32ByteString'v4 #-}
xor32ByteString'v4 :: Word32 -> BS.ByteString -> BS.ByteString
xor32ByteString'v4 0 bs = bs
xor32ByteString'v4 _ bs | BS.null bs = bs
xor32ByteString'v4 msk0 (BS.PS x s l)
= unsafeCreate l $ \p8 ->
withForeignPtr x $ \f -> do
memcpy p8 (f `plusPtr` s) (fromIntegral l)
_ <- IUT.xor32CStringLen msk0 (castPtr p8,l)
return ()

{-# INLINE xor32PtrNonAligned #-}
xor32PtrNonAligned :: Word32 -> Ptr Word8 -> Int -> IO Word32
xor32PtrNonAligned mask0 _ 0 = return mask0
xor32PtrNonAligned mask0 p0 n = go mask0 p0
where
p' = p0 `plusPtr` n
go m p
| p == p' = return m
| otherwise = do
let m' = rotateL m 8
xor8Ptr1 (fromIntegral m') p
go m' (p `plusPtr` 1)

{-# INLINE xor32PtrAligned #-}
xor32PtrAligned :: Word32 -> Ptr Word32 -> Int -> IO ()
xor32PtrAligned _ _ 0 = return ()
xor32PtrAligned mask0be p0 n
= assert (p0 == alignPtr p0 4 && n `rem` 4 == 0) $ go p0
where
p' = p0 `plusPtr` n
go p
| p == p' = return ()
| otherwise = do { xor32Ptr1 mask0 p; go (p `plusPtr` 4) }

mask0 = case targetByteOrder of
LittleEndian -> {- byteSwap32 -} mask0be
BigEndian -> mask0be

----------------------------------------------------------------------------

xor8Ptr1 :: Word8 -> Ptr Word8 -> IO ()
xor8Ptr1 msk ptr = do { x <- peek ptr; poke ptr (xor msk x) }

-- xor16Ptr1 :: Word16 -> Ptr Word16 -> IO ()
-- xor16Ptr1 msk ptr = do { x <- peek ptr; poke ptr (xor msk x) }

xor32Ptr1 :: Word32 -> Ptr Word32 -> IO ()
xor32Ptr1 msk ptr = do { x <- peek ptr; poke ptr (xor msk x) }

151 changes: 151 additions & 0 deletions src-test/Main.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,151 @@
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Copyright: © 2019-2020 Herbert Valerio Riedel
-- SPDX-License-Identifier: GPL-2.0-or-later
--
module Main (main) where

import Control.Monad
import Data.Bits
import Data.Int
import Data.Monoid (mempty)
import Data.Word
import qualified Foreign.Marshal as F
import qualified Foreign.Ptr as F
import Text.Printf (printf)

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Short as SBS

import qualified Test.QuickCheck.Monadic as QCM
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck as QC

import qualified Data.XOR as IUT

main :: IO ()
main = defaultMain tests

tests :: TestTree
tests = testGroup "Tests"
[ testGroup "hello"
[ testCase "REF" $ xor32StrictByteString'ref 0x37fa213d "\x7f\x9f\x4d\x51\x58" @?= "Hello"
, testCase "S.ByteString" $ IUT.xor32StrictByteString' 0x37fa213d "\x7f\x9f\x4d\x51\x58" @?= (0xfa213d37,"Hello")
, testCase "L.ByteString" $ IUT.xor32LazyByteString 0x37fa213d "\x7f\x9f\x4d\x51\x58" @?= "Hello"
, testCase "ShortByteString" $ IUT.xor32ShortByteString 0x37fa213d "\x7f\x9f\x4d\x51\x58" @?= "Hello"
]

, testGroup "empty"
[ testProperty "S.ByteString" $ \msk -> IUT.xor32StrictByteString msk mempty === Data.Monoid.mempty
, testProperty "L.ByteString" $ \msk -> IUT.xor32LazyByteString msk mempty === mempty
, testProperty "ShortByteString" $ \msk -> IUT.xor32ShortByteString msk mempty === mempty
]

, testGroup "zero-xor"
[ testProperty "S.ByteString" $ \xs -> let bs = BS.pack xs in IUT.xor32StrictByteString 0 bs === bs
, testProperty "L.ByteString" $ \xs -> let bs = BL.fromChunks (map BS.pack xs) in IUT.xor32LazyByteString 0 bs === BL.fromChunks [BS.pack (concat xs)]
, testProperty "ShortByteString" $ \xs -> let bs = SBS.pack xs in IUT.xor32ShortByteString 0 bs === bs
]

, testProperty "xor32Ptr" $ \msk lb len8 -> QCM.monadicIO $ do
let bufsize, ofs, len :: Int
bufsize = 2048
ofs = 512 + fromIntegral (lb :: Int8)
len = fromIntegral (len8 :: Word8)

QCM.run $ F.allocaBytes bufsize $ \bufptr -> do

origbuf <- BS.packCStringLen (bufptr, bufsize)

let (origbufPre, tmp) = BS.splitAt ofs origbuf
(origbufMid, origbufPost) = BS.splitAt len tmp

_ <- IUT.xor32CStringLen msk (F.castPtr bufptr `F.plusPtr` ofs,len)
newbufIut <- BS.packCStringLen (bufptr, bufsize)

let newbufRef = BS.concat [origbufPre, xor32StrictByteString'ref msk origbufMid, origbufPost]

unless (BS.length newbufRef == bufsize) $ fail "internal error"

unless (newbufRef == newbufIut) $ do
putStrLn $ show (msk,bufsize, ofs, len)
putStrLn $ "orig " ++ concatMap (printf "%02x") (BS.unpack origbuf)
putStrLn $ "ref " ++ concatMap (printf "%02x") (BS.unpack newbufRef)
putStrLn $ "iut " ++ concatMap (printf "%02x") (BS.unpack newbufIut)

forM_ (zip3 [0..] (BS.unpack newbufRef) (BS.unpack newbufIut)) $ \(j,ref8,iut8) ->
unless (ref8 == iut8) $
printf "%d (%d): %02x %02x\n" (j::Int) (j-ofs) ref8 iut8

return $! newbufRef == newbufIut

, testGroup "ref-vs-iut 32-bit"
[ testProperty "S.ByteString" $ \xs msk ->
let bs = BS.pack xs
in IUT.xor32StrictByteString msk bs === xor32StrictByteString'ref msk bs
, testProperty "L.ByteString" $ \xs msk ->
let bs = BL.fromChunks (map BS.pack xs)
bs' = BS.pack (concat xs)
in IUT.xor32LazyByteString msk bs === BL.fromStrict (xor32StrictByteString'ref msk bs')
, testProperty "ShortByteString" $ \xs msk ->
let bs = SBS.pack xs
in IUT.xor32ShortByteString msk bs === xor32ShortByteString'ref msk bs
]

, testGroup "ref-vs-iut 8-bit"
[ testProperty "S.ByteString" $ \xs msk ->
let bs = BS.pack xs
in IUT.xor8StrictByteString msk bs === xor8StrictByteString'ref msk bs
, testProperty "L.ByteString" $ \xs msk ->
let bs = BL.fromChunks (map BS.pack xs)
in IUT.xor8LazyByteString msk bs === xor8LazyByteString'ref msk bs
, testProperty "ShortByteString" $ \xs msk ->
let bs = SBS.pack xs
in IUT.xor8ShortByteString msk bs === xor8ShortByteString'ref msk bs
]

, testGroup "self-inverse"
[ testProperty "S.ByteString" $ \xs msk ->
let bs = BS.pack xs
in IUT.xor32StrictByteString msk (IUT.xor32StrictByteString msk bs) === bs
, testProperty "L.ByteString" $ \xs msk ->
let bs = BL.fromChunks (map BS.pack xs)
bs' = BL.fromChunks [BS.pack (concat xs)]
in IUT.xor32LazyByteString msk (IUT.xor32LazyByteString msk bs) === bs'
, testProperty "ShortByteString" $ \xs msk ->
let bs = SBS.pack xs
in IUT.xor32ShortByteString msk (IUT.xor32ShortByteString msk bs) === bs
]
]

xor32StrictByteString'ref :: Word32 -> BS.ByteString -> BS.ByteString
xor32StrictByteString'ref 0 = id
xor32StrictByteString'ref msk0 = snd . BS.mapAccumL go msk0
where
go :: Word32 -> Word8 -> (Word32,Word8)
go msk b = let b' = fromIntegral msk' `xor` b
msk' = rotateL msk 8
in b' `seq` (msk',b')

xor8StrictByteString'ref :: Word8 -> BS.ByteString -> BS.ByteString
xor8StrictByteString'ref 0 = id
xor8StrictByteString'ref msk0 = BS.map (xor msk0)

liftSBS :: (t -> BS.ByteString -> BS.ByteString) -> t -> SBS.ShortByteString -> SBS.ShortByteString
liftSBS op = \msk -> SBS.toShort . op msk . SBS.fromShort

liftBL :: (t -> BS.ByteString -> BS.ByteString) -> t -> BL.ByteString -> BL.ByteString
liftBL op = \msk -> BL.fromStrict . op msk . BL.toStrict

xor32ShortByteString'ref :: Word32 -> SBS.ShortByteString -> SBS.ShortByteString
xor32ShortByteString'ref = liftSBS xor32StrictByteString'ref

xor8ShortByteString'ref :: Word8 -> SBS.ShortByteString -> SBS.ShortByteString
xor8ShortByteString'ref = liftSBS xor8StrictByteString'ref

xor8LazyByteString'ref :: Word8 -> BL.ByteString -> BL.ByteString
xor8LazyByteString'ref = liftBL xor8StrictByteString'ref
Loading

0 comments on commit d36a688

Please sign in to comment.