diff --git a/src/Data/Digest/XXHash/FFI.hs b/src/Data/Digest/XXHash/FFI.hs --- a/src/Data/Digest/XXHash/FFI.hs +++ b/src/Data/Digest/XXHash/FFI.hs @@ -1,10 +1,12 @@ -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} -- | --- Module: Data.Digest.XXHash.FFI --- Copyright: (c) 2017 Henri Verroken --- Licence: BSD3 --- Maintainer: Henri Verroken CSize -- ^ Buffer length - -> CULLong -- ^ Seed - -> CULLong -- ^ Resulting hash - -foreign import ccall unsafe "XXH32" c_xxh32 :: - Ptr a -- ^ 'Ptr' to the input buffer - -> CSize -- ^ Buffer length - -> CUInt -- ^ Seed - -> CUInt -- ^ Resulting hash - -data XXH32State - -foreign import ccall unsafe "XXH32_createState" c_xxh32_createState :: - IO (Ptr XXH32State) -- ^ Pointer to a newly allocated state - -foreign import ccall unsafe "XXH32_freeState" c_xxh32_freeState :: - Ptr XXH32State - -> IO () -- ^ Free pointer allocated by 'c_xxh32_createState' - -foreign import ccall unsafe "XXH32_copyState" c_xxh32_copyState :: - Ptr XXH32State -- ^ Destination - -> Ptr XXH32State -- ^ Source - -> IO () - -foreign import ccall unsafe "XXH32_reset" c_xxh32_reset :: - Ptr XXH32State -- ^ The state to reset - -> CUInt -- ^ The initial seed - -> IO () - -foreign import ccall unsafe "XXH32_update" c_xxh32_update :: - Ptr XXH32State -- ^ The state to update - -> Ptr a -- ^ 'Ptr' to the input buffer - -> CSize -- ^ Buffer length - -> IO () - -foreign import ccall unsafe "XXH32_digest" c_xxh32_digest :: - Ptr XXH32State -- ^ The state to digest - -> IO CUInt -- ^ Resulting hash - -data XXH64State - -foreign import ccall unsafe "XXH64_createState" c_xxh64_createState :: - IO (Ptr XXH64State) -- ^ Pointer to a newly allocated state - -foreign import ccall unsafe "XXH64_freeState" c_xxh64_freeState :: - Ptr XXH64State - -> IO () -- ^ Free pointer allocated by 'c_xxh64_createState' - -foreign import ccall unsafe "XXH64_copyState" c_xxh64_copyState :: - Ptr XXH64State -- ^ Destination - -> Ptr XXH64State -- ^ Source - -> IO () - -foreign import ccall unsafe "XXH64_reset" c_xxh64_reset :: - Ptr XXH64State -- ^ The state to reset - -> CULLong -- ^ The initial seed - -> IO () - -foreign import ccall unsafe "XXH64_update" c_xxh64_update :: - Ptr XXH64State -- ^ The state to update - -> Ptr a -- ^ 'Ptr' to the input buffer - -> CSize -- ^ Buffer length - -> IO () +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r -foreign import ccall unsafe "XXH64_digest" c_xxh64_digest :: - Ptr XXH64State -- ^ The state to digest - -> IO CULLong -- ^ Resulting hash +{-# INLINE use #-} +use :: BS.ByteString -> (CString -> CSize -> IO a) -> IO a +use bs k = unsafeUseAsCStringLen bs $ \(ptr,len) -> k ptr (fromIntegral len) -- | Class for hashable data types. -- @@ -136,45 +53,31 @@ instance XXHash BS.ByteString where - xxh32 bs seed = unsafePerformIO $ - unsafeUseAsCString bs $ \ptr -> - return . fromIntegral $ c_xxh32 (castPtr ptr) len (fromIntegral seed) - where - len = fromIntegral $ BS.length bs + xxh32 bs seed = fromIntegral . inlinePerformIO . use bs $ + \ptr len -> c_xxh32 ptr len (fromIntegral seed) - xxh64 bs seed = unsafePerformIO $ - unsafeUseAsCString bs $ \ptr -> - return . fromIntegral $ c_xxh64 (castPtr ptr) len (fromIntegral seed) - where - len = fromIntegral $ BS.length bs + xxh64 bs seed = fromIntegral . inlinePerformIO . use bs $ + \ptr len -> c_xxh64 ptr len (fromIntegral seed) {-# SPECIALIZE xxh32 :: BS.ByteString -> Word32 -> Word32 #-} {-# SPECIALIZE xxh64 :: BS.ByteString -> Word64 -> Word64 #-} instance XXHash BL.ByteString where xxh32 bs seed = fromIntegral . unsafePerformIO $ - bracket c_xxh32_createState - c_xxh32_freeState $ \state -> do - c_xxh32_reset state (fromIntegral seed) - mapM_ (update state) (BL.toChunks bs) - c_xxh32_digest state + allocaXXH32State $ \state -> do + c_xxh32_reset state (fromIntegral seed) + mapM_ (update state) (BL.toChunks bs) + c_xxh32_digest state where - update state bs' = - let len = fromIntegral (BS.length bs') in - unsafeUseAsCString bs' $ \ ptr -> - c_xxh32_update state ptr len + update state bs' = use bs' $ c_xxh32_update state xxh64 bs seed = fromIntegral . unsafePerformIO $ - bracket c_xxh64_createState - c_xxh64_freeState $ \state -> do - c_xxh64_reset state (fromIntegral seed) - mapM_ (update state) (BL.toChunks bs) - c_xxh64_digest state + allocaXXH64State $ \state -> do + c_xxh64_reset state (fromIntegral seed) + mapM_ (update state) (BL.toChunks bs) + c_xxh64_digest state where - update state bs' = - let len = fromIntegral (BS.length bs') in - unsafeUseAsCString bs' $ \ ptr -> - c_xxh64_update state ptr len + update state bs' = use bs' $ c_xxh64_update state {-# SPECIALIZE xxh32 :: BL.ByteString -> Word32 -> Word32 #-} {-# SPECIALIZE xxh64 :: BL.ByteString -> Word64 -> Word64 #-} diff --git a/src/Data/Digest/XXHash/FFI/C.hsc b/src/Data/Digest/XXHash/FFI/C.hsc new file mode 100644 --- /dev/null +++ b/src/Data/Digest/XXHash/FFI/C.hsc @@ -0,0 +1,134 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} +-- | +-- Module: Data.Digest.XXHash.FFI.C +-- Copyright: (c) 2017 Henri Verroken +-- Licence: BSD3 +-- Maintainer: Henri Verroken . +-- +-- This binding keeps the intermediate state for stream processing in an +-- 'MutableByteArray#' on the managed GHC heap. All foreign imports use unsafe +-- call semantics. Therefore, it is possible to use either unpinned or pinned +-- 'MutableByteArray#' since GHC's garbage collector doesn't move the either +-- kind during an unsafe foreign call. However GHCi <8.4 may replace unsafe +-- foreign calls with safe foreign calls in the bytecode +-- interpreter. Consequently, unpinned 'MutableByteArray#s' may be moved by the +-- garbage collector during foreign calls which obviously breaks this code. So +-- extra care should be taken when loading this code into the bytecode +-- interpreter. +module Data.Digest.XXHash.FFI.C ( + -- * C Interface + -- ** Direct Calculation + c_xxh64 +, c_xxh32 + + -- ** 32-bit state functions +, XXH32State +, allocaXXH32State +, c_xxh32_copyState +, c_xxh32_reset +, c_xxh32_update +, c_xxh32_digest + + -- ** 64-bit state functions +, XXH64State +, allocaXXH64State +, c_xxh64_copyState +, c_xxh64_reset +, c_xxh64_update +, c_xxh64_digest +) where + +-- Define XXH_STATIC_LINKING_ONLY to expose the definition of the state structs. +-- We can then get the size of them and allocate them on the managed GHC heap. +#define XXH_STATIC_LINKING_ONLY +#include "xxhash.h" + +import Foreign.C.Types +import Foreign.Ptr (Ptr) +import GHC.Exts (Int(..), RealWorld, + MutableByteArray##, newByteArray##) +import GHC.IO (IO(IO)) + +foreign import ccall unsafe "XXH64" c_xxh64 :: + Ptr a -- ^ 'Ptr' to the input buffer + -> CSize -- ^ Buffer length + -> CULLong -- ^ Seed + -> IO CULLong -- ^ Resulting hash + +foreign import ccall unsafe "XXH32" c_xxh32 :: + Ptr a -- ^ 'Ptr' to the input buffer + -> CSize -- ^ Buffer length + -> CUInt -- ^ Seed + -> IO CUInt -- ^ Resulting hash + +-- | Intermediate state for computing a XXH32 using segmentation or streams. +type XXH32State = MutableByteArray## RealWorld + +foreign import ccall unsafe "XXH32_copyState" c_xxh32_copyState :: + XXH32State -- ^ Destination + -> XXH32State -- ^ Source + -> IO () + +foreign import ccall unsafe "XXH32_reset" c_xxh32_reset :: + XXH32State -- ^ The state to reset + -> CUInt -- ^ The initial seed + -> IO () + +foreign import ccall unsafe "XXH32_update" c_xxh32_update :: + XXH32State -- ^ The state to update + -> Ptr a -- ^ 'Ptr' to the input buffer + -> CSize -- ^ Buffer length + -> IO () + +foreign import ccall unsafe "XXH32_digest" c_xxh32_digest :: + XXH32State -- ^ The state to digest + -> IO CUInt -- ^ Resulting hash + +-- | Intermediate state for computing a XXH64 using segmentation or streams. +type XXH64State = MutableByteArray## RealWorld + +foreign import ccall unsafe "XXH64_copyState" c_xxh64_copyState :: + XXH64State -- ^ Destination + -> XXH64State -- ^ Source + -> IO () + +foreign import ccall unsafe "XXH64_reset" c_xxh64_reset :: + XXH64State -- ^ The state to reset + -> CULLong -- ^ The initial seed + -> IO () + +foreign import ccall unsafe "XXH64_update" c_xxh64_update :: + XXH64State -- ^ The state to update + -> Ptr a -- ^ 'Ptr' to the input buffer + -> CSize -- ^ Buffer length + -> IO () + +foreign import ccall unsafe "XXH64_digest" c_xxh64_digest :: + XXH64State -- ^ The state to digest + -> IO CULLong -- ^ Resulting hash + +{-# INLINE allocaMutableByteArray #-} +allocaMutableByteArray :: Int -> (MutableByteArray## RealWorld -> IO b) -> IO b +allocaMutableByteArray (I## len) f = IO $ \s0 -> + case newByteArray## len s0 of { (## s1, mba ##) -> + case f mba of { IO m -> m s1 }} + +{-# INLINE allocaXXH32State #-} +-- | 'allocaXXH32State f' temporarily allocates a 'XXH32State' and passes it +-- to the function 'f'. +allocaXXH32State :: (XXH32State -> IO a) -> IO a +allocaXXH32State = allocaMutableByteArray #{size XXH32_state_t} + +{-# INLINE allocaXXH64State #-} +-- | 'allocaXXH64State f' temporarily allocates a 'XXH64State' and passes it +-- to the function 'f'. +allocaXXH64State :: (XXH64State -> IO a) -> IO a +allocaXXH64State = allocaMutableByteArray #{size XXH64_state_t} diff --git a/xxhash-ffi.cabal b/xxhash-ffi.cabal --- a/xxhash-ffi.cabal +++ b/xxhash-ffi.cabal @@ -1,5 +1,5 @@ name: xxhash-ffi -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Bindings to the C implementation the xxHash algorithm description: Bindings to the C implementation the xxHash algorithm. xxHash provides 32-bit and 64-bit extremely fast non-cryptographic hash functions. homepage: https://github.com/haskell-haskey/xxhash-ffi#readme @@ -16,6 +16,7 @@ library hs-source-dirs: src exposed-modules: Data.Digest.XXHash.FFI + Data.Digest.XXHash.FFI.C build-depends: base >= 4.7 && < 5 , bytestring ghc-options: -Wall