diff --git a/Control/Monad/Primitive.hs b/Control/Monad/Primitive.hs --- a/Control/Monad/Primitive.hs +++ b/Control/Monad/Primitive.hs @@ -50,37 +50,47 @@ type PrimState IO = RealWorld primitive = IO internal (IO p) = p + {-# INLINE primitive #-} + {-# INLINE internal #-} instance PrimMonad (ST s) where type PrimState (ST s) = s primitive = ST internal (ST p) = p + {-# INLINE primitive #-} + {-# INLINE internal #-} -- | Convert a 'PrimMonad' to another monad with the same state token. primToPrim :: (PrimMonad m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a +{-# INLINE primToPrim #-} primToPrim m = primitive (internal m) -- | Convert a 'PrimMonad' with a 'RealWorld' state token to 'IO' primToIO :: (PrimMonad m, PrimState m ~ RealWorld) => m a -> IO a +{-# INLINE primToIO #-} primToIO = primToPrim -- | Convert a 'PrimMonad' to 'ST' primToST :: PrimMonad m => m a -> ST (PrimState m) a +{-# INLINE primToST #-} primToST = primToPrim -- | Convert a 'PrimMonad' to another monad with a possibly different state -- token. This operation is highly unsafe! unsafePrimToPrim :: (PrimMonad m1, PrimMonad m2) => m1 a -> m2 a +{-# INLINE unsafePrimToPrim #-} unsafePrimToPrim m = primitive (unsafeCoerce# (internal m)) -- | Convert any 'PrimMonad' to 'ST' with an arbitrary state token. This --- operations is highly unsafe! +-- operation is highly unsafe! unsafePrimToST :: PrimMonad m => m a -> ST s a +{-# INLINE unsafePrimToST #-} unsafePrimToST = unsafePrimToPrim -- | Convert any 'PrimMonad' to 'IO'. This operation is highly unsafe! unsafePrimToIO :: PrimMonad m => m a -> IO a +{-# INLINE unsafePrimToIO #-} unsafePrimToIO = unsafePrimToPrim unsafeInlinePrim :: PrimMonad m => m a -> a @@ -96,6 +106,7 @@ unsafeInlineST = unsafeInlinePrim touch :: PrimMonad m => a -> m () +{-# INLINE touch #-} touch x = unsafePrimToPrim $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ()) diff --git a/Data/Primitive.hs b/Data/Primitive.hs --- a/Data/Primitive.hs +++ b/Data/Primitive.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | -- Module : Data.Primitive --- Copyright : (c) Roman Leshchinskiy 2009 +-- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy diff --git a/Data/Primitive/Addr.hs b/Data/Primitive/Addr.hs --- a/Data/Primitive/Addr.hs +++ b/Data/Primitive/Addr.hs @@ -2,7 +2,7 @@ -- | -- Module : Data.Primitive.Addr --- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy @@ -12,11 +12,17 @@ -- module Data.Primitive.Addr ( + -- * Types Addr(..), + -- * Address arithmetic nullAddr, plusAddr, minusAddr, remAddr, + + -- * Element access indexOffAddr, readOffAddr, writeOffAddr, - copyAddr, moveAddr, memcpyAddr + + -- * Block operations + copyAddr, moveAddr, setAddr ) where import Control.Monad.Primitive @@ -88,8 +94,9 @@ moveAddr (Addr dst#) (Addr src#) n = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) n -memcpyAddr :: PrimMonad m => Addr -> Addr -> Int -> m () -{-# INLINE memcpyAddr #-} -{-# DEPRECATED memcpyAddr "Use copyAddr instead" #-} -memcpyAddr = copyAddr +-- | Fill a memory block of with the given value. The length is in +-- elements of type @a@ rather than in bytes. +setAddr :: (Prim a, PrimMonad m) => Addr -> Int -> a -> m () +{-# INLINE setAddr #-} +setAddr (Addr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) diff --git a/Data/Primitive/Array.hs b/Data/Primitive/Array.hs --- a/Data/Primitive/Array.hs +++ b/Data/Primitive/Array.hs @@ -2,7 +2,7 @@ -- | -- Module : Data.Primitive.Array --- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy diff --git a/Data/Primitive/ByteArray.hs b/Data/Primitive/ByteArray.hs --- a/Data/Primitive/ByteArray.hs +++ b/Data/Primitive/ByteArray.hs @@ -3,7 +3,7 @@ -- | -- Module : Data.Primitive.ByteArray --- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy @@ -13,17 +13,25 @@ -- module Data.Primitive.ByteArray ( + -- * Types ByteArray(..), MutableByteArray(..), ByteArray#, MutableByteArray#, + -- * Allocation newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, + + -- * Element access readByteArray, writeByteArray, indexByteArray, + + -- * Freezing and thawing unsafeFreezeByteArray, unsafeThawByteArray, - sizeofByteArray, sizeofMutableByteArray, sameMutableByteArray, - byteArrayContents, mutableByteArrayContents, - copyByteArray, copyMutableByteArray, moveByteArray, fillByteArray, - -- * Deprecated operations - memcpyByteArray, memcpyByteArray', memmoveByteArray, memsetByteArray + -- * Block operations + copyByteArray, copyMutableByteArray, moveByteArray, + setByteArray, fillByteArray, + + -- * Information + sizeofByteArray, sizeofMutableByteArray, sameMutableByteArray, + byteArrayContents, mutableByteArrayContents ) where import Control.Monad.Primitive @@ -33,6 +41,9 @@ import Data.Word ( Word8 ) import GHC.Base ( Int(..) ) import GHC.Prim +#if __GLASGOW_HASKELL__ >= 706 + hiding (setByteArray#) +#endif import Data.Typeable ( Typeable ) import Data.Data ( Data(..) ) @@ -203,70 +214,45 @@ $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff) (fromIntegral sz) --- | Fill a slice of a mutable byte array with a value. +-- | Fill a slice of a mutable byte array with a value. The offset and length +-- are given in elements of type @a@ rather than in bytes. +setByteArray + :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill + -> Int -- ^ offset into array + -> Int -- ^ number of values to fill + -> a -- ^ value to fill with + -> m () +{-# INLINE setByteArray #-} +setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x + = primitive_ (setByteArray# dst# doff# sz# x) + +-- | Fill a slice of a mutable byte array with a byte. fillByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ array to fill -> Int -- ^ offset into array -> Int -- ^ number of bytes to fill - -> Word8 -- ^ value to fill with + -> Word8 -- ^ byte to fill with -> m () {-# INLINE fillByteArray #-} -fillByteArray (MutableByteArray dst#) doff sz c - = unsafePrimToPrim - $ memset_mba dst# (fromIntegral doff) (fromIntegral c) (fromIntegral sz) +fillByteArray = setByteArray -memcpyByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> Int - -> MutableByteArray (PrimState m) -> Int - -> Int -> m () -{-# DEPRECATED memcpyByteArray "Use copyMutableByteArray instead" #-} -{-# INLINE memcpyByteArray #-} -memcpyByteArray = copyMutableByteArray - -memcpyByteArray' - :: PrimMonad m => MutableByteArray (PrimState m) -> Int - -> ByteArray -> Int - -> Int -> m () -{-# DEPRECATED memcpyByteArray' "Use copyByteArray instead" #-} -{-# INLINE memcpyByteArray' #-} -memcpyByteArray' = copyByteArray - -memmoveByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> Int - -> MutableByteArray (PrimState m) -> Int - -> Int -> m () -{-# DEPRECATED memmoveByteArray "Use moveByteArray instead" #-} -{-# INLINE memmoveByteArray #-} -memmoveByteArray = moveByteArray - -memsetByteArray - :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> Word8 - -> Int -> m () -{-# DEPRECATED memsetByteArray "Use fillByteArray instead (WARNING: order of arguments is different)" #-} -{-# INLINE memsetByteArray #-} -memsetByteArray dst off x sz = fillByteArray dst off sz x - - -foreign import ccall unsafe "primitive-memops.h memcpy_off" +foreign import ccall unsafe "primitive-memops.h hsprimitive_memcpy" memcpy_mba :: MutableByteArray# s -> CInt -> MutableByteArray# s -> CInt -> CSize -> IO () -foreign import ccall unsafe "primitive-memops.h memcpy_off" +foreign import ccall unsafe "primitive-memops.h hsprimitive_memcpy" memcpy_ba :: MutableByteArray# s -> CInt -> ByteArray# -> CInt -> CSize -> IO () -foreign import ccall unsafe "primitive-memops.h memmove_off" +foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove" memmove_mba :: MutableByteArray# s -> CInt -> MutableByteArray# s -> CInt -> CSize -> IO () - -foreign import ccall unsafe "primitive-memops.h memset_off" - memset_mba :: MutableByteArray# s -> CInt -> CInt -> CSize -> IO () instance Data ByteArray where toConstr _ = error "toConstr" diff --git a/Data/Primitive/Internal/Compat.hs b/Data/Primitive/Internal/Compat.hs --- a/Data/Primitive/Internal/Compat.hs +++ b/Data/Primitive/Internal/Compat.hs @@ -1,3 +1,14 @@ +-- | +-- Module : Data.Primitive.Internal.Compat +-- Copyright : (c) Roman Leshchinskiy 2011-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy +-- Portability : non-portable +-- +-- Compatibility functions +-- + module Data.Primitive.Internal.Compat (mkNoRepType) where #if MIN_VERSION_base(4,2,0) diff --git a/Data/Primitive/Internal/Operations.hs b/Data/Primitive/Internal/Operations.hs new file mode 100644 --- /dev/null +++ b/Data/Primitive/Internal/Operations.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE MagicHash, ForeignFunctionInterface, UnliftedFFITypes #-} + +-- | +-- Module : Data.Primitive.Internal.Operations +-- Copyright : (c) Roman Leshchinskiy 2011-2012 +-- License : BSD-style +-- +-- Maintainer : Roman Leshchinskiy +-- Portability : non-portable +-- +-- Internal operations +-- + + +module Data.Primitive.Internal.Operations ( + setWord8Array#, setWord16Array#, setWord32Array#, + setWord64Array#, setWordArray#, + setInt8Array#, setInt16Array#, setInt32Array#, + setInt64Array#, setIntArray#, + setAddrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#, + + setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#, + setWord64OffAddr#, setWordOffAddr#, + setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#, + setInt64OffAddr#, setIntOffAddr#, + setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr# +) where + +import Data.Primitive.MachDeps (Word64_#, Int64_#) +import GHC.Prim + +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" + setWord8Array# :: MutableByteArray# s -> Int# -> Int# -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" + setWord16Array# :: MutableByteArray# s -> Int# -> Int# -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" + setWord32Array# :: MutableByteArray# s -> Int# -> Int# -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" + setWord64Array# :: MutableByteArray# s -> Int# -> Int# -> Word64_# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" + setWordArray# :: MutableByteArray# s -> Int# -> Int# -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" + setInt8Array# :: MutableByteArray# s -> Int# -> Int# -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" + setInt16Array# :: MutableByteArray# s -> Int# -> Int# -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" + setInt32Array# :: MutableByteArray# s -> Int# -> Int# -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" + setInt64Array# :: MutableByteArray# s -> Int# -> Int# -> Int64_# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" + setIntArray# :: MutableByteArray# s -> Int# -> Int# -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" + setAddrArray# :: MutableByteArray# s -> Int# -> Int# -> Addr# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" + setFloatArray# :: MutableByteArray# s -> Int# -> Int# -> Float# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" + setDoubleArray# :: MutableByteArray# s -> Int# -> Int# -> Double# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" + setWideCharArray# :: MutableByteArray# s -> Int# -> Int# -> Char# -> IO () + +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" + setWord8OffAddr# :: Addr# -> Int# -> Int# -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" + setWord16OffAddr# :: Addr# -> Int# -> Int# -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" + setWord32OffAddr# :: Addr# -> Int# -> Int# -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" + setWord64OffAddr# :: Addr# -> Int# -> Int# -> Word64_# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" + setWordOffAddr# :: Addr# -> Int# -> Int# -> Word# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" + setInt8OffAddr# :: Addr# -> Int# -> Int# -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" + setInt16OffAddr# :: Addr# -> Int# -> Int# -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" + setInt32OffAddr# :: Addr# -> Int# -> Int# -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" + setInt64OffAddr# :: Addr# -> Int# -> Int# -> Int64_# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" + setIntOffAddr# :: Addr# -> Int# -> Int# -> Int# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" + setAddrOffAddr# :: Addr# -> Int# -> Int# -> Addr# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" + setFloatOffAddr# :: Addr# -> Int# -> Int# -> Float# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" + setDoubleOffAddr# :: Addr# -> Int# -> Int# -> Double# -> IO () +foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" + setWideCharOffAddr# :: Addr# -> Int# -> Int# -> Char# -> IO () + diff --git a/Data/Primitive/MachDeps.hs b/Data/Primitive/MachDeps.hs --- a/Data/Primitive/MachDeps.hs +++ b/Data/Primitive/MachDeps.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE MagicHash #-} -- | -- Module : Data.Primitive.MachDeps --- Copyright : (c) Roman Leshchinskiy 2009 +-- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy @@ -13,6 +14,8 @@ #include "MachDeps.h" +import GHC.Prim + sIZEOF_CHAR, aLIGNMENT_CHAR, @@ -109,4 +112,12 @@ sIZEOF_WORD64 = SIZEOF_WORD64 aLIGNMENT_WORD64 = ALIGNMENT_WORD64 + +#if WORD_SIZE_IN_BITS == 32 +type Word64_# = Word64# +type Int64_# = Int64# +#else +type Word64_# = Word# +type Int64_# = Int# +#endif diff --git a/Data/Primitive/MutVar.hs b/Data/Primitive/MutVar.hs --- a/Data/Primitive/MutVar.hs +++ b/Data/Primitive/MutVar.hs @@ -2,10 +2,10 @@ -- | -- Module : Data.Primitive.MutVar --- Copyright : (c) Justin Bonnar 2011 +-- Copyright : (c) Justin Bonnar 2011, Roman Leshchinskiy 2011-2012 -- License : BSD-style -- --- Maintainer : Justin Bonnar +-- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive boxed mutable variables @@ -17,12 +17,14 @@ newMutVar, readMutVar, writeMutVar, - + + atomicModifyMutVar, modifyMutVar ) where import Control.Monad.Primitive ( PrimMonad(..), primitive_ ) -import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#, readMutVar#, writeMutVar# ) +import GHC.Prim ( MutVar#, sameMutVar#, newMutVar#, + readMutVar#, writeMutVar#, atomicModifyMutVar# ) import Data.Typeable ( Typeable ) -- | A 'MutVar' behaves like a single-element mutable array associated @@ -49,6 +51,11 @@ writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m () {-# INLINE writeMutVar #-} writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue) + +-- | Atomically mutate the contents of a 'MutVar' +atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b +{-# INLINE atomicModifyMutVar #-} +atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f -- | Mutate the contents of a 'MutVar' modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () diff --git a/Data/Primitive/Types.hs b/Data/Primitive/Types.hs --- a/Data/Primitive/Types.hs +++ b/Data/Primitive/Types.hs @@ -2,7 +2,7 @@ -- | -- Module : Data.Primitive.Types --- Copyright : (c) Roman Leshchinskiy 2009-2010 +-- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy @@ -19,8 +19,10 @@ import Control.Monad.Primitive import Data.Primitive.MachDeps +import Data.Primitive.Internal.Operations import GHC.Base ( + unsafeCoerce#, Int(..), Char(..), ) import GHC.Float ( @@ -34,6 +36,9 @@ ) import GHC.Prim +#if __GLASGOW_HASKELL__ >= 706 + hiding (setByteArray#) +#endif import Data.Typeable ( Typeable ) import Data.Data ( Data(..) ) @@ -79,6 +84,10 @@ -- @a@ rather than in bytes. writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s + -- | Fill a slice of the mutable array with a value. The offset and length + -- of the chunk are in elements of type @a@ rather than in bytes. + setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s + -- | Read a value from a memory position given by an address and an offset. -- The memory block the address refers to must be immutable. The offset is in -- elements of type @a@ rather than in bytes. @@ -92,7 +101,11 @@ -- The offset is in elements of type @a@ rather than in bytes. writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s -#define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, idx_addr, rd_addr, wr_addr) \ + -- | Fill a memory block given by an address, an offset and a length. + -- The offset and length are in elements of type @a@ rather than in bytes. + setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s + +#define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \ instance Prim ty where { \ sizeOf# _ = unI# sz \ ; alignment# _ = unI# align \ @@ -100,55 +113,72 @@ ; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \ { (# s1#, x# #) -> (# s1#, ctr x# #) } \ ; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \ +; setByteArray# arr# i# n# (ctr x#) s# \ + = case internal (set_arr arr# i# n# x#) (unsafeCoerce# s#) of \ + { (# s1#, _ #) -> unsafeCoerce# s1# } \ \ ; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \ ; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \ { (# s1#, x# #) -> (# s1#, ctr x# #) } \ -; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# } +; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \ +; setOffAddr# addr# i# n# (ctr x#) s# \ + = case internal (set_addr addr# i# n# x#) (unsafeCoerce# s#) of \ + { (# s1#, _ #) -> unsafeCoerce# s1# } \ +; {-# INLINE sizeOf# #-} \ +; {-# INLINE alignment# #-} \ +; {-# INLINE indexByteArray# #-} \ +; {-# INLINE readByteArray# #-} \ +; {-# INLINE writeByteArray# #-} \ +; {-# INLINE setByteArray# #-} \ +; {-# INLINE indexOffAddr# #-} \ +; {-# INLINE readOffAddr# #-} \ +; {-# INLINE writeOffAddr# #-} \ +; {-# INLINE setOffAddr# #-} \ +} unI# :: Int -> Int# unI# (I# n#) = n# derivePrim(Word, W#, sIZEOF_WORD, aLIGNMENT_WORD, - indexWordArray#, readWordArray#, writeWordArray#, - indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#) + indexWordArray#, readWordArray#, writeWordArray#, setWordArray#, + indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#) derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8, - indexWord8Array#, readWord8Array#, writeWord8Array#, - indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#) + indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#, + indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#) derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16, - indexWord16Array#, readWord16Array#, writeWord16Array#, - indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#) + indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#, + indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#, setWord16OffAddr#) derivePrim(Word32, W32#, sIZEOF_WORD32, aLIGNMENT_WORD32, - indexWord32Array#, readWord32Array#, writeWord32Array#, - indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#) + indexWord32Array#, readWord32Array#, writeWord32Array#, setWord32Array#, + indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#, setWord32OffAddr#) derivePrim(Word64, W64#, sIZEOF_WORD64, aLIGNMENT_WORD64, - indexWord64Array#, readWord64Array#, writeWord64Array#, - indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#) + indexWord64Array#, readWord64Array#, writeWord64Array#, setWord64Array#, + indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#, setWord64OffAddr#) derivePrim(Int, I#, sIZEOF_INT, aLIGNMENT_INT, - indexIntArray#, readIntArray#, writeIntArray#, - indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#) + indexIntArray#, readIntArray#, writeIntArray#, setIntArray#, + indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#) derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8, - indexInt8Array#, readInt8Array#, writeInt8Array#, - indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#) + indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#, + indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#) derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16, - indexInt16Array#, readInt16Array#, writeInt16Array#, - indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#) + indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#, + indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#, setInt16OffAddr#) derivePrim(Int32, I32#, sIZEOF_INT32, aLIGNMENT_INT32, - indexInt32Array#, readInt32Array#, writeInt32Array#, - indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#) + indexInt32Array#, readInt32Array#, writeInt32Array#, setInt32Array#, + indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#, setInt32OffAddr#) derivePrim(Int64, I64#, sIZEOF_INT64, aLIGNMENT_INT64, - indexInt64Array#, readInt64Array#, writeInt64Array#, - indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#) + indexInt64Array#, readInt64Array#, writeInt64Array#, setInt64Array#, + indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#, setInt64OffAddr#) derivePrim(Float, F#, sIZEOF_FLOAT, aLIGNMENT_FLOAT, - indexFloatArray#, readFloatArray#, writeFloatArray#, - indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#) + indexFloatArray#, readFloatArray#, writeFloatArray#, setFloatArray#, + indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#, setFloatOffAddr#) derivePrim(Double, D#, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE, - indexDoubleArray#, readDoubleArray#, writeDoubleArray#, - indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#) + indexDoubleArray#, readDoubleArray#, writeDoubleArray#, setDoubleArray#, + indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#, setDoubleOffAddr#) derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR, - indexWideCharArray#, readWideCharArray#, writeWideCharArray#, - indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#) + indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#, + indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#) derivePrim(Addr, Addr, sIZEOF_PTR, aLIGNMENT_PTR, - indexAddrArray#, readAddrArray#, writeAddrArray#, - indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#) + indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, + indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) diff --git a/cbits/primitive-memops.c b/cbits/primitive-memops.c --- a/cbits/primitive-memops.c +++ b/cbits/primitive-memops.c @@ -1,17 +1,52 @@ #include +#include "primitive-memops.h" -void memcpy_off( void *dst, int doff, void *src, int soff, size_t len ) +void hsprimitive_memcpy( void *dst, int doff, void *src, int soff, size_t len ) { memcpy( (char *)dst + doff, (char *)src + soff, len ); } -void memmove_off( void *dst, int doff, void *src, int soff, size_t len ) +void hsprimitive_memmove( void *dst, int doff, void *src, int soff, size_t len ) { memmove( (char *)dst + doff, (char *)src + soff, len ); } -void memset_off( void *dst, int doff, int c, size_t len ) +#define MEMSET(TYPE, ATYPE) \ +void hsprimitive_memset_ ## TYPE (Hs ## TYPE *p, int off, int n, ATYPE x) \ +{ \ + p += off; \ + if (x == 0) \ + memset(p, 0, n * sizeof(Hs ## TYPE)); \ + else if (sizeof(Hs ## TYPE) == sizeof(int)*2) { \ + int *q = (int *)p; \ + const int *r = (const int *)&x; \ + while (n>0) { \ + q[0] = r[0]; \ + q[1] = r[1]; \ + q += 2; \ + --n; \ + } \ + } \ + else { \ + while (n>0) { \ + *p++ = x; \ + --n; \ + } \ + } \ +} + +void hsprimitive_memset_Word8 (HsWord8 *p, int off, int n, HsWord x) { - memset( (char *)dst + doff, c, len ); + memset( (char *)(p+off), x, n ); } + +/* MEMSET(HsWord8, HsWord) */ +MEMSET(Word16, HsWord) +MEMSET(Word32, HsWord) +MEMSET(Word64, HsWord64) +MEMSET(Word, HsWord) +MEMSET(Ptr, HsPtr) +MEMSET(Float, HsFloat) +MEMSET(Double, HsDouble) +MEMSET(Char, HsChar) diff --git a/cbits/primitive-memops.h b/cbits/primitive-memops.h --- a/cbits/primitive-memops.h +++ b/cbits/primitive-memops.h @@ -2,10 +2,20 @@ #define haskell_primitive_memops_h #include +#include -void memcpy_off( void *dst, int doff, void *src, int soff, size_t len ); -void memmove_off( void *dst, int doff, void *src, int soff, size_t len ); -void memset_off( void *dst, int doff, int c, size_t len ); +void hsprimitive_memcpy( void *dst, int doff, void *src, int soff, size_t len ); +void hsprimitive_memmove( void *dst, int doff, void *src, int soff, size_t len ); + +void hsprimitive_memset_Word8 (HsWord8 *, int, int, HsWord); +void hsprimitive_memset_Word16 (HsWord16 *, int, int, HsWord); +void hsprimitive_memset_Word32 (HsWord32 *, int, int, HsWord); +void hsprimitive_memset_Word64 (HsWord64 *, int, int, HsWord64); +void hsprimitive_memset_Word (HsWord *, int, int, HsWord); +void hsprimitive_memset_Ptr (HsPtr *, int, int, HsPtr); +void hsprimitive_memset_Float (HsFloat *, int, int, HsFloat); +void hsprimitive_memset_Double (HsDouble *, int, int, HsDouble); +void hsprimitive_memset_Char (HsChar *, int, int, HsChar); #endif diff --git a/primitive.cabal b/primitive.cabal --- a/primitive.cabal +++ b/primitive.cabal @@ -1,41 +1,22 @@ Name: primitive -Version: 0.4.1 +Version: 0.5 License: BSD3 License-File: LICENSE Author: Roman Leshchinskiy Maintainer: Roman Leshchinskiy -Copyright: (c) Roman Leshchinskiy 2009-2010 +Copyright: (c) Roman Leshchinskiy 2009-2012 Homepage: http://code.haskell.org/primitive Category: Data -Synopsis: Wrappers for primitive operations +Synopsis: Primitive memory-related operations Description: . - This package provides wrappers for primitive array operations from - GHC.Prim. - . - Changes in version 0.4.1 - . - * New module "Data.Primitive.MutVar" - . - Changes in version 0.4.0.1 - . - * Critical bug fix in @fillByteArray@ - . - Changes in version 0.4 - . - * Support for GHC 7.2 array copying primitives - . - * New in "Data.Primitive.ByteArray": @copyByteArray@, - @copyMutableByteArray@, @moveByteArray@, @fillByteArray@ - . - * Deprecated in "Data.Primitive.ByteArray": @memcpyByteArray@, - @memcpyByteArray'@, @memmoveByteArray@, @memsetByteArray@ + This package provides various primitive memory-related operations. . - * New in "Data.Primitive.Array": @copyArray@, @copyMutableByteArray@ + Changes in version 0.5 . - * New in "Data.Primitive.Addr": @copyAddr@, @moveAddr@ + * New in "Data.Primitive.MutVar": @atomicModifyMutVar@ . - * Deprecated in "Data.Primitive.Addr": @memcpyAddr@ + * Efficient block fill operations: @setByteArray@, @setAddr@ . Cabal-Version: >= 1.2 @@ -55,6 +36,7 @@ Other-Modules: Data.Primitive.Internal.Compat + Data.Primitive.Internal.Operations Build-Depends: base >= 4 && < 5, ghc-prim @@ -64,4 +46,8 @@ Install-Includes: primitive-memops.h includes: primitive-memops.h c-sources: cbits/primitive-memops.c + cc-options: -O3 -ftree-vectorize -fomit-frame-pointer + if arch(i386) || arch(x86_64) { + cc-options: -msse2 + }