From 58b268a71eb5e4bcfc12b080a43e63f1c9b856c5 Mon Sep 17 00:00:00 2001 From: konsumlamm Date: Mon, 13 Apr 2026 11:10:57 +0200 Subject: [PATCH 1/2] Use FFI for unaligned reads --- binary.cabal | 2 +- cbits/unaligned_read.c | 16 +++++++++++++ src/Data/Binary/Get.hs | 51 ++++++++++++++++++++++++++---------------- 3 files changed, 49 insertions(+), 20 deletions(-) create mode 100644 cbits/unaligned_read.c diff --git a/binary.cabal b/binary.cabal index 5f305ed..ff93dbb 100644 --- a/binary.cabal +++ b/binary.cabal @@ -53,7 +53,7 @@ library Data.Binary.Internal, Data.Binary.Generic, Data.Binary.FloatCast - + c-sources: cbits/unaligned_read.c ghc-options: -O2 -Wall -fliberate-case-threshold=1000 if impl(ghc >= 8.0) diff --git a/cbits/unaligned_read.c b/cbits/unaligned_read.c new file mode 100644 index 0000000..3437c67 --- /dev/null +++ b/cbits/unaligned_read.c @@ -0,0 +1,16 @@ +#include + +#include "HsFFI.h" + +#define UNALIGNED_READ(TYPE) Hs##TYPE _hs_binary_unaligned_read_##TYPE(HsWord8 *ptr) { Hs##TYPE result; memcpy(&result, ptr, sizeof(Hs##TYPE)); return result; } + +UNALIGNED_READ(Word) +UNALIGNED_READ(Word16) +UNALIGNED_READ(Word32) +UNALIGNED_READ(Word64) +UNALIGNED_READ(Int) +UNALIGNED_READ(Int16) +UNALIGNED_READ(Int32) +UNALIGNED_READ(Int64) +UNALIGNED_READ(Float) +UNALIGNED_READ(Double) diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs index a0b57da..71acf84 100644 --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -446,15 +446,6 @@ getShortByteString = fmap toShort . getByteString ------------------------------------------------------------------------ -- Primitives --- helper, get a raw Ptr onto a strict ByteString copied out of the --- underlying lazy byteString. - -#if !defined(HS_UNALIGNED_ADDR_PRIMOPS_AVAILABLE) -getPtr :: Storable a => Int -> Get a -getPtr n = readNWith n peek -{-# INLINE getPtr #-} -#endif - -- | Read a Word8 from the monad state getWord8 :: Get Word8 getWord8 = readN 1 B.unsafeHead @@ -594,7 +585,9 @@ getWordhost = readNWith SIZEOF_HSWORD $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsWord# p# 0# s of (# s', w# #) -> (# s', W# w# #) #else -getWordhost = getPtr (sizeOf (undefined :: Word)) +getWordhost = readNWith SIZEOF_HSWORD unalignedReadWord + +foreign import ccall unsafe "_hs_binary_unaligned_read_Word" unalignedReadWord :: Ptr Word -> IO Word #endif {-# INLINE getWordhost #-} @@ -605,7 +598,9 @@ getWord16host = readNWith 2 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsWord16# p# 0# s of (# s', w16# #) -> (# s', W16# w16# #) #else -getWord16host = getPtr (sizeOf (undefined :: Word16)) +getWord16host = readNWith 2 unalignedReadWord16 + +foreign import ccall unsafe "_hs_binary_unaligned_read_Word16" unalignedReadWord16 :: Ptr Word16 -> IO Word16 #endif {-# INLINE getWord16host #-} @@ -616,7 +611,9 @@ getWord32host = readNWith 4 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsWord32# p# 0# s of (# s', w32# #) -> (# s', W32# w32# #) #else -getWord32host = getPtr (sizeOf (undefined :: Word32)) +getWord32host = readNWith 4 unalignedReadWord32 + +foreign import ccall unsafe "_hs_binary_unaligned_read_Word32" unalignedReadWord32 :: Ptr Word32 -> IO Word32 #endif {-# INLINE getWord32host #-} @@ -627,7 +624,9 @@ getWord64host = readNWith 8 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsWord64# p# 0# s of (# s', w64# #) -> (# s', W64# w64# #) #else -getWord64host = getPtr (sizeOf (undefined :: Word64)) +getWord64host = readNWith 8 unalignedReadWord64 + +foreign import ccall unsafe "_hs_binary_unaligned_read_Word64" unalignedReadWord64 :: Ptr Word64 -> IO Word64 #endif {-# INLINE getWord64host #-} @@ -639,7 +638,9 @@ getInthost = readNWith SIZEOF_HSINT $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsInt# p# 0# s of (# s', i# #) -> (# s', I# i# #) #else -getInthost = getPtr (sizeOf (undefined :: Int)) +getInthost = readNWith SIZEOF_HSINT unalignedReadInt + +foreign import ccall unsafe "_hs_binary_unaligned_read_Int" unalignedReadInt :: Ptr Int -> IO Int #endif {-# INLINE getInthost #-} @@ -650,7 +651,9 @@ getInt16host = readNWith 2 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsInt16# p# 0# s of (# s', i16# #) -> (# s', I16# i16# #) #else -getInt16host = getPtr (sizeOf (undefined :: Int16)) +getInt16host = readNWith 2 unalignedReadInt16 + +foreign import ccall unsafe "_hs_binary_unaligned_read_Int16" unalignedReadInt16 :: Ptr Int16 -> IO Int16 #endif {-# INLINE getInt16host #-} @@ -661,7 +664,9 @@ getInt32host = readNWith 4 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsInt32# p# 0# s of (# s', i32# #) -> (# s', I32# i32# #) #else -getInt32host = getPtr (sizeOf (undefined :: Int32)) +getInt32host = readNWith 4 unalignedReadInt32 + +foreign import ccall unsafe "_hs_binary_unaligned_read_Int32" unalignedReadInt32 :: Ptr Int32 -> IO Int32 #endif {-# INLINE getInt32host #-} @@ -672,7 +677,9 @@ getInt64host = readNWith 8 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsInt64# p# 0# s of (# s', i64# #) -> (# s', I64# i64# #) #else -getInt64host = getPtr (sizeOf (undefined :: Int64)) +getInt64host = readNWith 8 unalignedReadInt64 + +foreign import ccall unsafe "_hs_binary_unaligned_read_Int64" unalignedReadInt64 :: Ptr Int64 -> IO Int64 #endif {-# INLINE getInt64host #-} @@ -705,7 +712,9 @@ getFloathost = readNWith 4 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsFloat# p# 0# s of (# s', f# #) -> (# s', F# f# #) #else -getFloathost = wordToFloat <$> getWord32host +getFloathost = readNWith 4 unalignedReadFloat + +foreign import ccall unsafe "_hs_binary_unaligned_read_Float" unalignedReadFloat :: Ptr Float -> IO Float #endif {-# INLINE getFloathost #-} @@ -734,6 +743,10 @@ getDoublehost = readNWith 8 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsDouble# p# 0# s of (# s', d# #) -> (# s', D# d# #) #else -getDoublehost = wordToDouble <$> getWord64host +getDoublehost = readNWith 8 unalignedReadDouble + +foreign import ccall unsafe "_hs_binary_unaligned_read_Double" unalignedReadDouble :: Ptr Double -> IO Double #endif {-# INLINE getDoublehost #-} + +-- TODO: use sizeOf From 7b57940ae075e9379a6ab4d7f855e952b2ea8156 Mon Sep 17 00:00:00 2001 From: konsumlamm Date: Mon, 13 Apr 2026 11:37:31 +0200 Subject: [PATCH 2/2] Use `sizeOf` for `readNWith` --- src/Data/Binary/Get.hs | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs index 71acf84..d20a7e9 100644 --- a/src/Data/Binary/Get.hs +++ b/src/Data/Binary/Get.hs @@ -585,7 +585,7 @@ getWordhost = readNWith SIZEOF_HSWORD $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsWord# p# 0# s of (# s', w# #) -> (# s', W# w# #) #else -getWordhost = readNWith SIZEOF_HSWORD unalignedReadWord +getWordhost = readNWith (sizeOf (0 :: Word)) unalignedReadWord foreign import ccall unsafe "_hs_binary_unaligned_read_Word" unalignedReadWord :: Ptr Word -> IO Word #endif @@ -598,7 +598,7 @@ getWord16host = readNWith 2 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsWord16# p# 0# s of (# s', w16# #) -> (# s', W16# w16# #) #else -getWord16host = readNWith 2 unalignedReadWord16 +getWord16host = readNWith (sizeOf (0 :: Word16)) unalignedReadWord16 foreign import ccall unsafe "_hs_binary_unaligned_read_Word16" unalignedReadWord16 :: Ptr Word16 -> IO Word16 #endif @@ -611,7 +611,7 @@ getWord32host = readNWith 4 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsWord32# p# 0# s of (# s', w32# #) -> (# s', W32# w32# #) #else -getWord32host = readNWith 4 unalignedReadWord32 +getWord32host = readNWith (sizeOf (0 :: Word32)) unalignedReadWord32 foreign import ccall unsafe "_hs_binary_unaligned_read_Word32" unalignedReadWord32 :: Ptr Word32 -> IO Word32 #endif @@ -624,7 +624,7 @@ getWord64host = readNWith 8 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsWord64# p# 0# s of (# s', w64# #) -> (# s', W64# w64# #) #else -getWord64host = readNWith 8 unalignedReadWord64 +getWord64host = readNWith (sizeOf (0 :: Word64)) unalignedReadWord64 foreign import ccall unsafe "_hs_binary_unaligned_read_Word64" unalignedReadWord64 :: Ptr Word64 -> IO Word64 #endif @@ -638,7 +638,7 @@ getInthost = readNWith SIZEOF_HSINT $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsInt# p# 0# s of (# s', i# #) -> (# s', I# i# #) #else -getInthost = readNWith SIZEOF_HSINT unalignedReadInt +getInthost = readNWith (sizeOf (0 :: Int)) unalignedReadInt foreign import ccall unsafe "_hs_binary_unaligned_read_Int" unalignedReadInt :: Ptr Int -> IO Int #endif @@ -651,7 +651,7 @@ getInt16host = readNWith 2 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsInt16# p# 0# s of (# s', i16# #) -> (# s', I16# i16# #) #else -getInt16host = readNWith 2 unalignedReadInt16 +getInt16host = readNWith (sizeOf (0 :: Int16)) unalignedReadInt16 foreign import ccall unsafe "_hs_binary_unaligned_read_Int16" unalignedReadInt16 :: Ptr Int16 -> IO Int16 #endif @@ -664,7 +664,7 @@ getInt32host = readNWith 4 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsInt32# p# 0# s of (# s', i32# #) -> (# s', I32# i32# #) #else -getInt32host = readNWith 4 unalignedReadInt32 +getInt32host = readNWith (sizeOf (0 :: Int32)) unalignedReadInt32 foreign import ccall unsafe "_hs_binary_unaligned_read_Int32" unalignedReadInt32 :: Ptr Int32 -> IO Int32 #endif @@ -677,7 +677,7 @@ getInt64host = readNWith 8 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsInt64# p# 0# s of (# s', i64# #) -> (# s', I64# i64# #) #else -getInt64host = readNWith 8 unalignedReadInt64 +getInt64host = readNWith (sizeOf (0 :: Int64)) unalignedReadInt64 foreign import ccall unsafe "_hs_binary_unaligned_read_Int64" unalignedReadInt64 :: Ptr Int64 -> IO Int64 #endif @@ -712,7 +712,7 @@ getFloathost = readNWith 4 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsFloat# p# 0# s of (# s', f# #) -> (# s', F# f# #) #else -getFloathost = readNWith 4 unalignedReadFloat +getFloathost = readNWith (sizeOf (0 :: Float)) unalignedReadFloat foreign import ccall unsafe "_hs_binary_unaligned_read_Float" unalignedReadFloat :: Ptr Float -> IO Float #endif @@ -743,10 +743,8 @@ getDoublehost = readNWith 8 $ \(Ptr p#) -> IO $ \s -> case readWord8OffAddrAsDouble# p# 0# s of (# s', d# #) -> (# s', D# d# #) #else -getDoublehost = readNWith 8 unalignedReadDouble +getDoublehost = readNWith (sizeOf (0 :: Double)) unalignedReadDouble foreign import ccall unsafe "_hs_binary_unaligned_read_Double" unalignedReadDouble :: Ptr Double -> IO Double #endif {-# INLINE getDoublehost #-} - --- TODO: use sizeOf