diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Criterion.Main +import Data.Monoid +import Data.Word +import Foreign +import HaskellWorks.Data.FromForeignRegion + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI +import qualified Data.Vector.Storable as DVS +import qualified System.IO as IO +import qualified System.IO.MMap as IO + +setupEnvByteString :: FilePath -> IO BS.ByteString +setupEnvByteString filepath = do + (fptr :: ForeignPtr Word8, offset, size) <- IO.mmapFileForeignPtr filepath IO.ReadOnly Nothing + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + return bs + +mmapVectorLike :: FromForeignRegion a => FilePath -> IO a +mmapVectorLike filePath = do + region <- IO.mmapFileForeignPtr filePath IO.ReadOnly Nothing + let !bs = fromForeignRegion region + return bs + +sumFileByteString :: FilePath -> IO () +sumFileByteString filePath = do + !(bs :: BS.ByteString) <- mmapVectorLike filePath + IO.hPutStrLn IO.stderr $ "Length ByteString: " <> show (BS.length bs) + let !_ = BS.foldl' (+) 0 bs + return () + +sumFileVectorWord64 :: FilePath -> IO () +sumFileVectorWord64 filePath = do + !(v :: DVS.Vector Word64) <- mmapVectorLike filePath + IO.hPutStrLn IO.stderr $ "Length Vector: " <> show (DVS.length v) + let !_ = DVS.foldl' (+) 0 v + return () + +benchRankJson40Conduits :: [Benchmark] +benchRankJson40Conduits = + [ env (return ()) $ \_ -> bgroup "medium.csv" + [ bench "Foldl' over ByteString" (whnfIO (sumFileByteString "corpus/medium.csv")) + , bench "Foldl' over Vector Word64" (whnfIO (sumFileVectorWord64 "corpus/medium.csv")) + ] + ] + +main :: IO () +main = defaultMain benchRankJson40Conduits diff --git a/hw-prim.cabal b/hw-prim.cabal --- a/hw-prim.cabal +++ b/hw-prim.cabal @@ -1,68 +1,111 @@ -name: hw-prim -version: 0.4.0.5 -synopsis: Primitive functions and data types -description: Please see README.md -homepage: http://github.com/haskell-works/hw-prim#readme -license: BSD3 -license-file: LICENSE -author: John Ky -maintainer: newhoggy@gmail.com -copyright: 2016 John Ky -category: Data -stability: Experimental -build-type: Simple -extra-source-files: README.md -cabal-version: >= 1.22 - -library - hs-source-dirs: src - exposed-modules: HaskellWorks.Data.AtIndex - , HaskellWorks.Data.ByteString - , HaskellWorks.Data.Char.IsChar - , HaskellWorks.Data.Concat - , HaskellWorks.Data.Container - , HaskellWorks.Data.Decode - , HaskellWorks.Data.Drop - , HaskellWorks.Data.Empty - , HaskellWorks.Data.Filter - , HaskellWorks.Data.FromByteString - , HaskellWorks.Data.FromForeignRegion - , HaskellWorks.Data.Generate - , HaskellWorks.Data.Head - , HaskellWorks.Data.Length - , HaskellWorks.Data.Naive - , HaskellWorks.Data.Positioning - , HaskellWorks.Data.Search - , HaskellWorks.Data.Sign - , HaskellWorks.Data.Snoc - , HaskellWorks.Data.Take - , HaskellWorks.Data.TreeCursor - , HaskellWorks.Data.Uncons - , HaskellWorks.Data.Unsign - , HaskellWorks.Data.Vector.AsVector64 - , HaskellWorks.Data.Vector.BoxedVectorLike - , HaskellWorks.Data.Vector.StorableVectorLike - build-depends: base >= 4 && < 5 - , bytestring - , vector +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 5f0d8912b294f5b5be8549239e1bc23d7911505275f8894882eaafa4bf683b5a - default-language: Haskell2010 - ghc-options: -Wall -O2 -msse4.2 +name: hw-prim +version: 0.4.0.7 +synopsis: Primitive functions and data types +description: Please see README.md +category: Data +stability: Experimental +homepage: http://github.com/haskell-works/hw-prim#readme +bug-reports: https://github.com/haskell-works/hw-prim/issues +author: John Ky +maintainer: newhoggy@gmail.com +copyright: 2016-2018 John Ky +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 -test-suite hw-prim-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Spec.hs - other-modules: HaskellWorks.Data.SearchSpec - build-depends: base >= 4 && < 5 - , bytestring - , hspec - , hw-prim - , QuickCheck - , vector - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - default-language: Haskell2010 +extra-source-files: + README.md source-repository head - type: git + type: git location: https://github.com/haskell-works/hw-prim + +library + hs-source-dirs: + src + ghc-options: -Wall -O2 -msse4.2 + build-depends: + base >=4 && <5 + , bytestring + , mmap + , vector + exposed-modules: + HaskellWorks.Data.AtIndex + HaskellWorks.Data.ByteString + HaskellWorks.Data.Char.IsChar + HaskellWorks.Data.Concat + HaskellWorks.Data.Container + HaskellWorks.Data.Decode + HaskellWorks.Data.Drop + HaskellWorks.Data.Empty + HaskellWorks.Data.Filter + HaskellWorks.Data.FromByteString + HaskellWorks.Data.FromForeignRegion + HaskellWorks.Data.Generate + HaskellWorks.Data.Head + HaskellWorks.Data.Length + HaskellWorks.Data.Naive + HaskellWorks.Data.Positioning + HaskellWorks.Data.Search + HaskellWorks.Data.Sign + HaskellWorks.Data.Snoc + HaskellWorks.Data.Take + HaskellWorks.Data.TreeCursor + HaskellWorks.Data.Uncons + HaskellWorks.Data.Unsign + HaskellWorks.Data.Vector.AsVector64 + HaskellWorks.Data.Vector.BoxedVectorLike + HaskellWorks.Data.Vector.StorableVectorLike + other-modules: + HaskellWorks.Data.Char + Paths_hw_prim + default-language: Haskell2010 + +test-suite hw-prim-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , base >=4 && <5 + , bytestring + , directory + , exceptions + , hedgehog + , hspec + , hw-hspec-hedgehog + , hw-prim + , mmap + , vector + other-modules: + HaskellWorks.Data.FromByteStringSpec + HaskellWorks.Data.FromForeignRegionSpec + HaskellWorks.Data.SearchSpec + Paths_hw_prim + default-language: Haskell2010 + +benchmark bench + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + bench + ghc-options: -Wall -O2 -msse4.2 + build-depends: + base >=4 && <5 + , bytestring + , criterion + , hw-prim + , mmap + , vector + other-modules: + Paths_hw_prim + default-language: Haskell2010 diff --git a/src/HaskellWorks/Data/Char.hs b/src/HaskellWorks/Data/Char.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Char.hs @@ -0,0 +1,5 @@ +module HaskellWorks.Data.Char + ( module X + ) where + +import HaskellWorks.Data.Char.IsChar as X diff --git a/src/HaskellWorks/Data/FromForeignRegion.hs b/src/HaskellWorks/Data/FromForeignRegion.hs --- a/src/HaskellWorks/Data/FromForeignRegion.hs +++ b/src/HaskellWorks/Data/FromForeignRegion.hs @@ -1,13 +1,19 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} -module HaskellWorks.Data.FromForeignRegion where +module HaskellWorks.Data.FromForeignRegion + ( FromForeignRegion(..) + , ForeignRegion + , mmapFromForeignRegion + ) where +import Data.Word +import Foreign.ForeignPtr + import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI import qualified Data.Vector.Storable as DVS -import Data.Word -import Foreign.ForeignPtr -import HaskellWorks.Data.FromByteString +import qualified System.IO.MMap as IO type ForeignRegion = (ForeignPtr Word8, Int, Int) @@ -20,13 +26,19 @@ fromForeignRegion (fptr, offset, size) = BSI.fromForeignPtr (castForeignPtr fptr) offset size instance FromForeignRegion (DVS.Vector Word8) where - fromForeignRegion = fromByteString . fromForeignRegion + fromForeignRegion (fptr, offset, size) = DVS.unsafeFromForeignPtr (castForeignPtr fptr) offset size instance FromForeignRegion (DVS.Vector Word16) where - fromForeignRegion = fromByteString . fromForeignRegion + fromForeignRegion (fptr, offset, size) = DVS.unsafeFromForeignPtr (castForeignPtr fptr) offset ((size + 1) `div` 2) instance FromForeignRegion (DVS.Vector Word32) where - fromForeignRegion = fromByteString . fromForeignRegion + fromForeignRegion (fptr, offset, size) = DVS.unsafeFromForeignPtr (castForeignPtr fptr) offset ((size + 3) `div` 4) instance FromForeignRegion (DVS.Vector Word64) where - fromForeignRegion = fromByteString . fromForeignRegion + fromForeignRegion (fptr, offset, size) = DVS.unsafeFromForeignPtr (castForeignPtr fptr) offset ((size + 7) `div` 8) + +mmapFromForeignRegion :: FromForeignRegion a => FilePath -> IO a +mmapFromForeignRegion filePath = do + region <- IO.mmapFileForeignPtr filePath IO.ReadOnly Nothing + let !bs = fromForeignRegion region + return bs diff --git a/test/HaskellWorks/Data/FromByteStringSpec.hs b/test/HaskellWorks/Data/FromByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/FromByteStringSpec.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedLists #-} + +module HaskellWorks.Data.FromByteStringSpec (spec) where + +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import Data.Word +import HaskellWorks.Data.FromByteString +import Test.Hspec + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.FromByteStringSpec" $ do + describe "For DVS.Vector Word8" $ do + it "fromByteString (BS.unpack []) :: DVS.Vector Word8" $ + let v = fromByteString (BS.pack []) :: DVS.Vector Word8 in + v `shouldBe` DVS.fromList [] + it "fromByteString (BS.unpack [0x1]) :: DVS.Vector Word8" $ + let v = fromByteString (BS.pack [0x1]) :: DVS.Vector Word8 in + v `shouldBe` DVS.fromList [0x1] + it "fromByteString (BS.unpack [0x1, 0x2]) :: DVS.Vector Word8" $ + let v = fromByteString (BS.pack [0x1, 0x2]) :: DVS.Vector Word8 in + v `shouldBe` DVS.fromList [0x1, 0x02] + it "fromByteString (BS.unpack [0x1, 0x2, 0x04]) :: DVS.Vector Word8" $ + let v = fromByteString (BS.pack [0x1, 0x2, 0x04]) :: DVS.Vector Word8 in + v `shouldBe` DVS.fromList [0x01, 0x2, 0x04] + describe "For DVS.Vector Word16" $ do + it "fromByteString (BS.unpack []) :: DVS.Vector Word16" $ + let v = fromByteString (BS.pack []) :: DVS.Vector Word16 in + v `shouldBe` DVS.fromList [] + it "fromByteString (BS.unpack [0x1]) :: DVS.Vector Word16" $ + let v = fromByteString (BS.pack [0x1]) :: DVS.Vector Word16 in + v `shouldBe` DVS.fromList [0x1] + it "fromByteString (BS.unpack [0x1, 0x2]) :: DVS.Vector Word16" $ + let v = fromByteString (BS.pack [0x1, 0x2]) :: DVS.Vector Word16 in + v `shouldBe` DVS.fromList [0x0201] + it "fromByteString (BS.unpack [0x1, 0x2, 0x10]) :: DVS.Vector Word16" $ + let v = fromByteString (BS.pack [0x1, 0x2, 0x10]) :: DVS.Vector Word16 in + v `shouldBe` DVS.fromList [0x0201, 0x10] + describe "For DVS.Vector Word32" $ do + it "fromByteString (BS.unpack []) :: DVS.Vector Word32" $ + let v = fromByteString (BS.pack []) :: DVS.Vector Word32 in + v `shouldBe` DVS.fromList [] + it "fromByteString (BS.unpack [0x1]) :: DVS.Vector Word32" $ + let v = fromByteString (BS.pack [0x1]) :: DVS.Vector Word32 in + v `shouldBe` DVS.fromList [0x1] + it "fromByteString (BS.unpack [0x1, 0x2, 0x4, 0x8]) :: DVS.Vector Word32" $ + let v = fromByteString (BS.pack [0x1, 0x2, 0x4, 0x8]) :: DVS.Vector Word32 in + v `shouldBe` DVS.fromList [0x08040201] + it "fromByteString (BS.unpack [0x1, 0x2, 0x4, 0x8, 0x10]) :: DVS.Vector Word32" $ + let v = fromByteString (BS.pack [0x1, 0x2, 0x4, 0x8, 0x10]) :: DVS.Vector Word32 in + v `shouldBe` DVS.fromList [0x08040201, 0x10] + describe "For DVS.Vector Word64" $ do + it "fromByteString (BS.unpack []) :: DVS.Vector Word64" $ + let v = fromByteString (BS.pack []) :: DVS.Vector Word64 in + v `shouldBe` DVS.fromList [] + it "fromByteString (BS.unpack [0x1]) :: DVS.Vector Word64" $ + let v = fromByteString (BS.pack [0x1]) :: DVS.Vector Word64 in + v `shouldBe` DVS.fromList [0x1] + it "fromByteString (BS.unpack [0x1, 0x2, 0x4, 0x8, 0x10, 0x20, 0x40, 0x80]) :: DVS.Vector Word64" $ + let v = fromByteString (BS.pack [0x1, 0x2, 0x4, 0x8, 0x10, 0x20, 0x40, 0x80]) :: DVS.Vector Word64 in + v `shouldBe` DVS.fromList [0x8040201008040201] + it "fromByteString (BS.unpack [0x1, 0x2, 0x4, 0x8, 0x10, 0x20, 0x40, 0x80, 0x81]) :: DVS.Vector Word64" $ + let v = fromByteString (BS.pack [0x1, 0x2, 0x4, 0x8, 0x10, 0x20, 0x40, 0x80, 0x81]) :: DVS.Vector Word64 in + v `shouldBe` DVS.fromList [0x8040201008040201, 0x81] diff --git a/test/HaskellWorks/Data/FromForeignRegionSpec.hs b/test/HaskellWorks/Data/FromForeignRegionSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/FromForeignRegionSpec.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module HaskellWorks.Data.FromForeignRegionSpec (spec) where + +import Control.Monad.IO.Class +import Data.Word +import Data.Word +import HaskellWorks.Data.FromByteString +import HaskellWorks.Data.FromForeignRegion +import HaskellWorks.Hspec.Hedgehog +import Hedgehog +import Hedgehog.Internal.Gen +import Test.Hspec + +import qualified Data.ByteString as BS +import qualified Data.Vector.Storable as DVS +import qualified HaskellWorks.Data.FromForeignRegion as IO +import qualified Hedgehog.Gen as G +import qualified Hedgehog.Range as R +import qualified System.Directory as IO +import qualified System.IO as IO + +{-# ANN module ("HLint: Ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.FromForeignRegionSpec" $ do + it "Be able to load file into Vector" $ requireProperty $ do + ws <- forAll $ G.list (R.linear 0 (1024 * 16)) (G.word8 R.constantBounded) + liftIO $ IO.createDirectoryIfMissing True "./tmp" + (fp, h) <- liftIO $ IO.openBinaryTempFile "./tmp" "property-test-.txt" + liftIO $ BS.hPut h (BS.pack ws) + liftIO $ IO.hClose h + !(_ :: DVS.Vector Word64) <- liftIO $ IO.mmapFromForeignRegion fp + liftIO $ IO.removeFile fp + True === True