diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +0.0.1 +===== + +* First public release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 Lars Kuhtz + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ +[![Build Status](https://travis-ci.org/larskuhtz/random-bytestring.svg)](https://travis-ci.org/larskuhtz/random-bytestring) + +# Efficient Random Haskell ByteStrings + +## Installation + +```sh +cabal install random-bytestring +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmark/Benchmarks.hs b/benchmark/Benchmarks.hs new file mode 100644 --- /dev/null +++ b/benchmark/Benchmarks.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE UnicodeSyntax #-} + +-- -------------------------------------------------------------------------- -- +-- | +-- Module: Benchmarks +-- Copyright: (c) Lars Kuhtz 2017 +-- License: MIT +-- Maintainer: lakuhtz@gmail.com +-- Stability: experimental +-- +-- -------------------------------------------------------------------------- -- + +module Benchmarks +( Impl(..) +, benchmarks +, largeBenchmarks +) where + +import Criterion +import Control.Concurrent.Async +import Data.ByteString +import Data.Monoid +import Numeric.Natural + +data Impl = Impl String (Natural → IO ByteString) + +benchmarks ∷ [Impl] → [Benchmark] +benchmarks impls = + [ bgroup "single-threaded" + [ singleThreaded impls 1024 + , singleThreaded impls (1024 * 1024) + ] + , bgroup "multi-threaded" + [ concurrent impls 10 1024 + , concurrent impls 10 (1024 * 1024) + ] + ] + +largeBenchmarks ∷ [Impl] → [Benchmark] +largeBenchmarks impls = + [ bgroup "single-threaded" + [ singleThreaded impls 1024 + , singleThreaded impls (1024 * 1024) + , singleThreaded impls (1024 * 1024 * 10) + , singleThreaded impls (1024 * 1024 * 100) + ] + , bgroup "multi-threaded" + [ concurrent impls 10 1024 + , concurrent impls 10 (1024 * 1024) + , concurrent impls 10 (1024 * 1024 * 10) + -- , concurrent impls 10 (1024 * 1024 * 100) + ] + ] + +concurrent ∷ [Impl] → Natural → Natural → Benchmark +concurrent impls c n = bgroup (show c <> "-" <> show n) + [ cgo label f | (Impl label f) ← impls ] + where + cgo s f = bench s $ nfIO $ + forConcurrently [0..(c-1)] (const $ f n) + +singleThreaded ∷ [Impl] → Natural → Benchmark +singleThreaded impls n = bgroup (show n) + [ bench label $ nfIO $ f n | (Impl label f) ← impls ] + diff --git a/benchmark/Implementations.hs b/benchmark/Implementations.hs new file mode 100644 --- /dev/null +++ b/benchmark/Implementations.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} + +-- -------------------------------------------------------------------------- -- +-- | +-- Module: Implementations +-- Copyright: (c) Lars Kuhtz 2017 +-- License: MIT +-- Maintainer: lakuhtz@gmail.com +-- Stability: experimental +-- +-- -------------------------------------------------------------------------- -- + +module Implementations +( allImplementations + +, random +, entropy +, mwcUnfoldr +, mwcUnfoldrIO + +-- +, mwcMalloc8 +, mwcMalloc32 +, mwcMalloc64 +) where + +import Control.Exception (bracketOnError) +import Control.Monad.Primitive + +import Data.ByteString (ByteString, pack, unfoldrN) +import Data.ByteString.Unsafe (unsafePackAddressLen) +import Data.Word (Word8, Word32, Word64) + +import Foreign (mallocBytes, poke, plusPtr, free, castPtr) + +import GHC.Prim +import GHC.Ptr (Ptr(..)) + +import Numeric.Natural + +import System.Entropy (getEntropy) +import System.Random (randoms, getStdGen) +import System.Random.MWC (uniform, create, Gen) + +import Benchmarks + +-- -------------------------------------------------------------------------- -- +-- All Implemenations + +allImplementations ∷ [Impl] +allImplementations = + [ Impl "random" random + , Impl "entropy" entropy + , Impl "mwc-unfoldr" mwcUnfoldr + , Impl "mwc-unfoldr-io" mwcUnfoldrIO + , Impl "mwc-malloc-8" mwcMalloc8 + , Impl "mwc-malloc-32" mwcMalloc32 + , Impl "mwc-malloc-64" mwcMalloc64 + ] + +-- -------------------------------------------------------------------------- -- +-- Basic + +random ∷ Natural → IO ByteString +random n = (pack . take (fromIntegral n) . randoms) <$> getStdGen + +-- -------------------------------------------------------------------------- -- +-- entropy + +entropy ∷ Natural → IO ByteString +entropy n = getEntropy (fromIntegral n) + +-- -------------------------------------------------------------------------- -- +-- Malloc8 + +mwcMalloc8 ∷ Natural → IO ByteString +mwcMalloc8 n = do + !gen ← create + bracketOnError (mallocBytes len) free $ \ptr@(Ptr !addr) → do + go gen ptr + unsafePackAddressLen len addr + + where + len ∷ Int + !len = fromIntegral n + + go !gen !ptr = loop 0 + where + loop !i + | i == pred len = return () + | otherwise = do + !b ← uniform gen ∷ IO Word8 + poke (ptr `plusPtr` i) b + loop (succ i) + +-- -------------------------------------------------------------------------- -- +-- Malloc32 + +mwcMalloc32 ∷ Natural → IO ByteString +mwcMalloc32 n = do + !gen ← create + bracketOnError (mallocBytes len8) free $ \ptr@(Ptr !addr) → do + go gen ptr + unsafePackAddressLen len8 addr + where + len8, len32 ∷ Int + !len8 = fromIntegral n + !len32 = len8 `div` 4 + + go !gen !startPtr = loop32 startPtr + where + !fin32Ptr = startPtr `plusPtr` (len32 * 4) + loop32 !curPtr + | curPtr < fin32Ptr = do + !b ← uniform gen ∷ IO Word32 + poke curPtr b + loop32 $ curPtr `plusPtr` 4 + | otherwise = loop8 $ castPtr curPtr + + !fin8Ptr = startPtr `plusPtr` len8 + loop8 !curPtr + | curPtr < fin8Ptr = do + !b ← uniform gen ∷ IO Word8 + poke curPtr b + loop8 $ curPtr `plusPtr` 1 + | otherwise = return () + + +-- -------------------------------------------------------------------------- -- +-- Malloc64 + +mwcMalloc64 ∷ Natural → IO ByteString +mwcMalloc64 n = do + !gen ← create + bracketOnError (mallocBytes len8) free $ \ptr@(Ptr !addr) → do + go gen ptr + unsafePackAddressLen len8 addr + where + len8, len64 ∷ Int + !len8 = fromIntegral n + !len64 = len8 `div` 8 + + go ∷ Gen (PrimState IO) → Ptr Word64 → IO () + go !gen !startPtr = loop64 startPtr + where + fin64Ptr ∷ Ptr Word64 + !fin64Ptr = startPtr `plusPtr` (len64 * 8) + + loop64 ∷ Ptr Word64 → IO () + loop64 !curPtr + | curPtr < fin64Ptr = do + !b ← uniform gen ∷ IO Word64 + poke curPtr b + loop64 $ curPtr `plusPtr` 8 + | otherwise = loop8 $ castPtr curPtr + + fin8Ptr ∷ Ptr Word8 + !fin8Ptr = startPtr `plusPtr` len8 + + loop8 ∷ Ptr Word8 → IO () + loop8 !curPtr + | curPtr < fin8Ptr = do + !b ← uniform gen ∷ IO Word8 + poke curPtr b + loop8 $ curPtr `plusPtr` 1 + | otherwise = return () + +-- -------------------------------------------------------------------------- -- +-- unfoldrN, PrimMonad + +data Box m = Box !(State# (PrimState m)) + +mwcUnfoldr ∷ ∀ m . (PrimMonad m, PrimBase m) ⇒ Natural → m ByteString +mwcUnfoldr n = do + !gen ← create + primitive $ go gen + where + go + ∷ Gen (PrimState m) + → State# (PrimState m) + → (# State# (PrimState m), ByteString #) + go !gen !st = + let !(!b, Just (Box !st')) = unfoldrN (fromIntegral n) (step gen) (Box st) + in (# st', b #) + + step + ∷ Gen (PrimState m) + → Box m + → Maybe (Word8, Box m) + step !gen (Box !s) = + let (# !s', !b #) = internal (uniform gen ∷ m Word8) s + in Just (b, Box s') + +-- -------------------------------------------------------------------------- -- +-- unfoldrN, IO + +mwcUnfoldrIO ∷ Natural → IO ByteString +mwcUnfoldrIO n = do + !gen ← create + primitive $ go gen + where + go + ∷ Gen (PrimState IO) + → State# (PrimState IO) + → (# State# (PrimState IO), ByteString #) + go !gen !st = + let !(!b, Just (Box !st')) = unfoldrN (fromIntegral n) (step gen) (Box st) + in (# st', b #) + + step + ∷ Gen (PrimState IO) + → Box IO + → Maybe (Word8, Box IO) + step !gen (Box !s) = + let (# !s', !b #) = internal (uniform gen ∷ IO Word8) s + in Just (b, Box s') + diff --git a/benchmark/benchmark-compare.hs b/benchmark/benchmark-compare.hs new file mode 100644 --- /dev/null +++ b/benchmark/benchmark-compare.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UnicodeSyntax #-} + +-- -------------------------------------------------------------------------- -- +-- | +-- Module: Main +-- Copyright: (c) Lars Kuhtz 2017 +-- License: MIT +-- Maintainer: lakuhtz@gmail.com +-- Stability: experimental +-- +-- -------------------------------------------------------------------------- -- + +module Main +( main +) where + +import Benchmarks +import Criterion.Main +import Implementations + +main ∷ IO () +main = defaultMain $ benchmarks allImplementations + diff --git a/benchmark/benchmark.hs b/benchmark/benchmark.hs new file mode 100644 --- /dev/null +++ b/benchmark/benchmark.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UnicodeSyntax #-} + +-- -------------------------------------------------------------------------- -- +-- | +-- Module: Main +-- Copyright: (c) Lars Kuhtz 2017 +-- License: MIT +-- Maintainer: lakuhtz@gmail.com +-- Stability: experimental +-- +-- -------------------------------------------------------------------------- -- + +module Main +( main +) where + +import Benchmarks +import Criterion.Main +import Data.ByteString.Random + +main ∷ IO () +main = defaultMain $ largeBenchmarks [Impl "Data.ByteString.Random" random] + diff --git a/benchmark/eventlog-compare.hs b/benchmark/eventlog-compare.hs new file mode 100644 --- /dev/null +++ b/benchmark/eventlog-compare.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE BangPatterns #-} + +-- -------------------------------------------------------------------------- -- +-- | +-- Module: Main +-- Copyright: (c) Lars Kuhtz 2017 +-- License: MIT +-- Maintainer: lakuhtz@gmail.com +-- Stability: experimental +-- +-- -------------------------------------------------------------------------- -- + +module Main +( main +) where + +import Control.Concurrent + +import Benchmarks +import Implementations + +main ∷ IO () +main = mapM_ run allImplementations + where + run (Impl label act) = do + putStrLn label + !_ ← act $ 1024 * 1024 * 5 + threadDelay 500000 + return () + + diff --git a/random-bytestring.cabal b/random-bytestring.cabal new file mode 100644 --- /dev/null +++ b/random-bytestring.cabal @@ -0,0 +1,108 @@ +Name: random-bytestring +Version: 0.0.1 +Synopsis: Efficient generation of random bytestrings +Description: + Efficient generation of random bytestrings +Homepage: https://www.github.com/larskuhtz/random-bytestring +License: MIT +Author: Lars Kuhtz +Maintainer: Lars Kuhtz +Copyright: Copyright (c) 2017 Lars Kuhtz +Category: System +Build-type: Simple +Cabal-version: >= 1.18 +Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.2 +License-file: LICENSE + +extra-doc-files: + README.md, + CHANGELOG.md + +source-repository head + type: git + location: https://www.github.com/larskuhtz/random-bytestring + +Library + default-language: Haskell2010 + hs-source-dirs: src + + exposed-modules: + Data.ByteString.Random + + build-depends: + base >= 4.7 && < 4.10 && < 4.10, + bytestring >= 0.10, + mwc-random >= 0.13 + + if impl(ghc < 7.10) + build-depends: + nats >= 1.1 + + ghc-options: -Wall + +Benchmark benchmark + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: benchmark.hs + hs-source-dirs: benchmark + ghc-options: -Wall -O2 -threaded -with-rtsopts=-N -rtsopts + build-depends: + random-bytestring, + async >= 2.1, + base >= 4.7 && < 4.10, + bytestring >= 0.10, + criterion >= 1.1 + + if impl(ghc < 7.10) + build-depends: + nats >= 1.1 + + other-modules: + Benchmarks + +Benchmark benchmark-compare + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: benchmark-compare.hs + hs-source-dirs: benchmark + ghc-options: -Wall -O2 -threaded -with-rtsopts=-N -rtsopts + build-depends: + random-bytestring, + async >= 2.1, + base >= 4.7 && < 4.10, + bytestring >= 0.10, + criterion >= 1.1, + entropy >= 0.3, + ghc-prim >= 0.3, + mwc-random >= 0.13, + primitive >= 0.6, + random >= 1.1 + + if impl(ghc < 7.10) + build-depends: + nats >= 1.1 + + other-modules: + Benchmarks, + Implementations + +Benchmark eventlog-compare + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: eventlog-compare.hs + hs-source-dirs: benchmark + ghc-options: -Wall -O2 -threaded -with-rtsopts=-N -rtsopts -eventlog + build-depends: + random-bytestring, + async >= 2.1, + base >= 4.7 && < 4.10, + bytestring >= 0.10, + criterion >= 1.1, + entropy >= 0.3, + ghc-prim >= 0.3, + mwc-random >= 0.13, + primitive >= 0.6, + random >= 1.1 + other-modules: + Benchmarks, + Implementations diff --git a/src/Data/ByteString/Random.hs b/src/Data/ByteString/Random.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Random.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE BangPatterns #-} + +-- -------------------------------------------------------------------------- -- +-- | +-- Module: Data.ByteString.Random +-- Copyright: (c) Lars Kuhtz 2017 +-- License: MIT +-- Maintainer: lakuhtz@gmail.com +-- Stability: experimental +-- +-- -------------------------------------------------------------------------- -- + +module Data.ByteString.Random +( random +, randomGen +) where + +import Control.Exception (bracketOnError) + +import Data.ByteString (ByteString) +import Data.ByteString.Unsafe (unsafePackAddressLen) +import Data.Word (Word8, Word64) + +import Foreign (mallocBytes, poke, plusPtr, free, castPtr) + +import GHC.Ptr (Ptr(..)) + +import Numeric.Natural (Natural) + +import System.Random.MWC (uniform, GenIO, create) + +random ∷ Natural → IO ByteString +random n = do + gen ← create + randomGen gen n + +randomGen ∷ GenIO → Natural → IO ByteString +randomGen gen n = + bracketOnError (mallocBytes len8) free $ \ptr@(Ptr !addr) → do + {-# SCC "go" #-} go ptr + {-# SCC "pack" #-} unsafePackAddressLen len8 addr + where + len8, len64 ∷ Int + !len8 = fromIntegral n + !len64 = len8 `div` 8 + + go ∷ Ptr Word64 → IO () + go !startPtr = loop64 startPtr + where + -- Would it help to add more manual unrolling levels? + -- How smart is the compiler about unrolling loops? + + -- Generate 64bit values + fin64Ptr ∷ Ptr Word64 + !fin64Ptr = startPtr `plusPtr` (len64 * 8) + + loop64 ∷ Ptr Word64 → IO () + loop64 !curPtr + | curPtr < fin64Ptr = {-# SCC "loop64" #-} do + !b ← uniform gen ∷ IO Word64 + {-# SCC "poke64" #-} poke curPtr b + loop64 $ {-# SCC "ptr_inc" #-} curPtr `plusPtr` 8 + | otherwise = loop8 $ castPtr curPtr + + -- Generate 8bit values + fin8Ptr ∷ Ptr Word8 + !fin8Ptr = startPtr `plusPtr` len8 + + loop8 ∷ Ptr Word8 → IO () + loop8 !curPtr + | curPtr < fin8Ptr = {-# SCC "loop8" #-} do + !b ← uniform gen ∷ IO Word8 + poke curPtr b + loop8 $ curPtr `plusPtr` 1 + | otherwise = return () +