diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for Z-Data +## 0.1.5.0 -- 2020-10-02 + +* Rework `CBytes` type to use unpinned byte array, add `withCBytesUnsafe`, `allocCBytesUnsafe`. +* Export `head`, `tail`, `init`, `last` from `Z.IO.Vector`, `Z.IO.Text` (well, safety first). +* Change `unalignedSize` in `UnalignedAccess` class's type to take a instance type and return `Int`. +* Rename `UnalignedAccess` to `Unaligned`. + ## 0.1.4.2 -- 2020-10-02 * Remove `withMutablePrimArrayUnsafe/Safe` from `Z.Foreign`. diff --git a/Z-Data.cabal b/Z-Data.cabal --- a/Z-Data.cabal +++ b/Z-Data.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: Z-Data -version: 0.1.4.2 +version: 0.1.5.0 synopsis: Array, vector and text description: This package provides array, slice and text operations license: BSD-3-Clause @@ -66,7 +66,7 @@ Z.Data.Array.Cast Z.Data.Array.Checked Z.Data.Array.QQ - Z.Data.Array.UnalignedAccess + Z.Data.Array.Unaligned Z.Data.Array.UnliftedArray Z.Data.CBytes Z.Data.Vector @@ -183,7 +183,7 @@ Z.Data.JSON.ValueSpec Z.Data.Parser.BaseSpec Z.Data.Parser.NumericSpec - Z.Data.Array.UnalignedAccessSpec + Z.Data.Array.UnalignedSpec Z.Data.Text.BaseSpec Z.Data.Text.BuilderSpec Z.Data.Text.ExtraSpec diff --git a/Z/Data/Array/Unaligned.hs b/Z/Data/Array/Unaligned.hs new file mode 100644 --- /dev/null +++ b/Z/Data/Array/Unaligned.hs @@ -0,0 +1,923 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} + +{-| +Module : Z.Data.Array.Unaligned +Description : unaligned access for primitive arrays +Copyright : (c) Dong Han, 2017-2019 +License : BSD +Maintainer : winterland1989@gmail.com +Stability : experimental +Portability : non-portable + +This module implements unaligned element access with ghc primitives (> 8.6), which can be used +as a simple binary encoding \/ decoding method. +-} + +module Z.Data.Array.Unaligned where + +import Control.Monad.Primitive +import Data.Primitive.ByteArray +import Data.Primitive.PrimArray +import GHC.Int +import GHC.Exts +import GHC.Word +import GHC.Float (stgFloatToWord32, stgWord32ToFloat, stgWord64ToDouble, stgDoubleToWord64) +import Foreign.C.Types + +-- toggle these defs to test different implements +#define USE_BSWAP +-- #define USE_SHIFT + +-------------------------------------------------------------------------------- + +-- | Primitive types which can be unaligned accessed +-- +-- It can also be used as a lightweight method to peek\/poke value from\/to C structs +-- when you pass 'MutableByteArray#' to FFI as struct pointer, e.g. +-- +-- @ +-- -- | note the .hsc syntax +-- peekSocketAddrMBA :: HasCallStack => MBA## SocketAddr -> IO SocketAddr +-- peekSocketAddrMBA p = do +-- family <- peekMBA p (#offset struct sockaddr, sa_family) +-- case family :: CSaFamily of +-- (#const AF_INET) -> do +-- addr <- peekMBA p (#offset struct sockaddr_in, sin_addr) +-- port <- peekMBA p (#offset struct sockaddr_in, sin_port) +-- return (SocketAddrInet (PortNumber port) addr) +-- .... +-- @ +-- +class Unaligned a where + {-# MINIMAL unalignedSize, indexWord8ArrayAs#, writeWord8ArrayAs#, readWord8ArrayAs# | + unalignedSize, indexBA, peekMBA, pokeMBA #-} + -- | byte size + unalignedSize :: a -> Int + + -- | index element off byte array with offset in bytes(maybe unaligned) + indexWord8ArrayAs# :: ByteArray# -> Int# -> a + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = indexBA ba# (I# i#) + + -- | read element from byte array with offset in bytes(maybe unaligned) + readWord8ArrayAs# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s# = + (unsafeCoerce# (peekMBA (unsafeCoerce# mba#) (I# i#) :: IO a)) s# + + -- | write element to byte array with offset in bytes(maybe unaligned) + writeWord8ArrayAs# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# x s# = + unsafeCoerce# (pokeMBA (unsafeCoerce# mba#) (I# i#) x) s# + + -- | IO version of 'writeWord8ArrayAs#' but more convenient to write manually. + peekMBA :: MutableByteArray# RealWorld -> Int -> IO a + {-# INLINE peekMBA #-} + peekMBA mba# (I# i#) = primitive (readWord8ArrayAs# mba# i#) + + -- | IO version of 'readWord8ArrayAs#' but more convenient to write manually. + pokeMBA :: MutableByteArray# RealWorld -> Int -> a -> IO () + {-# INLINE pokeMBA #-} + pokeMBA mba# (I# i#) x = primitive_ (writeWord8ArrayAs# mba# i# x) + + -- | index element off byte array with offset in bytes(maybe unaligned) + indexBA :: ByteArray# -> Int -> a + {-# INLINE indexBA #-} + indexBA ba# (I# i#) = indexWord8ArrayAs# ba# i# + + +-- | Lifted version of 'writeWord8ArrayAs#' +writeWord8ArrayAs :: (PrimMonad m, Unaligned a) => MutableByteArray (PrimState m) -> Int -> a -> m () +{-# INLINE writeWord8ArrayAs #-} +writeWord8ArrayAs (MutableByteArray mba#) (I# i#) x = primitive_ (writeWord8ArrayAs# mba# i# x) + +-- | Lifted version of 'readWord8ArrayAs#' +readWord8ArrayAs :: (PrimMonad m, Unaligned a) => MutableByteArray (PrimState m) -> Int -> m a +{-# INLINE readWord8ArrayAs #-} +readWord8ArrayAs (MutableByteArray mba#) (I# i#) = primitive (readWord8ArrayAs# mba# i#) + +-- | Lifted version of 'indexWord8ArrayAs#' +indexWord8ArrayAs :: Unaligned a => ByteArray -> Int -> a +{-# INLINE indexWord8ArrayAs #-} +indexWord8ArrayAs (ByteArray ba#) (I# i#) = indexWord8ArrayAs# ba# i# + +-- | Lifted version of 'writeWord8ArrayAs#' +writePrimWord8ArrayAs :: (PrimMonad m, Unaligned a) => MutablePrimArray (PrimState m) Word8 -> Int -> a -> m () +{-# INLINE writePrimWord8ArrayAs #-} +writePrimWord8ArrayAs (MutablePrimArray mba#) (I# i#) x = primitive_ (writeWord8ArrayAs# mba# i# x) + +-- | Lifted version of 'readWord8ArrayAs#' +readPrimWord8ArrayAs :: (PrimMonad m, Unaligned a) => MutablePrimArray (PrimState m) Word8 -> Int -> m a +{-# INLINE readPrimWord8ArrayAs #-} +readPrimWord8ArrayAs (MutablePrimArray mba#) (I# i#) = primitive (readWord8ArrayAs# mba# i#) + +-- | Lifted version of 'indexWord8ArrayAs#' +indexPrimWord8ArrayAs :: Unaligned a => PrimArray Word8 -> Int -> a +{-# INLINE indexPrimWord8ArrayAs #-} +indexPrimWord8ArrayAs (PrimArray ba#) (I# i#) = indexWord8ArrayAs# ba# i# + +instance Unaligned Word8 where + {-# INLINE unalignedSize #-} + unalignedSize _ = 1 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (W8# x#) = writeWord8Array# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8Array# mba# i# s0 in (# s1, W8# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = W8# (indexWord8Array# ba# i#) + +instance Unaligned Int8 where + {-# INLINE unalignedSize #-} + unalignedSize _ = 1 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (I8# x#) = writeInt8Array# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readInt8Array# mba# i# s0 in (# s1, I8# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = I8# (indexInt8Array# ba# i#) + +-- | little endianess wrapper +-- +newtype LE a = LE { getLE :: a } deriving (Show, Eq) + +-- | big endianess wrapper +-- +newtype BE a = BE { getBE :: a } deriving (Show, Eq) + +#define USE_HOST_IMPL(END) \ + {-# INLINE writeWord8ArrayAs# #-}; \ + writeWord8ArrayAs# mba# i# (END x) = writeWord8ArrayAs# mba# i# x; \ + {-# INLINE readWord8ArrayAs# #-}; \ + readWord8ArrayAs# mba# i# s0 = \ + let !(# s1, x #) = readWord8ArrayAs# mba# i# s0 in (# s1, END x #); \ + {-# INLINE indexWord8ArrayAs# #-}; \ + indexWord8ArrayAs# ba# i# = END (indexWord8ArrayAs# ba# i#); + +-------------------------------------------------------------------------------- + +instance Unaligned Word16 where + {-# INLINE unalignedSize #-} + unalignedSize _ = 2 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (W16# x#) = writeWord8ArrayAsWord16# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsWord16# mba# i# s0 in (# s1, W16# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = W16# (indexWord8ArrayAsWord16# ba# i#) + +instance Unaligned (LE Word16) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 2 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (W16# x#)) s0# = + let s1# = writeWord8Array# mba# i# x# s0# + in writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, w1# #) = readWord8Array# mba# i# s0 + !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 + in (# s2, LE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let w1# = indexWord8Array# ba# i# + w2# = indexWord8Array# ba# (i# +# 1#) + in LE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Word16) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 2 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else +-- on X86 we use bswap +-- TODO: find out if arch64 support this +#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (W16# x#)) = writeWord8ArrayAsWord16# mba# i# (byteSwap16# x#) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsWord16# mba# i# s0 + in (# s1, BE (W16# (byteSwap16# x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = BE (W16# (byteSwap16# (indexWord8ArrayAsWord16# ba# i#))) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (W16# x#)) s0# = + let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 8#) s0# + in writeWord8Array# mba# (i# +# 1#) x# s1# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, w2# #) = readWord8Array# mba# i# s0 + !(# s2, w1# #) = readWord8Array# mba# (i# +# 1#) s1 + in (# s2, BE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let w2# = indexWord8Array# ba# i# + w1# = indexWord8Array# ba# (i# +# 1#) + in BE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) +#endif +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Word32 where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (W32# x#) = writeWord8ArrayAsWord32# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsWord32# mba# i# s0 in (# s1, W32# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = W32# (indexWord8ArrayAsWord32# ba# i#) + + +instance Unaligned (LE Word32) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (W32# x#)) s0# = + let s1# = writeWord8Array# mba# i# x# s0# + s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# + s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 16#) s2# + in writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 24#) s3# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, w1# #) = readWord8Array# mba# i# s0 + !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 + !(# s3, w3# #) = readWord8Array# mba# (i# +# 2#) s2 + !(# s4, w4# #) = readWord8Array# mba# (i# +# 3#) s3 + in (# s4, LE (W32# ((uncheckedShiftL# w4# 24#) `or#` + (uncheckedShiftL# w3# 16#) `or#` + (uncheckedShiftL# w2# 8#) `or#` w1#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let w1# = indexWord8Array# ba# i# + w2# = indexWord8Array# ba# (i# +# 1#) + w3# = indexWord8Array# ba# (i# +# 2#) + w4# = indexWord8Array# ba# (i# +# 3#) + in LE (W32# ((uncheckedShiftL# w4# 24#) `or#` + (uncheckedShiftL# w3# 16#) `or#` + (uncheckedShiftL# w2# 8#) `or#` w1#)) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Word32) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else +-- on X86 we use bswap +-- TODO: find out if arch64 support this +#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (W32# x#)) = writeWord8ArrayAsWord32# mba# i# (byteSwap32# x#) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsWord32# mba# i# s0 + in (# s1, BE (W32# (byteSwap32# x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = BE (W32# (byteSwap32# (indexWord8ArrayAsWord32# ba# i#))) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (W32# x#)) s0# = + let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 24#) s0# + s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 16#) s1# + s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 8#) s2# + in writeWord8Array# mba# (i# +# 3#) x# s3# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, w4# #) = readWord8Array# mba# i# s0 + !(# s2, w3# #) = readWord8Array# mba# (i# +# 1#) s1 + !(# s3, w2# #) = readWord8Array# mba# (i# +# 2#) s2 + !(# s4, w1# #) = readWord8Array# mba# (i# +# 3#) s3 + in (# s4, BE (W32# ((uncheckedShiftL# w4# 24#) `or#` + (uncheckedShiftL# w3# 16#) `or#` + (uncheckedShiftL# w2# 8#) `or#` w1#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let w4# = indexWord8Array# ba# i# + w3# = indexWord8Array# ba# (i# +# 1#) + w2# = indexWord8Array# ba# (i# +# 2#) + w1# = indexWord8Array# ba# (i# +# 3#) + in BE (W32# ((uncheckedShiftL# w4# 24#) `or#` + (uncheckedShiftL# w3# 16#) `or#` + (uncheckedShiftL# w2# 8#) `or#` w1#)) +#endif +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Word64 where + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (W64# x#) = writeWord8ArrayAsWord64# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsWord64# mba# i# s0 in (# s1, W64# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = W64# (indexWord8ArrayAsWord64# ba# i#) + + +instance Unaligned (LE Word64) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (W64# x#)) s0# = + let s1# = writeWord8Array# mba# i# x# s0# + s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# + s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 16#) s2# + s4# = writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 24#) s3# + s5# = writeWord8Array# mba# (i# +# 4#) (uncheckedShiftRL# x# 32#) s4# + s6# = writeWord8Array# mba# (i# +# 5#) (uncheckedShiftRL# x# 40#) s5# + s7# = writeWord8Array# mba# (i# +# 6#) (uncheckedShiftRL# x# 48#) s6# + in writeWord8Array# mba# (i# +# 7#) (uncheckedShiftRL# x# 56#) s7# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, w1# #) = readWord8Array# mba# i# s0 + !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 + !(# s3, w3# #) = readWord8Array# mba# (i# +# 2#) s2 + !(# s4, w4# #) = readWord8Array# mba# (i# +# 3#) s3 + !(# s5, w5# #) = readWord8Array# mba# (i# +# 4#) s4 + !(# s6, w6# #) = readWord8Array# mba# (i# +# 5#) s5 + !(# s7, w7# #) = readWord8Array# mba# (i# +# 6#) s6 + !(# s8, w8# #) = readWord8Array# mba# (i# +# 7#) s7 + in (# s8, LE (W64# ((uncheckedShiftL# w8# 56#) `or#` + (uncheckedShiftL# w7# 48#) `or#` + (uncheckedShiftL# w6# 40#) `or#` + (uncheckedShiftL# w5# 32#) `or#` + (uncheckedShiftL# w4# 24#) `or#` + (uncheckedShiftL# w3# 16#) `or#` + (uncheckedShiftL# w2# 8#) `or#` w1#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let w1# = indexWord8Array# ba# i# + w2# = indexWord8Array# ba# (i# +# 1#) + w3# = indexWord8Array# ba# (i# +# 2#) + w4# = indexWord8Array# ba# (i# +# 3#) + w5# = indexWord8Array# ba# (i# +# 4#) + w6# = indexWord8Array# ba# (i# +# 5#) + w7# = indexWord8Array# ba# (i# +# 6#) + w8# = indexWord8Array# ba# (i# +# 7#) + in LE (W64# ((uncheckedShiftL# w8# 56#) `or#` + (uncheckedShiftL# w7# 48#) `or#` + (uncheckedShiftL# w6# 40#) `or#` + (uncheckedShiftL# w5# 32#) `or#` + (uncheckedShiftL# w4# 24#) `or#` + (uncheckedShiftL# w3# 16#) `or#` + (uncheckedShiftL# w2# 8#) `or#` w1#)) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Word64) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else +-- on X86 we use bswap +-- TODO: find out if arch64 support this +#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (W64# x#)) = writeWord8ArrayAsWord64# mba# i# (byteSwap64# x#) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsWord64# mba# i# s0 + in (# s1, BE (W64# (byteSwap64# x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = BE (W64# (byteSwap64# (indexWord8ArrayAsWord64# ba# i#))) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (W64# x#)) s0# = + let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 56#) s0# + s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 48#) s1# + s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 40#) s2# + s4# = writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 32#) s3# + s5# = writeWord8Array# mba# (i# +# 4#) (uncheckedShiftRL# x# 24#) s4# + s6# = writeWord8Array# mba# (i# +# 5#) (uncheckedShiftRL# x# 16#) s5# + s7# = writeWord8Array# mba# (i# +# 6#) (uncheckedShiftRL# x# 8#) s6# + in writeWord8Array# mba# (i# +# 7#) x# s7# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, w8# #) = readWord8Array# mba# i# s0 + !(# s2, w7# #) = readWord8Array# mba# (i# +# 1#) s1 + !(# s3, w6# #) = readWord8Array# mba# (i# +# 2#) s2 + !(# s4, w5# #) = readWord8Array# mba# (i# +# 3#) s3 + !(# s5, w4# #) = readWord8Array# mba# (i# +# 4#) s4 + !(# s6, w3# #) = readWord8Array# mba# (i# +# 5#) s5 + !(# s7, w2# #) = readWord8Array# mba# (i# +# 6#) s6 + !(# s8, w1# #) = readWord8Array# mba# (i# +# 7#) s7 + in (# s8, BE (W64# ((uncheckedShiftL# w8# 56#) `or#` + (uncheckedShiftL# w7# 48#) `or#` + (uncheckedShiftL# w6# 40#) `or#` + (uncheckedShiftL# w5# 32#) `or#` + (uncheckedShiftL# w4# 24#) `or#` + (uncheckedShiftL# w3# 16#) `or#` + (uncheckedShiftL# w2# 8#) `or#` w1#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let w8# = indexWord8Array# ba# i# + w7# = indexWord8Array# ba# (i# +# 1#) + w6# = indexWord8Array# ba# (i# +# 2#) + w5# = indexWord8Array# ba# (i# +# 3#) + w4# = indexWord8Array# ba# (i# +# 4#) + w3# = indexWord8Array# ba# (i# +# 5#) + w2# = indexWord8Array# ba# (i# +# 6#) + w1# = indexWord8Array# ba# (i# +# 7#) + in BE (W64# ((uncheckedShiftL# w8# 56#) `or#` + (uncheckedShiftL# w7# 48#) `or#` + (uncheckedShiftL# w6# 40#) `or#` + (uncheckedShiftL# w5# 32#) `or#` + (uncheckedShiftL# w4# 24#) `or#` + (uncheckedShiftL# w3# 16#) `or#` + (uncheckedShiftL# w2# 8#) `or#` w1#)) +#endif +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Word where +#if SIZEOF_HSWORD == 4 + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#else + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 +#endif + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (W# x#) = writeWord8ArrayAsWord# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsWord# mba# i# s0 in (# s1, W# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = W# (indexWord8ArrayAsWord# ba# i#) + +instance Unaligned (LE Word) where +#if SIZEOF_HSWORD == 4 + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (W# x#)) = writeWord8ArrayAs# mba# i# (LE (W32# x#)) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (W# x#) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (W32# x#)) -> LE (W# x#) +#else + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (W# x#)) = writeWord8ArrayAs# mba# i# (LE (W64# x#)) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (W# x#) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (W64# x#)) -> LE (W# x#) +#endif + +instance Unaligned (BE Word) where +#if SIZEOF_HSWORD == 4 + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (W# x#)) = writeWord8ArrayAs# mba# i# (BE (W32# x#)) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (W# x#) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (W32# x#)) -> BE (W# x#) +#else + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (W# x#)) = writeWord8ArrayAs# mba# i# (BE (W64# x#)) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (W# x#) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (W64# x#)) -> BE (W# x#) +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Int16 where + {-# INLINE unalignedSize #-} + unalignedSize _ = 2 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (I16# x#) = writeWord8ArrayAsInt16# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsInt16# mba# i# s0 in (# s1, I16# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = I16# (indexWord8ArrayAsInt16# ba# i#) + +instance Unaligned (LE Int16) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 2 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (I16# x#)) = + writeWord8ArrayAs# mba# i# (LE (W16# (int2Word# x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (W16# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, LE (I16# (narrow16Int# (word2Int# x#))) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let LE (W16# x#) = indexWord8ArrayAs# ba# i# + in LE (I16# (narrow16Int# (word2Int# x#))) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Int16) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 2 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (I16# x#)) = + writeWord8ArrayAs# mba# i# (BE (W16# (int2Word# x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (W16# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, BE (I16# (narrow16Int# (word2Int# x#))) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let !(BE (W16# x#)) = indexWord8ArrayAs# ba# i# + in BE (I16# (narrow16Int# (word2Int# x#))) +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Int32 where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (I32# x#) = writeWord8ArrayAsInt32# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsInt32# mba# i# s0 in (# s1, I32# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = I32# (indexWord8ArrayAsInt32# ba# i#) + +instance Unaligned (LE Int32) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (I32# x#)) = + writeWord8ArrayAs# mba# i# (LE (W32# (int2Word# x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, LE (I32# (narrow32Int# (word2Int# x#))) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let LE (W32# x#) = indexWord8ArrayAs# ba# i# + in LE (I32# (narrow32Int# (word2Int# x#))) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Int32) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (I32# x#)) = + writeWord8ArrayAs# mba# i# (BE (W32# (int2Word# x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, BE (I32# (narrow32Int# (word2Int# x#))) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let !(BE (W32# x#)) = indexWord8ArrayAs# ba# i# + in BE (I32# (narrow32Int# (word2Int# x#))) +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Int64 where + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (I64# x#) = writeWord8ArrayAsInt64# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsInt64# mba# i# s0 in (# s1, I64# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = I64# (indexWord8ArrayAsInt64# ba# i#) + +instance Unaligned (LE Int64) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (I64# x#)) = + writeWord8ArrayAs# mba# i# (LE (W64# (int2Word# x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, LE (I64# (word2Int# x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let LE (W64# x#) = indexWord8ArrayAs# ba# i# + in LE (I64# (word2Int# x#)) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Int64) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (I64# x#)) = + writeWord8ArrayAs# mba# i# (BE (W64# (int2Word# x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, BE (I64# (word2Int# x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let !(BE (W64# x#)) = indexWord8ArrayAs# ba# i# + in BE (I64# (word2Int# x#)) +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Int where +#if SIZEOF_HSWORD == 4 + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#else + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 +#endif + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (I# x#) = writeWord8ArrayAsInt# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsInt# mba# i# s0 in (# s1, I# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = I# (indexWord8ArrayAsInt# ba# i#) + +instance Unaligned (LE Int) where +#if SIZEOF_HSWORD == 4 + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (I# x#)) = writeWord8ArrayAs# mba# i# (LE (I32# x#)) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (I# x#) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (I32# x#)) -> LE (I# x#) +#else + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (I# x#)) = writeWord8ArrayAs# mba# i# (LE (I64# x#)) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (I64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (I# x#) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (I64# x#)) -> LE (I# x#) +#endif + +instance Unaligned (BE Int) where +#if SIZEOF_HSWORD == 4 + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (I# x#)) = writeWord8ArrayAs# mba# i# (BE (I32# x#)) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (I# x#) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (I32# x#)) -> BE (I# x#) +#else + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (I# x#)) = writeWord8ArrayAs# mba# i# (BE (I64# x#)) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (I64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (I# x#) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (I64# x#)) -> BE (I# x#) +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Float where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (F# x#) = writeWord8ArrayAsFloat# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsFloat# mba# i# s0 in (# s1, F# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = F# (indexWord8ArrayAsFloat# ba# i#) + +instance Unaligned (LE Float) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (F# x#)) = + writeWord8ArrayAs# mba# i# (LE (W32# (stgFloatToWord32 x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, LE (F# (stgWord32ToFloat x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let LE (W32# x#) = indexWord8ArrayAs# ba# i# + in LE (F# (stgWord32ToFloat x#)) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Float) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (F# x#)) = + writeWord8ArrayAs# mba# i# (BE (W32# (stgFloatToWord32 x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, BE (F# (stgWord32ToFloat x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let !(BE (W32# x#)) = indexWord8ArrayAs# ba# i# + in BE (F# (stgWord32ToFloat x#)) +#endif + +-------------------------------------------------------------------------------- + +instance Unaligned Double where + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (D# x#) = writeWord8ArrayAsDouble# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsDouble# mba# i# s0 in (# s1, D# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = D# (indexWord8ArrayAsDouble# ba# i#) + +instance Unaligned (LE Double) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 8 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (D# x#)) = + writeWord8ArrayAs# mba# i# (LE (W64# (stgDoubleToWord64 x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, LE (D# (stgWord64ToDouble x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let LE (W64# x#) = indexWord8ArrayAs# ba# i# + in LE (D# (stgWord64ToDouble x#)) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Double) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (D# x#)) = + writeWord8ArrayAs# mba# i# (BE (W64# (stgDoubleToWord64 x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, BE (D# (stgWord64ToDouble x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let !(BE (W64# x#)) = indexWord8ArrayAs# ba# i# + in BE (D# (stgWord64ToDouble x#)) +#endif + +-------------------------------------------------------------------------------- + +-- | Char's instance use 31bit wide char prim-op. +instance Unaligned Char where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (C# x#) = writeWord8ArrayAsWideChar# mba# i# x# + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, x# #) = readWord8ArrayAsWideChar# mba# i# s0 in (# s1, C# x# #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = C# (indexWord8ArrayAsWideChar# ba# i#) + +instance Unaligned (LE Char) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (LE (C# x#)) = + writeWord8ArrayAs# mba# i# (LE (I32# (ord# x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, LE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, LE (C# (chr# x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let LE (I32# x#) = indexWord8ArrayAs# ba# i# + in LE (C# (chr# x#)) +#else + USE_HOST_IMPL(LE) +#endif + +instance Unaligned (BE Char) where + {-# INLINE unalignedSize #-} + unalignedSize _ = 4 +#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) + USE_HOST_IMPL(BE) +#else + {-# INLINE writeWord8ArrayAs# #-} + writeWord8ArrayAs# mba# i# (BE (C# x#)) = + writeWord8ArrayAs# mba# i# (BE (I32# (ord# x#))) + {-# INLINE readWord8ArrayAs# #-} + readWord8ArrayAs# mba# i# s0 = + let !(# s1, BE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 + in (# s1, BE (C# (chr# x#)) #) + {-# INLINE indexWord8ArrayAs# #-} + indexWord8ArrayAs# ba# i# = + let !(BE (I32# x#)) = indexWord8ArrayAs# ba# i# + in BE (C# (chr# x#)) +#endif + +-------------------------------------------------------------------------------- + +-- Prim instances for newtypes in Foreign.C.Types +deriving instance Unaligned CChar +deriving instance Unaligned CSChar +deriving instance Unaligned CUChar +deriving instance Unaligned CShort +deriving instance Unaligned CUShort +deriving instance Unaligned CInt +deriving instance Unaligned CUInt +deriving instance Unaligned CLong +deriving instance Unaligned CULong +deriving instance Unaligned CPtrdiff +deriving instance Unaligned CSize +deriving instance Unaligned CWchar +deriving instance Unaligned CSigAtomic +deriving instance Unaligned CLLong +deriving instance Unaligned CULLong +deriving instance Unaligned CBool +deriving instance Unaligned CIntPtr +deriving instance Unaligned CUIntPtr +deriving instance Unaligned CIntMax +deriving instance Unaligned CUIntMax +deriving instance Unaligned CClock +deriving instance Unaligned CTime +deriving instance Unaligned CUSeconds +deriving instance Unaligned CSUSeconds +deriving instance Unaligned CFloat +deriving instance Unaligned CDouble diff --git a/Z/Data/Array/UnalignedAccess.hs b/Z/Data/Array/UnalignedAccess.hs deleted file mode 100644 --- a/Z/Data/Array/UnalignedAccess.hs +++ /dev/null @@ -1,924 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} - -{-| -Module : Z.Data.Array.UnalignedAccess -Description : unaligned access for primitive arrays -Copyright : (c) Dong Han, 2017-2019 -License : BSD -Maintainer : winterland1989@gmail.com -Stability : experimental -Portability : non-portable - -This module implements unaligned element access with ghc primitives (> 8.6). --} - -module Z.Data.Array.UnalignedAccess where - -import Control.Monad.Primitive -import Data.Primitive.ByteArray -import Data.Primitive.PrimArray -import GHC.Int -import GHC.Exts -import GHC.Word -import GHC.Float (stgFloatToWord32, stgWord32ToFloat, stgWord64ToDouble, stgDoubleToWord64) -import Foreign.C.Types - --- toggle these defs to test different implements -#define USE_BSWAP --- #define USE_SHIFT - --------------------------------------------------------------------------------- - -newtype UnalignedSize a = UnalignedSize { getUnalignedSize :: Int } deriving (Show, Eq) - --- | Primitive types which can be unaligned accessed --- --- It can also be used as a lightweight method to peek\/poke value from\/to C structs --- when you pass 'MutableByteArray#' to FFI as struct pointer, e.g. --- --- @ --- -- | note the .hsc syntax --- peekSocketAddrMBA :: HasCallStack => MBA## SocketAddr -> IO SocketAddr --- peekSocketAddrMBA p = do --- family <- peekMBA p (#offset struct sockaddr, sa_family) --- case family :: CSaFamily of --- (#const AF_INET) -> do --- addr <- peekMBA p (#offset struct sockaddr_in, sin_addr) --- port <- peekMBA p (#offset struct sockaddr_in, sin_port) --- return (SocketAddrInet (PortNumber port) addr) --- .... --- @ --- -class UnalignedAccess a where - {-# MINIMAL unalignedSize, indexWord8ArrayAs#, writeWord8ArrayAs#, readWord8ArrayAs# | - unalignedSize, indexBA, peekMBA, pokeMBA #-} - -- | byte size - unalignedSize :: UnalignedSize a - - -- | index element off byte array with offset in bytes(maybe unaligned) - indexWord8ArrayAs# :: ByteArray# -> Int# -> a - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = indexBA ba# (I# i#) - - -- | read element from byte array with offset in bytes(maybe unaligned) - readWord8ArrayAs# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s# = - (unsafeCoerce# (peekMBA (unsafeCoerce# mba#) (I# i#) :: IO a)) s# - - -- | write element to byte array with offset in bytes(maybe unaligned) - writeWord8ArrayAs# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# x s# = - unsafeCoerce# (pokeMBA (unsafeCoerce# mba#) (I# i#) x) s# - - -- | IO version of 'writeWord8ArrayAs#' but more convenient to write manually. - peekMBA :: MutableByteArray# RealWorld -> Int -> IO a - {-# INLINE peekMBA #-} - peekMBA mba# (I# i#) = primitive (readWord8ArrayAs# mba# i#) - - -- | IO version of 'readWord8ArrayAs#' but more convenient to write manually. - pokeMBA :: MutableByteArray# RealWorld -> Int -> a -> IO () - {-# INLINE pokeMBA #-} - pokeMBA mba# (I# i#) x = primitive_ (writeWord8ArrayAs# mba# i# x) - - -- | index element off byte array with offset in bytes(maybe unaligned) - indexBA :: ByteArray# -> Int -> a - {-# INLINE indexBA #-} - indexBA ba# (I# i#) = indexWord8ArrayAs# ba# i# - - --- | Lifted version of 'writeWord8ArrayAs#' -writeWord8ArrayAs :: (PrimMonad m, UnalignedAccess a) => MutableByteArray (PrimState m) -> Int -> a -> m () -{-# INLINE writeWord8ArrayAs #-} -writeWord8ArrayAs (MutableByteArray mba#) (I# i#) x = primitive_ (writeWord8ArrayAs# mba# i# x) - --- | Lifted version of 'readWord8ArrayAs#' -readWord8ArrayAs :: (PrimMonad m, UnalignedAccess a) => MutableByteArray (PrimState m) -> Int -> m a -{-# INLINE readWord8ArrayAs #-} -readWord8ArrayAs (MutableByteArray mba#) (I# i#) = primitive (readWord8ArrayAs# mba# i#) - --- | Lifted version of 'indexWord8ArrayAs#' -indexWord8ArrayAs :: UnalignedAccess a => ByteArray -> Int -> a -{-# INLINE indexWord8ArrayAs #-} -indexWord8ArrayAs (ByteArray ba#) (I# i#) = indexWord8ArrayAs# ba# i# - --- | Lifted version of 'writeWord8ArrayAs#' -writePrimWord8ArrayAs :: (PrimMonad m, UnalignedAccess a) => MutablePrimArray (PrimState m) Word8 -> Int -> a -> m () -{-# INLINE writePrimWord8ArrayAs #-} -writePrimWord8ArrayAs (MutablePrimArray mba#) (I# i#) x = primitive_ (writeWord8ArrayAs# mba# i# x) - --- | Lifted version of 'readWord8ArrayAs#' -readPrimWord8ArrayAs :: (PrimMonad m, UnalignedAccess a) => MutablePrimArray (PrimState m) Word8 -> Int -> m a -{-# INLINE readPrimWord8ArrayAs #-} -readPrimWord8ArrayAs (MutablePrimArray mba#) (I# i#) = primitive (readWord8ArrayAs# mba# i#) - --- | Lifted version of 'indexWord8ArrayAs#' -indexPrimWord8ArrayAs :: UnalignedAccess a => PrimArray Word8 -> Int -> a -{-# INLINE indexPrimWord8ArrayAs #-} -indexPrimWord8ArrayAs (PrimArray ba#) (I# i#) = indexWord8ArrayAs# ba# i# - -instance UnalignedAccess Word8 where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 1 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (W8# x#) = writeWord8Array# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8Array# mba# i# s0 in (# s1, W8# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = W8# (indexWord8Array# ba# i#) - -instance UnalignedAccess Int8 where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 1 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (I8# x#) = writeInt8Array# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readInt8Array# mba# i# s0 in (# s1, I8# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = I8# (indexInt8Array# ba# i#) - --- | little endianess wrapper --- -newtype LE a = LE { getLE :: a } deriving (Show, Eq) - --- | big endianess wrapper --- -newtype BE a = BE { getBE :: a } deriving (Show, Eq) - -#define USE_HOST_IMPL(END) \ - {-# INLINE writeWord8ArrayAs# #-}; \ - writeWord8ArrayAs# mba# i# (END x) = writeWord8ArrayAs# mba# i# x; \ - {-# INLINE readWord8ArrayAs# #-}; \ - readWord8ArrayAs# mba# i# s0 = \ - let !(# s1, x #) = readWord8ArrayAs# mba# i# s0 in (# s1, END x #); \ - {-# INLINE indexWord8ArrayAs# #-}; \ - indexWord8ArrayAs# ba# i# = END (indexWord8ArrayAs# ba# i#); - --------------------------------------------------------------------------------- - -instance UnalignedAccess Word16 where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 2 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (W16# x#) = writeWord8ArrayAsWord16# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWord16# mba# i# s0 in (# s1, W16# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = W16# (indexWord8ArrayAsWord16# ba# i#) - -instance UnalignedAccess (LE Word16) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 2 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W16# x#)) s0# = - let s1# = writeWord8Array# mba# i# x# s0# - in writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, w1# #) = readWord8Array# mba# i# s0 - !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 - in (# s2, LE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w1# = indexWord8Array# ba# i# - w2# = indexWord8Array# ba# (i# +# 1#) - in LE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Word16) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 2 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else --- on X86 we use bswap --- TODO: find out if arch64 support this -#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W16# x#)) = writeWord8ArrayAsWord16# mba# i# (byteSwap16# x#) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWord16# mba# i# s0 - in (# s1, BE (W16# (byteSwap16# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = BE (W16# (byteSwap16# (indexWord8ArrayAsWord16# ba# i#))) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W16# x#)) s0# = - let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 8#) s0# - in writeWord8Array# mba# (i# +# 1#) x# s1# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, w2# #) = readWord8Array# mba# i# s0 - !(# s2, w1# #) = readWord8Array# mba# (i# +# 1#) s1 - in (# s2, BE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w2# = indexWord8Array# ba# i# - w1# = indexWord8Array# ba# (i# +# 1#) - in BE (W16# (uncheckedShiftL# w2# 8# `or#` w1#)) -#endif -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Word32 where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (W32# x#) = writeWord8ArrayAsWord32# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWord32# mba# i# s0 in (# s1, W32# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = W32# (indexWord8ArrayAsWord32# ba# i#) - - -instance UnalignedAccess (LE Word32) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W32# x#)) s0# = - let s1# = writeWord8Array# mba# i# x# s0# - s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 16#) s2# - in writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 24#) s3# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, w1# #) = readWord8Array# mba# i# s0 - !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 - !(# s3, w3# #) = readWord8Array# mba# (i# +# 2#) s2 - !(# s4, w4# #) = readWord8Array# mba# (i# +# 3#) s3 - in (# s4, LE (W32# ((uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w1# = indexWord8Array# ba# i# - w2# = indexWord8Array# ba# (i# +# 1#) - w3# = indexWord8Array# ba# (i# +# 2#) - w4# = indexWord8Array# ba# (i# +# 3#) - in LE (W32# ((uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Word32) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else --- on X86 we use bswap --- TODO: find out if arch64 support this -#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W32# x#)) = writeWord8ArrayAsWord32# mba# i# (byteSwap32# x#) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWord32# mba# i# s0 - in (# s1, BE (W32# (byteSwap32# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = BE (W32# (byteSwap32# (indexWord8ArrayAsWord32# ba# i#))) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W32# x#)) s0# = - let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 24#) s0# - s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 16#) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 8#) s2# - in writeWord8Array# mba# (i# +# 3#) x# s3# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, w4# #) = readWord8Array# mba# i# s0 - !(# s2, w3# #) = readWord8Array# mba# (i# +# 1#) s1 - !(# s3, w2# #) = readWord8Array# mba# (i# +# 2#) s2 - !(# s4, w1# #) = readWord8Array# mba# (i# +# 3#) s3 - in (# s4, BE (W32# ((uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w4# = indexWord8Array# ba# i# - w3# = indexWord8Array# ba# (i# +# 1#) - w2# = indexWord8Array# ba# (i# +# 2#) - w1# = indexWord8Array# ba# (i# +# 3#) - in BE (W32# ((uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) -#endif -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Word64 where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (W64# x#) = writeWord8ArrayAsWord64# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWord64# mba# i# s0 in (# s1, W64# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = W64# (indexWord8ArrayAsWord64# ba# i#) - - -instance UnalignedAccess (LE Word64) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W64# x#)) s0# = - let s1# = writeWord8Array# mba# i# x# s0# - s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 8#) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 16#) s2# - s4# = writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 24#) s3# - s5# = writeWord8Array# mba# (i# +# 4#) (uncheckedShiftRL# x# 32#) s4# - s6# = writeWord8Array# mba# (i# +# 5#) (uncheckedShiftRL# x# 40#) s5# - s7# = writeWord8Array# mba# (i# +# 6#) (uncheckedShiftRL# x# 48#) s6# - in writeWord8Array# mba# (i# +# 7#) (uncheckedShiftRL# x# 56#) s7# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, w1# #) = readWord8Array# mba# i# s0 - !(# s2, w2# #) = readWord8Array# mba# (i# +# 1#) s1 - !(# s3, w3# #) = readWord8Array# mba# (i# +# 2#) s2 - !(# s4, w4# #) = readWord8Array# mba# (i# +# 3#) s3 - !(# s5, w5# #) = readWord8Array# mba# (i# +# 4#) s4 - !(# s6, w6# #) = readWord8Array# mba# (i# +# 5#) s5 - !(# s7, w7# #) = readWord8Array# mba# (i# +# 6#) s6 - !(# s8, w8# #) = readWord8Array# mba# (i# +# 7#) s7 - in (# s8, LE (W64# ((uncheckedShiftL# w8# 56#) `or#` - (uncheckedShiftL# w7# 48#) `or#` - (uncheckedShiftL# w6# 40#) `or#` - (uncheckedShiftL# w5# 32#) `or#` - (uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w1# = indexWord8Array# ba# i# - w2# = indexWord8Array# ba# (i# +# 1#) - w3# = indexWord8Array# ba# (i# +# 2#) - w4# = indexWord8Array# ba# (i# +# 3#) - w5# = indexWord8Array# ba# (i# +# 4#) - w6# = indexWord8Array# ba# (i# +# 5#) - w7# = indexWord8Array# ba# (i# +# 6#) - w8# = indexWord8Array# ba# (i# +# 7#) - in LE (W64# ((uncheckedShiftL# w8# 56#) `or#` - (uncheckedShiftL# w7# 48#) `or#` - (uncheckedShiftL# w6# 40#) `or#` - (uncheckedShiftL# w5# 32#) `or#` - (uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Word64) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else --- on X86 we use bswap --- TODO: find out if arch64 support this -#if (defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH)) && defined(USE_BSWAP) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W64# x#)) = writeWord8ArrayAsWord64# mba# i# (byteSwap64# x#) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWord64# mba# i# s0 - in (# s1, BE (W64# (byteSwap64# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = BE (W64# (byteSwap64# (indexWord8ArrayAsWord64# ba# i#))) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W64# x#)) s0# = - let s1# = writeWord8Array# mba# i# (uncheckedShiftRL# x# 56#) s0# - s2# = writeWord8Array# mba# (i# +# 1#) (uncheckedShiftRL# x# 48#) s1# - s3# = writeWord8Array# mba# (i# +# 2#) (uncheckedShiftRL# x# 40#) s2# - s4# = writeWord8Array# mba# (i# +# 3#) (uncheckedShiftRL# x# 32#) s3# - s5# = writeWord8Array# mba# (i# +# 4#) (uncheckedShiftRL# x# 24#) s4# - s6# = writeWord8Array# mba# (i# +# 5#) (uncheckedShiftRL# x# 16#) s5# - s7# = writeWord8Array# mba# (i# +# 6#) (uncheckedShiftRL# x# 8#) s6# - in writeWord8Array# mba# (i# +# 7#) x# s7# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, w8# #) = readWord8Array# mba# i# s0 - !(# s2, w7# #) = readWord8Array# mba# (i# +# 1#) s1 - !(# s3, w6# #) = readWord8Array# mba# (i# +# 2#) s2 - !(# s4, w5# #) = readWord8Array# mba# (i# +# 3#) s3 - !(# s5, w4# #) = readWord8Array# mba# (i# +# 4#) s4 - !(# s6, w3# #) = readWord8Array# mba# (i# +# 5#) s5 - !(# s7, w2# #) = readWord8Array# mba# (i# +# 6#) s6 - !(# s8, w1# #) = readWord8Array# mba# (i# +# 7#) s7 - in (# s8, BE (W64# ((uncheckedShiftL# w8# 56#) `or#` - (uncheckedShiftL# w7# 48#) `or#` - (uncheckedShiftL# w6# 40#) `or#` - (uncheckedShiftL# w5# 32#) `or#` - (uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let w8# = indexWord8Array# ba# i# - w7# = indexWord8Array# ba# (i# +# 1#) - w6# = indexWord8Array# ba# (i# +# 2#) - w5# = indexWord8Array# ba# (i# +# 3#) - w4# = indexWord8Array# ba# (i# +# 4#) - w3# = indexWord8Array# ba# (i# +# 5#) - w2# = indexWord8Array# ba# (i# +# 6#) - w1# = indexWord8Array# ba# (i# +# 7#) - in BE (W64# ((uncheckedShiftL# w8# 56#) `or#` - (uncheckedShiftL# w7# 48#) `or#` - (uncheckedShiftL# w6# 40#) `or#` - (uncheckedShiftL# w5# 32#) `or#` - (uncheckedShiftL# w4# 24#) `or#` - (uncheckedShiftL# w3# 16#) `or#` - (uncheckedShiftL# w2# 8#) `or#` w1#)) -#endif -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Word where -#if SIZEOF_HSWORD == 4 - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#else - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 -#endif - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (W# x#) = writeWord8ArrayAsWord# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWord# mba# i# s0 in (# s1, W# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = W# (indexWord8ArrayAsWord# ba# i#) - -instance UnalignedAccess (LE Word) where -#if SIZEOF_HSWORD == 4 - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W# x#)) = writeWord8ArrayAs# mba# i# (LE (W32# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (W# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (W32# x#)) -> LE (W# x#) -#else - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (W# x#)) = writeWord8ArrayAs# mba# i# (LE (W64# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (W# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (W64# x#)) -> LE (W# x#) -#endif - -instance UnalignedAccess (BE Word) where -#if SIZEOF_HSWORD == 4 - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W# x#)) = writeWord8ArrayAs# mba# i# (BE (W32# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (W# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (W32# x#)) -> BE (W# x#) -#else - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (W# x#)) = writeWord8ArrayAs# mba# i# (BE (W64# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (W# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (W64# x#)) -> BE (W# x#) -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Int16 where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 2 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (I16# x#) = writeWord8ArrayAsInt16# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsInt16# mba# i# s0 in (# s1, I16# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = I16# (indexWord8ArrayAsInt16# ba# i#) - -instance UnalignedAccess (LE Int16) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 2 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I16# x#)) = - writeWord8ArrayAs# mba# i# (LE (W16# (int2Word# x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W16# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (I16# (narrow16Int# (word2Int# x#))) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let LE (W16# x#) = indexWord8ArrayAs# ba# i# - in LE (I16# (narrow16Int# (word2Int# x#))) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Int16) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 2 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I16# x#)) = - writeWord8ArrayAs# mba# i# (BE (W16# (int2Word# x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W16# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (I16# (narrow16Int# (word2Int# x#))) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let !(BE (W16# x#)) = indexWord8ArrayAs# ba# i# - in BE (I16# (narrow16Int# (word2Int# x#))) -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Int32 where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (I32# x#) = writeWord8ArrayAsInt32# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsInt32# mba# i# s0 in (# s1, I32# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = I32# (indexWord8ArrayAsInt32# ba# i#) - -instance UnalignedAccess (LE Int32) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I32# x#)) = - writeWord8ArrayAs# mba# i# (LE (W32# (int2Word# x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (I32# (narrow32Int# (word2Int# x#))) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let LE (W32# x#) = indexWord8ArrayAs# ba# i# - in LE (I32# (narrow32Int# (word2Int# x#))) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Int32) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I32# x#)) = - writeWord8ArrayAs# mba# i# (BE (W32# (int2Word# x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (I32# (narrow32Int# (word2Int# x#))) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let !(BE (W32# x#)) = indexWord8ArrayAs# ba# i# - in BE (I32# (narrow32Int# (word2Int# x#))) -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Int64 where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (I64# x#) = writeWord8ArrayAsInt64# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsInt64# mba# i# s0 in (# s1, I64# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = I64# (indexWord8ArrayAsInt64# ba# i#) - -instance UnalignedAccess (LE Int64) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I64# x#)) = - writeWord8ArrayAs# mba# i# (LE (W64# (int2Word# x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (I64# (word2Int# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let LE (W64# x#) = indexWord8ArrayAs# ba# i# - in LE (I64# (word2Int# x#)) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Int64) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I64# x#)) = - writeWord8ArrayAs# mba# i# (BE (W64# (int2Word# x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (I64# (word2Int# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let !(BE (W64# x#)) = indexWord8ArrayAs# ba# i# - in BE (I64# (word2Int# x#)) -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Int where -#if SIZEOF_HSWORD == 4 - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#else - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 -#endif - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (I# x#) = writeWord8ArrayAsInt# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsInt# mba# i# s0 in (# s1, I# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = I# (indexWord8ArrayAsInt# ba# i#) - -instance UnalignedAccess (LE Int) where -#if SIZEOF_HSWORD == 4 - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I# x#)) = writeWord8ArrayAs# mba# i# (LE (I32# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (I# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (I32# x#)) -> LE (I# x#) -#else - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (I# x#)) = writeWord8ArrayAs# mba# i# (LE (I64# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (I64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, LE (I# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (LE (I64# x#)) -> LE (I# x#) -#endif - -instance UnalignedAccess (BE Int) where -#if SIZEOF_HSWORD == 4 - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I# x#)) = writeWord8ArrayAs# mba# i# (BE (I32# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (I# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (I32# x#)) -> BE (I# x#) -#else - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (I# x#)) = writeWord8ArrayAs# mba# i# (BE (I64# x#)) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (I64# x#) #) = readWord8ArrayAs# mba# i# s0 in (# s1, BE (I# x#) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = case (indexWord8ArrayAs# ba# i#) of (BE (I64# x#)) -> BE (I# x#) -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Float where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (F# x#) = writeWord8ArrayAsFloat# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsFloat# mba# i# s0 in (# s1, F# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = F# (indexWord8ArrayAsFloat# ba# i#) - -instance UnalignedAccess (LE Float) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (F# x#)) = - writeWord8ArrayAs# mba# i# (LE (W32# (stgFloatToWord32 x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (F# (stgWord32ToFloat x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let LE (W32# x#) = indexWord8ArrayAs# ba# i# - in LE (F# (stgWord32ToFloat x#)) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Float) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (F# x#)) = - writeWord8ArrayAs# mba# i# (BE (W32# (stgFloatToWord32 x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (F# (stgWord32ToFloat x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let !(BE (W32# x#)) = indexWord8ArrayAs# ba# i# - in BE (F# (stgWord32ToFloat x#)) -#endif - --------------------------------------------------------------------------------- - -instance UnalignedAccess Double where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (D# x#) = writeWord8ArrayAsDouble# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsDouble# mba# i# s0 in (# s1, D# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = D# (indexWord8ArrayAsDouble# ba# i#) - -instance UnalignedAccess (LE Double) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 8 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (D# x#)) = - writeWord8ArrayAs# mba# i# (LE (W64# (stgDoubleToWord64 x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (D# (stgWord64ToDouble x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let LE (W64# x#) = indexWord8ArrayAs# ba# i# - in LE (D# (stgWord64ToDouble x#)) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Double) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (D# x#)) = - writeWord8ArrayAs# mba# i# (BE (W64# (stgDoubleToWord64 x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (W64# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (D# (stgWord64ToDouble x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let !(BE (W64# x#)) = indexWord8ArrayAs# ba# i# - in BE (D# (stgWord64ToDouble x#)) -#endif - --------------------------------------------------------------------------------- - --- | Char's instance use 31bit wide char prim-op. -instance UnalignedAccess Char where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (C# x#) = writeWord8ArrayAsWideChar# mba# i# x# - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, x# #) = readWord8ArrayAsWideChar# mba# i# s0 in (# s1, C# x# #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = C# (indexWord8ArrayAsWideChar# ba# i#) - -instance UnalignedAccess (LE Char) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (LE (C# x#)) = - writeWord8ArrayAs# mba# i# (LE (I32# (ord# x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, LE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, LE (C# (chr# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let LE (I32# x#) = indexWord8ArrayAs# ba# i# - in LE (C# (chr# x#)) -#else - USE_HOST_IMPL(LE) -#endif - -instance UnalignedAccess (BE Char) where - {-# INLINE unalignedSize #-} - unalignedSize = UnalignedSize 4 -#if defined(WORDS_BIGENDIAN) || defined(USE_SHIFT) - USE_HOST_IMPL(BE) -#else - {-# INLINE writeWord8ArrayAs# #-} - writeWord8ArrayAs# mba# i# (BE (C# x#)) = - writeWord8ArrayAs# mba# i# (BE (I32# (ord# x#))) - {-# INLINE readWord8ArrayAs# #-} - readWord8ArrayAs# mba# i# s0 = - let !(# s1, BE (I32# x#) #) = readWord8ArrayAs# mba# i# s0 - in (# s1, BE (C# (chr# x#)) #) - {-# INLINE indexWord8ArrayAs# #-} - indexWord8ArrayAs# ba# i# = - let !(BE (I32# x#)) = indexWord8ArrayAs# ba# i# - in BE (C# (chr# x#)) -#endif - --------------------------------------------------------------------------------- - --- Prim instances for newtypes in Foreign.C.Types -deriving instance UnalignedAccess CChar -deriving instance UnalignedAccess CSChar -deriving instance UnalignedAccess CUChar -deriving instance UnalignedAccess CShort -deriving instance UnalignedAccess CUShort -deriving instance UnalignedAccess CInt -deriving instance UnalignedAccess CUInt -deriving instance UnalignedAccess CLong -deriving instance UnalignedAccess CULong -deriving instance UnalignedAccess CPtrdiff -deriving instance UnalignedAccess CSize -deriving instance UnalignedAccess CWchar -deriving instance UnalignedAccess CSigAtomic -deriving instance UnalignedAccess CLLong -deriving instance UnalignedAccess CULLong -deriving instance UnalignedAccess CBool -deriving instance UnalignedAccess CIntPtr -deriving instance UnalignedAccess CUIntPtr -deriving instance UnalignedAccess CIntMax -deriving instance UnalignedAccess CUIntMax -deriving instance UnalignedAccess CClock -deriving instance UnalignedAccess CTime -deriving instance UnalignedAccess CUSeconds -deriving instance UnalignedAccess CSUSeconds -deriving instance UnalignedAccess CFloat -deriving instance UnalignedAccess CDouble diff --git a/Z/Data/Builder/Base.hs b/Z/Data/Builder/Base.hs --- a/Z/Data/Builder/Base.hs +++ b/Z/Data/Builder/Base.hs @@ -82,7 +82,7 @@ import GHC.CString (unpackCString#, unpackCStringUtf8#) import GHC.Exts import qualified Z.Data.Array as A -import Z.Data.Array.UnalignedAccess +import Z.Data.Array.Unaligned import qualified Z.Data.Text.Base as T import qualified Z.Data.Text.UTF8Codec as T import qualified Z.Data.Vector.Base as V @@ -378,7 +378,7 @@ f buf offset >> k () (Buffer buf (offset+n))) -- | write primitive types in host byte order. -encodePrim :: forall a. UnalignedAccess a => a -> Builder () +encodePrim :: forall a. Unaligned a => a -> Builder () {-# INLINE encodePrim #-} {-# SPECIALIZE INLINE encodePrim :: Word -> Builder () #-} {-# SPECIALIZE INLINE encodePrim :: Word64 -> Builder () #-} @@ -396,10 +396,10 @@ writePrimWord8ArrayAs mpa i x k () (Buffer mpa (i + n))) where - n = (getUnalignedSize (unalignedSize :: UnalignedSize a)) + n = unalignedSize (undefined :: a) -- | write primitive types with little endianess. -encodePrimLE :: forall a. UnalignedAccess (LE a) => a -> Builder () +encodePrimLE :: forall a. Unaligned (LE a) => a -> Builder () {-# INLINE encodePrimLE #-} {-# SPECIALIZE INLINE encodePrimLE :: Word -> Builder () #-} {-# SPECIALIZE INLINE encodePrimLE :: Word64 -> Builder () #-} @@ -412,7 +412,7 @@ encodePrimLE = encodePrim . LE -- | write primitive types with big endianess. -encodePrimBE :: forall a. UnalignedAccess (BE a) => a -> Builder () +encodePrimBE :: forall a. Unaligned (BE a) => a -> Builder () {-# INLINE encodePrimBE #-} {-# SPECIALIZE INLINE encodePrimBE :: Word -> Builder () #-} {-# SPECIALIZE INLINE encodePrimBE :: Word64 -> Builder () #-} diff --git a/Z/Data/Builder/Numeric.hs b/Z/Data/Builder/Numeric.hs --- a/Z/Data/Builder/Numeric.hs +++ b/Z/Data/Builder/Numeric.hs @@ -709,19 +709,19 @@ -- | Decimal encoding of a 'Double', note grisu only handles strictly positive finite numbers. grisu3 :: Double -> ([Int], Int) {-# INLINE grisu3 #-} -grisu3 d = snd . unsafePerformIO $ - allocMutablePrimArrayUnsafe @Word8 GRISU3_DOUBLE_BUF_LEN $ \ pBuf -> do - (len, (e, success)) <- allocPrimUnsafe $ \ pLen -> - allocPrimUnsafe $ \ pE -> - c_grisu3 (realToFrac d) pBuf pLen pE - if success == 0 -- grisu3 fail - then pure (floatToDigits 10 d) - else do - buf <- forM [0..len-1] $ \ i -> do - w8 <- readByteArray (MutableByteArray pBuf) i :: IO Word8 - pure $! fromIntegral w8 - let !e' = e + len - pure (buf, e') +grisu3 d = unsafePerformIO $ do + (MutableByteArray pBuf) <- newByteArray GRISU3_DOUBLE_BUF_LEN + (len, (e, success)) <- allocPrimUnsafe $ \ pLen -> + allocPrimUnsafe $ \ pE -> + c_grisu3 (realToFrac d) pBuf pLen pE + if success == 0 -- grisu3 fail + then pure (floatToDigits 10 d) + else do + buf <- forM [0..len-1] $ \ i -> do + w8 <- readByteArray (MutableByteArray pBuf) i :: IO Word8 + pure $! fromIntegral w8 + let !e' = e + len + pure (buf, e') foreign import ccall unsafe "static grisu3_sp" c_grisu3_sp :: Float @@ -733,19 +733,19 @@ -- | Decimal encoding of a 'Float', note grisu3_sp only handles strictly positive finite numbers. grisu3_sp :: Float -> ([Int], Int) {-# INLINE grisu3_sp #-} -grisu3_sp d = snd . unsafePerformIO $ - allocMutablePrimArrayUnsafe @Word8 GRISU3_SINGLE_BUF_LEN $ \ pBuf -> do - (len, (e, success)) <- allocPrimUnsafe $ \ pLen -> - allocPrimUnsafe $ \ pE -> - c_grisu3_sp (realToFrac d) pBuf pLen pE - if success == 0 -- grisu3 fail - then pure (floatToDigits 10 d) - else do - buf <- forM [0..len-1] $ \ i -> do - w8 <- readByteArray (MutableByteArray pBuf) i :: IO Word8 - pure $! fromIntegral w8 - let !e' = e + len - pure (buf, e') +grisu3_sp d = unsafePerformIO $ do + (MutableByteArray pBuf) <- newByteArray GRISU3_SINGLE_BUF_LEN + (len, (e, success)) <- allocPrimUnsafe $ \ pLen -> + allocPrimUnsafe $ \ pE -> + c_grisu3_sp (realToFrac d) pBuf pLen pE + if success == 0 -- grisu3 fail + then pure (floatToDigits 10 d) + else do + buf <- forM [0..len-1] $ \ i -> do + w8 <- readByteArray (MutableByteArray pBuf) i :: IO Word8 + pure $! fromIntegral w8 + let !e' = e + len + pure (buf, e') -------------------------------------------------------------------------------- diff --git a/Z/Data/CBytes.hs b/Z/Data/CBytes.hs --- a/Z/Data/CBytes.hs +++ b/Z/Data/CBytes.hs @@ -1,9 +1,11 @@ {-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE UnliftedFFITypes #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE PatternSynonyms #-} {-| Module : Z.Data.CBytes Description : Null-ternimated byte string. @@ -13,47 +15,24 @@ Stability : experimental Portability : non-portable -This module provide 'CBytes' with some useful instances \/ functions, A 'CBytes' is a -wrapper for immutable null-terminated string. -The main design target of this type is to ease the bridging of C FFI APIs, since most -of the unix APIs use null-terminated string. On windows you're encouraged to use a -compatibility layer like 'WideCharToMultiByte/MultiByteToWideChar' and keep the same -interface, e.g. libuv do this when deal with file paths. - -We neither guarantee to store length info, nor support O(1) slice for 'CBytes': -This will defeat the purpose of null-terminated string which is to save memory, -We do save the length if it's created on GHC heap though. If you need advance editing, -convert a 'CBytes' to 'V.Bytes' with 'toBytes' and use vector combinators. -Use 'fromBytes' to convert it back. - -It can be used with @OverloadedString@, literal encoding is UTF-8 with some modifications: -@\NUL@ char is encoded to 'C0 80', and '\xD800' ~ '\xDFFF' is encoded as a three bytes -normal utf-8 codepoint. This is also how ghc compile string literal into binaries, -thus we can use rewrite-rules to construct 'CBytes' value in O(1) without wasting runtime heap. - -Note most of the unix API is not unicode awared though, you may find a `scandir` call -return a filename which is not proper encoded in any unicode encoding at all. -But still, UTF-8 is recommanded to be used everywhere, and we use UTF-8 assumption in -various places, such as displaying 'CBytes' and literals encoding above. +-- This module provide 'CBytes' with some useful instances \/ tools for retrieving, storing or processing +-- short byte sequences, such as file path, environment variables, etc. -} module Z.Data.CBytes - ( CBytes - , create + ( CBytes(CB) + , toPrimArray , pack , unpack , null , length , empty, append, concat, intercalate, intercalateElem , toBytes, fromBytes, toText, toTextMaybe, fromText - , fromCString, fromCString', fromCStringN - , withCBytes, allocCBytes - -- helpers re-export - , V.w2c, V.c2w - -- * exception - , NullPointerException(..) + , fromCString, fromCStringN + , withCBytesUnsafe, withCBytes, allocCBytesUnsafe, allocCBytes -- re-export , CString + , V.c2w, V.w2c ) where import Control.DeepSeq @@ -65,12 +44,11 @@ import Data.Foldable (foldlM) import Data.Hashable (Hashable(..)) import qualified Data.List as List -import Data.String (IsString (..)) import Data.Typeable import Data.Primitive.PrimArray import Data.Word -import Foreign.C -import Foreign.Storable (peekElemOff) +import Foreign.C.String +import GHC.Exts import GHC.CString import GHC.Ptr import GHC.Stack @@ -86,84 +64,75 @@ unlines, unzip, writeFile, zip, zipWith) import Z.Data.Array +import Z.Data.Array.Unaligned import qualified Z.Data.Text as T -import Z.Data.Text.UTF8Codec (encodeCharModifiedUTF8) +import Z.Data.Text.UTF8Codec (encodeCharModifiedUTF8, decodeChar) import qualified Z.Data.Vector.Base as V +import Z.Foreign import System.IO.Unsafe (unsafeDupablePerformIO) --- | A efficient wrapper for immutable null-terminated string which can be +-- | A efficient wrapper for short immutable null-terminated byte sequences which can be -- automatically freed by ghc garbage collector. -- -data CBytes - = CBytesOnHeap {-# UNPACK #-} !(PrimArray Word8) -- ^ On heap pinned 'PrimArray' - -- there's an invariance that this array's - -- length is always shrinked to contain content - -- and \NUL terminator - | CBytesLiteral {-# UNPACK #-} !CString -- ^ String literals with static address - --- | Create a 'CBytes' with IO action. +-- The main use case of this type is to ease the bridging of C FFI APIs, since most +-- of the unix APIs use null-terminated string. On windows you're encouraged to use a +-- compatibility layer like 'WideCharToMultiByte/MultiByteToWideChar' and keep the same +-- interface, e.g. libuv do this when deal with file paths. -- +-- 'CBytes' don't support O(1) slicing, it's not suitable to use it to store large byte +-- chunk, If you need advance editing, convert 'CBytes' to \/ from 'PrimArray' with 'CB', +-- or 'V.Bytes' with 'toBytes\/fromBytes' if you need O(1) slicing, then use vector combinators. -- --- User only have to do content initialization and return the content length, --- 'create' takes the responsibility to add the @\NUL@ ternimator. If the --- initialize function write @\NUL@ terminator(most FFI functions for example), --- you should use 'allocCBytes'. +-- When textual represatation is needed(conver to 'String', 'T.Text', 'Show' instance, etc.), +-- we assume 'CBytes' using UTF-8 encodings, 'CBytes' can be used with @OverloadedString@, +-- literal encoding is UTF-8 with some modifications: @\NUL@ is encoded to 'C0 80', +-- and '\xD800' ~ '\xDFFF' is encoded as a three bytes normal utf-8 codepoint. -- --- If (<=0) capacity is provided, a 'nullPtr' is passed to initialize function and --- 'empty' will be returned. other than that, if length returned is larger than (capacity-1), --- a 'NULLTerminatorNotFound' will be thrown. -create :: HasCallStack - => Int -- ^ capacity n, including the @\NUL@ terminator - -> (CString -> IO Int) -- ^ initialize function - -- write the pointer, return the length (<= n-1) - -> IO CBytes -{-# INLINE create #-} -create n fill | n <= 0 = fill nullPtr >> return empty - | otherwise = do - mba <- newPinnedPrimArray n :: IO (MutablePrimArray RealWorld Word8) - l <- withMutablePrimArrayContents mba (fill . castPtr) - when (l+1>n) (throwIO (NULLTerminatorNotFound callStack)) - writePrimArray mba l 0 -- the @\NUL@ ternimator - shrinkMutablePrimArray mba (l+1) - CBytesOnHeap <$> unsafeFreezePrimArray mba +-- Note most of the unix API is not unicode awared though, you may find a `scandir` call +-- return a filename which is not proper encoded in any unicode encoding at all. +-- But still, UTF-8 is recommanded to be used when text represatation is needed. +-- -- +data CBytes = CBytes + { + -- | Convert to 'PrimArray', + -- + -- there's an invariance that this array never contains @\NUL@ + toPrimArray :: {-# UNPACK #-} !(PrimArray Word8) + } --- | All exception can be throw by using 'CBytes'. -data CBytesException = NULLTerminatorNotFound CallStack - deriving (Show, Typeable) -instance Exception CBytesException +-- | Use this pattern to match or construct 'CBytes', result will be trimmed down to first byte before @\NUL@ byte if there's any. +pattern CB :: PrimArray Word8 -> CBytes +pattern CB arr <- CBytes arr where + CB arr = fromPrimArray arr +fromPrimArray :: PrimArray Word8 -> CBytes +{-# INLINE fromPrimArray #-} +fromPrimArray arr = runST ( + case V.elemIndex 0 arr of + Just i -> do + mpa <- newPrimArray i + copyPrimArray mpa 0 arr 0 i + pa <- unsafeFreezePrimArray mpa + return (CBytes pa) + _ -> return (CBytes arr)) + instance Show CBytes where - show = unpack + showsPrec p t = showsPrec p (unpack t) instance Read CBytes where readsPrec p s = [(pack x, r) | (x, r) <- readsPrec p s] instance NFData CBytes where {-# INLINE rnf #-} - rnf (CBytesOnHeap _) = () - rnf (CBytesLiteral _) = () + rnf (CBytes _) = () instance Eq CBytes where {-# INLINE (==) #-} - cbyteA == cbyteB = unsafeDupablePerformIO $ - withCBytes cbyteA $ \ pA -> - withCBytes cbyteB $ \ pB -> - if pA == pB - then return True - else do - r <- c_strcmp pA pB - return (r == 0) + CBytes ba == CBytes bb = ba == bb instance Ord CBytes where {-# INLINE compare #-} - cbyteA `compare` cbyteB = unsafeDupablePerformIO $ - withCBytes cbyteA $ \ pA -> - withCBytes cbyteB $ \ pB -> - if pA == pB - then return EQ - else do - r <- c_strcmp pA pB - return (r `compare` 0) + CBytes ba `compare` CBytes bb = ba `compare` bb instance Semigroup CBytes where (<>) = append @@ -177,36 +146,60 @@ mconcat = concat instance Hashable CBytes where - hashWithSalt salt (CBytesOnHeap pa@(PrimArray ba#)) = unsafeDupablePerformIO $ do - V.c_fnv_hash_ba ba# 0 (sizeofPrimArray pa - 1) salt - hashWithSalt salt (CBytesLiteral p@(Ptr addr#)) = unsafeDupablePerformIO $ do - len <- c_strlen p - V.c_fnv_hash_addr addr# (fromIntegral len) salt + hashWithSalt salt (CBytes pa@(PrimArray ba#)) = unsafeDupablePerformIO $ do + V.c_fnv_hash_ba ba# 0 (sizeofPrimArray pa) salt +-- | This instance peek bytes until @\NUL@(or input chunk ends), poke bytes with an extra \NUL terminator. +instance Unaligned CBytes where + {-# INLINE unalignedSize #-} + unalignedSize (CBytes arr) = sizeofPrimArray arr + 1 + {-# INLINE peekMBA #-} + peekMBA mba# i = do + b <- getSizeofMutableByteArray (MutableByteArray mba#) + let rest = b-i + l <- c_memchr mba# i 0 rest + let l' = if l == -1 then rest else l + mpa <- newPrimArray l' + copyMutablePrimArray mpa 0 (MutablePrimArray mba#) i l' + pa <- unsafeFreezePrimArray mpa + return (CBytes pa) + + {-# INLINE pokeMBA #-} + pokeMBA mba# i (CBytes pa) = do + let l = sizeofPrimArray pa + copyPrimArray (MutablePrimArray mba# :: MutablePrimArray RealWorld Word8) i pa 0 l + writePrimArray (MutablePrimArray mba# :: MutablePrimArray RealWorld Word8) (i+l) 0 + + {-# INLINE indexBA #-} + indexBA ba# i = runST (do + let b = sizeofByteArray (ByteArray ba#) + rest = b-i + l = V.c_memchr ba# i 0 rest + l' = if l == -1 then rest else l + mpa <- newPrimArray l' + copyPrimArray mpa 0 (PrimArray ba#) i l' + pa <- unsafeFreezePrimArray mpa + return (CBytes pa)) + append :: CBytes -> CBytes -> CBytes {-# INLINABLE append #-} -append strA strB +append strA@(CBytes pa) strB@(CBytes pb) | lenA == 0 = strB | lenB == 0 = strA | otherwise = unsafeDupablePerformIO $ do - mpa <- newPinnedPrimArray (lenA+lenB+1) - withCBytes strA $ \ pa -> - withCBytes strB $ \ pb -> do - copyPtrToMutablePrimArray mpa 0 (castPtr pa) lenA - copyPtrToMutablePrimArray mpa lenA (castPtr pb) lenB - writePrimArray mpa (lenA + lenB) 0 -- the \NUL terminator - pa' <- unsafeFreezePrimArray mpa - return (CBytesOnHeap pa') + mpa <- newPrimArray (lenA+lenB) + copyPrimArray mpa 0 pa 0 lenA + copyPrimArray mpa lenA pb 0 lenB + pa' <- unsafeFreezePrimArray mpa + return (CBytes pa') where lenA = length strA lenB = length strB --- | 'empty' 'CBytes' --- --- Passing 'empty' to C FFI is equivalent to passing a @NULL@ pointer. +-- | An empty 'CBytes' empty :: CBytes {-# NOINLINE empty #-} -empty = CBytesLiteral (Ptr "\0"#) +empty = CBytes (V.empty) concat :: [CBytes] -> CBytes {-# INLINABLE concat #-} @@ -214,10 +207,9 @@ (0, _) -> empty (1, _) -> let Just b = List.find (not . null) bss in b -- there must be a not empty CBytes (_, l) -> runST $ do - buf <- newPinnedPrimArray (l+1) + buf <- newPrimArray l copy bss 0 buf - writePrimArray buf l 0 -- the \NUL terminator - CBytesOnHeap <$> unsafeFreezePrimArray buf + CBytes <$> unsafeFreezePrimArray buf where -- pre scan to decide if we really need to copy and calculate total length -- we don't accumulate another result list, since it's rare to got empty @@ -230,13 +222,9 @@ copy :: [CBytes] -> Int -> MutablePrimArray s Word8 -> ST s () copy [] !_ !_ = return () - copy (b:bs) !i !mba = do + copy (b@(CBytes ba):bs) !i !mba = do let l = length b - when (l /= 0) (case b of - CBytesOnHeap ba -> - copyPrimArray mba i ba 0 l - CBytesLiteral p -> - copyPtrToMutablePrimArray mba i (castPtr p) l) + when (l /= 0) (copyPrimArray mba i ba 0 l) copy bs (i+l) mba -- | /O(n)/ The 'intercalate' function takes a 'CBytes' and a list of @@ -249,31 +237,28 @@ {-# INLINE intercalate #-} intercalate s = concat . List.intersperse s - -- | /O(n)/ An efficient way to join 'CByte' s with a byte. -- +-- Intercalate bytes list with @\NUL@ will effectively leave the first bytes in the list. intercalateElem :: Word8 -> [CBytes] -> CBytes {-# INLINABLE intercalateElem #-} +intercalateElem 0 [] = empty +intercalateElem 0 (bs:_) = bs intercalateElem w8 bss = case len bss 0 of 0 -> empty l -> runST $ do - buf <- newPinnedPrimArray (l+1) + buf <- newPrimArray l copy bss 0 buf - writePrimArray buf l 0 -- the \NUL terminator - CBytesOnHeap <$> unsafeFreezePrimArray buf + CBytes <$> unsafeFreezePrimArray buf where len [] !acc = acc len [b] !acc = length b + acc len (b:bs) !acc = len bs (acc + length b + 1) copy :: [CBytes] -> Int -> MutablePrimArray s Word8 -> ST s () -- bss must not be empty, which is checked by len above - copy (b:bs) !i !mba = do + copy (b@(CBytes ba):bs) !i !mba = do let l = length b - when (l /= 0) (case b of - CBytesOnHeap ba -> - copyPrimArray mba i ba 0 l - CBytesLiteral p -> - copyPtrToMutablePrimArray mba i (castPtr p) l) + when (l /= 0) (copyPrimArray mba i ba 0 l) case bs of [] -> return () -- last one _ -> do @@ -287,32 +272,41 @@ {-# RULES "CBytes pack/unpackCString#" forall addr# . - pack (unpackCString# addr#) = CBytesLiteral (Ptr addr#) + pack (unpackCString# addr#) = packAddr addr# #-} {-# RULES "CBytes pack/unpackCStringUtf8#" forall addr# . - pack (unpackCStringUtf8# addr#) = CBytesLiteral (Ptr addr#) + pack (unpackCStringUtf8# addr#) = packAddr addr# #-} --- | Pack a 'String' into null-terminated 'CBytes'. +packAddr :: Addr# -> CBytes +packAddr addr0# = go addr0# + where + len = (fromIntegral . unsafeDupablePerformIO $ V.c_strlen addr0#) + go addr# = runST $ do + marr <- newPrimArray len + copyPtrToMutablePrimArray marr 0 (Ptr addr#) len + arr <- unsafeFreezePrimArray marr + return (CBytes arr) + +-- | Pack a 'String' into 'CBytes'. -- -- @\NUL@ is encoded as two bytes @C0 80@ , '\xD800' ~ '\xDFFF' is encoded as a three bytes normal UTF-8 codepoint. pack :: String -> CBytes {-# INLINE CONLIKE [1] pack #-} pack s = runST $ do - mba <- newPinnedPrimArray V.defaultInitSize + mba <- newPrimArray V.defaultInitSize (SP2 i mba') <- foldlM go (SP2 0 mba) s - writePrimArray mba' i 0 -- the \NUL terminator - shrinkMutablePrimArray mba' (i+1) + shrinkMutablePrimArray mba' i ba <- unsafeFreezePrimArray mba' - return (CBytesOnHeap ba) + return (CBytes ba) where -- It's critical that this function get specialized and unboxed -- Keep an eye on its core! go :: SP2 s -> Char -> ST s (SP2 s) go (SP2 i mba) !c = do siz <- getSizeofMutablePrimArray mba - if i < siz - 4 -- we need at least 5 bytes for safety due to extra '\0' byte + if i < siz - 3 -- we need at least 4 bytes for safety then do i' <- encodeCharModifiedUTF8 mba i c return (SP2 i' mba) @@ -325,47 +319,74 @@ data SP2 s = SP2 {-# UNPACK #-}!Int {-# UNPACK #-}!(MutablePrimArray s Word8) +-- | /O(n)/ Convert cbytes to a char list using UTF8 encoding assumption. +-- +-- This function is much tolerant than 'toText', it simply decoding codepoints using UTF8 'decodeChar' +-- without checking errors such as overlong or invalid range. +-- +-- Unpacking is done lazily. i.e. we will retain reference to the array until all element are consumed. +-- +-- This function is a /good producer/ in the sense of build/foldr fusion. unpack :: CBytes -> String -{-# INLINABLE unpack #-} --- TODO: rewrite with our own decoder -unpack cbytes = unsafeDupablePerformIO . withCBytes cbytes $ \ (Ptr addr#) -> - return (unpackCStringUtf8# addr#) +{-# INLINE [1] unpack #-} +unpack (CBytes arr) = go 0 + where + !end = sizeofPrimArray arr + go !idx + | idx >= end = [] + | otherwise = let (# c, i #) = decodeChar arr idx in c : go (idx + i) +unpackFB :: CBytes -> (Char -> a -> a) -> a -> a +{-# INLINE [0] unpackFB #-} +unpackFB (CBytes arr) k z = go 0 + where + !end = sizeofPrimArray arr + go !idx + | idx >= end = z + | otherwise = let (# c, i #) = decodeChar arr idx in c `k` go (idx + i) + +{-# RULES +"unpack" [~1] forall t . unpack t = build (\ k z -> unpackFB t k z) +"unpackFB" [1] forall t . unpackFB t (:) [] = unpack t + #-} + -------------------------------------------------------------------------------- +-- | Return 'True' if 'CBytes' is empty. +-- null :: CBytes -> Bool {-# INLINE null #-} -null (CBytesOnHeap pa) = indexPrimArray pa 0 == 0 -null (CBytesLiteral p) = unsafeDupablePerformIO (peekElemOff p 0) == 0 +null (CBytes pa) = sizeofPrimArray pa == 0 +-- | Return the BTYE length of 'CBytes'. +-- length :: CBytes -> Int {-# INLINE length #-} -length (CBytesOnHeap pa) = sizeofPrimArray pa - 1 -length (CBytesLiteral p) = fromIntegral $ unsafeDupablePerformIO (c_strlen p) +length (CBytes pa) = sizeofPrimArray pa --- | /O(1)/, (/O(n)/ in case of literal), convert to 'V.Bytes', which can be --- processed by vector combinators. --- --- NOTE: the @\NUL@ ternimator is not included. +-- | /O(1)/, convert to 'V.Bytes', which can be processed by vector combinators. toBytes :: CBytes -> V.Bytes {-# INLINABLE toBytes #-} -toBytes cbytes@(CBytesOnHeap pa) = V.PrimVector pa 0 l - where l = length cbytes -toBytes cbytes@(CBytesLiteral p) = V.create (l+1) (\ mpa -> do - copyPtrToMutablePrimArray mpa 0 (castPtr p) l - writePrimArray mpa l 0) -- the \NUL terminator - where l = length cbytes +toBytes (CBytes arr) = V.PrimVector arr 0 (sizeofPrimArray arr) --- | /O(n)/, convert from 'V.Bytes', allocate pinned memory and --- add the @\NUL@ ternimator +-- | /O(n)/, convert from 'V.Bytes' +-- +-- Result will be trimmed down to first byte before @\NUL@ byte if there's any. fromBytes :: V.Bytes -> CBytes {-# INLINABLE fromBytes #-} -fromBytes (V.Vec arr s l) = runST (do - mpa <- newPinnedPrimArray (l+1) - copyPrimArray mpa 0 arr s l - writePrimArray mpa l 0 -- the \NUL terminator - pa <- unsafeFreezePrimArray mpa - return (CBytesOnHeap pa)) +fromBytes v@(V.PrimVector arr s l) = runST (do + case V.elemIndex 0 v of + Just i -> do + mpa <- newPrimArray i + copyPrimArray mpa 0 arr s i + pa <- unsafeFreezePrimArray mpa + return (CBytes pa) + _ | s == 0 && sizeofPrimArray arr == l -> return (CBytes arr) + | otherwise -> do + mpa <- newPrimArray l + copyPrimArray mpa 0 arr s l + pa <- unsafeFreezePrimArray mpa + return (CBytes pa)) -- | /O(n)/, convert to 'T.Text' using UTF8 encoding assumption. -- @@ -381,15 +402,15 @@ {-# INLINABLE toTextMaybe #-} toTextMaybe = T.validateMaybe . toBytes --- | /O(n)/, convert from 'T.Text', allocate pinned memory and --- add the @\NUL@ ternimator +-- | /O(n)/, convert from 'T.Text', +-- +-- Result will be trimmed down to first byte before @\NUL@ byte if there's any. fromText :: T.Text -> CBytes {-# INLINABLE fromText #-} fromText = fromBytes . T.getUTF8Bytes -------------------------------------------------------------------------------- - -- | Copy a 'CString' type into a 'CBytes', return 'empty' if the pointer is NULL. -- -- After copying you're free to free the 'CString' 's memory. @@ -399,79 +420,101 @@ if cstring == nullPtr then return empty else do - len <- fromIntegral <$> c_strlen cstring - mpa <- newPinnedPrimArray (len+1) + len <- fromIntegral <$> c_strlen_ptr cstring + mpa <- newPrimArray len copyPtrToMutablePrimArray mpa 0 (castPtr cstring) len - writePrimArray mpa len 0 -- the \NUL terminator pa <- unsafeFreezePrimArray mpa - return (CBytesOnHeap pa) - --- | Same with 'fromCString', but throw 'NullPointerException' when meet a null pointer. --- -fromCString' :: HasCallStack => CString -> IO (Maybe CBytes) -{-# INLINABLE fromCString' #-} -fromCString' cstring = - if cstring == nullPtr - then throwIO (NullPointerException callStack) - else do - len <- fromIntegral <$> c_strlen cstring - mpa <- newPinnedPrimArray (len+1) - copyPtrToMutablePrimArray mpa 0 (castPtr cstring) len - writePrimArray mpa len 0 -- the \NUL terminator - pa <- unsafeFreezePrimArray mpa - return (Just (CBytesOnHeap pa)) + return (CBytes pa) --- | Same with 'fromCString', but only take N bytes (and append a null byte as terminator). +-- | Same with 'fromCString', but only take at most N bytes. -- +-- Result will be trimmed down to first byte before @\NUL@ byte if there's any. fromCStringN :: CString -> Int -> IO CBytes {-# INLINABLE fromCStringN #-} -fromCStringN cstring len = do - if cstring == nullPtr || len == 0 +fromCStringN cstring len0 = do + if cstring == nullPtr || len0 == 0 then return empty else do - mpa <- newPinnedPrimArray (len+1) + len1 <- fromIntegral <$> c_strlen_ptr cstring + let len = min len0 len1 + mpa <- newPrimArray len copyPtrToMutablePrimArray mpa 0 (castPtr cstring) len - writePrimArray mpa len 0 -- the \NUL terminator pa <- unsafeFreezePrimArray mpa - return (CBytesOnHeap pa) + return (CBytes pa) -data NullPointerException = NullPointerException CallStack deriving (Show, Typeable) -instance Exception NullPointerException +-- | Pass 'CBytes' to foreign function as a @const char*@. +-- +-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. +withCBytesUnsafe :: CBytes -> (BA# Word8 -> IO a) -> IO a +{-# INLINABLE withCBytesUnsafe #-} +withCBytesUnsafe (CBytes pa) f = do + let l = sizeofPrimArray pa + mpa <- newPrimArray (l+1) + copyPrimArray mpa 0 pa 0 l + writePrimArray mpa l 0 + pa' <- unsafeFreezePrimArray mpa + withPrimArrayUnsafe pa' (\ p _ -> f p) -- | Pass 'CBytes' to foreign function as a @const char*@. -- -- Don't pass a forever loop to this function, see . -withCBytes :: CBytes -> (CString -> IO a) -> IO a +withCBytes :: CBytes -> (Ptr Word8 -> IO a) -> IO a {-# INLINABLE withCBytes #-} -withCBytes (CBytesOnHeap pa) f = withPrimArrayContents pa (f . castPtr) -withCBytes (CBytesLiteral ptr) f = f ptr +withCBytes (CBytes pa) f = do + let l = sizeofPrimArray pa + mpa <- newPinnedPrimArray (l+1) + copyPrimArray mpa 0 pa 0 l + writePrimArray mpa l 0 + pa' <- unsafeFreezePrimArray mpa + withPrimArraySafe pa' (\ p _ -> f p) -- | Create a 'CBytes' with IO action. -- +-- If (<=0) capacity is provided, a pointer pointing to @\NUL@ is passed to initialize function +-- and 'empty' will be returned. This behavior is different from 'allocCBytes', which may cause +-- trouble for some FFI functions. +-- +-- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. +allocCBytesUnsafe :: HasCallStack + => Int -- ^ capacity n(include the @\NUL@ terminator) + -> (MBA# Word8 -> IO a) -- ^ initialization function, + -> IO (CBytes, a) +{-# INLINABLE allocCBytesUnsafe #-} +allocCBytesUnsafe n fill | n <= 0 = withPrimUnsafe (0::Word8) fill >>= + \ (_, b) -> return (empty, b) + | otherwise = do + mba@(MutablePrimArray mba#) <- newPrimArray n :: IO (MutablePrimArray RealWorld Word8) + a <- fill mba# + l <- fromIntegral <$> (c_memchr mba# 0 0 n) + shrinkMutablePrimArray mba (if l == -1 then n else l) + bs <- unsafeFreezePrimArray mba + return (CBytes bs, a) + + +-- | Create a 'CBytes' with IO action. +-- -- If (<=0) capacity is provided, a 'nullPtr' is passed to initialize function and -- 'empty' will be returned. Other than that, User have to make sure a @\NUL@ ternimated --- string will be written, otherwise a 'NULLTerminatorNotFound' will be thrown. +-- string will be written. allocCBytes :: HasCallStack - => Int -- ^ capacity n, including the @\NUL@ terminator - -> (CString -> IO a) -- ^ initialization function, - -> IO (CBytes, a) + => Int -- ^ capacity n(include the @\NUL@ terminator) + -> (CString -> IO a) -- ^ initialization function, + -> IO (CBytes, a) {-# INLINABLE allocCBytes #-} allocCBytes n fill | n <= 0 = fill nullPtr >>= \ a -> return (empty, a) | otherwise = do - mba <- newPinnedPrimArray n :: IO (MutablePrimArray RealWorld Word8) + mba@(MutablePrimArray mba#) <- newPinnedPrimArray n :: IO (MutablePrimArray RealWorld Word8) a <- withMutablePrimArrayContents mba (fill . castPtr) - l <- fromIntegral <$> withMutablePrimArrayContents mba (c_strlen . castPtr) - when (l+1>n) (throwIO (NULLTerminatorNotFound callStack)) - shrinkMutablePrimArray mba (l+1) + l <- fromIntegral <$> (c_memchr mba# 0 0 n) + shrinkMutablePrimArray mba (if l == -1 then n else l) bs <- unsafeFreezePrimArray mba - return (CBytesOnHeap bs, a) + return (CBytes bs, a) -------------------------------------------------------------------------------- -c_strcmp :: CString -> CString -> IO CInt -{-# INLINE c_strcmp #-} -c_strcmp (Ptr a#) (Ptr b#) = V.c_strcmp a# b# +c_strlen_ptr :: CString -> IO CSize +{-# INLINE c_strlen_ptr #-} +c_strlen_ptr (Ptr a#) = V.c_strlen a# -c_strlen :: CString -> IO CSize -{-# INLINE c_strlen #-} -c_strlen (Ptr a#) = V.c_strlen a# +-- HsInt hs_memchr(uint8_t *a, HsInt aoff, uint8_t b, HsInt n); +foreign import ccall unsafe "hs_memchr" c_memchr :: MBA# Word8 -> Int -> Word8 -> Int -> IO Int diff --git a/Z/Data/Parser/Base.hs b/Z/Data/Parser/Base.hs --- a/Z/Data/Parser/Base.hs +++ b/Z/Data/Parser/Base.hs @@ -52,7 +52,7 @@ import Data.Word import GHC.Types import Prelude hiding (take, takeWhile) -import Z.Data.Array.UnalignedAccess +import Z.Data.Array.Unaligned import qualified Z.Data.Text.Base as T import qualified Z.Data.Vector.Base as V import qualified Z.Data.Vector.Extra as V @@ -279,7 +279,7 @@ then Partial (\ inp' -> k (V.null inp') inp') else k False inp -decodePrim :: forall a. (UnalignedAccess a) => Parser a +decodePrim :: forall a. (Unaligned a) => Parser a {-# INLINE decodePrim #-} {-# SPECIALIZE INLINE decodePrim :: Parser Word #-} {-# SPECIALIZE INLINE decodePrim :: Parser Word64 #-} @@ -297,9 +297,9 @@ let !r = indexPrimWord8ArrayAs ba i in k r (V.PrimVector ba (i+n) (len-n))) where - n = getUnalignedSize (unalignedSize :: UnalignedSize a) + n = unalignedSize (undefined :: a) -decodePrimLE :: forall a. (UnalignedAccess (LE a)) => Parser a +decodePrimLE :: forall a. (Unaligned (LE a)) => Parser a {-# INLINE decodePrimLE #-} {-# SPECIALIZE INLINE decodePrimLE :: Parser Word #-} {-# SPECIALIZE INLINE decodePrimLE :: Parser Word64 #-} @@ -315,9 +315,9 @@ let !r = indexPrimWord8ArrayAs ba i in k (getLE r) (V.PrimVector ba (i+n) (len-n))) where - n = getUnalignedSize (unalignedSize :: UnalignedSize (LE a)) + n = unalignedSize (undefined :: (LE a)) -decodePrimBE :: forall a. (UnalignedAccess (BE a)) => Parser a +decodePrimBE :: forall a. (Unaligned (BE a)) => Parser a {-# INLINE decodePrimBE #-} {-# SPECIALIZE INLINE decodePrimBE :: Parser Word #-} {-# SPECIALIZE INLINE decodePrimBE :: Parser Word64 #-} @@ -333,7 +333,7 @@ let !r = indexPrimWord8ArrayAs ba i in k (getBE r) (V.PrimVector ba (i+n) (len-n))) where - n = getUnalignedSize (unalignedSize :: UnalignedSize (BE a)) + n = unalignedSize (undefined :: (BE a)) -- | A stateful scanner. The predicate consumes and transforms a -- state argument, and each transformed state is passed to successive diff --git a/Z/Data/Text.hs b/Z/Data/Text.hs --- a/Z/Data/Text.hs +++ b/Z/Data/Text.hs @@ -51,6 +51,7 @@ , uncons, unsnoc , headMaybe, tailMayEmpty , lastMaybe, initMayEmpty + , head, tail, last, init , inits, tails , take, drop, takeR, dropR , slice diff --git a/Z/Data/Text/Base.hs b/Z/Data/Text/Base.hs --- a/Z/Data/Text/Base.hs +++ b/Z/Data/Text/Base.hs @@ -26,7 +26,6 @@ -- * Building text , validate, validateASCII , validateMaybe, validateASCIIMaybe - , TextException(..) , index, indexMaybe, charByteIndex, indexR, indexMaybeR, charByteIndexR -- * Basic creating , empty, singleton, copy @@ -115,6 +114,7 @@ , CategoryIsdigit , CategoryIsxdigit) -- * Misc + , TextException(..), errorEmptyText , c_utf8_validate_ba , c_utf8_validate_addr , c_ascii_validate_ba @@ -323,8 +323,13 @@ data TextException = InvalidUTF8Exception CallStack | InvalidASCIIException CallStack | IndexOutOfTextRange Int CallStack -- ^ first payload is invalid char index + | EmptyText CallStack deriving (Show, Typeable) instance Exception TextException + +errorEmptyText :: HasCallStack => a +{-# INLINE errorEmptyText #-} +errorEmptyText = throw (EmptyText callStack) -------------------------------------------------------------------------------- diff --git a/Z/Data/Text/Extra.hs b/Z/Data/Text/Extra.hs --- a/Z/Data/Text/Extra.hs +++ b/Z/Data/Text/Extra.hs @@ -22,8 +22,8 @@ -- * Slice manipulation cons, snoc , uncons, unsnoc - , headMaybe, tailMayEmpty - , lastMaybe, initMayEmpty + , headMaybe, tailMayEmpty, lastMaybe, initMayEmpty + , head, tail, last, init , inits, tails , take, drop, takeR, dropR , slice @@ -63,6 +63,7 @@ foldl, foldl1, foldr, foldr1, maximum, minimum, product, sum, all, any, replicate, traverse, + head, tail, init, last, take, drop, splitAt, takeWhile, dropWhile, break, span, reverse, @@ -107,6 +108,34 @@ | otherwise = let (# c, i #) = decodeCharReverse ba (s + l - 1) in Just (Text (V.PrimVector ba s (l-i)), c) + +-- | /O(1)/ Extract the first char of a text. +-- +-- Throw 'EmptyText' if text is empty. +head :: Text -> Char +{-# INLINABLE head #-} +head t = case uncons t of { Just (c, _) -> c; _ -> errorEmptyText } + +-- | /O(1)/ Extract the chars after the head of a text. +-- +-- Throw 'EmptyText' if text is empty. +tail :: Text -> Text +{-# INLINABLE tail #-} +tail t = case uncons t of { Nothing -> errorEmptyText; Just (_, t') -> t' } + +-- | /O(1)/ Extract the last char of a text. +-- +-- Throw 'EmptyText' if text is empty. +last :: Text -> Char +{-# INLINABLE last #-} +last t = case unsnoc t of { Just (_, c) -> c; _ -> errorEmptyText } + +-- | /O(1)/ Extract the chars before of the last one. +-- +-- Throw 'EmptyText' if text is empty. +init :: Text -> Text +{-# INLINABLE init #-} +init t = case unsnoc t of { Just (t', _) -> t'; _ -> errorEmptyText } -- | /O(1)/ Extract the first char of a text. headMaybe :: Text -> Maybe Char diff --git a/Z/Data/Vector.hs b/Z/Data/Vector.hs --- a/Z/Data/Vector.hs +++ b/Z/Data/Vector.hs @@ -117,6 +117,7 @@ , uncons, unsnoc , headMaybe, tailMayEmpty , lastMaybe, initMayEmpty + , head, tail, last, init , inits, tails , take, drop, takeR, dropR , slice diff --git a/Z/Data/Vector/Base.hs b/Z/Data/Vector/Base.hs --- a/Z/Data/Vector/Base.hs +++ b/Z/Data/Vector/Base.hs @@ -1315,11 +1315,11 @@ instance Exception VectorException errorEmptyVector :: HasCallStack => a -{-# NOINLINE errorEmptyVector #-} +{-# INLINE errorEmptyVector #-} errorEmptyVector = throw (EmptyVector callStack) errorOutRange :: HasCallStack => Int -> a -{-# NOINLINE errorOutRange #-} +{-# INLINE errorOutRange #-} errorOutRange i = throw (IndexOutOfVectorRange i callStack) -- | Cast between vectors diff --git a/Z/Foreign.hs b/Z/Foreign.hs --- a/Z/Foreign.hs +++ b/Z/Foreign.hs @@ -61,7 +61,6 @@ ( -- ** Unsafe FFI withPrimArrayUnsafe , allocPrimArrayUnsafe - , allocMutablePrimArrayUnsafe , withPrimVectorUnsafe , allocPrimVectorUnsafe , allocBytesUnsafe @@ -70,7 +69,6 @@ -- ** Safe FFI , withPrimArraySafe , allocPrimArraySafe - , allocMutablePrimArraySafe , withPrimVectorSafe , allocPrimVectorSafe , allocBytesSafe @@ -86,9 +84,10 @@ , fromNullTerminated, fromPtr, fromPrimPtr -- ** re-export , module Data.Primitive.ByteArray + , module Data.Primitive.PrimArray , module Foreign.C.Types , module Data.Primitive.Ptr - , module Z.Data.Array.UnalignedAccess + , module Z.Data.Array.Unaligned ) where import Control.Monad.Primitive @@ -96,36 +95,36 @@ import Data.Word import Data.Primitive.Ptr import Data.Primitive.ByteArray +import Data.Primitive.PrimArray import Foreign.C.Types import GHC.Ptr import Z.Data.Array -import Z.Data.Array.UnalignedAccess +import Z.Data.Array.Unaligned import Z.Data.Vector.Base -- | Type alias for 'ByteArray#'. -- --- Since we can't newtype an unlifted type yet, type alias is the best we can get --- to describe a 'ByteArray#' which we are going to pass across FFI. At C side you --- should use a proper const pointer type. +-- Describe a 'ByteArray#' which we are going to pass across FFI. Use this type with @UnliftedFFITypes@ +-- extension, At C side you should use a proper const pointer type. -- -- Don't cast 'BA#' to 'Addr#' since the heap object offset is hard-coded in code generator: -- -- --- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. --- A 'ByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL. +-- In haskell side we use type system to distinguish immutable / mutable arrays, but in C side we can't. +-- So it's users' responsibility to make sure the array content is not mutated (a const pointer type may help). +-- +-- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. A 'ByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL. type BA# a = ByteArray# -- | Type alias for 'MutableByteArray#' 'RealWorld'. -- --- Since we can't newtype an unlifted type yet, type alias is the best we can get --- to describe a 'MutableByteArray#' which we are going to pass across FFI. At C side you --- should use a proper pointer type. +-- Describe a 'MutableByteArray#' which we are going to pass across FFI. Use this type with @UnliftedFFITypes@ +-- extension, At C side you should use a proper pointer type. -- -- Don't cast 'MBA#' to 'Addr#' since the heap object offset is hard-coded in code generator: --- +-- -- --- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. --- A 'MutableByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL. +-- USE THIS TYPE WITH UNSAFE FFI CALL ONLY. A 'MutableByteArray#' COULD BE MOVED BY GC DURING SAFE FFI CALL. type MBA# a = MutableByteArray# RealWorld -- | Clear 'MBA#' with given length to zero. @@ -143,14 +142,7 @@ -- -- The second 'Int' arguement is the element size not the bytes size. -- --- Don't cast 'ByteArray#' to 'Addr#' since the heap object offset is hard-coded in code generator: --- --- --- In haskell side we use type system to distinguish immutable / mutable arrays, but in C side we can't. --- So it's users' responsibility to make sure the array content is not mutated (a const pointer type may help). --- -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. --- withPrimArrayUnsafe :: (Prim a) => PrimArray a -> (BA# a -> Int -> IO b) -> IO b {-# INLINE withPrimArrayUnsafe #-} withPrimArrayUnsafe pa@(PrimArray ba#) f = f ba# (sizeofPrimArray pa) @@ -166,38 +158,19 @@ !pa <- unsafeFreezePrimArray mpa return (pa, r) - --- | Allocate some bytes and pass to FFI as pointer. --- --- This function allocate some unpinned bytes and pass to FFI as MBA#, you should prefer --- use this function (together with 'UalignedAccess') if no safe FFI is needed, since --- this unpinned byte array can be easily collected. --- --- example usage with hsc2hs: --- --- @ --- allocMutablePrimArrayUnsafe @Word8 (#size c_struct) $ \ p -> do --- --- pokeMBA p (#offset c_struct c_field1) field1 --- pokeMBA p (#offset c_struct c_field2) field2 +-- | Pass 'PrimVector' to unsafe FFI as pointer -- --- c_ffi p .... +-- The 'PrimVector' version of 'withPrimArrayUnsafe'. -- --- field1' <- peekMBA p (#offset c_struct c_field1) --- field2' <- peekMBA p (#offset c_struct c_field2) --- ... --- return (CStruct field1' field2') --- @ +-- The second 'Int' arguement is the first element offset, the third 'Int' argument is the +-- element length. -- -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. -allocMutablePrimArrayUnsafe :: forall a b . Prim a - => Int -- ^ number of elements - -> (MBA# a -> IO b) -> IO (MutablePrimArray RealWorld a, b) -{-# INLINE allocMutablePrimArrayUnsafe #-} -allocMutablePrimArrayUnsafe len f = do - mba@(MutablePrimArray mba# :: MutablePrimArray RealWorld a) <- newPrimArray len - r <- f mba# - return (mba, r) +-- +withPrimVectorUnsafe :: (Prim a) + => PrimVector a -> (BA# a -> Int -> Int -> IO b) -> IO b +{-# INLINE withPrimVectorUnsafe #-} +withPrimVectorUnsafe (PrimVector arr s l) f = withPrimArrayUnsafe arr $ \ ba# _ -> f ba# s l -- | Allocate a prim array and pass to FFI as pointer, freeze result into a 'PrimVector'. -- @@ -221,21 +194,7 @@ allocBytesUnsafe = allocPrimVectorUnsafe --- | Pass 'PrimVector' to unsafe FFI as pointer --- --- The 'PrimVector' version of 'withPrimArrayUnsafe'. --- --- The second 'Int' arguement is the first element offset, the third 'Int' argument is the --- element length. --- --- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. --- -withPrimVectorUnsafe :: (Prim a) - => PrimVector a -> (BA# a -> Int -> Int -> IO b) -> IO b -{-# INLINE withPrimVectorUnsafe #-} -withPrimVectorUnsafe (PrimVector arr s l) f = withPrimArrayUnsafe arr $ \ ba# _ -> f ba# s l - -- | Create an one element primitive array and use it as a pointer to the primitive element. -- -- Return the element and the computation result. @@ -285,7 +244,7 @@ copyPrimArray buf 0 arr 0 siz withMutablePrimArrayContents buf $ \ ptr -> f ptr siz --- | Allocate some bytes and pass to FFI as pointer, freeze result into a 'PrimVector'. +-- | Allocate a prim array and pass to FFI as pointer, freeze result into a 'PrimVector'. allocPrimArraySafe :: forall a b . Prim a => Int -- ^ in elements -> (Ptr a -> IO b) @@ -297,16 +256,6 @@ !pa <- unsafeFreezePrimArray mpa return (pa, r) --- | Allocate a primitive array and pass to FFI as pointer. --- --- After call returned, pointer is no longer valid. -allocMutablePrimArraySafe :: (Prim a) => Int -- ^ in number of elements not bytes - -> (Ptr a -> IO b) -> IO b -{-# INLINE allocMutablePrimArraySafe #-} -allocMutablePrimArraySafe siz f = do - buf <- newPinnedPrimArray siz - withMutablePrimArrayContents buf f - -- | Pass 'PrimVector' to safe FFI as pointer -- -- The 'PrimVector' version of 'withPrimArraySafe'. The 'Ptr' is already pointed @@ -401,9 +350,11 @@ {-# INLINE clearPtr #-} clearPtr dest nbytes = memset dest 0 (fromIntegral nbytes) --- | Copy some bytes from a null terminated pointer(without copy the null terminator). +-- | Copy some bytes from a null terminated pointer(without copying the null terminator). -- --- There's no encoding guarantee, result could be any bytes sequence. +-- You should consider using 'Z.Data.CBytes' type for storing NULL terminated bytes first, +-- This method is provided if you really need to read 'Bytes', there's no encoding guarantee, +-- result could be any bytes sequence. fromNullTerminated :: Ptr a -> IO Bytes {-# INLINE fromNullTerminated #-} fromNullTerminated (Ptr addr#) = do diff --git a/test/Z/Data/Array/UnalignedAccessSpec.hs b/test/Z/Data/Array/UnalignedAccessSpec.hs deleted file mode 100644 --- a/test/Z/Data/Array/UnalignedAccessSpec.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Z.Data.Array.UnalignedAccessSpec where - -import qualified Data.List as L -import Data.Int -import GHC.Float -import Data.Word -import Z.Data.Array.UnalignedAccess -import Control.Monad.Primitive -import Data.Primitive.ByteArray -import Test.QuickCheck -import Test.QuickCheck.Function -import Test.QuickCheck.Property -import Test.Hspec -import Test.Hspec.QuickCheck - -spec :: Spec -spec = describe "unaligned acess" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do - prop "roundtrip Word8" $ \ (w::Word8) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Word16" $ \ (w::Word16) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Word32" $ \ (w::Word32) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Word64" $ \ (w::Word64) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Word" $ \ (w::Word) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Word16" $ \ (w::Word16) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Word32" $ \ (w::Word32) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Word64" $ \ (w::Word64) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Word" $ \ (w::Word) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Word16" $ \ (w::Word16) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Word32" $ \ (w::Word32) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Word64" $ \ (w::Word64) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Word" $ \ (w::Word) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - --------------------------------------------------------------------------------- - - prop "roundtrip Int16" $ \ (w::Int16) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Int16" $ \ (w::Int16) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Int16" $ \ (w::Int16) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Int32" $ \ (w::Int32) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Int32" $ \ (w::Int32) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Int32" $ \ (w::Int32) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Int64" $ \ (w::Int64) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Int64" $ \ (w::Int64) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Int64" $ \ (w::Int64) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Int" $ \ (w::Int) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Int" $ \ (w::Int) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Int" $ \ (w::Int) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Float" $ \ (w::Float) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Float" $ \ (w::Float) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Float" $ \ (w::Float) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Double" $ \ (w::Double) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Double" $ \ (w::Double) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Double" $ \ (w::Double) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip Char" $ \ (w::Char) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# w) - w' <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let w'' = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip LE Char" $ \ (w::Char) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) - (LE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (LE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') - - prop "roundtrip BE Char" $ \ (w::Char) -> ioProperty $ do - mba@(MutableByteArray mba#) <- newByteArray 128 - primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) - (BE w') <- primitive (readWord8ArrayAs# mba# 7#) - (ByteArray ba#) <- unsafeFreezeByteArray mba - let (BE w'') = indexWord8ArrayAs# ba# 7# - return $ (w === w') .&&. (w === w'') diff --git a/test/Z/Data/Array/UnalignedSpec.hs b/test/Z/Data/Array/UnalignedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/Data/Array/UnalignedSpec.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Z.Data.Array.UnalignedSpec where + +import qualified Data.List as L +import Data.Int +import GHC.Float +import Data.Word +import Z.Data.Array.Unaligned +import Control.Monad.Primitive +import Data.Primitive.ByteArray +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Property +import Test.Hspec +import Test.Hspec.QuickCheck + +spec :: Spec +spec = describe "unaligned acess" . modifyMaxSuccess (*10) . modifyMaxSize (*10) $ do + prop "roundtrip Word8" $ \ (w::Word8) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Word16" $ \ (w::Word16) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Word32" $ \ (w::Word32) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Word64" $ \ (w::Word64) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Word" $ \ (w::Word) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Word16" $ \ (w::Word16) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Word32" $ \ (w::Word32) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Word64" $ \ (w::Word64) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Word" $ \ (w::Word) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Word16" $ \ (w::Word16) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Word32" $ \ (w::Word32) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Word64" $ \ (w::Word64) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Word" $ \ (w::Word) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + +-------------------------------------------------------------------------------- + + prop "roundtrip Int16" $ \ (w::Int16) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Int16" $ \ (w::Int16) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Int16" $ \ (w::Int16) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Int32" $ \ (w::Int32) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Int32" $ \ (w::Int32) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Int32" $ \ (w::Int32) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Int64" $ \ (w::Int64) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Int64" $ \ (w::Int64) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Int64" $ \ (w::Int64) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Int" $ \ (w::Int) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Int" $ \ (w::Int) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Int" $ \ (w::Int) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Float" $ \ (w::Float) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Float" $ \ (w::Float) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Float" $ \ (w::Float) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Double" $ \ (w::Double) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Double" $ \ (w::Double) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Double" $ \ (w::Double) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip Char" $ \ (w::Char) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# w) + w' <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let w'' = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip LE Char" $ \ (w::Char) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (LE w)) + (LE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (LE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') + + prop "roundtrip BE Char" $ \ (w::Char) -> ioProperty $ do + mba@(MutableByteArray mba#) <- newByteArray 128 + primitive_ (writeWord8ArrayAs# mba# 7# (BE w)) + (BE w') <- primitive (readWord8ArrayAs# mba# 7#) + (ByteArray ba#) <- unsafeFreezeByteArray mba + let (BE w'') = indexWord8ArrayAs# ba# 7# + return $ (w === w') .&&. (w === w'') diff --git a/test/Z/Data/CBytesSpec.hs b/test/Z/Data/CBytesSpec.hs --- a/test/Z/Data/CBytesSpec.hs +++ b/test/Z/Data/CBytesSpec.hs @@ -5,10 +5,11 @@ module Z.Data.CBytesSpec where import qualified Data.List as List +import qualified GHC.Exts as List import Data.Word import Data.Hashable (hashWithSalt, hash) import qualified Z.Data.CBytes as CB -import Z.Foreign (fromNullTerminated) +import Z.Foreign import qualified Z.Data.Vector.Base as V import System.IO.Unsafe import Test.QuickCheck @@ -38,8 +39,14 @@ describe "CBytes IsString instance property" $ do prop "ASCII string" $ "hello world" === CB.fromText "hello world" + prop "ASCII string" $ + "hello world" === CB.fromBytes "hello world" + prop "ASCII string" $ + CB.toBytes "\NUL" === (V.pack [0xC0, 0x80]) prop "UTF8 string" $ "你好世界" === CB.fromText "你好世界" + prop "UTF8 string" $ + "\NUL" === CB.pack ['\NUL'] describe "CBytes length == List.length" $ do prop "CBytes length === List.length" $ \ (ASCIIString xs) -> @@ -50,7 +57,17 @@ prop "CBytes eq === List.eq" $ \ xs ys -> (CB.pack xs `CB.append` CB.pack ys) === CB.pack (xs ++ ys) + describe "CBytes concat == List.concat" $ do + prop "CBytes eq === List.eq" $ \ xss -> + (CB.concat (map CB.pack xss)) === CB.pack (List.concat xss) + + describe "withCBytes fromCString == id" $ do + prop "withCBytes fromCString == id" $ \ xs -> + (unsafeDupablePerformIO $ CB.withCBytes (CB.pack xs) (CB.fromCString . castPtr)) + === CB.pack xs + describe "withCBytes fromNullTerminated == toBytes" $ do prop "CBytes eq === List.eq" $ \ xs -> CB.toBytes (CB.pack xs) === (unsafeDupablePerformIO $ CB.withCBytes (CB.pack xs) fromNullTerminated) +