diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,15 +6,33 @@ project adheres to the [Haskell Package Versioning Policy (PVP)](https://pvp.haskell.org) +## [1.2.0.0] - 2018-04-03 +### Changed + * Split the different conversion functions into separate modules, rather than having a single `Data.Array.Accelerate.IO` module which export everything. + * Conversion to/from `ByteString` is now non-copying + +### Added + * Conversions between `Data.Vector.Unboxed` + * Instances for `Data.Vector.Generic` + * Support for AoS representations + +### Fixed + * Image created by `writeImageToBMP` flipped vertically ([#289]) + + ## [1.0.0.1] - 2017-10-14 ### Fixed - * `fromIArray` would fail with exception "Error in array index" when the IArray - indices were not zero-based. This has been fixed. + * `fromIArray` would fail with exception "Error in array index" when the IArray indices were not zero-based. This has been fixed. + ## [1.0.0.0] - 2017-03-31 * stable release -[1.1.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/1.0.0.0...1.0.0.1 -[1.0.0.0]: https://github.com/AccelerateHS/accelerate-llvm/compare/0.15.1.0...1.0.0.0 +[1.2.0.0]: https://github.com/AccelerateHS/accelerate-io/compare/1.0.0.1...1.2.0.0 +[1.0.0.1]: https://github.com/AccelerateHS/accelerate-io/compare/1.0.0.0...1.0.0.1 +[1.0.0.0]: https://github.com/AccelerateHS/accelerate-io/compare/0.15.1.0...1.0.0.0 + + +[#289]: https://github.com/AccelerateHS/accelerate/issues/289 diff --git a/Data/Array/Accelerate/IO.hs b/Data/Array/Accelerate/IO.hs deleted file mode 100644 --- a/Data/Array/Accelerate/IO.hs +++ /dev/null @@ -1,47 +0,0 @@ --- | --- Module : Data.Array.Accelerate.IO --- Copyright : [2010..2012] Sean Seefried --- [2010..2016] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- This module provides efficient conversion routines between different array --- types and Accelerate arrays. --- - -module Data.Array.Accelerate.IO ( - - -- * Array libraries - module Data.Array.Accelerate.IO.Repa, - module Data.Array.Accelerate.IO.Vector, - module Data.Array.Accelerate.IO.IArray, - - -- * Specialised file IO - module Data.Array.Accelerate.IO.BMP, - - -- * Low-level conversions - -- - -- | Copying conversions of low-level primitive data, stored in - -- one-dimensional row-major blocks of contiguous memory. To use these, you - -- should really know what you are doing. Potential pitfalls include: - -- - -- * copying from memory your program doesn't have access to (e.g. it may be - -- unallocated, or not enough memory is allocated) - -- - -- * memory alignment errors - -- - module Data.Array.Accelerate.IO.ByteString, - module Data.Array.Accelerate.IO.Ptr, - -) where - -import Data.Array.Accelerate.IO.BMP -import Data.Array.Accelerate.IO.ByteString -import Data.Array.Accelerate.IO.IArray -import Data.Array.Accelerate.IO.Ptr -import Data.Array.Accelerate.IO.Repa -import Data.Array.Accelerate.IO.Vector - diff --git a/Data/Array/Accelerate/IO/BMP.hs b/Data/Array/Accelerate/IO/BMP.hs deleted file mode 100644 --- a/Data/Array/Accelerate/IO/BMP.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | --- Module : Data.Array.Accelerate.IO.BMP --- Copyright : [2012..2014] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- Read and write BMP images into a packed-word RGBA format. See the --- /colour-accelerate/ package for colour representations and utilities such as --- packing and unpacking. --- - -module Data.Array.Accelerate.IO.BMP ( - - -- ** Bitmap images - -- - -- | Reading and writing arrays as uncompressed 24 or 32-bit Windows BMP - -- files. - -- - RGBA32, - readImageFromBMP, writeImageToBMP, - -) where - -import Data.Word -import Codec.BMP - -import Data.Array.Accelerate as A -import Data.Array.Accelerate.IO.ByteString as A - - --- | Packed RGBA pixel data --- -type RGBA32 = Word32 - --- File IO --------------------------------------------------------------------- - --- | Read RGBA components from a BMP file. --- -readImageFromBMP :: FilePath -> IO (Either Error (Array DIM2 RGBA32)) -readImageFromBMP file = do - ebmp <- readBMP file - case ebmp of - Left err -> return $ Left err - Right bmp -> do - let (w,h) = bmpDimensions bmp - bs = unpackBMPToRGBA32 bmp - -- - Right `fmap` A.fromByteString (Z :. h :. w) bs - - --- | Write the image data to a file. --- -writeImageToBMP :: FilePath -> Array DIM2 RGBA32 -> IO () -writeImageToBMP file rgba = do - let Z :. h :. w = A.arrayShape rgba - bs <- A.toByteString rgba - -- - writeBMP file (packRGBA32ToBMP w h bs) - diff --git a/Data/Array/Accelerate/IO/BlockCopy.hs b/Data/Array/Accelerate/IO/BlockCopy.hs deleted file mode 100644 --- a/Data/Array/Accelerate/IO/BlockCopy.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Data.Array.Accelerate.IO.BlockCopy --- Copyright : [2010..2011] Sean Seefried --- [2010..2014] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.IO.BlockCopy ( - - -- * Types - BlockCopyFun, BlockCopyFuns, BlockPtrs, ByteStrings, - - -- * The low-level machinery - allocateArray, blockCopy, blockCopyFunGenerator - -) where - --- standard libraries -import Foreign -import Foreign.C -import GHC.Base -import Data.Array.Base (wORD_SCALE, fLOAT_SCALE, dOUBLE_SCALE) -import Data.ByteString - --- friends -import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Sugar - - --- | Functions of this type are passed as arguments to 'toArray'. A function of --- this type should copy a number of bytes (equal to the value of the --- parameter of type 'Int') to the destination memory pointed to by @Ptr e@. --- -type BlockCopyFun e = Ptr e -> Int -> IO () - --- | Represents a collection of "block copy functions" (see 'BlockCopyFun'). The --- structure of the collection of 'BlockCopyFun's depends on the element type --- @e@. --- --- e.g. --- --- If @e :: Float@ --- then @BlockCopyFuns (EltRepr e) :: ((), Ptr Float -> Int -> IO ())@ --- --- If @e :: (Double, Float)@ --- then @BlockCopyFuns (EltRepr e) :: (((), Ptr Double -> Int -> IO ()), Ptr Float -> Int -> IO ())@ --- -type family BlockCopyFuns e - -type instance BlockCopyFuns () = () -type instance BlockCopyFuns Int = BlockCopyFun Int -type instance BlockCopyFuns Int8 = BlockCopyFun Int8 -type instance BlockCopyFuns Int16 = BlockCopyFun Int16 -type instance BlockCopyFuns Int32 = BlockCopyFun Int32 -type instance BlockCopyFuns Int64 = BlockCopyFun Int64 -type instance BlockCopyFuns Word = BlockCopyFun Word -type instance BlockCopyFuns Word8 = BlockCopyFun Word8 -type instance BlockCopyFuns Word16 = BlockCopyFun Word16 -type instance BlockCopyFuns Word32 = BlockCopyFun Word32 -type instance BlockCopyFuns Word64 = BlockCopyFun Word64 -type instance BlockCopyFuns CShort = BlockCopyFun Int16 -type instance BlockCopyFuns CUShort = BlockCopyFun Word16 -type instance BlockCopyFuns CInt = BlockCopyFun Int32 -type instance BlockCopyFuns CUInt = BlockCopyFun Word32 -type instance BlockCopyFuns CLong = BlockCopyFun HTYPE_LONG -type instance BlockCopyFuns CULong = BlockCopyFun HTYPE_UNSIGNED_LONG -type instance BlockCopyFuns CLLong = BlockCopyFun Int64 -type instance BlockCopyFuns CULLong = BlockCopyFun Word64 -type instance BlockCopyFuns Float = BlockCopyFun Float -type instance BlockCopyFuns Double = BlockCopyFun Double -type instance BlockCopyFuns CFloat = BlockCopyFun Float -type instance BlockCopyFuns CDouble = BlockCopyFun Double -type instance BlockCopyFuns Bool = BlockCopyFun Word8 -type instance BlockCopyFuns Char = BlockCopyFun Char -type instance BlockCopyFuns CChar = BlockCopyFun HTYPE_CCHAR -type instance BlockCopyFuns CSChar = BlockCopyFun Int8 -type instance BlockCopyFuns CUChar = BlockCopyFun Word8 -type instance BlockCopyFuns (a,b) = (BlockCopyFuns a, BlockCopyFuns b) - --- | A family of types that represents a collection of pointers that are the --- source/destination addresses for a block copy. The structure of the --- collection of pointers depends on the element type @e@. --- --- e.g. --- --- If @e :: Int@, then @BlockPtrs (EltRepr e) :: ((), Ptr Int)@ --- --- If @e :: (Double, Float)@ then @BlockPtrs (EltRepr e) :: (((), Ptr Double), Ptr Float)@ --- -type family BlockPtrs e - -type instance BlockPtrs () = () -type instance BlockPtrs Int = Ptr Int -type instance BlockPtrs Int8 = Ptr Int8 -type instance BlockPtrs Int16 = Ptr Int16 -type instance BlockPtrs Int32 = Ptr Int32 -type instance BlockPtrs Int64 = Ptr Int64 -type instance BlockPtrs Word = Ptr Word -type instance BlockPtrs Word8 = Ptr Word8 -type instance BlockPtrs Word16 = Ptr Word16 -type instance BlockPtrs Word32 = Ptr Word32 -type instance BlockPtrs Word64 = Ptr Word64 -type instance BlockPtrs CShort = Ptr Int16 -type instance BlockPtrs CUShort = Ptr Word16 -type instance BlockPtrs CInt = Ptr Int32 -type instance BlockPtrs CUInt = Ptr Word32 -type instance BlockPtrs CLong = Ptr HTYPE_LONG -type instance BlockPtrs CULong = Ptr HTYPE_UNSIGNED_LONG -type instance BlockPtrs CLLong = Ptr Int64 -type instance BlockPtrs CULLong = Ptr Word64 -type instance BlockPtrs Float = Ptr Float -type instance BlockPtrs Double = Ptr Double -type instance BlockPtrs CFloat = Ptr Float -type instance BlockPtrs CDouble = Ptr Double -type instance BlockPtrs Bool = Ptr Word8 -type instance BlockPtrs Char = Ptr Char -type instance BlockPtrs CChar = Ptr HTYPE_CCHAR -type instance BlockPtrs CSChar = Ptr Int8 -type instance BlockPtrs CUChar = Ptr Word8 -type instance BlockPtrs (a,b) = (BlockPtrs a, BlockPtrs b) - --- | A family of types that represents a collection of 'ByteString's. They are --- the source data for function 'fromByteString' and the result data for --- 'toByteString' --- -type family ByteStrings e - -type instance ByteStrings () = () -type instance ByteStrings Int = ByteString -type instance ByteStrings Int8 = ByteString -type instance ByteStrings Int16 = ByteString -type instance ByteStrings Int32 = ByteString -type instance ByteStrings Int64 = ByteString -type instance ByteStrings Word = ByteString -type instance ByteStrings Word8 = ByteString -type instance ByteStrings Word16 = ByteString -type instance ByteStrings Word32 = ByteString -type instance ByteStrings Word64 = ByteString -type instance ByteStrings CShort = ByteString -type instance ByteStrings CUShort = ByteString -type instance ByteStrings CInt = ByteString -type instance ByteStrings CUInt = ByteString -type instance ByteStrings CLong = ByteString -type instance ByteStrings CULong = ByteString -type instance ByteStrings CLLong = ByteString -type instance ByteStrings CULLong = ByteString -type instance ByteStrings CShort = ByteString -type instance ByteStrings Float = ByteString -type instance ByteStrings Double = ByteString -type instance ByteStrings CFloat = ByteString -type instance ByteStrings CDouble = ByteString -type instance ByteStrings Bool = ByteString -type instance ByteStrings Char = ByteString -type instance ByteStrings CChar = ByteString -type instance ByteStrings CSChar = ByteString -type instance ByteStrings CUChar = ByteString -type instance ByteStrings (a,b) = (ByteStrings a, ByteStrings b) - - -type GenFuns e = (( BlockPtrs e -> IO () - , ByteStrings e -> IO ()) - ,( BlockPtrs e -> IO () - , IO (ByteStrings e)) - , BlockCopyFuns e -> IO ()) - -base :: forall a b. Ptr b -> Int -> (( Ptr a -> IO (), ByteString -> IO ()) - ,( Ptr a -> IO (), IO ByteString) - ,(Ptr b -> Int -> IO ()) -> IO ()) -base accArrayPtr byteSize = - ((blockPtrToArray, byteStringToArray) - ,(arrayToBlockPtr, arrayToByteString) - , blockCopyFunToOrFromArray) - where - blockPtrToArray :: Ptr a -> IO () - blockPtrToArray blockPtr = blockCopy blockPtr accArrayPtr byteSize - arrayToBlockPtr :: Ptr a -> IO () - arrayToBlockPtr blockPtr = blockCopy accArrayPtr blockPtr byteSize - blockCopyFunToOrFromArray :: (Ptr b -> Int -> IO ()) -> IO () - blockCopyFunToOrFromArray blockCopyFun = blockCopyFun accArrayPtr byteSize - byteStringToArray :: ByteString -> IO () - byteStringToArray bs = useAsCString bs (blockPtrToArray . castPtr) - arrayToByteString :: IO ByteString - arrayToByteString = packCStringLen (castPtr accArrayPtr, byteSize) - -blockCopyFunGenerator :: Array sh e -> GenFuns (EltRepr e) -blockCopyFunGenerator array@(Array _ arrayData) = aux arrayElt arrayData - where - sizeA = size (shape array) - aux :: ArrayEltR e -> ArrayData e -> GenFuns e - aux ArrayEltRunit _ = let f () = return () in ((f,f),(f,return ()),f) - aux ArrayEltRint ad = base (ptrsOfArrayData ad) (box wORD_SCALE sizeA) - aux ArrayEltRint8 ad = base (ptrsOfArrayData ad) sizeA - aux ArrayEltRint16 ad = base (ptrsOfArrayData ad) (sizeA * 2) - aux ArrayEltRint32 ad = base (ptrsOfArrayData ad) (sizeA * 4) - aux ArrayEltRint64 ad = base (ptrsOfArrayData ad) (sizeA * 8) - aux ArrayEltRword ad = base (ptrsOfArrayData ad) (box wORD_SCALE sizeA) - aux ArrayEltRword8 ad = base (ptrsOfArrayData ad) sizeA - aux ArrayEltRword16 ad = base (ptrsOfArrayData ad) (sizeA * 2) - aux ArrayEltRword32 ad = base (ptrsOfArrayData ad) (sizeA * 4) - aux ArrayEltRword64 ad = base (ptrsOfArrayData ad) (sizeA * 8) - aux ArrayEltRcshort ad = base (ptrsOfArrayData ad) (sizeA * 2) - aux ArrayEltRcushort ad = base (ptrsOfArrayData ad) (sizeA * 2) - aux ArrayEltRcint ad = base (ptrsOfArrayData ad) (sizeA * 4) - aux ArrayEltRcuint ad = base (ptrsOfArrayData ad) (sizeA * 4) - aux ArrayEltRclong ad = base (ptrsOfArrayData ad) (sizeA * 8) - aux ArrayEltRculong ad = base (ptrsOfArrayData ad) (sizeA * 8) - aux ArrayEltRcllong ad = base (ptrsOfArrayData ad) (sizeA * 8) - aux ArrayEltRcullong ad = base (ptrsOfArrayData ad) (sizeA * 8) - aux ArrayEltRfloat ad = base (ptrsOfArrayData ad) (box fLOAT_SCALE sizeA) - aux ArrayEltRcfloat ad = base (ptrsOfArrayData ad) (box fLOAT_SCALE sizeA) - aux ArrayEltRdouble ad = base (ptrsOfArrayData ad) (box dOUBLE_SCALE sizeA) - aux ArrayEltRcdouble ad = base (ptrsOfArrayData ad) (box dOUBLE_SCALE sizeA) - aux ArrayEltRbool ad = base (ptrsOfArrayData ad) sizeA - aux ArrayEltRchar ad = base (ptrsOfArrayData ad) (sizeA * 4) - aux ArrayEltRcchar ad = base (ptrsOfArrayData ad) sizeA - aux ArrayEltRcschar ad = base (ptrsOfArrayData ad) sizeA - aux ArrayEltRcuchar ad = base (ptrsOfArrayData ad) sizeA - aux (ArrayEltRpair a b) (AD_Pair ad1 ad2) = ((bpFromC, bsFromC), (bpToC, bsToC), toH) - where - ((bpFromC1, bsFromC1), (bpToC1, bsToC1), toH1) = aux a ad1 - ((bpFromC2, bsFromC2), (bpToC2, bsToC2), toH2) = aux b ad2 - toH (funs1, funs2) = toH1 funs1 >> toH2 funs2 - bpToC (ptrA, ptrB) = bpToC1 ptrA >> bpToC2 ptrB - bsToC = do { bsA <- bsToC1; bsB <- bsToC2; return (bsA, bsB) } - bpFromC (ptrA, ptrB) = bpFromC1 ptrA >> bpFromC2 ptrB - bsFromC (bsA, bsB) = bsFromC1 bsA >> bsFromC2 bsB - -blockCopy :: Ptr a -> Ptr b -> Int -> IO () -blockCopy src dst byteSize = memcpy dst src (fromIntegral byteSize) - - --- Foreign imports -foreign import ccall memcpy :: Ptr a -> Ptr b -> CInt -> IO () - --- Helpers -box :: (Int# -> Int#) -> Int -> Int -box f (I# x) = I# (f x) - diff --git a/Data/Array/Accelerate/IO/ByteString.hs b/Data/Array/Accelerate/IO/ByteString.hs deleted file mode 100644 --- a/Data/Array/Accelerate/IO/ByteString.hs +++ /dev/null @@ -1,49 +0,0 @@ --- | --- Module : Data.Array.Accelerate.IO.ByteString --- Copyright : [2010..2011] Sean Seefried --- [2010..2014] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.IO.ByteString ( - - -- ** Data.ByteString - ByteStrings, fromByteString, toByteString - -) where - -import Data.Array.Accelerate.IO.BlockCopy -import Data.Array.Accelerate.Array.Sugar - - --- | Block copies bytes from a collection of 'ByteString's to freshly allocated --- Accelerate array. --- --- The type of elements (@e@) in the output Accelerate array determines the --- structure of the collection of 'ByteString's that will be required as the --- second argument to this function. See 'ByteStrings' --- -fromByteString :: (Shape sh, Elt e) => sh -> ByteStrings (EltRepr e) -> IO (Array sh e) -fromByteString sh byteStrings = do - arr <- allocateArray sh - let copier = let ((_,f),_,_) = blockCopyFunGenerator arr in f - copier byteStrings - return arr - - --- | Block copy from an Accelerate array to a collection of freshly allocated --- 'ByteString's. --- --- The type of elements (@e@) in the input Accelerate array determines the --- structure of the collection of 'ByteString's that will be output. See --- 'ByteStrings' --- -toByteString :: (Shape sh, Elt e) => Array sh e -> IO (ByteStrings (EltRepr e)) -toByteString arr = do - let copier = let (_,(_,f),_) = blockCopyFunGenerator arr in f - copier - diff --git a/Data/Array/Accelerate/IO/IArray.hs b/Data/Array/Accelerate/IO/IArray.hs deleted file mode 100644 --- a/Data/Array/Accelerate/IO/IArray.hs +++ /dev/null @@ -1,97 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Data.Array.Accelerate.IO.IArray --- Copyright : [2016] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- Convert immutable arrays of the library into Accelerate 'Array's. --- - -module Data.Array.Accelerate.IO.IArray ( - - -- ** 'Data.Array.IArray.IArray' - fromIArray, - toIArray, - -) where - -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Type - -import Data.Array.IArray ( IArray ) -import qualified Data.Array.IArray as IArray - - --- | Convert an 'IArray' to an accelerated array. --- --- While the type signature mentions Accelerate internals that are not exported, --- in practice satisfying the type equality is straight forward. The index type --- @ix@ must be the unit type @()@ for singleton arrays, or an @Int@ or tuple of --- @Int@'s for multidimensional arrays. --- -fromIArray - :: (IxShapeRepr (EltRepr ix) ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e) - => a ix e - -> Array sh e -fromIArray iarr = fromFunction sh (\ix -> iarr IArray.! fromIxShapeRepr (offset lo' ix)) - where - (lo,hi) = IArray.bounds iarr - lo' = toIxShapeRepr lo - hi' = toIxShapeRepr hi - sh = rangeToShape (lo', hi') - - -- IArray does not necessarily start indexing from zero. Thus, we need to - -- add some offset to the Accelerate indices to map them onto the valid - -- index range of the IArray - -- - offset :: forall sh. Shape sh => sh -> sh -> sh - offset ix0 ix = toElt $ go (eltType (undefined::sh)) (fromElt ix0) (fromElt ix) - where - go :: TupleType ix -> ix -> ix -> ix - go UnitTuple () () = () - go (PairTuple tl tr) (l0, r0) (l,r) = (go tl l0 l, go tr r0 r) - go (SingleTuple (NumScalarType (IntegralNumType TypeInt{}))) i0 i = i0+i - go _ _ _ - = error "Data.Array.Accelerate.IO.IArray: error in index offset" - --- | Convert an accelerated array to an 'IArray'. --- -toIArray - :: (IxShapeRepr (EltRepr ix) ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix) - => Array sh e - -> a ix e -toIArray arr = IArray.array bnds [(ix, arr ! toIxShapeRepr ix) | ix <- IArray.range bnds] - where - (lo,hi) = shapeToRange (shape arr) - bnds = (fromIxShapeRepr lo, fromIxShapeRepr hi) - - -type family IxShapeRepr e where - IxShapeRepr () = () - IxShapeRepr Int = ((),Int) - IxShapeRepr (t,h) = (IxShapeRepr t, h) - -fromIxShapeRepr :: forall ix sh. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix) => sh -> ix -fromIxShapeRepr sh = toElt (go (eltType (undefined::ix)) (fromElt sh)) - where - go :: forall ix'. TupleType ix' -> IxShapeRepr ix' -> ix' - go UnitTuple () = () - go (SingleTuple (NumScalarType (IntegralNumType TypeInt{}))) ((),h) = h - go (PairTuple tt _) (t, h) = (go tt t, h) - go _ _ = error "Data.Array.Accelerate.IO.IArray: not a valid IArray.Ix" - -toIxShapeRepr :: forall ix sh. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix) => ix -> sh -toIxShapeRepr ix = toElt (go (eltType (undefined::ix)) (fromElt ix)) - where - go :: forall ix'. TupleType ix' -> ix' -> IxShapeRepr ix' - go UnitTuple () = () - go (SingleTuple (NumScalarType (IntegralNumType TypeInt{}))) h = ((), h) - go (PairTuple tt _) (t, h) = (go tt t, h) - go _ _ = error "Data.Array.Accelerate.IO.IArray: not a valid IArray.Ix" - diff --git a/Data/Array/Accelerate/IO/Ptr.hs b/Data/Array/Accelerate/IO/Ptr.hs deleted file mode 100644 --- a/Data/Array/Accelerate/IO/Ptr.hs +++ /dev/null @@ -1,100 +0,0 @@ --- | --- Module : Data.Array.Accelerate.IO.Ptr --- Copyright : [2010..2011] Sean Seefried --- [2010..2014] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.IO.Ptr ( - - -- ** Raw pointers - BlockPtrs, fromPtr, toPtr, - - -- ** Direct copying functions - BlockCopyFun, BlockCopyFuns, fromArray, toArray - -) where - -import Data.Array.Accelerate.IO.BlockCopy -import Data.Array.Accelerate.Array.Sugar - - --- | Block copy regions of memory into a freshly allocated Accelerate array. The --- type of elements (@e@) in the output Accelerate array determines the --- structure of the collection of pointers that will be required as the second --- argument to this function. See 'BlockPtrs' --- --- Each one of these pointers points to a block of memory that is the source --- of data for the Accelerate array (unlike function 'toArray' where one --- passes in function which copies data to a destination address.). --- -fromPtr :: (Shape sh, Elt e) => sh -> BlockPtrs (EltRepr e) -> IO (Array sh e) -fromPtr sh blkPtrs = do - arr <- allocateArray sh - let copier = let ((f,_),_,_) = blockCopyFunGenerator arr in f - copier blkPtrs - return arr - - --- | Block copy from Accelerate array to pre-allocated regions of memory. The --- type of element of the input Accelerate array (@e@) determines the --- structure of the collection of pointers that will be required as the second --- argument to this function. See 'BlockPtrs' --- --- The memory associated with the pointers must have already been allocated. --- -toPtr :: (Shape sh, Elt e) => Array sh e -> BlockPtrs (EltRepr e) -> IO () -toPtr arr blockPtrs = do - let copier = let (_,(f,_),_) = blockCopyFunGenerator arr in f - copier blockPtrs - return () - - --- | Copy values from an Accelerate array using a collection of functions that --- have type 'BlockCopyFun'. The argument of type @Ptr e@ in each of these --- functions refers to the address of the /source/ block of memory in the --- Accelerate Array. The /destination/ address is implicit. e.g. the --- 'BlockCopyFun' could be the result of partially application to a @Ptr e@ --- pointing to the destination block. --- --- The structure of this collection of functions depends on the elemente type --- @e@. Each function (of type 'BlockCopyFun') copies data to a destination --- address (pointed to by the argument of type @Ptr ()@). --- --- Unless there is a particularly pressing reason to use this function, the --- 'fromPtr' function is sufficient as it uses an efficient low-level call to --- libc's @memcpy@ to perform the copy. --- -fromArray :: (Shape sh, Elt e) => Array sh e -> BlockCopyFuns (EltRepr e) -> IO () -fromArray arr blockCopyFuns = do - let copier = let (_,_,f) = blockCopyFunGenerator arr in f - copier blockCopyFuns - return () - - --- | Copy values to a freshly allocated Accelerate array using a collection of --- functions that have type 'BlockCopyFun'. The argument of type @Ptr e@ in --- each of these functions refers to the address of the /destination/ block of --- memory in the Accelerate Array. The /source/ address is implicit. e.g. the --- 'BlockCopyFun' could be the result of a partial application to a @Ptr e@ --- pointing to the source block. --- --- The structure of this collection of functions depends on the elemente type --- @e@. Each function (of type 'BlockCopyFun') copies data to a destination --- address (pointed to by the argument of type @Ptr ()@). --- --- Unless there is a particularly pressing reason to use this function, the --- 'fromPtr' function is sufficient as it uses an efficient low-level call to --- libc's @memcpy@ to perform the copy. --- -toArray :: (Shape sh, Elt e) => sh -> BlockCopyFuns (EltRepr e) -> IO (Array sh e) -toArray sh blockCopyFuns = do - arr <- allocateArray sh - let copier = let (_,_,f) = blockCopyFunGenerator arr in f - copier blockCopyFuns - return arr - diff --git a/Data/Array/Accelerate/IO/Repa.hs b/Data/Array/Accelerate/IO/Repa.hs deleted file mode 100644 --- a/Data/Array/Accelerate/IO/Repa.hs +++ /dev/null @@ -1,177 +0,0 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} --- | --- Module : Data.Array.Accelerate.IO.Repa --- Copyright : [2012..2014] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- - -module Data.Array.Accelerate.IO.Repa ( - - -- ** Data.Array.Repa - -- - -- | This provides an efficient non-copying Repa manifest array representation - -- that can be passed directly to Accelerate. - -- - -- The standard rules for dealing with manifest Repa arrays apply: - -- - -- * If you want to have Repa 'R.computeP' directly into an Accelerate array, - -- the source array must have a delayed representation. - -- - -- * If you want to copy between manifest arrays, use 'R.copyP' instead. - -- - A, Shapes, - fromRepa, toRepa, - computeAccS, computeAccP - -) where - -import Control.Monad - -import qualified Data.Array.Repa as R -import qualified Data.Array.Repa.Eval as R -import qualified Data.Array.Accelerate.Array.Data as A -import qualified Data.Array.Accelerate.Array.Sugar as A - - --- | Index conversion and equivalence statement between Repa and Accelerate --- array shapes. That is, a n-dimensional Repa array will produce an --- n-dimensional Accelerate array of the same extent, and vice-versa. --- -class (R.Shape r, A.Shape a) => Shapes r a | a -> r, r -> a where - -- these are really equivalent representations, so unsafeCoerce would probably - -- work, but bad programmers get no cookies. - toR :: a -> r - toA :: r -> a - -instance Shapes R.Z A.Z where - {-# INLINE toR #-} - toR A.Z = R.Z - {-# INLINE toA #-} - toA R.Z = A.Z - -instance Shapes sr sa => Shapes (sr R.:. Int) (sa A.:. Int) where - {-# INLINE toR #-} - toR (sa A.:. sz) = toR sa R.:. sz - {-# INLINE toA #-} - toA (sr R.:. sz) = toA sr A.:. sz - - --- | The representation tag for manifest arrays based on Data.Array.Accelerate. --- --- The Accelerate array implementation is based on type families and picks an --- efficient, unboxed representation for every element type. Moreover, these --- arrays can be handed efficiently (without copying) to Accelerate programs --- for further computation. --- -data A - --- Repr ------------------------------------------------------------------------ - --- | Reading elements of the Accelerate array --- -instance A.Elt e => R.Source A e where - data Array A sh e - = AAccelerate !sh !(A.ArrayData (A.EltRepr e)) - - {-# INLINE extent #-} - extent (AAccelerate sh _) - = sh - - {-# INLINE linearIndex #-} - linearIndex (AAccelerate sh adata) ix - | ix >= 0 && ix < R.size sh - = A.toElt (adata `A.unsafeIndexArrayData` ix) - - | otherwise - = error "Repa: accelerate array out of bounds" - - {-# INLINE unsafeLinearIndex #-} - unsafeLinearIndex (AAccelerate _ adata) ix - = A.toElt (adata `A.unsafeIndexArrayData` ix) - - {-# INLINE deepSeqArray #-} - deepSeqArray (AAccelerate sh adata) x - = sh `R.deepSeq` adata `seq` x - - --- | Filling Accelerate arrays --- -instance A.Elt e => R.Target A e where - data MVec A e - = MAVec (A.MutableArrayData (A.EltRepr e)) - - {-# INLINE newMVec #-} - newMVec n - = MAVec `liftM` A.newArrayData n - - {-# INLINE unsafeWriteMVec #-} - unsafeWriteMVec (MAVec mad) n e - = A.unsafeWriteArrayData mad n (A.fromElt e) - - {-# INLINE unsafeFreezeMVec #-} - unsafeFreezeMVec sh (MAVec mad) - = do adata <- A.unsafeFreezeArrayData mad - return $! AAccelerate sh adata - - {-# INLINE deepSeqMVec #-} - deepSeqMVec (MAVec arr) x -- maybe? - = arr `seq` x - - {-# INLINE touchMVec #-} - touchMVec _ -- maybe? - = return () - - --- Conversions ----------------------------------------------------------------- - --- | /O(1)/. Wrap an Accelerate array. --- -toRepa - :: Shapes sh sh' - => A.Array sh' e -> R.Array A sh e -{-# INLINE toRepa #-} -toRepa arr@(A.Array _ adata) - = AAccelerate (toR (A.shape arr)) adata - --- | /O(1)/. Unpack to an Accelerate array. --- -fromRepa - :: (Shapes sh sh', A.Elt e) - => R.Array A sh e -> A.Array sh' e -{-# INLINE fromRepa #-} -fromRepa (AAccelerate sh adata) - = A.Array (A.fromElt (toA sh)) adata - - --- Computations ---------------------------------------------------------------- - --- | Sequential computation of array elements --- -computeAccS - :: (R.Load r sh e, A.Elt e) - => R.Array r sh e -> R.Array A sh e -{-# INLINE computeAccS #-} -computeAccS = R.computeS - --- | Parallel computation of array elements --- -computeAccP - :: (R.Load r sh e, A.Elt e, Monad m) - => R.Array r sh e - -> m (R.Array A sh e) -{-# INLINE computeAccP #-} -computeAccP = R.computeP - diff --git a/Data/Array/Accelerate/IO/Vector.hs b/Data/Array/Accelerate/IO/Vector.hs deleted file mode 100644 --- a/Data/Array/Accelerate/IO/Vector.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Data.Array.Accelerate.IO.Vector --- Copyright : [2012] Adam C. Foltzer --- [2012..2015] Trevor L. McDonell --- License : BSD3 --- --- Maintainer : Trevor L. McDonell --- Stability : experimental --- Portability : non-portable (GHC extensions) --- --- Helpers for fast conversion between 'Data.Vector.Storable' vectors into --- Accelerate arrays. --- - -module Data.Array.Accelerate.IO.Vector ( - - -- ** Data.Vector.Storable - -- - -- | This provides an efficient non-copying conversion between storable - -- vectors and Accelerate arrays. - -- - Vectors, toVectors, fromVectors, - -) where - --- standard libraries -import Data.Int -import Data.Word -import Foreign.C.Types -import Data.Vector.Storable -import System.IO.Unsafe - --- friends -import Data.Array.Accelerate.Lifetime -import Data.Array.Accelerate.Array.Unique -import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Sugar hiding ( Vector, size ) -import Data.Array.Accelerate.Array.Representation ( size ) - - --- | A family of types that represents a collection of storable 'Vector's. The --- structure of the collection depends on the element type @e@. --- --- For example: --- --- * if @e :: Int@, then @Vectors (EltRepr e) :: ((), Vector Int)@ --- --- * if @e :: (Double, Float)@, then @Vectors (EltRepr e) :: (((), Vector Double), Vector Float)@ --- -type family Vectors e - -type instance Vectors () = () -type instance Vectors Int = Vector Int -type instance Vectors Int8 = Vector Int8 -type instance Vectors Int16 = Vector Int16 -type instance Vectors Int32 = Vector Int32 -type instance Vectors Int64 = Vector Int64 -type instance Vectors Word = Vector Word -type instance Vectors Word8 = Vector Word8 -type instance Vectors Word16 = Vector Word16 -type instance Vectors Word32 = Vector Word32 -type instance Vectors Word64 = Vector Word64 -type instance Vectors CShort = Vector Int16 -type instance Vectors CUShort = Vector Word16 -type instance Vectors CInt = Vector Int32 -type instance Vectors CUInt = Vector Word32 -type instance Vectors CLong = Vector HTYPE_LONG -type instance Vectors CULong = Vector HTYPE_UNSIGNED_LONG -type instance Vectors CLLong = Vector Int64 -type instance Vectors CULLong = Vector Word64 -type instance Vectors Float = Vector Float -type instance Vectors CFloat = Vector Float -type instance Vectors Double = Vector Double -type instance Vectors CDouble = Vector Double -type instance Vectors Bool = Vector Word8 -type instance Vectors Char = Vector Char -type instance Vectors CChar = Vector HTYPE_CCHAR -type instance Vectors CSChar = Vector Int8 -type instance Vectors CUChar = Vector Word8 -type instance Vectors (a,b) = (Vectors a, Vectors b) - - --- | /O(1)/. Treat a set of storable vectors as Accelerate arrays. The type of --- elements @e@ in the output Accelerate array determines the structure of the --- collection that will be required as the second argument. See 'Vectors'. --- --- Data will be consumed from the vector in row-major order. You must make sure --- that each of the input vectors contains the right number of elements --- -fromVectors :: (Shape sh, Elt e) => sh -> Vectors (EltRepr e) -> Array sh e -fromVectors sh vecs = Array (fromElt sh) (aux arrayElt vecs) - where - wrap k v = let (fp,_) = unsafeToForeignPtr0 v - in k (unsafePerformIO $ newUniqueArray fp) - - aux :: ArrayEltR e -> Vectors e -> ArrayData e - aux ArrayEltRunit = const AD_Unit - aux ArrayEltRint = wrap AD_Int - aux ArrayEltRint8 = wrap AD_Int8 - aux ArrayEltRint16 = wrap AD_Int16 - aux ArrayEltRint32 = wrap AD_Int32 - aux ArrayEltRint64 = wrap AD_Int64 - aux ArrayEltRword = wrap AD_Word - aux ArrayEltRword8 = wrap AD_Word8 - aux ArrayEltRword16 = wrap AD_Word16 - aux ArrayEltRword32 = wrap AD_Word32 - aux ArrayEltRword64 = wrap AD_Word64 - aux ArrayEltRcshort = wrap AD_CShort - aux ArrayEltRcushort = wrap AD_CUShort - aux ArrayEltRcint = wrap AD_CInt - aux ArrayEltRcuint = wrap AD_CUInt - aux ArrayEltRclong = wrap AD_CLong - aux ArrayEltRculong = wrap AD_CULong - aux ArrayEltRcllong = wrap AD_CLLong - aux ArrayEltRcullong = wrap AD_CULLong - aux ArrayEltRfloat = wrap AD_Float - aux ArrayEltRdouble = wrap AD_Double - aux ArrayEltRcfloat = wrap AD_CFloat - aux ArrayEltRcdouble = wrap AD_CDouble - aux ArrayEltRbool = wrap AD_Bool - aux ArrayEltRchar = wrap AD_Char - aux ArrayEltRcchar = wrap AD_CChar - aux ArrayEltRcschar = wrap AD_CSChar - aux ArrayEltRcuchar = wrap AD_CUChar - aux (ArrayEltRpair ae1 ae2) = \(v1,v2) -> AD_Pair (aux ae1 v1) (aux ae2 v2) - - --- | /O(1)/. Turn the Accelerate array into a collection of storable 'Vector's. --- The element type of the array @e@ will determine the structure of the output --- collection. See 'Vectors'. --- --- Data will be output in row-major order. --- -toVectors :: (Shape sh, Elt e) => Array sh e -> Vectors (EltRepr e) -toVectors (Array sh adata) = aux arrayElt adata - where - wrap :: Storable a => UniqueArray a -> Vector a - wrap ua = unsafeFromForeignPtr0 (unsafeGetValue (uniqueArrayData ua)) (size sh) - - aux :: ArrayEltR e -> ArrayData e -> Vectors e - aux ArrayEltRunit AD_Unit = () - aux ArrayEltRint (AD_Int s) = wrap s - aux ArrayEltRint8 (AD_Int8 s) = wrap s - aux ArrayEltRint16 (AD_Int16 s) = wrap s - aux ArrayEltRint32 (AD_Int32 s) = wrap s - aux ArrayEltRint64 (AD_Int64 s) = wrap s - aux ArrayEltRword (AD_Word s) = wrap s - aux ArrayEltRword8 (AD_Word8 s) = wrap s - aux ArrayEltRword16 (AD_Word16 s) = wrap s - aux ArrayEltRword32 (AD_Word32 s) = wrap s - aux ArrayEltRword64 (AD_Word64 s) = wrap s - aux ArrayEltRcshort (AD_CShort s) = wrap s - aux ArrayEltRcushort (AD_CUShort s) = wrap s - aux ArrayEltRcint (AD_CInt s) = wrap s - aux ArrayEltRcuint (AD_CUInt s) = wrap s - aux ArrayEltRclong (AD_CLong s) = wrap s - aux ArrayEltRculong (AD_CULong s) = wrap s - aux ArrayEltRcllong (AD_CLLong s) = wrap s - aux ArrayEltRcullong (AD_CULLong s) = wrap s - aux ArrayEltRfloat (AD_Float s) = wrap s - aux ArrayEltRdouble (AD_Double s) = wrap s - aux ArrayEltRcfloat (AD_CFloat s) = wrap s - aux ArrayEltRcdouble (AD_CDouble s) = wrap s - aux ArrayEltRbool (AD_Bool s) = wrap s - aux ArrayEltRchar (AD_Char s) = wrap s - aux ArrayEltRcchar (AD_CChar s) = wrap s - aux ArrayEltRcschar (AD_CSChar s) = wrap s - aux ArrayEltRcuchar (AD_CUChar s) = wrap s - aux (ArrayEltRpair ae1 ae2) (AD_Pair s1 s2) = (aux ae1 s1, aux ae2 s2) - diff --git a/accelerate-io.cabal b/accelerate-io.cabal --- a/accelerate-io.cabal +++ b/accelerate-io.cabal @@ -1,6 +1,6 @@ Name: accelerate-io -Version: 1.0.0.1 -Cabal-version: >= 1.6 +Version: 1.2.0.0 +Cabal-version: >= 1.10 Tested-with: GHC >= 7.8 Build-type: Simple @@ -29,68 +29,98 @@ README.md CHANGELOG.md -Flag bounds-checks - Description: Enable bounds checking - Default: True - -Flag unsafe-checks - Description: Enable bounds checking in unsafe operations - Default: False - -Flag internal-checks - Description: Enable internal consistency checks - Default: False - -Library - Build-depends: - base >= 4.7 && < 4.11 - , accelerate >= 1.0 +library + build-depends: + base >= 4.7 && < 4.12 + , accelerate >= 1.2 , array >= 0.3 , bmp >= 1.2 , bytestring >= 0.9 + , primitive >= 0.6 , repa >= 3.2 , vector >= 0.9 - Exposed-modules: - Data.Array.Accelerate.IO + exposed-modules: + -- bmp + Data.Array.Accelerate.IO.Codec.BMP - Other-modules: - Data.Array.Accelerate.IO.BlockCopy - Data.Array.Accelerate.IO.BMP - Data.Array.Accelerate.IO.ByteString - Data.Array.Accelerate.IO.IArray - Data.Array.Accelerate.IO.Ptr - Data.Array.Accelerate.IO.Repa - Data.Array.Accelerate.IO.Vector + -- bytestring + Data.Array.Accelerate.IO.Data.ByteString + -- vector + Data.Array.Accelerate.IO.Data.Vector.Generic + Data.Array.Accelerate.IO.Data.Vector.Generic.Mutable + Data.Array.Accelerate.IO.Data.Vector.Primitive + Data.Array.Accelerate.IO.Data.Vector.Storable + Data.Array.Accelerate.IO.Data.Vector.Unboxed + + -- array + Data.Array.Accelerate.IO.Data.Array.IArray + Data.Array.Accelerate.IO.Data.Array.Unboxed + + -- foeign + Data.Array.Accelerate.IO.Foreign.Ptr + Data.Array.Accelerate.IO.Foreign.ForeignPtr + + -- repa + Data.Array.Repa.Repr.Accelerate + + other-modules: + Data.Array.Accelerate.IO.Data.Array.Internal + Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal + + default-language: + Haskell2010 + + hs-source-dirs: + src + ghc-options: -O2 -Wall -funbox-strict-fields - if flag(bounds-checks) - cpp-options: -DACCELERATE_BOUNDS_CHECKS + ghc-prof-options: + -fprof-auto - if flag(unsafe-checks) - cpp-options: -DACCELERATE_UNSAFE_CHECKS - if flag(internal-checks) - cpp-options: -DACCELERATE_INTERNAL_CHECKS +test-suite test-io + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + main-is: Test.hs + ghc-options: -main-is Test - -- Don't add the extensions list here. Instead, place individual LANGUAGE - -- pragmas in the files that require a specific extension. This means the - -- project loads in GHCi, and avoids extension clashes. - -- - -- Extensions: + build-depends: + base >= 4.7 && < 4.12 + , accelerate + , accelerate-io + , array + , hedgehog >= 0.5 + , tasty >= 0.11 + , tasty-hedgehog >= 0.1 + , vector -Source-repository head + ghc-options: + -Wall + -threaded + -rtsopts + + other-modules: + Test.Array.IArray + Test.Array.Unboxed + Test.Vector.Storable + Test.Vector.Unboxed + Test.Util + + +source-repository head Type: git Location: git://github.com/AccelerateHS/accelerate-io.git -Source-repository this +source-repository this Type: git - Tag: 1.0.0.1 + Tag: 1.2.0.0 Location: git://github.com/AccelerateHS/accelerate-io.git -- vim: nospell - diff --git a/src/Data/Array/Accelerate/IO/Codec/BMP.hs b/src/Data/Array/Accelerate/IO/Codec/BMP.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Codec/BMP.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Data.Array.Accelerate.IO.Codec.BMP +-- Copyright : [2012..2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Read and write uncompressed 24 or 32-bit Windows BMP images into +-- a packed-word RGBA format. See the /colour-accelerate/ package for colour +-- representations and utilities such as packing and unpacking. +-- + +module Data.Array.Accelerate.IO.Codec.BMP ( + + RGBA32, + readImageFromBMP, writeImageToBMP, + +) where + +import Data.Word +import Codec.BMP + +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.IO.Data.ByteString + + +-- | Packed RGBA pixel data +-- +type RGBA32 = Word32 + + +-- File IO --------------------------------------------------------------------- + +-- | Read RGBA components from a BMP file. +-- +readImageFromBMP :: FilePath -> IO (Either Error (Array DIM2 RGBA32)) +readImageFromBMP file = do + ebmp <- readBMP file + case ebmp of + Left err -> return $ Left err + Right bmp -> do + let (w,h) = bmpDimensions bmp + bs = unpackBMPToRGBA32 bmp' + arr = fromByteStrings (Z :. h :. w) bs + -- + bmp' = bmp { bmpBitmapInfo = info' } + info' = case bmpBitmapInfo bmp of + InfoV3 i -> InfoV3 (info3 i) + InfoV4 i -> InfoV4 (info4 i) + InfoV5 i -> InfoV5 (info5 i) + + info3 BitmapInfoV3{..} = BitmapInfoV3 { dib3HeightFlipped = not dib3HeightFlipped, .. } + info4 BitmapInfoV4{..} = BitmapInfoV4 { dib4InfoV3 = info3 dib4InfoV3, .. } + info5 BitmapInfoV5{..} = BitmapInfoV5 { dib5InfoV4 = info4 dib5InfoV4, .. } + -- + return $ Right arr + + +-- | Write the image data to a file. +-- +writeImageToBMP :: FilePath -> Array DIM2 RGBA32 -> IO () +writeImageToBMP file rgba = writeBMP file bmp' + where + Z :. h :. w = shape rgba + bs = toByteStrings rgba + bmp = packRGBA32ToBMP w h bs + -- + bmp' = bmp { bmpBitmapInfo = info' } + info' = case bmpBitmapInfo bmp of + InfoV3 i -> InfoV3 (info3 i) + InfoV4 i -> InfoV4 (info4 i) + InfoV5 i -> InfoV5 (info5 i) + + info3 BitmapInfoV3{..} = BitmapInfoV3 { dib3Height = -dib3Height, dib3HeightFlipped = True, .. } + info4 BitmapInfoV4{..} = BitmapInfoV4 { dib4InfoV3 = info3 dib4InfoV3, .. } + info5 BitmapInfoV5{..} = BitmapInfoV5 { dib5InfoV4 = info4 dib5InfoV4, .. } + diff --git a/src/Data/Array/Accelerate/IO/Data/Array/IArray.hs b/src/Data/Array/Accelerate/IO/Data/Array/IArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Array/IArray.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Array.IArray +-- Copyright : [2016..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Convert between immutable 'IArray's and Accelerate 'Array's. +-- + +module Data.Array.Accelerate.IO.Data.Array.IArray ( + + IxShapeRepr, + fromIArray, + toIArray, + +) where + +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Type +import Data.Array.Accelerate.Error + +import Data.Array.Accelerate.IO.Data.Array.Internal + +import Data.Array.IArray ( IArray ) +import qualified Data.Array.IArray as IArray + + +-- | /O(n)/. Convert an 'IArray' to an Accelerate 'Array'. +-- +-- The index type @ix@ of the 'IArray' corresponds to the shape @sh@ of the +-- Accelerate 'Array' in the following way: +-- +-- > DIM0 ~ () +-- > DIM1 ~ Int +-- > DIM2 ~ (Int,Int) +-- > DIM3 ~ (Int,Int,Int) +-- +-- ...and so forth. +-- +{-# INLINE fromIArray #-} +fromIArray + :: (IxShapeRepr (EltRepr ix) ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e) + => a ix e + -> Array sh e +fromIArray iarr = fromFunction sh (\ix -> iarr IArray.! fromIxShapeRepr (offset lo' ix)) + where + (lo,hi) = IArray.bounds iarr + lo' = toIxShapeRepr lo + hi' = toIxShapeRepr hi + sh = rangeToShape (lo', hi') + + -- IArray does not necessarily start indexing from zero. Thus, we need to + -- add some offset to the Accelerate indices to map them onto the valid + -- index range of the IArray + -- + offset :: forall sh. Shape sh => sh -> sh -> sh + offset ix0 ix = toElt $ go (eltType (undefined::sh)) (fromElt ix0) (fromElt ix) + where + go :: TupleType ix -> ix -> ix -> ix + go TypeRunit () () = () + go (TypeRpair tl tr) (l0, r0) (l,r) = (go tl l0 l, go tr r0 r) + go (TypeRscalar (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) i0 i = i0+i + go _ _ _ = + $internalError "fromIArray" "error in index offset" + + +-- | /O(n)/. Convert an Accelerate 'Array' to an 'IArray'. +-- +-- See 'fromIArray' for a discussion on the expected shape types. +-- +{-# INLINE toIArray #-} +toIArray + :: forall ix sh a e. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix) + => Maybe ix -- ^ if 'Just' this as the index lower bound, otherwise the array is indexed from zero + -> Array sh e + -> a ix e +toIArray mix0 arr = IArray.array bnds0 [(offset ix, arr ! toIxShapeRepr ix) | ix <- IArray.range bnds] + where + (u,v) = shapeToRange (shape arr) + bnds@(lo,hi) = (fromIxShapeRepr u, fromIxShapeRepr v) + bnds0 = (offset lo, offset hi) + + offset :: ix -> ix + offset ix = + case mix0 of + Nothing -> ix + Just ix0 -> offset' ix0 ix + + offset' :: ix -> ix -> ix + offset' ix0 ix + = fromIxShapeRepr + . (toElt :: EltRepr sh -> sh) + $ go (eltType (undefined::sh)) (fromElt (toIxShapeRepr ix0 :: sh)) (fromElt (toIxShapeRepr ix :: sh)) + where + go :: TupleType sh' -> sh' -> sh' -> sh' + go TypeRunit () () = () + go (TypeRpair tl tr) (l0,r0) (l,r) = (go tl l0 l, go tr r0 r) + go (TypeRscalar (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) i0 i = i0+i + go _ _ _ = + $internalError "toIArray" "error in index offset" + diff --git a/src/Data/Array/Accelerate/IO/Data/Array/Internal.hs b/src/Data/Array/Accelerate/IO/Data/Array/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Array/Internal.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Array.Internal +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.IO.Data.Array.Internal + where + +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Type + + +type family IxShapeRepr e where + IxShapeRepr () = () + IxShapeRepr Int = ((),Int) + IxShapeRepr (t,h) = (IxShapeRepr t, h) + +fromIxShapeRepr :: forall ix sh. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix) => sh -> ix +fromIxShapeRepr sh = toElt (go (eltType (undefined::ix)) (fromElt sh)) + where + go :: forall ix'. TupleType ix' -> IxShapeRepr ix' -> ix' + go TypeRunit () = () + go (TypeRpair tt _) (t, h) = (go tt t, h) + go (TypeRscalar (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) ((),h) = h + go _ _ = + $internalError "fromIxShapeRepr" "not a valid IArray.Ix" + +toIxShapeRepr :: forall ix sh. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix) => ix -> sh +toIxShapeRepr ix = toElt (go (eltType (undefined::ix)) (fromElt ix)) + where + go :: forall ix'. TupleType ix' -> ix' -> IxShapeRepr ix' + go TypeRunit () = () + go (TypeRpair tt _) (t, h) = (go tt t, h) + go (TypeRscalar (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) h = ((),h) + go _ _ = + $internalError "toIxShapeRepr" "not a valid IArray.Ix" + diff --git a/src/Data/Array/Accelerate/IO/Data/Array/Unboxed.hs b/src/Data/Array/Accelerate/IO/Data/Array/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Array/Unboxed.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Array.Unboxed +-- Copyright : [2016..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Efficient conversion between immutable unboxed 'IArray's and Accelerate +-- 'Array's. +-- + +module Data.Array.Accelerate.IO.Data.Array.Unboxed ( + + IxShapeRepr, + fromUArray, + toUArray, + +) where + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Type +import qualified Data.Array.Accelerate.Array.Representation as R + +import Data.Array.Accelerate.IO.Data.Array.Internal +import Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal + +import Data.Primitive ( Prim, sizeOf ) +import Data.Primitive.ByteArray + +import Data.Array.Base +import Data.Array.Unboxed as U hiding ( Array ) +import System.IO.Unsafe + + +-- | /O(n)/. Convert an unboxed 'UArray' into an Accelerate array. +-- +-- See 'Data.Array.Accelerate.IO.Data.Array.IArray.fromIArray' for more +-- information about the array index type. +-- +-- If the underlying vectors are pinned then this can be done without copying. +-- +-- See also: +-- +-- @since 1.1.0.0@ +-- +{-# INLINE fromUArray #-} +fromUArray + :: forall ix sh e. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, IArray UArray e, Ix ix, Shape sh, Elt ix, Elt e) + => UArray ix e + -> Array sh e +fromUArray (UArray lo hi n ba#) = Array (fromElt sh) (aux (arrayElt :: ArrayEltR (EltRepr e))) + where + sh = rangeToShape (toIxShapeRepr lo, toIxShapeRepr hi) :: sh + + wrap :: forall a. Prim a => (UniqueArray a -> ArrayData a) -> ArrayData a + wrap k = k $ unsafePerformIO (newUniqueArray =<< foreignPtrOfByteArray 0 (n * sizeOf (undefined::a)) (ByteArray ba#)) + + aux :: ArrayEltR a -> ArrayData a + aux ArrayEltRint = wrap AD_Int + aux ArrayEltRint8 = wrap AD_Int8 + aux ArrayEltRint16 = wrap AD_Int16 + aux ArrayEltRint32 = wrap AD_Int32 + aux ArrayEltRint64 = wrap AD_Int64 + aux ArrayEltRword = wrap AD_Word + aux ArrayEltRword8 = wrap AD_Word8 + aux ArrayEltRword16 = wrap AD_Word16 + aux ArrayEltRword32 = wrap AD_Word32 + aux ArrayEltRword64 = wrap AD_Word64 + aux ArrayEltRfloat = wrap AD_Float + aux ArrayEltRdouble = wrap AD_Double + aux ArrayEltRchar = wrap AD_Char + aux ArrayEltRbool = $internalError "fromUArray" "TODO: Bool" -- need to unpack bit array + aux _ = $internalError "fromUArray" "unsupported type" + + +-- | /O(1)/ (typically). Convert an Accelerate 'Array' to an unboxed 'UArray'. +-- +-- See 'Data.Array.Accelerate.IO.Data.Array.IArray.fromIArray' for more +-- information about the array index type. +-- +-- If the array data was allocated by Accelerate, this can typically be done +-- without copying. +-- +-- @since 1.1.0.0@ +-- +{-# INLINE toUArray #-} +toUArray + :: forall ix sh e. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, IArray UArray e, Ix ix, Shape sh, Elt ix) + => Maybe ix -- ^ if 'Just' this is the index lower bound, otherwise the array is indexed from zero + -> Array sh e + -> UArray ix e +toUArray mix0 arr@(Array sh adata) = + case ba of + ByteArray ba# -> UArray lo hi n ba# + where + n = R.size sh + bnds = shapeToRange (shape arr) + lo = fromIxShapeRepr (offset (fst bnds)) + hi = fromIxShapeRepr (offset (snd bnds)) + ba = aux arrayElt adata + + offset :: sh -> sh + offset ix = + case mix0 of + Nothing -> ix + Just ix0 -> offset' ix0 ix + + offset' :: ix -> sh -> sh + offset' ix0 = toElt . go (eltType (undefined::sh)) (fromElt (toIxShapeRepr ix0 :: sh)) . fromElt + where + go :: TupleType sh' -> sh' -> sh' -> sh' + go TypeRunit () () = () + go (TypeRpair tl tr) (l0, r0) (l,r) = (go tl l0 l, go tr r0 r) + go (TypeRscalar (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) i0 i = i0+i + go _ _ _ = + $internalError "toUArray" "error in index offset" + + wrap :: forall a. Prim a => UniqueArray a -> ByteArray + wrap ua = unsafePerformIO $ byteArrayOfForeignPtr (n * sizeOf (undefined::a)) (unsafeGetValue (uniqueArrayData ua)) + + aux :: ArrayEltR a -> ArrayData a -> ByteArray + aux ArrayEltRint (AD_Int v) = wrap v + aux ArrayEltRint8 (AD_Int8 v) = wrap v + aux ArrayEltRint16 (AD_Int16 v) = wrap v + aux ArrayEltRint32 (AD_Int32 v) = wrap v + aux ArrayEltRint64 (AD_Int64 v) = wrap v + aux ArrayEltRword (AD_Word v) = wrap v + aux ArrayEltRword8 (AD_Word8 v) = wrap v + aux ArrayEltRword16 (AD_Word16 v) = wrap v + aux ArrayEltRword32 (AD_Word32 v) = wrap v + aux ArrayEltRword64 (AD_Word64 v) = wrap v + aux ArrayEltRfloat (AD_Float v) = wrap v + aux ArrayEltRdouble (AD_Double v) = wrap v + aux ArrayEltRchar (AD_Char v) = wrap v + aux ArrayEltRbool (AD_Bool _) = $internalError "toUArray" "TODO: Bool" -- need to pack bit array + aux _ _ = $internalError "toUArray" "unsupported type" + diff --git a/src/Data/Array/Accelerate/IO/Data/ByteString.hs b/src/Data/Array/Accelerate/IO/Data/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/ByteString.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.ByteString +-- Copyright : [2010..2011] Sean Seefried +-- [2010..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Conversion between strict 'ByteString's and Accelerate 'Array's. +-- + +module Data.Array.Accelerate.IO.Data.ByteString ( + + ByteStrings, + fromByteStrings, toByteStrings, + +) where + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Type +import qualified Data.Array.Accelerate.Array.Representation as R + +import Data.ByteString as B +import Data.ByteString.Internal as B +import Foreign.ForeignPtr +import Foreign.Storable +import System.IO.Unsafe + +#if !MIN_VERSION_base(4,10,0) +import GHC.ForeignPtr +import GHC.Base +#endif + + +-- | A family of types that represents a collection of 'ByteString's. The +-- structure of the collection depends on the element type @e@. +-- +type family ByteStrings e + +type instance ByteStrings () = () +type instance ByteStrings Int = ByteString +type instance ByteStrings Int8 = ByteString +type instance ByteStrings Int16 = ByteString +type instance ByteStrings Int32 = ByteString +type instance ByteStrings Int64 = ByteString +type instance ByteStrings Word = ByteString +type instance ByteStrings Word8 = ByteString +type instance ByteStrings Word16 = ByteString +type instance ByteStrings Word32 = ByteString +type instance ByteStrings Word64 = ByteString +type instance ByteStrings CShort = ByteString +type instance ByteStrings CUShort = ByteString +type instance ByteStrings CInt = ByteString +type instance ByteStrings CUInt = ByteString +type instance ByteStrings CLong = ByteString +type instance ByteStrings CULong = ByteString +type instance ByteStrings CLLong = ByteString +type instance ByteStrings CULLong = ByteString +type instance ByteStrings CShort = ByteString +type instance ByteStrings Half = ByteString +type instance ByteStrings Float = ByteString +type instance ByteStrings Double = ByteString +type instance ByteStrings CFloat = ByteString +type instance ByteStrings CDouble = ByteString +type instance ByteStrings Bool = ByteString +type instance ByteStrings Char = ByteString +type instance ByteStrings CChar = ByteString +type instance ByteStrings CSChar = ByteString +type instance ByteStrings CUChar = ByteString +type instance ByteStrings (V2 a) = ByteStrings a +type instance ByteStrings (V3 a) = ByteStrings a +type instance ByteStrings (V4 a) = ByteStrings a +type instance ByteStrings (V8 a) = ByteStrings a +type instance ByteStrings (V16 a) = ByteStrings a +type instance ByteStrings (a,b) = (ByteStrings a, ByteStrings b) + + +-- | /O(1)/. Treat a set of strict 'ByteStrings' as an Accelerate array. The +-- type of the elements @e@ in the output Accelerate array determines the +-- structure of the collection. +-- +-- Data is considered to be in row-major order. You must ensure that each input +-- contains the right number of bytes (this is not checked). +-- +-- The input data may not be modified through the 'ByteString's afterwards. +-- +-- @since 1.1.0.0@ +-- +{-# INLINE fromByteStrings #-} +fromByteStrings :: (Shape sh, Elt e) => sh -> ByteStrings (EltRepr e) -> Array sh e +fromByteStrings sh bs = Array (fromElt sh) (aux arrayElt bs) + where + wrap :: (UniqueArray e -> r) -> ByteString -> r + wrap k (B.toForeignPtr -> (ps,s,_)) = + k (unsafePerformIO $ newUniqueArray (castForeignPtr (plusForeignPtr ps s))) + + aux :: ArrayEltR e -> ByteStrings e -> ArrayData e + aux ArrayEltRunit = const AD_Unit + aux ArrayEltRint = wrap AD_Int + aux ArrayEltRint8 = wrap AD_Int8 + aux ArrayEltRint16 = wrap AD_Int16 + aux ArrayEltRint32 = wrap AD_Int32 + aux ArrayEltRint64 = wrap AD_Int64 + aux ArrayEltRword = wrap AD_Word + aux ArrayEltRword8 = wrap AD_Word8 + aux ArrayEltRword16 = wrap AD_Word16 + aux ArrayEltRword32 = wrap AD_Word32 + aux ArrayEltRword64 = wrap AD_Word64 + aux ArrayEltRcshort = wrap AD_CShort + aux ArrayEltRcushort = wrap AD_CUShort + aux ArrayEltRcint = wrap AD_CInt + aux ArrayEltRcuint = wrap AD_CUInt + aux ArrayEltRclong = wrap AD_CLong + aux ArrayEltRculong = wrap AD_CULong + aux ArrayEltRcllong = wrap AD_CLLong + aux ArrayEltRcullong = wrap AD_CULLong + aux ArrayEltRhalf = wrap AD_Half + aux ArrayEltRfloat = wrap AD_Float + aux ArrayEltRdouble = wrap AD_Double + aux ArrayEltRcfloat = wrap AD_CFloat + aux ArrayEltRcdouble = wrap AD_CDouble + aux ArrayEltRbool = wrap AD_Bool + aux ArrayEltRchar = wrap AD_Char + aux ArrayEltRcchar = wrap AD_CChar + aux ArrayEltRcschar = wrap AD_CSChar + aux ArrayEltRcuchar = wrap AD_CUChar + aux (ArrayEltRvec2 ae) = AD_V2 . aux ae + aux (ArrayEltRvec3 ae) = AD_V3 . aux ae + aux (ArrayEltRvec4 ae) = AD_V4 . aux ae + aux (ArrayEltRvec8 ae) = AD_V8 . aux ae + aux (ArrayEltRvec16 ae) = AD_V16 . aux ae + aux (ArrayEltRpair ae1 ae2) = \(v1,v2) -> AD_Pair (aux ae1 v1) (aux ae2 v2) + + +-- | /O(1)/. Convert an Accelerate 'Array' into a collection of strict +-- 'ByteStrings'. The element type @e@ will determine the structure of the +-- output collection. +-- +-- Data is considered to be in row-major order. +-- +-- @since 1.1.0.0@ +-- +{-# INLINE toByteStrings #-} +toByteStrings :: (Shape sh, Elt e) => Array sh e -> ByteStrings (EltRepr e) +toByteStrings (Array sh adata) = aux arrayElt adata + where + n :: Int + n = R.size sh + + wrap :: forall a. Storable a => UniqueArray a -> ByteString + wrap (unsafeGetValue . uniqueArrayData -> fp) = + B.fromForeignPtr (castForeignPtr fp) 0 (n * sizeOf (undefined::a)) + + aux :: ArrayEltR e -> ArrayData e -> ByteStrings e + aux ArrayEltRunit AD_Unit = () + aux ArrayEltRint (AD_Int s) = wrap s + aux ArrayEltRint8 (AD_Int8 s) = wrap s + aux ArrayEltRint16 (AD_Int16 s) = wrap s + aux ArrayEltRint32 (AD_Int32 s) = wrap s + aux ArrayEltRint64 (AD_Int64 s) = wrap s + aux ArrayEltRword (AD_Word s) = wrap s + aux ArrayEltRword8 (AD_Word8 s) = wrap s + aux ArrayEltRword16 (AD_Word16 s) = wrap s + aux ArrayEltRword32 (AD_Word32 s) = wrap s + aux ArrayEltRword64 (AD_Word64 s) = wrap s + aux ArrayEltRcshort (AD_CShort s) = wrap s + aux ArrayEltRcushort (AD_CUShort s) = wrap s + aux ArrayEltRcint (AD_CInt s) = wrap s + aux ArrayEltRcuint (AD_CUInt s) = wrap s + aux ArrayEltRclong (AD_CLong s) = wrap s + aux ArrayEltRculong (AD_CULong s) = wrap s + aux ArrayEltRcllong (AD_CLLong s) = wrap s + aux ArrayEltRcullong (AD_CULLong s) = wrap s + aux ArrayEltRhalf (AD_Half s) = wrap s + aux ArrayEltRfloat (AD_Float s) = wrap s + aux ArrayEltRdouble (AD_Double s) = wrap s + aux ArrayEltRcfloat (AD_CFloat s) = wrap s + aux ArrayEltRcdouble (AD_CDouble s) = wrap s + aux ArrayEltRbool (AD_Bool s) = wrap s + aux ArrayEltRchar (AD_Char s) = wrap s + aux ArrayEltRcchar (AD_CChar s) = wrap s + aux ArrayEltRcschar (AD_CSChar s) = wrap s + aux ArrayEltRcuchar (AD_CUChar s) = wrap s + aux (ArrayEltRvec2 ae) (AD_V2 s) = aux ae s + aux (ArrayEltRvec3 ae) (AD_V3 s) = aux ae s + aux (ArrayEltRvec4 ae) (AD_V4 s) = aux ae s + aux (ArrayEltRvec8 ae) (AD_V8 s) = aux ae s + aux (ArrayEltRvec16 ae) (AD_V16 s) = aux ae s + aux (ArrayEltRpair ae1 ae2) (AD_Pair s1 s2) = (aux ae1 s1, aux ae2 s2) + + +#if !MIN_VERSION_base(4,10,0) +plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b +plusForeignPtr (ForeignPtr addr# c) (I# d#) = ForeignPtr (plusAddr# addr# d#) c +#endif + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Generic.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Generic.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Vector.Generic +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module provides an instance for 'Data.Vector.Generic.Vector', for +-- immutable vectors from the @vector@ package backed by Accelerate arrays. +-- +-- This allows computations written with the @vector@ library to read from and +-- store into, arrays which can then be passed directly to an Accelerate +-- computation. +-- +-- @since 1.2.0.0 +-- + +module Data.Array.Accelerate.IO.Data.Vector.Generic + where + +import Data.Array.Accelerate.Array.Sugar as A +import Data.Array.Accelerate.Array.Data as A +import Data.Array.Accelerate.IO.Data.Vector.Generic.Mutable as A + +import qualified Data.Vector.Generic as V +import qualified Data.Vector.Generic.Mutable as M + + +type instance V.Mutable Vector = MVector + +instance Elt e => V.Vector Vector e where + {-# INLINE basicUnsafeFreeze #-} + {-# INLINE basicUnsafeThaw #-} + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicUnsafeIndexM #-} + {-# INLINE basicUnsafeCopy #-} + basicUnsafeFreeze (MArray sh mad) = return (Array sh mad) + basicUnsafeThaw (Array sh ad) = return (MArray sh ad) + basicLength (Array ((),n) _) = n + + basicUnsafeSlice i n (Array sh ad) = + case M.basicUnsafeSlice i n (MArray sh ad :: MVector s e) of + MArray sh' mad' -> Array sh' mad' + + basicUnsafeIndexM (Array _ ad) i = return $ toElt (unsafeIndexArrayData ad i) + + basicUnsafeCopy dst (Array sh ad) = M.basicUnsafeCopy dst (MArray sh ad) + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Vector.Generic.Mutable +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This module provides instance for 'Data.Vector.Generic.Mutable.MVector', for +-- generic mutable vectors backed by Accelerate. +-- +-- @since 1.2.0.0 +-- + +module Data.Array.Accelerate.IO.Data.Vector.Generic.Mutable + where + +import Data.Array.Accelerate.Array.Data as A +import Data.Array.Accelerate.Array.Sugar as A +import Data.Array.Accelerate.Array.Unique as A +import Data.Array.Accelerate.Lifetime + +import qualified Data.Vector.Generic.Mutable as V + +import Control.Monad.Primitive +import Data.Typeable +import Foreign.Ptr +import Foreign.Marshal.Utils +import Foreign.Storable +import Prelude hiding ( length ) + +import GHC.Base +import GHC.ForeignPtr + + +-- | Dense, regular, mutable, multi-dimensional arrays +-- +data MArray sh s e where + MArray :: (Shape sh, Elt e) + => EltRepr sh -- extent of dimensions == shape + -> MutableArrayData (EltRepr e) -- mutable array payload + -> MArray sh s e + +deriving instance Typeable MArray + +type MVector = MArray DIM1 + +instance Elt e => V.MVector MVector e where + {-# INLINE basicLength #-} + {-# INLINE basicUnsafeSlice #-} + {-# INLINE basicOverlaps #-} + {-# INLINE basicUnsafeNew #-} + {-# INLINE basicInitialize #-} + {-# INLINE basicUnsafeRead #-} + {-# INLINE basicUnsafeWrite #-} + {-# INLINE basicUnsafeCopy #-} + basicLength (MArray ((), n) _) = n + + basicUnsafeSlice j m (MArray _ mad) = MArray ((),m) (go arrayElt mad 1) + where + go :: ArrayEltR a -> MutableArrayData a -> Int -> MutableArrayData a + go ArrayEltRunit AD_Unit !_ = AD_Unit + go ArrayEltRint (AD_Int v) !s = AD_Int (slice v s) + go ArrayEltRint8 (AD_Int8 v) !s = AD_Int8 (slice v s) + go ArrayEltRint16 (AD_Int16 v) !s = AD_Int16 (slice v s) + go ArrayEltRint32 (AD_Int32 v) !s = AD_Int32 (slice v s) + go ArrayEltRint64 (AD_Int64 v) !s = AD_Int64 (slice v s) + go ArrayEltRword (AD_Word v) !s = AD_Word (slice v s) + go ArrayEltRword8 (AD_Word8 v) !s = AD_Word8 (slice v s) + go ArrayEltRword16 (AD_Word16 v) !s = AD_Word16 (slice v s) + go ArrayEltRword32 (AD_Word32 v) !s = AD_Word32 (slice v s) + go ArrayEltRword64 (AD_Word64 v) !s = AD_Word64 (slice v s) + go ArrayEltRcshort (AD_CShort v) !s = AD_CShort (slice v s) + go ArrayEltRcushort (AD_CUShort v) !s = AD_CUShort (slice v s) + go ArrayEltRcint (AD_CInt v) !s = AD_CInt (slice v s) + go ArrayEltRcuint (AD_CUInt v) !s = AD_CUInt (slice v s) + go ArrayEltRclong (AD_CLong v) !s = AD_CLong (slice v s) + go ArrayEltRculong (AD_CULong v) !s = AD_CULong (slice v s) + go ArrayEltRcllong (AD_CLLong v) !s = AD_CLLong (slice v s) + go ArrayEltRcullong (AD_CULLong v) !s = AD_CULLong (slice v s) + go ArrayEltRhalf (AD_Half v) !s = AD_Half (slice v s) + go ArrayEltRfloat (AD_Float v) !s = AD_Float (slice v s) + go ArrayEltRdouble (AD_Double v) !s = AD_Double (slice v s) + go ArrayEltRcfloat (AD_CFloat v) !s = AD_CFloat (slice v s) + go ArrayEltRcdouble (AD_CDouble v) !s = AD_CDouble (slice v s) + go ArrayEltRbool (AD_Bool v) !s = AD_Bool (slice v s) + go ArrayEltRchar (AD_Char v) !s = AD_Char (slice v s) + go ArrayEltRcchar (AD_CChar v) !s = AD_CChar (slice v s) + go ArrayEltRcschar (AD_CSChar v) !s = AD_CSChar (slice v s) + go ArrayEltRcuchar (AD_CUChar v) !s = AD_CUChar (slice v s) + go (ArrayEltRvec2 ae) (AD_V2 v) !s = AD_V2 (go ae v (s*2)) + go (ArrayEltRvec3 ae) (AD_V3 v) !s = AD_V3 (go ae v (s*3)) + go (ArrayEltRvec4 ae) (AD_V4 v) !s = AD_V4 (go ae v (s*4)) + go (ArrayEltRvec8 ae) (AD_V8 v) !s = AD_V8 (go ae v (s*8)) + go (ArrayEltRvec16 ae) (AD_V16 v) !s = AD_V16 (go ae v (s*16)) + go (ArrayEltRpair ae1 ae2) (AD_Pair v1 v2) !s = AD_Pair (go ae1 v1 s) (go ae2 v2 s) + + slice :: forall a. Storable a => UniqueArray a -> Int -> UniqueArray a + slice (UniqueArray uid (Lifetime lft w fp)) s = + UniqueArray uid (Lifetime lft w (plusForeignPtr fp (j * s * sizeOf (undefined::a)))) + + basicOverlaps (MArray ((),m) mad1) (MArray ((),n) mad2) = go arrayElt mad1 mad2 1 + where + go :: ArrayEltR a -> MutableArrayData a -> MutableArrayData a -> Int -> Bool + go ArrayEltRunit AD_Unit AD_Unit !_ = False + go ArrayEltRint (AD_Int v1) (AD_Int v2) !s = overlaps v1 v2 s + go ArrayEltRint8 (AD_Int8 v1) (AD_Int8 v2) !s = overlaps v1 v2 s + go ArrayEltRint16 (AD_Int16 v1) (AD_Int16 v2) !s = overlaps v1 v2 s + go ArrayEltRint32 (AD_Int32 v1) (AD_Int32 v2) !s = overlaps v1 v2 s + go ArrayEltRint64 (AD_Int64 v1) (AD_Int64 v2) !s = overlaps v1 v2 s + go ArrayEltRword (AD_Word v1) (AD_Word v2) !s = overlaps v1 v2 s + go ArrayEltRword8 (AD_Word8 v1) (AD_Word8 v2) !s = overlaps v1 v2 s + go ArrayEltRword16 (AD_Word16 v1) (AD_Word16 v2) !s = overlaps v1 v2 s + go ArrayEltRword32 (AD_Word32 v1) (AD_Word32 v2) !s = overlaps v1 v2 s + go ArrayEltRword64 (AD_Word64 v1) (AD_Word64 v2) !s = overlaps v1 v2 s + go ArrayEltRcshort (AD_CShort v1) (AD_CShort v2) !s = overlaps v1 v2 s + go ArrayEltRcushort (AD_CUShort v1) (AD_CUShort v2) !s = overlaps v1 v2 s + go ArrayEltRcint (AD_CInt v1) (AD_CInt v2) !s = overlaps v1 v2 s + go ArrayEltRcuint (AD_CUInt v1) (AD_CUInt v2) !s = overlaps v1 v2 s + go ArrayEltRclong (AD_CLong v1) (AD_CLong v2) !s = overlaps v1 v2 s + go ArrayEltRculong (AD_CULong v1) (AD_CULong v2) !s = overlaps v1 v2 s + go ArrayEltRcllong (AD_CLLong v1) (AD_CLLong v2) !s = overlaps v1 v2 s + go ArrayEltRcullong (AD_CULLong v1) (AD_CULLong v2) !s = overlaps v1 v2 s + go ArrayEltRhalf (AD_Half v1) (AD_Half v2) !s = overlaps v1 v2 s + go ArrayEltRfloat (AD_Float v1) (AD_Float v2) !s = overlaps v1 v2 s + go ArrayEltRdouble (AD_Double v1) (AD_Double v2) !s = overlaps v1 v2 s + go ArrayEltRcfloat (AD_CFloat v1) (AD_CFloat v2) !s = overlaps v1 v2 s + go ArrayEltRcdouble (AD_CDouble v1) (AD_CDouble v2) !s = overlaps v1 v2 s + go ArrayEltRbool (AD_Bool v1) (AD_Bool v2) !s = overlaps v1 v2 s + go ArrayEltRchar (AD_Char v1) (AD_Char v2) !s = overlaps v1 v2 s + go ArrayEltRcchar (AD_CChar v1) (AD_CChar v2) !s = overlaps v1 v2 s + go ArrayEltRcschar (AD_CSChar v1) (AD_CSChar v2) !s = overlaps v1 v2 s + go ArrayEltRcuchar (AD_CUChar v1) (AD_CUChar v2) !s = overlaps v1 v2 s + go (ArrayEltRvec2 ae) (AD_V2 v1) (AD_V2 v2) !s = go ae v1 v2 (s*2) + go (ArrayEltRvec3 ae) (AD_V3 v1) (AD_V3 v3) !s = go ae v1 v3 (s*3) + go (ArrayEltRvec4 ae) (AD_V4 v1) (AD_V4 v4) !s = go ae v1 v4 (s*4) + go (ArrayEltRvec8 ae) (AD_V8 v1) (AD_V8 v8) !s = go ae v1 v8 (s*8) + go (ArrayEltRvec16 ae) (AD_V16 v1) (AD_V16 v16) !s = go ae v1 v16 (s*16) + go (ArrayEltRpair ae1 ae2) (AD_Pair v11 v12) (AD_Pair v21 v22) !s = go ae1 v11 v21 s || go ae2 v12 v22 s + + overlaps :: forall a. Storable a => UniqueArray a -> UniqueArray a -> Int -> Bool + overlaps (UniqueArray _ (Lifetime _ _ (ForeignPtr addr1# c1))) (UniqueArray _ (Lifetime _ _ (ForeignPtr addr2# c2))) s = + let i = I# (addr2Int# addr1#) + j = I# (addr2Int# addr2#) + k = s * sizeOf (undefined::a) + in + same c1 c2 && (between i j (j + n*k) || between j i (i + m*k)) + + same :: ForeignPtrContents -> ForeignPtrContents -> Bool + same (PlainPtr mba1#) (PlainPtr mba2#) = isTrue# (sameMutableByteArray# mba1# mba2#) + same (MallocPtr mba1# _) (MallocPtr mba2# _) = isTrue# (sameMutableByteArray# mba1# mba2#) + -- same PlainForeignPtr{} PlainForeignPtr{} = False -- probably? + same _ _ = False -- probably? should we still check whether the address ranges overlap? + + between :: Int -> Int -> Int -> Bool + between x y z = x >= y && x < z + + basicUnsafeNew n = unsafePrimToPrim $ MArray ((),n) <$> newArrayData n + + basicInitialize (MArray ((),n) mad) = unsafePrimToPrim $ go (arrayElt :: ArrayEltR (EltRepr e)) (ptrsOfArrayData mad) 1 + where + go :: ArrayEltR a -> ArrayPtrs a -> Int -> IO () + go ArrayEltRunit () !_ = return () + go ArrayEltRint p !s = initialise p s + go ArrayEltRint8 p !s = initialise p s + go ArrayEltRint16 p !s = initialise p s + go ArrayEltRint32 p !s = initialise p s + go ArrayEltRint64 p !s = initialise p s + go ArrayEltRword p !s = initialise p s + go ArrayEltRword8 p !s = initialise p s + go ArrayEltRword16 p !s = initialise p s + go ArrayEltRword32 p !s = initialise p s + go ArrayEltRword64 p !s = initialise p s + go ArrayEltRcshort p !s = initialise p s + go ArrayEltRcushort p !s = initialise p s + go ArrayEltRcint p !s = initialise p s + go ArrayEltRcuint p !s = initialise p s + go ArrayEltRclong p !s = initialise p s + go ArrayEltRculong p !s = initialise p s + go ArrayEltRcllong p !s = initialise p s + go ArrayEltRcullong p !s = initialise p s + go ArrayEltRhalf p !s = initialise p s + go ArrayEltRfloat p !s = initialise p s + go ArrayEltRdouble p !s = initialise p s + go ArrayEltRcfloat p !s = initialise p s + go ArrayEltRcdouble p !s = initialise p s + go ArrayEltRbool p !s = initialise p s + go ArrayEltRchar p !s = initialise p s + go ArrayEltRcchar p !s = initialise p s + go ArrayEltRcschar p !s = initialise p s + go ArrayEltRcuchar p !s = initialise p s + go (ArrayEltRvec2 ae) p !s = go ae p (s*2) + go (ArrayEltRvec3 ae) p !s = go ae p (s*3) + go (ArrayEltRvec4 ae) p !s = go ae p (s*4) + go (ArrayEltRvec8 ae) p !s = go ae p (s*8) + go (ArrayEltRvec16 ae) p !s = go ae p (s*16) + go (ArrayEltRpair ae1 ae2) (p1,p2) s = go ae1 p1 s >> go ae2 p2 s + + initialise :: forall a. Storable a => Ptr a -> Int -> IO () + initialise p s = fillBytes p 0 (n * s * sizeOf (undefined::a)) + + basicUnsafeRead (MArray _ mad) i = unsafePrimToPrim $ toElt <$> unsafeReadArrayData mad i + basicUnsafeWrite (MArray _ mad) i v = unsafePrimToPrim $ unsafeWriteArrayData mad i (fromElt v) + + basicUnsafeCopy (MArray _ dst) (MArray ((),n) src) = unsafePrimToPrim $ go (arrayElt :: ArrayEltR (EltRepr e)) (ptrsOfArrayData dst) (ptrsOfArrayData src) 1 + where + go :: ArrayEltR a -> ArrayPtrs a -> ArrayPtrs a -> Int -> IO () + go ArrayEltRunit () () !_ = return () + go ArrayEltRint u v !s = copy u v s + go ArrayEltRint8 u v !s = copy u v s + go ArrayEltRint16 u v !s = copy u v s + go ArrayEltRint32 u v !s = copy u v s + go ArrayEltRint64 u v !s = copy u v s + go ArrayEltRword u v !s = copy u v s + go ArrayEltRword8 u v !s = copy u v s + go ArrayEltRword16 u v !s = copy u v s + go ArrayEltRword32 u v !s = copy u v s + go ArrayEltRword64 u v !s = copy u v s + go ArrayEltRcshort u v !s = copy u v s + go ArrayEltRcushort u v !s = copy u v s + go ArrayEltRcint u v !s = copy u v s + go ArrayEltRcuint u v !s = copy u v s + go ArrayEltRclong u v !s = copy u v s + go ArrayEltRculong u v !s = copy u v s + go ArrayEltRcllong u v !s = copy u v s + go ArrayEltRcullong u v !s = copy u v s + go ArrayEltRhalf u v !s = copy u v s + go ArrayEltRfloat u v !s = copy u v s + go ArrayEltRdouble u v !s = copy u v s + go ArrayEltRcfloat u v !s = copy u v s + go ArrayEltRcdouble u v !s = copy u v s + go ArrayEltRbool u v !s = copy u v s + go ArrayEltRchar u v !s = copy u v s + go ArrayEltRcchar u v !s = copy u v s + go ArrayEltRcschar u v !s = copy u v s + go ArrayEltRcuchar u v !s = copy u v s + go (ArrayEltRvec2 ae) u v !s = go ae u v (s*2) + go (ArrayEltRvec3 ae) u v !s = go ae u v (s*3) + go (ArrayEltRvec4 ae) u v !s = go ae u v (s*4) + go (ArrayEltRvec8 ae) u v !s = go ae u v (s*8) + go (ArrayEltRvec16 ae) u v !s = go ae u v (s*16) + go (ArrayEltRpair ae1 ae2) (u1,u2) (v1,v2) s = go ae1 u1 v1 s >> go ae2 u2 v2 s + + copy :: forall a. Storable a => Ptr a -> Ptr a -> Int -> IO () + copy u v s = copyBytes u v (n * s * sizeOf (undefined::a)) + + +#if !MIN_VERSION_base(4,10,0) +plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b +plusForeignPtr (ForeignPtr addr# c) (I# i#) = ForeignPtr (plusAddr# addr# i#) c +#endif + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Primitive.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Primitive.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Vector.Primitive +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Efficient conversion between 'Data.Vector.Primitive' vectors and Accelerate +-- 'Array's. +-- + +module Data.Array.Accelerate.IO.Data.Vector.Primitive ( + + Vectors, + toVectors, + fromVectors, + +) where + +import Data.Vector.Primitive + +import Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar hiding ( Vector ) +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Error +import qualified Data.Array.Accelerate.Array.Representation as R + +import Data.Int +import Data.Word + + +-- | A family of types which represent a collection of Primitive Vectors. The +-- structure of the collection depends on the element type @e@ of the +-- corresponding Accelerate array. +-- +type family Vectors e :: * + +type instance Vectors () = () +type instance Vectors Int = Vector Int +type instance Vectors Int8 = Vector Int8 +type instance Vectors Int16 = Vector Int16 +type instance Vectors Int32 = Vector Int32 +type instance Vectors Int64 = Vector Int64 +type instance Vectors Word = Vector Word +type instance Vectors Word8 = Vector Word8 +type instance Vectors Word16 = Vector Word16 +type instance Vectors Word32 = Vector Word32 +type instance Vectors Word64 = Vector Word64 +type instance Vectors Float = Vector Float +type instance Vectors Double = Vector Double +type instance Vectors Char = Vector Char +type instance Vectors (a,b) = (Vectors a, Vectors b) + + +-- | /O(n)/ (typically). Convert a collection of primitive vectors into an +-- Accelerate array. +-- +-- If the underlying vectors are pinned then this can be done without. +-- +-- See also: +-- +-- @since 1.1.0.0@ +-- +{-# INLINE fromVectors #-} +fromVectors :: (Shape sh, Elt e) => sh -> Vectors (EltRepr e) -> Array sh e +fromVectors sh vecs = Array (fromElt sh) (aux arrayElt vecs) + where + {-# INLINE wrap #-} + wrap :: Prim a => Vector a -> UniqueArray a + wrap v@(Vector _ l _) + = $boundsCheck "fromVectors" "shape mismatch" (size sh == l) + $ uniqueArrayOfVector v + + {-# INLINE aux #-} + aux :: ArrayEltR e -> Vectors e -> ArrayData e + aux ArrayEltRunit _ = AD_Unit + aux ArrayEltRint v = AD_Int (wrap v) + aux ArrayEltRint8 v = AD_Int8 (wrap v) + aux ArrayEltRint16 v = AD_Int16 (wrap v) + aux ArrayEltRint32 v = AD_Int32 (wrap v) + aux ArrayEltRint64 v = AD_Int64 (wrap v) + aux ArrayEltRword v = AD_Word (wrap v) + aux ArrayEltRword8 v = AD_Word8 (wrap v) + aux ArrayEltRword16 v = AD_Word16 (wrap v) + aux ArrayEltRword32 v = AD_Word32 (wrap v) + aux ArrayEltRword64 v = AD_Word64 (wrap v) + aux ArrayEltRchar v = AD_Char (wrap v) + aux ArrayEltRfloat v = AD_Float (wrap v) + aux ArrayEltRdouble v = AD_Double (wrap v) + aux (ArrayEltRpair ad1 ad2) (v1,v2) = AD_Pair (aux ad1 v1) (aux ad2 v2) + -- + aux _ _ = $internalError "fromVectors" "unsupported type" + + +-- | /O(1)/ (typically). Convert an Accelerate array into a collection of +-- primitive vectors. +-- +-- If the array data was allocated by Accelerate, this can typically be done +-- without copying. +-- +-- @since 1.1.0.0@ +-- +{-# INLINE toVectors #-} +toVectors :: (Shape sh, Elt e) => Array sh e -> Vectors (EltRepr e) +toVectors (Array sh adata) = aux arrayElt adata + where + n :: Int + !n = R.size sh + + {-# INLINE wrap #-} + wrap :: Prim a => UniqueArray a -> Vector a + wrap ua = vectorOfUniqueArray n ua + + {-# INLINE aux #-} + aux :: ArrayEltR e -> ArrayData e -> Vectors e + aux ArrayEltRunit AD_Unit = () + aux ArrayEltRint (AD_Int v) = wrap v + aux ArrayEltRint8 (AD_Int8 v) = wrap v + aux ArrayEltRint16 (AD_Int16 v) = wrap v + aux ArrayEltRint32 (AD_Int32 v) = wrap v + aux ArrayEltRint64 (AD_Int64 v) = wrap v + aux ArrayEltRword (AD_Word v) = wrap v + aux ArrayEltRword8 (AD_Word8 v) = wrap v + aux ArrayEltRword16 (AD_Word16 v) = wrap v + aux ArrayEltRword32 (AD_Word32 v) = wrap v + aux ArrayEltRword64 (AD_Word64 v) = wrap v + aux ArrayEltRchar (AD_Char v) = wrap v + aux ArrayEltRfloat (AD_Float v) = wrap v + aux ArrayEltRdouble (AD_Double v) = wrap v + aux (ArrayEltRpair ad1 ad2) (AD_Pair v1 v2) = (aux ad1 v1, aux ad2 v2) + -- + aux _ _ = $internalError "toVectors" "unsupported type" + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal + where + +import Data.Primitive ( sizeOf ) +import Data.Primitive.ByteArray + +import Data.Vector.Primitive + +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Lifetime + +import GHC.Base +import GHC.ForeignPtr +import System.IO.Unsafe + + +-- Convert a primitive vector into a unique array +-- +{-# INLINE uniqueArrayOfVector #-} +uniqueArrayOfVector :: forall a. Prim a => Vector a -> UniqueArray a +uniqueArrayOfVector (Vector o l ba) + = unsafePerformIO + $ newUniqueArray =<< foreignPtrOfByteArray o (l * sizeOf (undefined::a)) ba + +-- Convert a unique array into a primitive vector +-- +{-# INLINE vectorOfUniqueArray #-} +vectorOfUniqueArray :: forall a. Prim a => Int -> UniqueArray a -> Vector a +vectorOfUniqueArray n ua + = unsafePerformIO + $ Vector 0 n `fmap` byteArrayOfForeignPtr (n * sizeOf (undefined::a)) (unsafeGetValue (uniqueArrayData ua)) + + +-- Return the ByteArray underlying a ForeignPtr, or a new byte array if it is +-- not a Plain ForeignPtr. +-- +{-# INLINE byteArrayOfForeignPtr #-} +byteArrayOfForeignPtr :: Int -> ForeignPtr a -> IO ByteArray +byteArrayOfForeignPtr (I# bytes#) (ForeignPtr addr# c) = IO $ \s -> + case c of + PlainPtr mba# -> case unsafeFreezeByteArray# mba# s of + (# s', ba# #) -> (# s', ByteArray ba# #) + + _ -> case newAlignedPinnedByteArray# bytes# 16# s of + (# s1, mba# #) -> case copyAddrToByteArray# addr# mba# 0# bytes# s1 of + s2 -> case unsafeFreezeByteArray# mba# s2 of + (# s3, ba# #) -> (# s3, ByteArray ba# #) + + +-- Return the ByteArray as a ForeignPtr. This will attempt a non-copying +-- conversion, if the underlying byte array is pinned. +-- +{-# INLINE foreignPtrOfByteArray #-} +foreignPtrOfByteArray :: Int -> Int -> ByteArray -> IO (ForeignPtr a) +foreignPtrOfByteArray (I# soff#) (I# bytes#) (ByteArray ba#) = IO $ \s -> + case isByteArrayPinned# ba# of + 0# -> case newAlignedPinnedByteArray# bytes# 16# s of + (# s1, mba# #) -> case copyByteArray# ba# 0# mba# soff# bytes# s1 of + s2 -> (# s2, ForeignPtr (byteArrayContents# (unsafeCoerce# mba#)) (PlainPtr mba#) #) + + _ -> (# s, ForeignPtr (byteArrayContents# ba#) (PlainPtr (unsafeCoerce# ba#)) #) + + +#if !MIN_VERSION_base(4,10,0) +isByteArrayPinned# :: ByteArray# -> Int# +isByteArrayPinned# _ = 0# +#endif + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Vector.Storable +-- Copyright : [2012] Adam C. Foltzer +-- [2012..2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Efficient non-copying conversion between 'Data.Vector.Storable' vectors and +-- Accelerate 'Array's. +-- + +module Data.Array.Accelerate.IO.Data.Vector.Storable ( + + Vectors, + toVectors, + fromVectors, + +) where + +-- friends +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar hiding ( Vector ) +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Type +import qualified Data.Array.Accelerate.Array.Representation as R + +-- standard libraries +import Data.Vector.Storable +import System.IO.Unsafe + + +-- | A family of types that represents a collection of storable 'Vector's. The +-- structure of the collection depends on the element type @e@. +-- +-- For example: +-- +-- * if @e :: Int@, then @Vectors (EltRepr e) :: Vector Int@ +-- +-- * if @e :: (Double, Float)@, then @Vectors (EltRepr e) :: (((), Vector Double), Vector Float)@ +-- +type family Vectors e + +type instance Vectors () = () +type instance Vectors Int = Vector Int +type instance Vectors Int8 = Vector Int8 +type instance Vectors Int16 = Vector Int16 +type instance Vectors Int32 = Vector Int32 +type instance Vectors Int64 = Vector Int64 +type instance Vectors Word = Vector Word +type instance Vectors Word8 = Vector Word8 +type instance Vectors Word16 = Vector Word16 +type instance Vectors Word32 = Vector Word32 +type instance Vectors Word64 = Vector Word64 +type instance Vectors CShort = Vector Int16 +type instance Vectors CUShort = Vector Word16 +type instance Vectors CInt = Vector Int32 +type instance Vectors CUInt = Vector Word32 +type instance Vectors CLong = Vector HTYPE_LONG +type instance Vectors CULong = Vector HTYPE_UNSIGNED_LONG +type instance Vectors CLLong = Vector Int64 +type instance Vectors CULLong = Vector Word64 +type instance Vectors Half = Vector Half +type instance Vectors Float = Vector Float +type instance Vectors CFloat = Vector Float +type instance Vectors Double = Vector Double +type instance Vectors CDouble = Vector Double +type instance Vectors Bool = Vector Word8 +type instance Vectors Char = Vector Char +type instance Vectors CChar = Vector HTYPE_CCHAR +type instance Vectors CSChar = Vector Int8 +type instance Vectors CUChar = Vector Word8 +type instance Vectors (V2 a) = Vectors a +type instance Vectors (V3 a) = Vectors a +type instance Vectors (V4 a) = Vectors a +type instance Vectors (V8 a) = Vectors a +type instance Vectors (V16 a) = Vectors a +type instance Vectors (a,b) = (Vectors a, Vectors b) + + +-- | /O(1)/. Treat a set of storable vectors as Accelerate arrays. The type of +-- elements @e@ in the output Accelerate array determines the structure of the +-- collection that will be required as the second argument. See 'Vectors'. +-- +-- Data will be consumed from the vector in row-major order. You must make sure +-- that each of the input vectors contains the right number of elements +-- +{-# INLINE fromVectors #-} +fromVectors :: (Shape sh, Elt e) => sh -> Vectors (EltRepr e) -> Array sh e +fromVectors sh vecs = Array (fromElt sh) (aux arrayElt vecs 1) + where + {-# INLINE wrap #-} + wrap :: Storable e => (UniqueArray e -> a) -> Vector e -> Int -> a + wrap k v s + = $boundsCheck "fromVectors" "shape mismatch" (vsize `quot` s == size sh) + $ k (unsafePerformIO $ newUniqueArray fp) + where + (fp,vsize) = unsafeToForeignPtr0 v + + {-# INLINE aux #-} + aux :: ArrayEltR e -> Vectors e -> Int -> ArrayData e + aux ArrayEltRunit _ _ = AD_Unit + aux ArrayEltRint v s = wrap AD_Int v s + aux ArrayEltRint8 v s = wrap AD_Int8 v s + aux ArrayEltRint16 v s = wrap AD_Int16 v s + aux ArrayEltRint32 v s = wrap AD_Int32 v s + aux ArrayEltRint64 v s = wrap AD_Int64 v s + aux ArrayEltRword v s = wrap AD_Word v s + aux ArrayEltRword8 v s = wrap AD_Word8 v s + aux ArrayEltRword16 v s = wrap AD_Word16 v s + aux ArrayEltRword32 v s = wrap AD_Word32 v s + aux ArrayEltRword64 v s = wrap AD_Word64 v s + aux ArrayEltRcshort v s = wrap AD_CShort v s + aux ArrayEltRcushort v s = wrap AD_CUShort v s + aux ArrayEltRcint v s = wrap AD_CInt v s + aux ArrayEltRcuint v s = wrap AD_CUInt v s + aux ArrayEltRclong v s = wrap AD_CLong v s + aux ArrayEltRculong v s = wrap AD_CULong v s + aux ArrayEltRcllong v s = wrap AD_CLLong v s + aux ArrayEltRcullong v s = wrap AD_CULLong v s + aux ArrayEltRhalf v s = wrap AD_Half v s + aux ArrayEltRfloat v s = wrap AD_Float v s + aux ArrayEltRdouble v s = wrap AD_Double v s + aux ArrayEltRcfloat v s = wrap AD_CFloat v s + aux ArrayEltRcdouble v s = wrap AD_CDouble v s + aux ArrayEltRbool v s = wrap AD_Bool v s + aux ArrayEltRchar v s = wrap AD_Char v s + aux ArrayEltRcchar v s = wrap AD_CChar v s + aux ArrayEltRcschar v s = wrap AD_CSChar v s + aux ArrayEltRcuchar v s = wrap AD_CUChar v s + aux (ArrayEltRvec2 ae) v s = AD_V2 (aux ae v (s*2)) + aux (ArrayEltRvec3 ae) v s = AD_V3 (aux ae v (s*3)) + aux (ArrayEltRvec4 ae) v s = AD_V4 (aux ae v (s*4)) + aux (ArrayEltRvec8 ae) v s = AD_V8 (aux ae v (s*8)) + aux (ArrayEltRvec16 ae) v s = AD_V16 (aux ae v (s*16)) + aux (ArrayEltRpair ae1 ae2) (v1,v2) s = AD_Pair (aux ae1 v1 s) (aux ae2 v2 s) + + +-- | /O(1)/. Turn the Accelerate array into a collection of storable 'Vector's. +-- The element type of the array @e@ will determine the structure of the output +-- collection. See 'Vectors'. +-- +-- Data will be output in row-major order. +-- +{-# INLINE toVectors #-} +toVectors :: (Shape sh, Elt e) => Array sh e -> Vectors (EltRepr e) +toVectors (Array sh adata) = aux arrayElt adata 1 + where + {-# INLINE wrap #-} + wrap :: Storable a => UniqueArray a -> Int -> Vector a + wrap ua k = unsafeFromForeignPtr0 (unsafeGetValue (uniqueArrayData ua)) (R.size sh * k) + + {-# INLINE aux #-} + aux :: ArrayEltR e -> ArrayData e -> Int -> Vectors e + aux ArrayEltRunit AD_Unit _ = () + aux ArrayEltRint (AD_Int s) k = wrap s k + aux ArrayEltRint8 (AD_Int8 s) k = wrap s k + aux ArrayEltRint16 (AD_Int16 s) k = wrap s k + aux ArrayEltRint32 (AD_Int32 s) k = wrap s k + aux ArrayEltRint64 (AD_Int64 s) k = wrap s k + aux ArrayEltRword (AD_Word s) k = wrap s k + aux ArrayEltRword8 (AD_Word8 s) k = wrap s k + aux ArrayEltRword16 (AD_Word16 s) k = wrap s k + aux ArrayEltRword32 (AD_Word32 s) k = wrap s k + aux ArrayEltRword64 (AD_Word64 s) k = wrap s k + aux ArrayEltRcshort (AD_CShort s) k = wrap s k + aux ArrayEltRcushort (AD_CUShort s) k = wrap s k + aux ArrayEltRcint (AD_CInt s) k = wrap s k + aux ArrayEltRcuint (AD_CUInt s) k = wrap s k + aux ArrayEltRclong (AD_CLong s) k = wrap s k + aux ArrayEltRculong (AD_CULong s) k = wrap s k + aux ArrayEltRcllong (AD_CLLong s) k = wrap s k + aux ArrayEltRcullong (AD_CULLong s) k = wrap s k + aux ArrayEltRhalf (AD_Half s) k = wrap s k + aux ArrayEltRfloat (AD_Float s) k = wrap s k + aux ArrayEltRdouble (AD_Double s) k = wrap s k + aux ArrayEltRcfloat (AD_CFloat s) k = wrap s k + aux ArrayEltRcdouble (AD_CDouble s) k = wrap s k + aux ArrayEltRbool (AD_Bool s) k = wrap s k + aux ArrayEltRchar (AD_Char s) k = wrap s k + aux ArrayEltRcchar (AD_CChar s) k = wrap s k + aux ArrayEltRcschar (AD_CSChar s) k = wrap s k + aux ArrayEltRcuchar (AD_CUChar s) k = wrap s k + aux (ArrayEltRvec2 ae) (AD_V2 s) k = aux ae s (k*2) + aux (ArrayEltRvec3 ae) (AD_V3 s) k = aux ae s (k*3) + aux (ArrayEltRvec4 ae) (AD_V4 s) k = aux ae s (k*4) + aux (ArrayEltRvec8 ae) (AD_V8 s) k = aux ae s (k*8) + aux (ArrayEltRvec16 ae) (AD_V16 s) k = aux ae s (k*16) + aux (ArrayEltRpair ae1 ae2) (AD_Pair s1 s2) k = (aux ae1 s1 k, aux ae2 s2 k) + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs @@ -0,0 +1,356 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Vector.Unboxed +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Efficient conversion between 'Data.Vector.Unboxed' vectors and Accelerate +-- 'Array's. +-- + +module Data.Array.Accelerate.IO.Data.Vector.Unboxed ( + + Unbox(..), + toUnboxed, + fromUnboxed, + +) where + +import Data.Vector.Unboxed.Base hiding ( Unbox ) +import qualified Data.Vector.Unboxed as U + +import Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar as A hiding ( Vector ) +import qualified Data.Array.Accelerate.Array.Representation as R + +import Data.Int +import Data.Word + + +-- | /O(n)/ (typically). Convert an Unboxed vector into an Accelerate array +-- Accelerate array. +-- +-- If the underlying vectors are pinned then this can be done without copying. +-- +-- See also: +-- +-- @since 1.1.0.0@ +-- +{-# INLINE fromUnboxed #-} +fromUnboxed :: Unbox e => Vector e -> Array DIM1 e +fromUnboxed v = Array ((), U.length v) (arrayDataOfUnboxed v) + + +-- | /O(1)/ (typically). Convert an Accelerate array into an Unboxed vector. +-- +-- If the array data was allocated by Accelerate, this can typically be done +-- without copying. The resulting vector will be pinned. +-- +-- @since 1.1.0.0@ +-- +{-# INLINE toUnboxed #-} +toUnboxed :: (Shape sh, Unbox e) => Array sh e -> Vector e +toUnboxed (Array sh adata) = unboxedOfArrayData (R.size sh) adata + + +-- Instances +-- --------- + +class (U.Unbox e, A.Elt e) => Unbox e where + arrayDataOfUnboxed :: U.Vector e -> ArrayData (EltRepr e) + unboxedOfArrayData :: Int -> ArrayData (EltRepr e) -> U.Vector e + +instance Unbox Int where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Int v) = AD_Int (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Int v) = V_Int (vectorOfUniqueArray n v) + +instance Unbox Int8 where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Int8 v) = AD_Int8 (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Int8 v) = V_Int8 (vectorOfUniqueArray n v) + +instance Unbox Int16 where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Int16 v) = AD_Int16 (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Int16 v) = V_Int16 (vectorOfUniqueArray n v) + +instance Unbox Int32 where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Int32 v) = AD_Int32 (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Int32 v) = V_Int32 (vectorOfUniqueArray n v) + +instance Unbox Int64 where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Int64 v) = AD_Int64 (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Int64 v) = V_Int64 (vectorOfUniqueArray n v) + +instance Unbox Word where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Word v) = AD_Word (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Word v) = V_Word (vectorOfUniqueArray n v) + +instance Unbox Word8 where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Word8 v) = AD_Word8 (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Word8 v) = V_Word8 (vectorOfUniqueArray n v) + +instance Unbox Word16 where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Word16 v) = AD_Word16 (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Word16 v) = V_Word16 (vectorOfUniqueArray n v) + +instance Unbox Word32 where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Word32 v) = AD_Word32 (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Word32 v) = V_Word32 (vectorOfUniqueArray n v) + +instance Unbox Word64 where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Word64 v) = AD_Word64 (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Word64 v) = V_Word64 (vectorOfUniqueArray n v) + +instance Unbox Float where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Float v) = AD_Float (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Float v) = V_Float (vectorOfUniqueArray n v) + +instance Unbox Double where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Double v) = AD_Double (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Double v) = V_Double (vectorOfUniqueArray n v) + +instance Unbox Char where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Char v) = AD_Char (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Char v) = V_Char (vectorOfUniqueArray n v) + +instance Unbox Bool where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Bool v) = AD_Bool (uniqueArrayOfVector v) + unboxedOfArrayData !n (AD_Bool v) = V_Bool (vectorOfUniqueArray n v) + +instance Unbox () where + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed V_Unit{} = AD_Unit + unboxedOfArrayData !n AD_Unit = V_Unit n + +instance (Unbox a, Unbox b) => Unbox (a, b) where + {-# INLINE arrayDataOfUnboxed #-} + arrayDataOfUnboxed (V_2 _ a b) = + AD_Unit `AD_Pair` arrayDataOfUnboxed a + `AD_Pair` arrayDataOfUnboxed b + -- + {-# INLINE unboxedOfArrayData #-} + unboxedOfArrayData !n (AD_Unit `AD_Pair` a `AD_Pair` b) = + V_2 n (unboxedOfArrayData n a) + (unboxedOfArrayData n b) + +instance (Unbox a, Unbox b, Unbox c) => Unbox (a, b, c) where + {-# INLINE arrayDataOfUnboxed #-} + arrayDataOfUnboxed (V_3 _ a b c) = + AD_Unit `AD_Pair` arrayDataOfUnboxed a + `AD_Pair` arrayDataOfUnboxed b + `AD_Pair` arrayDataOfUnboxed c + -- + {-# INLINE unboxedOfArrayData #-} + unboxedOfArrayData !n (AD_Unit `AD_Pair` a `AD_Pair` b `AD_Pair` c) = + V_3 n (unboxedOfArrayData n a) + (unboxedOfArrayData n b) + (unboxedOfArrayData n c) + +instance (Unbox a, Unbox b, Unbox c, Unbox d) => Unbox (a, b, c, d) where + {-# INLINE arrayDataOfUnboxed #-} + arrayDataOfUnboxed (V_4 _ a b c d) = + AD_Unit `AD_Pair` arrayDataOfUnboxed a + `AD_Pair` arrayDataOfUnboxed b + `AD_Pair` arrayDataOfUnboxed c + `AD_Pair` arrayDataOfUnboxed d + -- + {-# INLINE unboxedOfArrayData #-} + unboxedOfArrayData !n (AD_Unit `AD_Pair` a `AD_Pair` b `AD_Pair` c `AD_Pair` d) = + V_4 n (unboxedOfArrayData n a) + (unboxedOfArrayData n b) + (unboxedOfArrayData n c) + (unboxedOfArrayData n d) + +instance (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e) => Unbox (a, b, c, d, e) where + {-# INLINE arrayDataOfUnboxed #-} + arrayDataOfUnboxed (V_5 _ a b c d e) = + AD_Unit `AD_Pair` arrayDataOfUnboxed a + `AD_Pair` arrayDataOfUnboxed b + `AD_Pair` arrayDataOfUnboxed c + `AD_Pair` arrayDataOfUnboxed d + `AD_Pair` arrayDataOfUnboxed e + -- + {-# INLINE unboxedOfArrayData #-} + unboxedOfArrayData !n (AD_Unit `AD_Pair` a `AD_Pair` b `AD_Pair` c `AD_Pair` d `AD_Pair` e) = + V_5 n (unboxedOfArrayData n a) + (unboxedOfArrayData n b) + (unboxedOfArrayData n c) + (unboxedOfArrayData n d) + (unboxedOfArrayData n e) + +instance (Unbox a, Unbox b, Unbox c, Unbox d, Unbox e, Unbox f) => Unbox (a, b, c, d, e, f) where + {-# INLINE arrayDataOfUnboxed #-} + arrayDataOfUnboxed (V_6 _ a b c d e f) = + AD_Unit `AD_Pair` arrayDataOfUnboxed a + `AD_Pair` arrayDataOfUnboxed b + `AD_Pair` arrayDataOfUnboxed c + `AD_Pair` arrayDataOfUnboxed d + `AD_Pair` arrayDataOfUnboxed e + `AD_Pair` arrayDataOfUnboxed f + -- + {-# INLINE unboxedOfArrayData #-} + unboxedOfArrayData !n (AD_Unit `AD_Pair` a `AD_Pair` b `AD_Pair` c `AD_Pair` d `AD_Pair` e `AD_Pair` f) = + V_6 n (unboxedOfArrayData n a) + (unboxedOfArrayData n b) + (unboxedOfArrayData n c) + (unboxedOfArrayData n d) + (unboxedOfArrayData n e) + (unboxedOfArrayData n f) + +{-- +#if MIN_VERSION_vector(0,12,0) +instance Unbox a => Unbox (Complex a) where +#else +instance (RealFloat a, Unbox a) => Unbox (Complex a) where +#endif + {-# INLINE arrayDataOfUnboxed #-} + {-# INLINE unboxedOfArrayData #-} + arrayDataOfUnboxed (V_Complex v2) = arrayDataOfUnboxed v2 + unboxedOfArrayData !n v2 = V_Complex (unboxedOfArrayData n v2) +--} + + +{-- +-- | A family of types which represent a collection of Primitive Vectors. The +-- structure of the collection depends on the element type @e@ of the +-- corresponding Accelerate array. +-- +type family Vectors e :: * + +type instance Vectors () = () +type instance Vectors Int = Vector Int +type instance Vectors Int8 = Vector Int8 +type instance Vectors Int16 = Vector Int16 +type instance Vectors Int32 = Vector Int32 +type instance Vectors Int64 = Vector Int64 +type instance Vectors Word = Vector Word +type instance Vectors Word8 = Vector Word8 +type instance Vectors Word16 = Vector Word16 +type instance Vectors Word32 = Vector Word32 +type instance Vectors Word64 = Vector Word64 +type instance Vectors Float = Vector Float +type instance Vectors Double = Vector Double +type instance Vectors Char = Vector Char +type instance Vectors Bool = Vector Bool +type instance Vectors (a,b) = (Vectors a, Vectors b) + + +-- | /O(n)/ (typically). Convert a collection of unboxed vectors into an +-- Accelerate array. +-- +-- Remember that unboxed vectors can be zipped and unzipped in O(1), so creating +-- the required 'Vectors' structure is free. +-- +-- If the underlying vectors are pinned then this can be done without copying. +-- +-- @since 1.1.0.0@ +-- +fromVectors :: (Shape sh, Elt e) => sh -> Vectors (EltRepr e) -> Array sh e +fromVectors sh vecs = Array (fromElt sh) (aux arrayElt vecs) + where + wrap :: forall a. P.Prim a => P.Vector a -> UniqueArray a + wrap v@(P.Vector _ l _) + = $boundsCheck "fromVectors" "shape mismatch" (size sh == l) + $ uniqueArrayOfVector v + -- + aux :: ArrayEltR e -> Vectors e -> ArrayData e + aux ArrayEltRunit () = AD_Unit + aux ArrayEltRint (V_Int v) = AD_Int (wrap v) + aux ArrayEltRint8 (V_Int8 v) = AD_Int8 (wrap v) + aux ArrayEltRint16 (V_Int16 v) = AD_Int16 (wrap v) + aux ArrayEltRint32 (V_Int32 v) = AD_Int32 (wrap v) + aux ArrayEltRint64 (V_Int64 v) = AD_Int64 (wrap v) + aux ArrayEltRword (V_Word v) = AD_Word (wrap v) + aux ArrayEltRword8 (V_Word8 v) = AD_Word8 (wrap v) + aux ArrayEltRword16 (V_Word16 v) = AD_Word16 (wrap v) + aux ArrayEltRword32 (V_Word32 v) = AD_Word32 (wrap v) + aux ArrayEltRword64 (V_Word64 v) = AD_Word64 (wrap v) + aux ArrayEltRfloat (V_Float v) = AD_Float (wrap v) + aux ArrayEltRdouble (V_Double v) = AD_Double (wrap v) + aux ArrayEltRchar (V_Char v) = AD_Char (wrap v) + aux ArrayEltRbool (V_Bool v) = AD_Bool (wrap v) + aux (ArrayEltRpair ad1 ad2) (v1,v2) = AD_Pair (aux ad1 v1) (aux ad2 v2) + -- + aux _ _ = $internalError "fromVectors" "unsupported type" + + +-- | /O(1)/ (typically). Convert an Accelerate array into a collection of +-- unboxed vectors. +-- +-- If the array data was allocated by Accelerate, this can typically be done +-- without copying. +-- +-- Remember that unboxed vectors can be zipped and unzipped in O(1), so you can +-- convert the result of this function into a more natural unboxed tuple +-- representation for free. +-- +-- @since 1.1.0.0@ +-- +toVectors :: (Shape sh, Elt e) => Array sh e -> Vectors (EltRepr e) +toVectors (Array sh adata) = aux arrayElt adata + where + n :: Int + n = R.size sh + + wrap :: forall a. P.Prim a => UniqueArray a -> P.Vector a + wrap ua = vectorOfUniqueArray n ua + + aux :: ArrayEltR e -> ArrayData e -> Vectors e + aux ArrayEltRunit AD_Unit = () + aux ArrayEltRint (AD_Int v) = V_Int (wrap v) + aux ArrayEltRint8 (AD_Int8 v) = V_Int8 (wrap v) + aux ArrayEltRint16 (AD_Int16 v) = V_Int16 (wrap v) + aux ArrayEltRint32 (AD_Int32 v) = V_Int32 (wrap v) + aux ArrayEltRint64 (AD_Int64 v) = V_Int64 (wrap v) + aux ArrayEltRword (AD_Word v) = V_Word (wrap v) + aux ArrayEltRword8 (AD_Word8 v) = V_Word8 (wrap v) + aux ArrayEltRword16 (AD_Word16 v) = V_Word16 (wrap v) + aux ArrayEltRword32 (AD_Word32 v) = V_Word32 (wrap v) + aux ArrayEltRword64 (AD_Word64 v) = V_Word64 (wrap v) + aux ArrayEltRfloat (AD_Float v) = V_Float (wrap v) + aux ArrayEltRdouble (AD_Double v) = V_Double (wrap v) + aux ArrayEltRchar (AD_Char v) = V_Char (wrap v) + aux ArrayEltRbool (AD_Bool v) = V_Bool (wrap v) + aux (ArrayEltRpair ad1 ad2) (AD_Pair v1 v2) = (aux ad1 v1, aux ad2 v2) + -- + aux _ _ = $internalError "toVectors" "unsupported type" +--} + diff --git a/src/Data/Array/Accelerate/IO/Foreign/ForeignPtr.hs b/src/Data/Array/Accelerate/IO/Foreign/ForeignPtr.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Foreign/ForeignPtr.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.Foreign.ForeignPtr +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.IO.Foreign.ForeignPtr + where + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Unique +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Type + +import Foreign.ForeignPtr +import System.IO.Unsafe + + +-- | A family of types which represent a collection of 'ForeignPtr's. The +-- structure of the collection depends on the element type @e@. +-- +type family ForeignPtrs e + +type instance ForeignPtrs () = () +type instance ForeignPtrs Int = ForeignPtr Int +type instance ForeignPtrs Int8 = ForeignPtr Int8 +type instance ForeignPtrs Int16 = ForeignPtr Int16 +type instance ForeignPtrs Int32 = ForeignPtr Int32 +type instance ForeignPtrs Int64 = ForeignPtr Int64 +type instance ForeignPtrs Word = ForeignPtr Word +type instance ForeignPtrs Word8 = ForeignPtr Word8 +type instance ForeignPtrs Word16 = ForeignPtr Word16 +type instance ForeignPtrs Word32 = ForeignPtr Word32 +type instance ForeignPtrs Word64 = ForeignPtr Word64 +type instance ForeignPtrs CShort = ForeignPtr Int16 +type instance ForeignPtrs CUShort = ForeignPtr Word16 +type instance ForeignPtrs CInt = ForeignPtr Int32 +type instance ForeignPtrs CUInt = ForeignPtr Word32 +type instance ForeignPtrs CLong = ForeignPtr HTYPE_LONG +type instance ForeignPtrs CULong = ForeignPtr HTYPE_UNSIGNED_LONG +type instance ForeignPtrs CLLong = ForeignPtr Int64 +type instance ForeignPtrs CULLong = ForeignPtr Word64 +type instance ForeignPtrs Half = ForeignPtr Half +type instance ForeignPtrs Float = ForeignPtr Float +type instance ForeignPtrs Double = ForeignPtr Double +type instance ForeignPtrs CFloat = ForeignPtr Float +type instance ForeignPtrs CDouble = ForeignPtr Double +type instance ForeignPtrs Bool = ForeignPtr Word8 +type instance ForeignPtrs Char = ForeignPtr Char +type instance ForeignPtrs CChar = ForeignPtr HTYPE_CCHAR +type instance ForeignPtrs CSChar = ForeignPtr Int8 +type instance ForeignPtrs CUChar = ForeignPtr Word8 +type instance ForeignPtrs (V2 a) = ForeignPtrs a +type instance ForeignPtrs (V3 a) = ForeignPtrs a +type instance ForeignPtrs (V4 a) = ForeignPtrs a +type instance ForeignPtrs (V8 a) = ForeignPtrs a +type instance ForeignPtrs (V16 a) = ForeignPtrs a +type instance ForeignPtrs (a,b) = (ForeignPtrs a, ForeignPtrs b) + + +-- | /O(1)/. Treat the set of 'ForeignPtrs' as an Accelerate array. The type of +-- elements @e@ in the output Accelerate array determines the structure of the +-- collection. +-- +-- Data is considered to be in row-major order. You must ensure that each of the +-- input pointers contains the right number of elements. +-- +-- The data may not be modified through the 'ForeignPtr's afterwards. +-- +-- You should make sure that the data is suitably aligned. +-- +-- @since 1.1.0.0@ +-- +{-# INLINE fromForeignPtrs #-} +fromForeignPtrs :: (Shape sh, Elt e) => sh -> ForeignPtrs (EltRepr e) -> Array sh e +fromForeignPtrs sh fps = Array (fromElt sh) (aux arrayElt fps) + where + wrap :: (UniqueArray e -> r) -> ForeignPtr e -> r + wrap k fp = k (unsafePerformIO $ newUniqueArray fp) + + aux :: ArrayEltR e -> ForeignPtrs e -> ArrayData e + aux ArrayEltRunit = const AD_Unit + aux ArrayEltRint = wrap AD_Int + aux ArrayEltRint8 = wrap AD_Int8 + aux ArrayEltRint16 = wrap AD_Int16 + aux ArrayEltRint32 = wrap AD_Int32 + aux ArrayEltRint64 = wrap AD_Int64 + aux ArrayEltRword = wrap AD_Word + aux ArrayEltRword8 = wrap AD_Word8 + aux ArrayEltRword16 = wrap AD_Word16 + aux ArrayEltRword32 = wrap AD_Word32 + aux ArrayEltRword64 = wrap AD_Word64 + aux ArrayEltRcshort = wrap AD_CShort + aux ArrayEltRcushort = wrap AD_CUShort + aux ArrayEltRcint = wrap AD_CInt + aux ArrayEltRcuint = wrap AD_CUInt + aux ArrayEltRclong = wrap AD_CLong + aux ArrayEltRculong = wrap AD_CULong + aux ArrayEltRcllong = wrap AD_CLLong + aux ArrayEltRcullong = wrap AD_CULLong + aux ArrayEltRhalf = wrap AD_Half + aux ArrayEltRfloat = wrap AD_Float + aux ArrayEltRdouble = wrap AD_Double + aux ArrayEltRcfloat = wrap AD_CFloat + aux ArrayEltRcdouble = wrap AD_CDouble + aux ArrayEltRbool = wrap AD_Bool + aux ArrayEltRchar = wrap AD_Char + aux ArrayEltRcchar = wrap AD_CChar + aux ArrayEltRcschar = wrap AD_CSChar + aux ArrayEltRcuchar = wrap AD_CUChar + aux (ArrayEltRvec2 ae) = AD_V2 . aux ae + aux (ArrayEltRvec3 ae) = AD_V3 . aux ae + aux (ArrayEltRvec4 ae) = AD_V4 . aux ae + aux (ArrayEltRvec8 ae) = AD_V8 . aux ae + aux (ArrayEltRvec16 ae) = AD_V16 . aux ae + aux (ArrayEltRpair ae1 ae2) = \(v1,v2) -> AD_Pair (aux ae1 v1) (aux ae2 v2) + + +-- | /O(1)/. Yield the 'ForeignPtr's underlying the given Accelerate 'Array'. +-- The element type @e@ will determine the structure of the output collection. +-- +-- Data is considered to be in row-major order. +-- +-- @since 1.1.0.0@ +-- +{-# LANGUAGE toForeignPts #-} +toForeignPtrs :: (Shape sh, Elt e) => Array sh e -> ForeignPtrs (EltRepr e) +toForeignPtrs (Array _ adata) = aux arrayElt adata + where + wrap :: UniqueArray a -> ForeignPtr a + wrap ua = unsafeGetValue (uniqueArrayData ua) + + aux :: ArrayEltR e -> ArrayData e -> ForeignPtrs e + aux ArrayEltRunit AD_Unit = () + aux ArrayEltRint (AD_Int s) = wrap s + aux ArrayEltRint8 (AD_Int8 s) = wrap s + aux ArrayEltRint16 (AD_Int16 s) = wrap s + aux ArrayEltRint32 (AD_Int32 s) = wrap s + aux ArrayEltRint64 (AD_Int64 s) = wrap s + aux ArrayEltRword (AD_Word s) = wrap s + aux ArrayEltRword8 (AD_Word8 s) = wrap s + aux ArrayEltRword16 (AD_Word16 s) = wrap s + aux ArrayEltRword32 (AD_Word32 s) = wrap s + aux ArrayEltRword64 (AD_Word64 s) = wrap s + aux ArrayEltRcshort (AD_CShort s) = wrap s + aux ArrayEltRcushort (AD_CUShort s) = wrap s + aux ArrayEltRcint (AD_CInt s) = wrap s + aux ArrayEltRcuint (AD_CUInt s) = wrap s + aux ArrayEltRclong (AD_CLong s) = wrap s + aux ArrayEltRculong (AD_CULong s) = wrap s + aux ArrayEltRcllong (AD_CLLong s) = wrap s + aux ArrayEltRcullong (AD_CULLong s) = wrap s + aux ArrayEltRhalf (AD_Half s) = wrap s + aux ArrayEltRfloat (AD_Float s) = wrap s + aux ArrayEltRdouble (AD_Double s) = wrap s + aux ArrayEltRcfloat (AD_CFloat s) = wrap s + aux ArrayEltRcdouble (AD_CDouble s) = wrap s + aux ArrayEltRbool (AD_Bool s) = wrap s + aux ArrayEltRchar (AD_Char s) = wrap s + aux ArrayEltRcchar (AD_CChar s) = wrap s + aux ArrayEltRcschar (AD_CSChar s) = wrap s + aux ArrayEltRcuchar (AD_CUChar s) = wrap s + aux (ArrayEltRvec2 ae) (AD_V2 s) = aux ae s + aux (ArrayEltRvec3 ae) (AD_V3 s) = aux ae s + aux (ArrayEltRvec4 ae) (AD_V4 s) = aux ae s + aux (ArrayEltRvec8 ae) (AD_V8 s) = aux ae s + aux (ArrayEltRvec16 ae) (AD_V16 s) = aux ae s + aux (ArrayEltRpair ae1 ae2) (AD_Pair s1 s2) = (aux ae1 s1, aux ae2 s2) + diff --git a/src/Data/Array/Accelerate/IO/Foreign/Ptr.hs b/src/Data/Array/Accelerate/IO/Foreign/Ptr.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Foreign/Ptr.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.Foreign.Ptr +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.IO.Foreign.Ptr + where + +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Array.Unique + +import Foreign.Ptr +import Foreign.ForeignPtr +import System.IO.Unsafe + + +-- | A family of types which represent a collection of 'Ptr's. The +-- structure of the collection depends on the element type @e@. +-- +type Ptrs e = ArrayPtrs e + + +-- | /O(1)/. Treat the set of 'Ptrs' as an Accelerate array. The type of +-- elements @e@ in the output Accelerate array determines the structure of the +-- collection. +-- +-- Data is considered to be in row-major order. You must ensure that each of the +-- input pointers contains the right number of elements. +-- +-- The data may not be modified through the 'Ptrs' afterwards. +-- +-- You are responsible for ensuring that the data remains alive for the duration +-- of the Accelerate computation, and for freeing it afterwards. +-- +-- You should make sure that the data is suitably aligned. +-- +-- @since 1.1.0.0@ +-- +{-# INLINE fromPtrs #-} +fromPtrs :: (Shape sh, Elt e) => sh -> Ptrs (EltRepr e) -> Array sh e +fromPtrs sh ps = Array (fromElt sh) (aux arrayElt ps) + where + wrap :: (UniqueArray e -> r) -> Ptr e -> r + wrap k p = k (unsafePerformIO $ newUniqueArray =<< newForeignPtr_ p) + + aux :: ArrayEltR e -> Ptrs e -> ArrayData e + aux ArrayEltRunit = const AD_Unit + aux ArrayEltRint = wrap AD_Int + aux ArrayEltRint8 = wrap AD_Int8 + aux ArrayEltRint16 = wrap AD_Int16 + aux ArrayEltRint32 = wrap AD_Int32 + aux ArrayEltRint64 = wrap AD_Int64 + aux ArrayEltRword = wrap AD_Word + aux ArrayEltRword8 = wrap AD_Word8 + aux ArrayEltRword16 = wrap AD_Word16 + aux ArrayEltRword32 = wrap AD_Word32 + aux ArrayEltRword64 = wrap AD_Word64 + aux ArrayEltRcshort = wrap AD_CShort + aux ArrayEltRcushort = wrap AD_CUShort + aux ArrayEltRcint = wrap AD_CInt + aux ArrayEltRcuint = wrap AD_CUInt + aux ArrayEltRclong = wrap AD_CLong + aux ArrayEltRculong = wrap AD_CULong + aux ArrayEltRcllong = wrap AD_CLLong + aux ArrayEltRcullong = wrap AD_CULLong + aux ArrayEltRhalf = wrap AD_Half + aux ArrayEltRfloat = wrap AD_Float + aux ArrayEltRdouble = wrap AD_Double + aux ArrayEltRcfloat = wrap AD_CFloat + aux ArrayEltRcdouble = wrap AD_CDouble + aux ArrayEltRbool = wrap AD_Bool + aux ArrayEltRchar = wrap AD_Char + aux ArrayEltRcchar = wrap AD_CChar + aux ArrayEltRcschar = wrap AD_CSChar + aux ArrayEltRcuchar = wrap AD_CUChar + aux (ArrayEltRvec2 ae) = AD_V2 . aux ae + aux (ArrayEltRvec3 ae) = AD_V3 . aux ae + aux (ArrayEltRvec4 ae) = AD_V4 . aux ae + aux (ArrayEltRvec8 ae) = AD_V8 . aux ae + aux (ArrayEltRvec16 ae) = AD_V16 . aux ae + aux (ArrayEltRpair ae1 ae2) = \(v1,v2) -> AD_Pair (aux ae1 v1) (aux ae2 v2) + + +-- | /O(1)/. Yield the underlying 'Ptrs' backing the given Accelerate array. The +-- element type @e@ will determine the structure of the output collection. +-- +-- Data is considered to be in row-major order. +-- +-- @since 1.1.0.0@ +-- +{-# INLINE toPtrs #-} +toPtrs :: (Shape sh, Elt e) => Array sh e -> Ptrs (EltRepr e) +toPtrs (Array _ adata) = ptrsOfArrayData adata + diff --git a/src/Data/Array/Repa/Repr/Accelerate.hs b/src/Data/Array/Repa/Repr/Accelerate.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Repa/Repr/Accelerate.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Data.Array.Repa.Repr.Accelerate +-- Copyright : [2012..2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- This provides an efficient non-copying Repa manifest array representation +-- that can be passed directly to Accelerate. +-- +-- The standard rules for dealing with manifest Repa arrays apply: +-- +-- * If you want to have Repa 'R.computeP' directly into an Accelerate array, +-- the source array must have a delayed representation. +-- +-- * If you want to copy between manifest arrays, use 'R.copyP' instead. +-- + +module Data.Array.Repa.Repr.Accelerate ( + + A, Shapes, + + fromRepa, toRepa, + computeAccS, computeAccP + +) where + +import Control.Monad + +import qualified Data.Array.Repa as R +import qualified Data.Array.Repa.Eval as R +import qualified Data.Array.Accelerate.Array.Data as A +import qualified Data.Array.Accelerate.Array.Sugar as A + + +-- | Index conversion and equivalence statement between Repa and Accelerate +-- array shapes. That is, a n-dimensional Repa array will produce an +-- n-dimensional Accelerate array of the same extent, and vice-versa. +-- +class (R.Shape r, A.Shape a) => Shapes r a | a -> r, r -> a where + -- these are really equivalent representations, so unsafeCoerce would probably + -- work, but bad programmers get no cookies. + toR :: a -> r + toA :: r -> a + +instance Shapes R.Z A.Z where + {-# INLINE toR #-} + toR A.Z = R.Z + {-# INLINE toA #-} + toA R.Z = A.Z + +instance Shapes sr sa => Shapes (sr R.:. Int) (sa A.:. Int) where + {-# INLINE toR #-} + toR (sa A.:. sz) = toR sa R.:. sz + {-# INLINE toA #-} + toA (sr R.:. sz) = toA sr A.:. sz + + +-- | The representation tag for manifest arrays based on Data.Array.Accelerate. +-- +-- The Accelerate array implementation is based on type families and picks an +-- efficient, unboxed representation for every element type. Moreover, these +-- arrays can be handed efficiently (without copying) to Accelerate programs +-- for further computation. +-- +data A + +-- Repr ------------------------------------------------------------------------ + +-- | Reading elements of the Accelerate array +-- +instance A.Elt e => R.Source A e where + data Array A sh e + = AAccelerate !sh !(A.ArrayData (A.EltRepr e)) + + {-# INLINE extent #-} + extent (AAccelerate sh _) + = sh + + {-# INLINE linearIndex #-} + linearIndex (AAccelerate sh adata) ix + | ix >= 0 && ix < R.size sh + = A.toElt (adata `A.unsafeIndexArrayData` ix) + + | otherwise + = error "Repa: accelerate array out of bounds" + + {-# INLINE unsafeLinearIndex #-} + unsafeLinearIndex (AAccelerate _ adata) ix + = A.toElt (adata `A.unsafeIndexArrayData` ix) + + {-# INLINE deepSeqArray #-} + deepSeqArray (AAccelerate sh adata) x + = sh `R.deepSeq` adata `seq` x + + +-- | Filling Accelerate arrays +-- +instance A.Elt e => R.Target A e where + data MVec A e + = MAVec (A.MutableArrayData (A.EltRepr e)) + + {-# INLINE newMVec #-} + newMVec n + = MAVec `liftM` A.newArrayData n + + {-# INLINE unsafeWriteMVec #-} + unsafeWriteMVec (MAVec mad) n e + = A.unsafeWriteArrayData mad n (A.fromElt e) + + {-# INLINE unsafeFreezeMVec #-} + unsafeFreezeMVec sh (MAVec mad) + = do adata <- A.unsafeFreezeArrayData mad + return $! AAccelerate sh adata + + {-# INLINE deepSeqMVec #-} + deepSeqMVec (MAVec arr) x -- maybe? + = arr `seq` x + + {-# INLINE touchMVec #-} + touchMVec _ -- maybe? + = return () + + +-- Conversions ----------------------------------------------------------------- + +-- | /O(1)/. Wrap an Accelerate array. +-- +toRepa + :: Shapes sh sh' + => A.Array sh' e -> R.Array A sh e +{-# INLINE toRepa #-} +toRepa arr@(A.Array _ adata) + = AAccelerate (toR (A.shape arr)) adata + +-- | /O(1)/. Unpack to an Accelerate array. +-- +fromRepa + :: (Shapes sh sh', A.Elt e) + => R.Array A sh e -> A.Array sh' e +{-# INLINE fromRepa #-} +fromRepa (AAccelerate sh adata) + = A.Array (A.fromElt (toA sh)) adata + + +-- Computations ---------------------------------------------------------------- + +-- | Sequential computation of array elements +-- +computeAccS + :: (R.Load r sh e, A.Elt e) + => R.Array r sh e -> R.Array A sh e +{-# INLINE computeAccS #-} +computeAccS = R.computeS + +-- | Parallel computation of array elements +-- +computeAccP + :: (R.Load r sh e, A.Elt e, Monad m) + => R.Array r sh e + -> m (R.Array A sh e) +{-# INLINE computeAccP #-} +computeAccP = R.computeP + diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Test +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Test where + +import Test.Tasty + +import Test.Array.IArray +import Test.Array.Unboxed +import Test.Vector.Storable +import Test.Vector.Unboxed + +main :: IO () +main + = defaultMain + $ testGroup "IO" + [ test_vector_unboxed + , test_vector_storable + , test_array_iarray + , test_array_unboxed + ] + diff --git a/test/Test/Array/IArray.hs b/test/Test/Array/IArray.hs new file mode 100644 --- /dev/null +++ b/test/Test/Array/IArray.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Test.Array.IArray +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Test.Array.IArray + where + +import Test.Util +import Test.Tasty +import Test.Tasty.Hedgehog + +import Data.Array.Accelerate ( Shape, Elt ) +import Data.Array.Accelerate.Array.Sugar ( EltRepr ) +import Data.Array.Accelerate.IO.Data.Array.IArray as A +import qualified Data.Array.Accelerate as A + +import Data.Array.IArray hiding ( array, indices, elems ) +import qualified Data.Array.IArray as I + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Data.Proxy +import Prelude + + +iarray :: (Ix ix, IArray a e) => Gen (ix,ix) -> Gen e -> Gen (a ix e) +iarray ix e = do + (lo,hi) <- ix + let n = rangeSize (lo,hi) + indices = range (lo,hi) + -- + elems <- Gen.list (Range.singleton n) e + return $ I.array (lo,hi) (zip indices elems) + + +test_i2a + :: forall ix sh a e. (Ix ix, IArray a e, Elt ix, Shape sh, Elt e, Eq e, Show (a ix e), Eq (a ix e), IxShapeRepr (EltRepr ix) ~ EltRepr sh) + => Proxy a + -> Gen sh + -> Gen (ix,ix) + -> Gen e + -> Property +test_i2a _ _ ix e = + property $ do + ia <- forAll (iarray ix e :: Gen (a ix e)) + let + (lo,_) = bounds ia + acc = fromIArray ia :: A.Array sh e + ia' = toIArray (Just lo) acc + -- + I.elems ia === A.toList acc -- elements convert correctly + ia === ia' -- indices round-trip correctly + +test_a2i + :: forall ix sh a e. (Ix ix, IArray a e, Elt ix, Shape sh, Elt e, Eq e, Show (a ix e), Eq sh, Eq e, IxShapeRepr (EltRepr ix) ~ EltRepr sh) + => Proxy a + -> Gen sh + -> Gen (ix,ix) + -> Gen e + -> Property +test_a2i _ dim _ e = + property $ do + sh <- forAll dim + acc <- forAll (array sh e) + -- + A.toList acc === I.elems (toIArray Nothing acc :: a ix e) + + +test_array_iarray :: TestTree +test_array_iarray = + testGroup "Data.Array.IArray" + [ testGroup "iarray->accelerate" + [ testGroup "DIM1" + [ testProperty "Int" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 int + , testProperty "Int8" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 i8 + , testProperty "Int16" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 i16 + , testProperty "Int32" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 i32 + , testProperty "Int64" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 i64 + , testProperty "Word" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 word + , testProperty "Word8" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 w8 + , testProperty "Word16" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 w16 + , testProperty "Word32" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 w32 + , testProperty "Word64" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 w64 + , testProperty "Float" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 f32 + , testProperty "Double" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 f64 + , testProperty "Complex Float" $ test_i2a (Proxy::Proxy I.Array) dim1 ix1 (complex f32) + ] + , testGroup "DIM2" + [ testProperty "Int" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 int + , testProperty "Int8" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 i8 + , testProperty "Int16" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 i16 + , testProperty "Int32" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 i32 + , testProperty "Int64" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 i64 + , testProperty "Word" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 word + , testProperty "Word8" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 w8 + , testProperty "Word16" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 w16 + , testProperty "Word32" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 w32 + , testProperty "Word64" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 w64 + , testProperty "Float" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 f32 + , testProperty "Double" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 f64 + , testProperty "Complex Float" $ test_i2a (Proxy::Proxy I.Array) dim2 ix2 (complex f32) + ] + ] + , testGroup "accelerate->iarray" + [ testGroup "DIM1" + [ testProperty "Int" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 int + , testProperty "Int8" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 i8 + , testProperty "Int16" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 i16 + , testProperty "Int32" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 i32 + , testProperty "Int64" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 i64 + , testProperty "Word" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 word + , testProperty "Word8" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 w8 + , testProperty "Word16" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 w16 + , testProperty "Word32" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 w32 + , testProperty "Word64" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 w64 + , testProperty "Float" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 f32 + , testProperty "Double" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 f64 + , testProperty "Complex Float" $ test_a2i (Proxy::Proxy I.Array) dim1 ix1 (complex f32) + ] + , testGroup "DIM2" + [ testProperty "Int" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 int + , testProperty "Int8" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 i8 + , testProperty "Int16" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 i16 + , testProperty "Int32" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 i32 + , testProperty "Int64" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 i64 + , testProperty "Word" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 word + , testProperty "Word8" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 w8 + , testProperty "Word16" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 w16 + , testProperty "Word32" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 w32 + , testProperty "Word64" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 w64 + , testProperty "Float" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 f32 + , testProperty "Double" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 f64 + , testProperty "Complex Float" $ test_a2i (Proxy::Proxy I.Array) dim2 ix2 (complex f32) + ] + ] + ] + diff --git a/test/Test/Array/Unboxed.hs b/test/Test/Array/Unboxed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Array/Unboxed.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Test.Array.Unboxed +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Test.Array.Unboxed + where + +import Test.Array.IArray + +import Test.Util +import Test.Tasty +import Test.Tasty.Hedgehog + +import Data.Array.Accelerate ( Shape, Elt ) +import Data.Array.Accelerate.Array.Sugar ( EltRepr ) +import Data.Array.Accelerate.IO.Data.Array.Unboxed as A +import qualified Data.Array.Accelerate as A + +import Data.Array.Unboxed as U hiding ( array ) + +import Hedgehog + + +test_u2a + :: forall ix sh e. (Ix ix, IArray UArray e, Elt ix, Shape sh, Elt e, Eq e, Show (UArray ix e), Eq (UArray ix e), IxShapeRepr (EltRepr ix) ~ EltRepr sh) + => Gen sh + -> Gen (ix,ix) + -> Gen e + -> Property +test_u2a _ ix e = + property $ do + ua <- forAll (iarray ix e :: Gen (UArray ix e)) + let + (lo,_) = bounds ua + acc = fromUArray ua :: A.Array sh e + ua' = toUArray (Just lo) acc + -- + U.elems ua === A.toList acc -- elements convert correctly + ua === ua' -- indices round-trip correctly + +test_a2u + :: forall ix sh e. (Ix ix, IArray UArray e, Elt ix, Shape sh, Elt e, Show (UArray ix e), Eq (UArray ix e), Eq sh, Eq e, IxShapeRepr (EltRepr ix) ~ EltRepr sh) + => Gen sh + -> Gen (ix,ix) + -> Gen e + -> Property +test_a2u dim _ e = + property $ do + sh <- forAll dim + arr <- forAll (array sh e) + -- + A.toList arr === U.elems (toUArray Nothing arr :: UArray ix e) + + +test_array_unboxed :: TestTree +test_array_unboxed = + testGroup "Data.Array.Unboxed" + [ testGroup "uarray->accelerate" + [ testGroup "DIM1" + [ testProperty "Int" $ test_u2a dim1 ix1 int + , testProperty "Int8" $ test_u2a dim1 ix1 i8 + , testProperty "Int16" $ test_u2a dim1 ix1 i16 + , testProperty "Int32" $ test_u2a dim1 ix1 i32 + , testProperty "Int64" $ test_u2a dim1 ix1 i64 + , testProperty "Word" $ test_u2a dim1 ix1 word + , testProperty "Word8" $ test_u2a dim1 ix1 w8 + , testProperty "Word16" $ test_u2a dim1 ix1 w16 + , testProperty "Word32" $ test_u2a dim1 ix1 w32 + , testProperty "Word64" $ test_u2a dim1 ix1 w64 + , testProperty "Float" $ test_u2a dim1 ix1 f32 + , testProperty "Double" $ test_u2a dim1 ix1 f64 + ] + , testGroup "DIM2" + [ testProperty "Int" $ test_u2a dim2 ix2 int + , testProperty "Int8" $ test_u2a dim2 ix2 i8 + , testProperty "Int16" $ test_u2a dim2 ix2 i16 + , testProperty "Int32" $ test_u2a dim2 ix2 i32 + , testProperty "Int64" $ test_u2a dim2 ix2 i64 + , testProperty "Word" $ test_u2a dim2 ix2 word + , testProperty "Word8" $ test_u2a dim2 ix2 w8 + , testProperty "Word16" $ test_u2a dim2 ix2 w16 + , testProperty "Word32" $ test_u2a dim2 ix2 w32 + , testProperty "Word64" $ test_u2a dim2 ix2 w64 + , testProperty "Float" $ test_u2a dim2 ix2 f32 + , testProperty "Double" $ test_u2a dim2 ix2 f64 + ] + ] + , testGroup "accelerate->uarray" + [ testGroup "DIM1" + [ testProperty "Int" $ test_a2u dim1 ix1 int + , testProperty "Int8" $ test_a2u dim1 ix1 i8 + , testProperty "Int16" $ test_a2u dim1 ix1 i16 + , testProperty "Int32" $ test_a2u dim1 ix1 i32 + , testProperty "Int64" $ test_a2u dim1 ix1 i64 + , testProperty "Word" $ test_a2u dim1 ix1 word + , testProperty "Word8" $ test_a2u dim1 ix1 w8 + , testProperty "Word16" $ test_a2u dim1 ix1 w16 + , testProperty "Word32" $ test_a2u dim1 ix1 w32 + , testProperty "Word64" $ test_a2u dim1 ix1 w64 + , testProperty "Float" $ test_a2u dim1 ix1 f32 + , testProperty "Double" $ test_a2u dim1 ix1 f64 + ] + , testGroup "DIM2" + [ testProperty "Int" $ test_a2u dim2 ix2 int + , testProperty "Int8" $ test_a2u dim2 ix2 i8 + , testProperty "Int16" $ test_a2u dim2 ix2 i16 + , testProperty "Int32" $ test_a2u dim2 ix2 i32 + , testProperty "Int64" $ test_a2u dim2 ix2 i64 + , testProperty "Word" $ test_a2u dim2 ix2 word + , testProperty "Word8" $ test_a2u dim2 ix2 w8 + , testProperty "Word16" $ test_a2u dim2 ix2 w16 + , testProperty "Word32" $ test_a2u dim2 ix2 w32 + , testProperty "Word64" $ test_a2u dim2 ix2 w64 + , testProperty "Float" $ test_a2u dim2 ix2 f32 + , testProperty "Double" $ test_a2u dim2 ix2 f64 + ] + ] + ] + diff --git a/test/Test/Util.hs b/test/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Test.Util +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Test.Util where + +import Data.Array.Accelerate ( Arrays, Array, Acc, Shape, Elt ) +import Data.Array.Accelerate.Trafo ( Afunction, AfunctionR ) +import Data.Array.Accelerate.Array.Sugar ( DIM1, DIM2, Z(..), (:.)(..), fromList, size ) +import Data.Array.Accelerate.Data.Complex + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Data.Int +import Data.Word +import Prelude as P + + +type Run = forall a. Arrays a => Acc a -> a +type RunN = forall f. Afunction f => f -> AfunctionR f + +floating :: P.RealFloat a => Gen a +floating = Gen.realFloat (Range.linearFracFrom 0 (-1) 1) + +complex :: Gen a -> Gen (Complex a) +complex f = (:+) <$> f <*> f + +dim0 :: Gen Z +dim0 = return Z + +dim1 :: Gen DIM1 +dim1 = (Z :.) <$> Gen.int (Range.linear 0 1024) + +dim2 :: Gen DIM2 +dim2 = do + x <- Gen.int (Range.linear 0 128) + y <- Gen.int (Range.linear 0 128) + return (Z :. y :. x) + +ix1 :: Gen (Int,Int) +ix1 = do + lo <- Gen.int (Range.linearFrom 0 (-128) 128) + hi <- Gen.int (Range.linear lo (lo+256)) + return (lo,hi) + +ix2 :: Gen ((Int,Int), (Int,Int)) +ix2 = do + l0 <- Gen.int (Range.linearFrom 0 (-64) (64)) + l1 <- Gen.int (Range.linearFrom 0 (-64) (64)) + h0 <- Gen.int (Range.linear l0 (l0+128)) + h1 <- Gen.int (Range.linear l1 (l1+128)) + return ((l0,l1), (h0,h1)) + +array :: (Shape sh, Elt e) => sh -> Gen e -> Gen (Array sh e) +array sh gen = fromList sh <$> Gen.list (Range.singleton (size sh)) gen + +int :: Gen Int +int = Gen.int Range.linearBounded + +i8 :: Gen Int8 +i8 = Gen.int8 Range.linearBounded + +i16 :: Gen Int16 +i16 = Gen.int16 Range.linearBounded + +i32 :: Gen Int32 +i32 = Gen.int32 Range.linearBounded + +i64 :: Gen Int64 +i64 = Gen.int64 Range.linearBounded + +word :: Gen Word +word = Gen.word Range.linearBounded + +w8 :: Gen Word8 +w8 = Gen.word8 Range.linearBounded + +w16 :: Gen Word16 +w16 = Gen.word16 Range.linearBounded + +w32 :: Gen Word32 +w32 = Gen.word32 Range.linearBounded + +w64 :: Gen Word64 +w64 = Gen.word64 Range.linearBounded + +f32 :: Gen Float +f32 = Gen.float (Range.linearFracFrom 0 flt_min flt_max) + +f64 :: Gen Double +f64 = Gen.double (Range.linearFracFrom 0 flt_min flt_max) + +flt_max :: RealFloat a => a +flt_max = x + where + n = floatDigits x + b = floatRadix x + (_, u) = floatRange x + x = encodeFloat (b^n - 1) (u - n) + +flt_min :: RealFloat a => a +flt_min = x + where + n = floatDigits x + b = floatRadix x + (l, _) = floatRange x + x = encodeFloat (b^n - 1) (l - n - 1) + diff --git a/test/Test/Vector/Storable.hs b/test/Test/Vector/Storable.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vector/Storable.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Test.Vector.Storable +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Test.Vector.Storable + where + +import Test.Util +import Test.Tasty +import Test.Tasty.Hedgehog + +import Data.Array.Accelerate ( Shape, Elt, Z(..), (:.)(..) ) +import Data.Array.Accelerate.Array.Sugar ( rank, EltRepr ) +import Data.Array.Accelerate.Data.Complex +import Data.Array.Accelerate.IO.Data.Vector.Storable as A +import qualified Data.Array.Accelerate as A + +import Data.Vector.Storable as S + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Data.Word +import Text.Printf +import Prelude as P + + +storable :: Storable e => Int -> Gen e -> Gen (S.Vector e) +storable n gen = + S.fromListN n <$> Gen.list (Range.singleton n) gen + +boolToWord8 :: Bool -> Word8 +boolToWord8 True = 1 +boolToWord8 False = 0 + +test_s2a + :: forall e. (Storable e, Elt e, Eq e, Vectors (EltRepr e) ~ Vector e) + => Gen e + -> Property +test_s2a e = + property $ do + sh@(Z :. n) <- forAll dim1 + svec <- forAll (storable n e) + -- + S.toList svec === A.toList (A.fromVectors sh svec) + +test_s2a_t2 + :: forall a b. ( Storable a, Elt a, Eq a, Vectors (EltRepr a) ~ Vector a + , Storable b, Elt b, Eq b, Vectors (EltRepr b) ~ Vector b + ) + => Gen a + -> Gen b + -> Property +test_s2a_t2 a b = + property $ do + sh@(Z :. n) <- forAll dim1 + sa <- forAll (storable n a) + sb <- forAll (storable n b) + -- + P.zip (S.toList sa) (S.toList sb) === A.toList (A.fromVectors sh (((), sa), sb)) + + +test_a2s + :: forall sh e. (Shape sh, Storable e, Elt e, Eq sh, Eq e, Vectors (EltRepr e) ~ Vector e) + => Gen sh + -> Gen e + -> Property +test_a2s dim e = + property $ do + sh <- forAll dim + arr <- forAll (array sh e) + -- + A.toList arr === S.toList (A.toVectors arr) + +test_a2s_t2 + :: forall sh a b. ( Shape sh, Eq sh, Eq a, Eq b, Elt a, Elt b, Storable a, Storable b + , Vectors (EltRepr (a,b)) ~ (((), Vector a), Vector b) + ) + => Gen sh + -> Gen (a,b) + -> Property +test_a2s_t2 dim e = + property $ do + sh <- forAll dim + arr <- forAll (array sh e) + let + (((), va), vb) = A.toVectors arr + -- + A.toList arr === P.zip (S.toList va) (S.toList vb) + + +test_s2a_complex + :: forall e. ( Storable e, Elt (Complex e), Eq e + , Vectors (EltRepr (Complex e)) ~ Vector e + ) + => Gen (Complex e) + -> Property +test_s2a_complex e = + property $ do + sh@(Z :. n) <- forAll dim1 + svec <- forAll (storable n e) + -- + S.toList svec === A.toList (A.fromVectors sh (S.unsafeCast svec :: S.Vector e)) + +test_a2s_complex + :: forall sh e. ( Shape sh, Storable e, Elt (Complex e), Eq sh, Eq e + , Vectors (EltRepr (Complex e)) ~ Vector e + ) + => Gen sh + -> Gen (Complex e) + -> Property +test_a2s_complex dim e = + property $ do + sh <- forAll dim + arr <- forAll (array sh e) + -- + A.toList arr === S.toList (S.unsafeCast (A.toVectors arr) :: S.Vector (Complex e)) + + +test_a2s_dim + :: forall sh. (Shape sh, Eq sh) + => Gen sh + -> TestTree +test_a2s_dim dim = + testGroup (printf "DIM%d" (rank (undefined::sh))) + [ testProperty "Int" $ test_a2s dim int + , testProperty "Int8" $ test_a2s dim i8 + , testProperty "Int16" $ test_a2s dim i16 + , testProperty "Int32" $ test_a2s dim i32 + , testProperty "Int64" $ test_a2s dim i64 + , testProperty "Word" $ test_a2s dim word + , testProperty "Word8" $ test_a2s dim w8 + , testProperty "Word16" $ test_a2s dim w16 + , testProperty "Word32" $ test_a2s dim w32 + , testProperty "Word64" $ test_a2s dim w64 + , testProperty "Char" $ test_a2s dim Gen.unicode + -- , testProperty "Bool" $ test_a2s dim Gen.bool + , testProperty "Float" $ test_a2s dim f32 + , testProperty "Double" $ test_a2s dim f64 + , testProperty "Complex Float" $ test_a2s_complex dim (complex f32) + , testProperty "(Double, Int16)" $ test_a2s_t2 dim ((,) <$> f64 <*> i16) + , testProperty "(Float, Float)" $ test_a2s_t2 dim ((,) <$> f32 <*> f32) + -- , testProperty "(Float, (Double,Int))" $ test_a2s dim ((,) <$> f32 <*> ((,) <$> f64 <*> int)) + ] + +test_vector_storable :: TestTree +test_vector_storable = + testGroup "Data.Vector.Storable" + [ testGroup "storable->accelerate" + [ testProperty "Int" $ test_s2a int + , testProperty "Int8" $ test_s2a i8 + , testProperty "Int16" $ test_s2a i16 + , testProperty "Int32" $ test_s2a i32 + , testProperty "Int64" $ test_s2a i64 + , testProperty "Word" $ test_s2a word + , testProperty "Word8" $ test_s2a w8 + , testProperty "Word16" $ test_s2a w16 + , testProperty "Word32" $ test_s2a w32 + , testProperty "Word64" $ test_s2a w64 + , testProperty "Char" $ test_s2a Gen.unicode + , testProperty "Bool" $ test_s2a (boolToWord8 <$> Gen.bool) + , testProperty "Float" $ test_s2a f32 + , testProperty "Double" $ test_s2a f64 + , testProperty "Complex Float" $ test_s2a_complex (complex f32) + , testProperty "(Int,Float)" $ test_s2a_t2 int f32 + , testProperty "(Int8,Word)" $ test_s2a_t2 i8 word + ] + , testGroup"accelerate->storable" + [ test_a2s_dim dim0 + , test_a2s_dim dim1 + , test_a2s_dim dim2 + ] + ] + diff --git a/test/Test/Vector/Unboxed.hs b/test/Test/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vector/Unboxed.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Test.Vector.Unboxed +-- Copyright : [2017] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Test.Vector.Unboxed + where + +import Test.Util +import Test.Tasty +import Test.Tasty.Hedgehog + +import Data.Array.Accelerate ( Shape, Elt, Z(..), (:.)(..) ) +import Data.Array.Accelerate.Array.Sugar ( rank ) +import Data.Array.Accelerate.IO.Data.Vector.Unboxed as A +import qualified Data.Array.Accelerate as A + +import Data.Vector.Unboxed as U + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Text.Printf + + +unboxed :: U.Unbox e => Int -> Gen e -> Gen (U.Vector e) +unboxed n gen = + U.fromListN n <$> Gen.list (Range.singleton n) gen + +test_u2a + :: (A.Unbox e, Show e, Eq e) + => Gen e + -> Property +test_u2a e = + property $ do + Z :. n <- forAll dim1 + uvec <- forAll (unboxed n e) + -- + U.toList uvec === A.toList (A.fromUnboxed uvec) + +test_a2u + :: forall sh e. (A.Unbox e, Shape sh, Elt e, Eq sh, Eq e) + => Gen sh + -> Gen e + -> Property +test_a2u dim e = + property $ do + sh <- forAll dim + arr <- forAll (array sh e) + -- + A.toList arr === U.toList (A.toUnboxed arr) + +test_a2u_dim + :: forall sh. (Shape sh, Eq sh) + => Gen sh + -> TestTree +test_a2u_dim dim = + testGroup (printf "DIM%d" (rank (undefined::sh))) + [ testProperty "Int" $ test_a2u dim int + , testProperty "Int8" $ test_a2u dim i8 + , testProperty "Int16" $ test_a2u dim i16 + , testProperty "Int32" $ test_a2u dim i32 + , testProperty "Int64" $ test_a2u dim i64 + , testProperty "Word" $ test_a2u dim word + , testProperty "Word8" $ test_a2u dim w8 + , testProperty "Word16" $ test_a2u dim w16 + , testProperty "Word32" $ test_a2u dim w32 + , testProperty "Word64" $ test_a2u dim w64 + , testProperty "Char" $ test_a2u dim Gen.unicode + , testProperty "Bool" $ test_a2u dim Gen.bool + , testProperty "Float" $ test_a2u dim f32 + , testProperty "Double" $ test_a2u dim f64 + -- , testProperty "Complex Float" $ test_a2u dim (complex f32) + , testProperty "(Double, Int16)" $ test_a2u dim ((,) <$> f64 <*> i16) + , testProperty "(Float, (Double,Int))" $ test_a2u dim ((,) <$> f32 <*> ((,) <$> f64 <*> int)) + ] + +test_vector_unboxed :: TestTree +test_vector_unboxed = + testGroup "Data.Vector.Unboxed" + [ testGroup "unboxed->accelerate" + [ testProperty "Int" $ test_u2a int + , testProperty "Int8" $ test_u2a i8 + , testProperty "Int16" $ test_u2a i16 + , testProperty "Int32" $ test_u2a i32 + , testProperty "Int64" $ test_u2a i64 + , testProperty "Word" $ test_u2a word + , testProperty "Word8" $ test_u2a w8 + , testProperty "Word16" $ test_u2a w16 + , testProperty "Word32" $ test_u2a w32 + , testProperty "Word64" $ test_u2a w64 + , testProperty "Char" $ test_u2a Gen.unicode + , testProperty "Bool" $ test_u2a Gen.bool + , testProperty "Float" $ test_u2a f32 + , testProperty "Double" $ test_u2a f64 + -- , testProperty "Complex Float" $ test_u2a (complex f32) + , testProperty "(Int,Float)" $ test_u2a ((,) <$> int <*> f32) + , testProperty "((Int8,Word),Double)" $ test_u2a ((,) <$> ((,) <$> i8 <*> word) <*> f64) + ] + , testGroup"accelerate->unboxed" + [ test_a2u_dim dim0 + , test_a2u_dim dim1 + , test_a2u_dim dim2 + ] + ] +