Commit 7c4fe524 authored by Khudyakov's avatar Khudyakov
Browse files

Merge branch 'master' into signed-int

parents 03332c47 8429d6b4
......@@ -3,6 +3,7 @@
*.p_hi
*.prof
*.tix
*.swp
.hpc/
/benchmarks/bench
/benchmarks/builder
......@@ -12,4 +13,5 @@ GNUmakefile
dist-boot
dist-install
ghc.mk
.cabal-sandbox
\ No newline at end of file
.cabal-sandbox
cabal.sandbox.config
......@@ -3,3 +3,5 @@ syntax: glob
.*.swp
*~
\#*
.cabal-sandbox
cabal.sandbox.config
# See https://github.com/hvr/multi-ghc-travis for more information
language: c
sudo: false
matrix:
include:
- env: CABALVER=1.18 GHCVER=7.4.2
addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}}
- env: CABALVER=1.18 GHCVER=7.6.3
addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}
- env: CABALVER=1.18 GHCVER=7.8.4
addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
- env: CABALVER=1.22 GHCVER=7.10.2
addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
- env: CABALVER=head GHCVER=head
addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}}
allow_failures:
- env: CABALVER=head GHCVER=head
before_install:
- export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
install:
- cabal --version
- travis_retry cabal update
# workaround for https://ghc.haskell.org/trac/ghc/ticket/9221
- sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
- cabal sandbox init
# can't use "cabal install --only-dependencies --enable-tests --enable-benchmarks" due to dep-cycle
- cabal install criterion deepseq mtl "QuickCheck >= 2.8" HUnit "test-framework-quickcheck2 >= 0.3" "random >= 1.0.1.0" attoparsec cereal 'Cabal == 1.22.*' tar zlib -j
script:
- cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options=-fno-spec-constr
- cabal build
- cabal test
# "cabal check" disabled due to -O2 warning
# - cabal check
- cabal sdist
# check that the generated source-distribution can be built & installed
- export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;
cd dist/;
cabal sandbox init;
if [ -f "$SRC_TGZ" ]; then
cabal install --force-reinstalls "$SRC_TGZ";
else
echo "expected '$SRC_TGZ' not found";
exit 1;
fi
notifications:
email:
- kolmodin@gmail.com
# binary package #
[![Build Status](https://api.travis-ci.org/kolmodin/binary.png?branch=master)](http://travis-ci.org/kolmodin/binary)
*Efficient, pure binary serialisation using lazy ByteStrings.*
The ``binary`` package provides Data.Binary, containing the Binary class,
......@@ -52,42 +54,22 @@ the ``Get`` and ``Put`` monads.
More information in the haddock documentation.
## Deriving binary instances ##
It is possible to mechanically derive new instances of Binary for your
types, if they support the Data and Typeable classes. A script is
provided in tools/derive. Here's an example of its use.
$ cd binary
$ cd tools/derive
$ ghci -fglasgow-exts BinaryDerive.hs
*BinaryDerive> :l Example.hs
*Main> deriveM (undefined :: Exp)
instance Binary Main.Exp where
put (ExpOr a b) = putWord8 0 >> put a >> put b
put (ExpAnd a b) = putWord8 1 >> put a >> put b
put (ExpEq a b) = putWord8 2 >> put a >> put b
put (ExpNEq a b) = putWord8 3 >> put a >> put b
put (ExpAdd a b) = putWord8 4 >> put a >> put b
put (ExpSub a b) = putWord8 5 >> put a >> put b
put (ExpVar a) = putWord8 6 >> put a
put (ExpInt a) = putWord8 7 >> put a
get = do
tag_ <- getWord8
case tag_ of
0 -> get >>= \a -> get >>= \b -> return (ExpOr a b)
1 -> get >>= \a -> get >>= \b -> return (ExpAnd a b)
2 -> get >>= \a -> get >>= \b -> return (ExpEq a b)
3 -> get >>= \a -> get >>= \b -> return (ExpNEq a b)
4 -> get >>= \a -> get >>= \b -> return (ExpAdd a b)
5 -> get >>= \a -> get >>= \b -> return (ExpSub a b)
6 -> get >>= \a -> return (ExpVar a)
7 -> get >>= \a -> return (ExpInt a)
_ -> fail "no decoding"
## Deriving binary instances using GHC's Generic ##
Beginning with GHC 7.2, it is possible to use binary serialization without
writing any instance boilerplate code.
```haskell
{-# LANGUAGE DeriveGeneric #-}
import Data.Binary
import GHC.Generics (Generic)
data Foo = Foo deriving (Generic)
-- GHC will automatically fill out the instance
instance Binary Foo
```
## Contributors ##
......@@ -106,3 +88,6 @@ provided in tools/derive. Here's an example of its use.
* Bryan O'Sullivan
* Bas van Dijk
* Florian Weimer
For a full list of contributors, see
[here](https://github.com/kolmodin/binary/graphs/contributors).
......@@ -6,22 +6,25 @@
module Main (main) where
#if ! MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid(mappend, mempty))
#endif
import Control.DeepSeq
import Control.Exception (evaluate)
import Control.Monad.Trans (liftIO)
import Criterion.Config
import Criterion.Main hiding (run)
import Criterion.Main
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import Data.Char (ord)
import Data.Monoid (Monoid(mappend, mempty))
import Data.Word (Word8)
import Data.Binary.Builder
#if __GLASGOW_HASKELL__ < 706
#if !MIN_VERSION_bytestring(0,10,0)
instance NFData S.ByteString
instance NFData L.ByteString where
rnf = rnf . L.toChunks
#endif
main :: IO ()
......@@ -83,7 +86,7 @@ from4Word8s (x:xs) = singleton x <> singleton x <> singleton x <> singleton x <>
-- Write 100 short, length-prefixed ByteStrings.
lengthPrefixedBS :: S.ByteString -> Builder
lengthPrefixedBS bs = loop 100
lengthPrefixedBS bs = loop (100 :: Int)
where loop n | n `seq` False = undefined
loop 0 = mempty
loop n =
......
{-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns #-}
module Main where
import qualified Data.ByteString.Lazy as L
import Distribution.PackageDescription
import Criterion.Main
import qualified Data.Binary as Binary
import Data.Binary.Get (Get)
import qualified Data.Binary.Get as Binary
import GenericsBenchCache
main :: IO ()
main = benchmark =<< readPackageDescriptionCache 100
benchmark :: [PackageDescription] -> IO ()
benchmark pds = do
let lbs = encode pds
!_ = L.length lbs
str = show pds
!_ = length str
defaultMain [
bench "encode" (nf encode pds)
, bench "decode" (nf decode lbs)
, bench "decode null" (nf decodeNull lbs)
, bgroup "embarrassment" [
bench "read" (nf readPackageDescription str)
, bench "show" (nf show pds)
]
]
encode :: [PackageDescription] -> L.ByteString
encode = Binary.encode
decode :: L.ByteString -> Int
decode = length . (Binary.decode :: L.ByteString -> [PackageDescription])
decodeNull :: L.ByteString -> ()
decodeNull =
Binary.runGet $ do
n <- Binary.get :: Get Int
go n
where
go 0 = return ()
go i = do
x <- Binary.get :: Get PackageDescription
x `seq` go (i-1)
readPackageDescription :: String -> Int
readPackageDescription = length . (read :: String -> [PackageDescription])
{-# LANGUAGE DeriveGeneric, StandaloneDeriving, BangPatterns, CPP #-}
module GenericsBenchCache (readPackageDescriptionCache) where
import qualified Text.ParserCombinators.ReadP as Read
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC8
import Data.Version (parseVersion)
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
import Distribution.PackageDescription.Parse
import Distribution.Version (Version)
import qualified Codec.Archive.Tar as Tar
import qualified Codec.Compression.GZip as GZip
import qualified Data.HashMap.Lazy as Map
import System.Directory
import System.Exit
import GenericsBenchTypes ()
#if ! MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
readTar :: String -> Int -> IO [PackageDescription]
readTar tarPath limit = do
entries <- Tar.read . GZip.decompress <$> L.readFile tarPath
let contents = Tar.foldEntries unpack [] (error "tar error") entries
let !pkgs = Map.fromListWith pick
[ (pkg, (version, content))
| (path, content) <- contents
, Just (pkg, version) <- return (readFilePath path) ]
return $ take limit [ flattenPackageDescription gpd
| (_, (_, content)) <- Map.toList pkgs
, ParseOk _warns gpd <- return (parsePackageDescription (LC8.unpack content)) ]
where
pick (v,a) (w,b) | v >= w = (v,a)
| otherwise = (w,b)
unpack e acc =
case Tar.entryContent e of
Tar.NormalFile content _ -> (Tar.entryPath e, content):acc
_ -> acc
readFilePath :: String -> Maybe (String, Version)
readFilePath str = extract (Read.readP_to_S parse str)
where
extract [(result,_)] = Just result
extract _ = Nothing
parse = do
packageName <- Read.many1 (Read.satisfy (/='/'))
_ <- Read.char '/'
version <- parseVersion
_ <- Read.char '/'
return (packageName, version)
writePackageDescriptionCache :: String -> [PackageDescription] -> IO ()
writePackageDescriptionCache path = writeFile path . show
readPackageDescriptionCache :: Int -> IO [PackageDescription]
readPackageDescriptionCache amount = do
let cacheFilePath' = cacheFilePath ++ "-" ++ (show amount)
createPackageDescriptionCache cacheFilePath' amount
pds <- read <$> readFile cacheFilePath'
-- PackageDescription doesn't implement NFData, let's force with the following line
(length (show pds)) `seq` return pds
cacheFilePath :: String
cacheFilePath = "generics-bench.cache"
createPackageDescriptionCache :: String -> Int -> IO ()
createPackageDescriptionCache path amount = do
cacheExists <- doesFileExist path
if cacheExists
then putStrLn "reusing cache from previous run"
else do
putStr "creating cabal cache file... "
tarFilePath <- (++"/.cabal/packages/hackage.haskell.org/00-index.tar.gz") <$> getHomeDirectory
fileExists <- doesFileExist tarFilePath
if fileExists
then do
pds <- readTar tarFilePath amount
writePackageDescriptionCache path pds
putStrLn "done"
else do
putStrLn (tarFilePath ++ " missing, aborting")
exitFailure
{-# LANGUAGE DeriveGeneric, StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GenericsBenchTypes where
import Distribution.Compiler
import Distribution.License
import Distribution.ModuleName hiding (main)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Version
import Language.Haskell.Extension
import GHC.Generics (Generic)
import Data.Binary
deriving instance Generic Version
instance Binary Benchmark
instance Binary BenchmarkInterface
instance Binary BenchmarkType
instance Binary BuildInfo
instance Binary BuildType
instance Binary CompilerFlavor
instance Binary Dependency
instance Binary Executable
instance Binary Extension
instance Binary FlagName
instance Binary KnownExtension
instance Binary Language
instance Binary Library
instance Binary License
instance Binary ModuleName
instance Binary ModuleReexport
instance Binary ModuleRenaming
instance Binary PackageDescription
instance Binary PackageIdentifier
instance Binary PackageName
instance Binary RepoKind
instance Binary RepoType
instance Binary SourceRepo
instance Binary TestSuite
instance Binary TestSuiteInterface
instance Binary TestType
instance Binary VersionRange
......@@ -8,22 +8,19 @@ module Main where
import Control.DeepSeq
import Control.Exception (evaluate)
import Control.Monad.Trans (liftIO)
import Criterion.Config
import Criterion.Main hiding (run)
import Criterion.Main
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as L
import Data.Bits
import Data.Char (ord)
import Data.Monoid (Monoid(mappend, mempty))
import Data.Word (Word8, Word16, Word32)
import Data.List (foldl')
import Control.Applicative
import Data.Binary
import Data.Binary.Get
import Data.Binary ( get )
import qualified Data.Serialize.Get as Cereal
import qualified Data.Serialize as Cereal
import qualified Data.Attoparsec.ByteString as A
import qualified Data.Attoparsec.ByteString.Lazy as AL
......@@ -41,62 +38,88 @@ main = do
rnf bracketsInChunks,
rnf bracketCount,
rnf oneMegabyte,
rnf oneMegabyteLBS
rnf oneMegabyteLBS,
rnf manyBytes,
rnf encodedBigInteger
]
defaultMain
[
bench "brackets 100kb one chunk input" $
whnf (checkBracket . runTest bracketParser) brackets
, bench "brackets 100kb in 100 byte chunks" $
whnf (checkBracket . runTest bracketParser) bracketsInChunks
, bench "Attoparsec lazy-bs brackets 100kb one chunk" $
whnf (checkBracket . runAttoL bracketParser_atto) brackets
, bench "Attoparsec lazy-bs brackets 100kb in 100 byte chunks" $
whnf (checkBracket . runAttoL bracketParser_atto) bracketsInChunks
, bench "Attoparsec strict-bs brackets 100kb" $
whnf (checkBracket . runAtto bracketParser_atto) $ S.concat (L.toChunks brackets)
, bench "Cereal strict-bs brackets 100kb" $
whnf (checkBracket . runCereal bracketParser_cereal) $ S.concat (L.toChunks brackets)
, bench "Binary getStruct4 1MB struct of 4 word8" $
whnf (runTest (getStruct4 mega)) oneMegabyteLBS
, bench "Cereal getStruct4 1MB struct of 4 word8" $
whnf (runCereal (getStruct4_cereal mega)) oneMegabyte
, bench "Attoparsec getStruct4 1MB struct of 4 word8" $
whnf (runAtto (getStruct4_atto mega)) oneMegabyte
, bench "Binary getWord8 1MB chunk size 1 byte" $
whnf (runTest (getWord8N1 mega)) oneMegabyteLBS
, bench "Cereal getWord8 1MB chunk size 1 byte" $
whnf (runCereal (getWord8N1_cereal mega)) oneMegabyte
, bench "Attoparsec getWord8 1MB chunk size 1 byte" $
whnf (runAtto (getWord8N1_atto mega)) oneMegabyte
, bench "getWord8 1MB chunk size 2 bytes" $
whnf (runTest (getWord8N2 mega)) oneMegabyteLBS
, bench "getWord8 1MB chunk size 4 bytes" $
whnf (runTest (getWord8N4 mega)) oneMegabyteLBS
, bench "getWord8 1MB chunk size 8 bytes" $
whnf (runTest (getWord8N8 mega)) oneMegabyteLBS
, bench "getWord8 1MB chunk size 16 bytes" $
whnf (runTest (getWord8N16 mega)) oneMegabyteLBS
, bench "getWord8 1MB chunk size 2 bytes Applicative" $
whnf (runTest (getWord8N2A mega)) oneMegabyteLBS
, bench "getWord8 1MB chunk size 4 bytes Applicative" $
whnf (runTest (getWord8N4A mega)) oneMegabyteLBS
, bench "getWord8 1MB chunk size 8 bytes Applicative" $
whnf (runTest (getWord8N8A mega)) oneMegabyteLBS
, bench "getWord8 1MB chunk size 16 bytes Applicative" $
whnf (runTest (getWord8N16A mega)) oneMegabyteLBS
[ bgroup "brackets"
[ bench "Binary 100kb, one chunk" $
whnf (checkBracket . runTest bracketParser) brackets
, bench "Binary 100kb, 100 byte chunks" $
whnf (checkBracket . runTest bracketParser) bracketsInChunks
, bench "Attoparsec lazy-bs 100kb, one chunk" $
whnf (checkBracket . runAttoL bracketParser_atto) brackets
, bench "Attoparsec lazy-bs 100kb, 100 byte chunks" $
whnf (checkBracket . runAttoL bracketParser_atto) bracketsInChunks
, bench "Attoparsec strict-bs 100kb" $
whnf (checkBracket . runAtto bracketParser_atto) $ S.concat (L.toChunks brackets)
, bench "Cereal strict-bs 100kb" $
whnf (checkBracket . runCereal bracketParser_cereal) $ S.concat (L.toChunks brackets)
]
, bgroup "comparison getStruct4, 1MB of struct of 4 Word8s"
[ bench "Attoparsec" $
whnf (runAtto (getStruct4_atto mega)) oneMegabyte
, bench "Binary" $
whnf (runTest (getStruct4 mega)) oneMegabyteLBS
, bench "Cereal" $
whnf (runCereal (getStruct4_cereal mega)) oneMegabyte
]
, bgroup "comparison getWord8, 1MB"
[ bench "Attoparsec" $
whnf (runAtto (getWord8N1_atto mega)) oneMegabyte
, bench "Binary" $
whnf (runTest (getWord8N1 mega)) oneMegabyteLBS
, bench "Cereal" $
whnf (runCereal (getWord8N1_cereal mega)) oneMegabyte
]
, bgroup "getWord8 1MB"
[ bench "chunk size 2 bytes" $
whnf (runTest (getWord8N2 mega)) oneMegabyteLBS
, bench "chunk size 4 bytes" $
whnf (runTest (getWord8N4 mega)) oneMegabyteLBS
, bench "chunk size 8 bytes" $
whnf (runTest (getWord8N8 mega)) oneMegabyteLBS
, bench "chunk size 16 bytes" $
whnf (runTest (getWord8N16 mega)) oneMegabyteLBS
]
, bgroup "getWord8 1MB Applicative"
[ bench "chunk size 2 bytes" $
whnf (runTest (getWord8N2A mega)) oneMegabyteLBS
, bench "chunk size 4 bytes" $
whnf (runTest (getWord8N4A mega)) oneMegabyteLBS
, bench "chunk size 8 bytes" $
whnf (runTest (getWord8N8A mega)) oneMegabyteLBS
, bench "chunk size 16 bytes" $
whnf (runTest (getWord8N16A mega)) oneMegabyteLBS
]
, bgroup "roll"
[ bench "foldr" $ nf (roll_foldr :: [Word8] -> Integer) manyBytes
, bench "foldl'" $ nf (roll_foldl' :: [Word8] -> Integer) manyBytes
]
, bgroup "Integer"
[ bench "decode" $ nf (decode :: L.ByteString -> Integer) encodedBigInteger
]
]
checkBracket :: Int -> Int
checkBracket x | x == bracketCount = x
| otherwise = error "argh!"
runTest :: Get a -> L.ByteString -> a
runTest decoder inp = runGet decoder inp
runCereal :: Cereal.Get a -> C8.ByteString -> a
runCereal decoder inp = case Cereal.runGet decoder inp of
Right a -> a
Left err -> error err
runAtto :: AL.Parser a -> C8.ByteString -> a
runAtto decoder inp = case A.parseOnly decoder inp of
Right a -> a
Left err -> error err
runAttoL :: Show a => AL.Parser a -> L.ByteString -> a
runAttoL decoder inp = case AL.parse decoder inp of
AL.Done _ r -> r
a -> error (show a)
......@@ -109,15 +132,20 @@ oneMegabyte = S.replicate mega $ fromIntegral $ ord 'a'
oneMegabyteLBS :: L.ByteString
oneMegabyteLBS = L.fromChunks [oneMegabyte]
mega :: Int
mega = 1024 * 1024
-- 100k of brackets
bracketTest :: L.ByteString -> Int
bracketTest inp = runTest bracketParser inp
bracketCount :: Int
bracketCount = fromIntegral $ L.length brackets `div` 2
brackets :: L.ByteString
brackets = L.fromChunks [C8.concat (L.toChunks bracketsInChunks)]
bracketsInChunks :: L.ByteString
bracketsInChunks = L.fromChunks (replicate chunksOfBrackets oneChunk)
where
oneChunk = "((()((()()))((()(()()()()()()()(((()()()()(()()(()(()())))))()((())())))()())(((())())(()))))()(()))"
......@@ -144,19 +172,23 @@ bracketParser_cereal = cont <|> return 0
bracketParser_atto :: A.Parser Int
bracketParser_atto = cont <|> return 0
where
cont = do v <- some ( do A.word8 40
cont = do v <- some ( do _ <- A.word8 40
n <- bracketParser_atto
A.word8 41
_ <- A.word8 41
return $! n + 1)
return $! sum v
-- Strict struct of 4 Word8s
data Struct4 = Struct4 {-# UNPACK #-} !Word8
{-# UNPACK #-} !Word8
{-# UNPACK #-} !Word8
{-# UNPACK #-} !Word8
deriving Show
data S2 = S2 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
data S4 = S4 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
data S8 = S8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
{-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
data S16 = S16 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
{-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
{-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
{-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8
getStruct4 :: Int -> Get [S4]
getStruct4 = loop []
where loop acc 0 = return acc
loop acc n = do
......@@ -164,9 +196,10 @@ getStruct4 = loop []
!w1 <- getWord8
!w2 <- getWord8
!w3 <- getWord8
let !s = Struct4 w0 w1 w2 w3
let !s = S4 w0 w1 w2 w3
loop (s : acc) (n - 4)
getStruct4_cereal :: Int -> Cereal.Get [S4]
getStruct4_cereal = loop []
where loop acc 0 = return acc
loop acc n = do
......@@ -174,9 +207,10 @@ getStruct4_cereal = loop []
!w1 <- Cereal.getWord8
!w2 <- Cereal.getWord8
!w3 <- Cereal.getWord8
let !s = Struct4 w0 w1 w2 w3
let !s = S4 w0 w1 w2 w3
loop (s : acc) (n - 4)
getStruct4_atto :: Int -> A.Parser [S4]
getStruct4_atto = loop []
where loop acc 0 = return acc
loop acc n = do
......@@ -184,48 +218,53 @@ getStruct4_atto = loop []
!w1 <- A.anyWord8
!w2 <- A.anyWord8
!w3 <- A.anyWord8
let !s = Struct4 w0 w1 w2 w3
let !s = S4 w0 w1 w2 w3
loop (s : acc) (n - 4)