diff --git a/Data/Array/Accelerate/IO.hs b/Data/Array/Accelerate/IO.hs --- a/Data/Array/Accelerate/IO.hs +++ b/Data/Array/Accelerate/IO.hs @@ -10,29 +10,35 @@ -- This module provides efficient conversion routines between different array -- types and Accelerate arrays. -- --- The Repa interface provides an efficient non-copying instance for Repa to --- read and write directly into arrays that can then be passed to Accelerate. --- Additional copying conversions of low-level primitive arrays (i.e. one --- dimensional, row-major blocks of contiguous memory) are provided, however 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 ( - module Data.Array.Accelerate.IO.ByteString, - module Data.Array.Accelerate.IO.Ptr, + -- * Array libraries module Data.Array.Accelerate.IO.Repa, module Data.Array.Accelerate.IO.Vector, + -- * 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.ByteString +import Data.Array.Accelerate.IO.BMP 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 new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/IO/BMP.hs @@ -0,0 +1,132 @@ +-- | +-- Module : Data.Array.Accelerate.IO.BMP +-- Copyright : [2012] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Manuel M T Chakravarty +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.IO.BMP ( + + -- ** Bitmap images + -- + -- | Reading and writing arrays as uncompressed 24 or 32-bit Windows BMP + -- files. + -- + RGBA32, + readImageFromBMP, writeImageToBMP, + + -- *** Manipulating pixels + unpackRGBA32, packRGBA32, luminanceOfRGBA32, rgba32OfLuminance, rgba32OfFloat, + +) where + +import Data.Bits +import Data.Word +import Codec.BMP + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.IO.ByteString as A + + +-- 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) + + +-- Manipulating pixels --------------------------------------------------------- +-- +-- TLM: perhaps this should be moved into something like: +-- accelerate-algorithms:Data.Array.Accelerate.Algorithms.Pixel +-- + +-- | Packed RGBA pixel data +-- +type RGBA32 = Word32 + +-- | Unpack a 'RGBA32' value into a tuple of (Red, Green, Blue, Alpha) values. +-- +unpackRGBA32 :: Exp RGBA32 -> Exp (Word8, Word8, Word8, Word8) +unpackRGBA32 rgba = + let r = A.fromIntegral $ rgba .&. 0xFF + g = A.fromIntegral $ (rgba `div` 0x100) .&. 0xFF + b = A.fromIntegral $ (rgba `div` 0x10000) .&. 0xFF + a = A.fromIntegral $ (rgba `div` 0x1000000) .&. 0xFF + in + lift (r, g, b, a) + + +-- | Promote a tuple of (Red, Green, Blue, Alpha) values into a packed 'RGBA32' +-- value. +-- +packRGBA32 :: Exp (Word8, Word8, Word8, Word8) -> Exp RGBA32 +packRGBA32 rgba = + let (r', g', b', a') = unlift rgba + r = A.fromIntegral r' + g = (A.fromIntegral g') * 0x100 + b = (A.fromIntegral b') * 0x10000 + a = (A.fromIntegral a') * 0x1000000 + in + r + g + b + a + + +-- | Convert an RGBA colour to its luminance value in the range [0..1]. +-- +luminanceOfRGBA32 :: (Elt a, IsFloating a) => Exp RGBA32 -> Exp a +luminanceOfRGBA32 rgba = + let r = 0.3 * A.fromIntegral (rgba .&. 0xFF) + g = 0.59 * A.fromIntegral ((rgba `div` 0x100) .&. 0xFF) + b = 0.11 * A.fromIntegral ((rgba `div` 0x10000) .&. 0xFF) + in + (r + g + b) / 255 + + +-- | Convert a value in the range [0..1] to a grey RGB colour. +-- +rgba32OfLuminance :: (Elt a, IsFloating a) => Exp a -> Exp RGBA32 +rgba32OfLuminance val = + let v = A.truncate (255 * val) -- (0 `A.max` val `A.min` 1) + r = v + g = v * 0x100 + b = v * 0x10000 + a = 0xFF000000 + in + r + g + b + a + + +-- | Promote a tuple of (Red, Green, Blue, Alpha) values in the range [0..1] +-- into a packed 'RGBA32'. +-- +rgba32OfFloat :: (Elt a, IsFloating a) => Exp (a, a, a, a) -> Exp RGBA32 +rgba32OfFloat rgba = + let (r, g, b, a) = unlift rgba + r' = A.truncate (255 * r) * 0x1000000 + g' = A.truncate (255 * g) * 0x10000 + b' = A.truncate (255 * b) * 0x100 + a' = A.truncate (255 * a) + in + r' + g' + b' + a' + diff --git a/Data/Array/Accelerate/IO/BlockCopy.hs b/Data/Array/Accelerate/IO/BlockCopy.hs --- a/Data/Array/Accelerate/IO/BlockCopy.hs +++ b/Data/Array/Accelerate/IO/BlockCopy.hs @@ -15,7 +15,7 @@ BlockCopyFun, BlockCopyFuns, BlockPtrs, ByteStrings, -- * The low-level machinery - allocateArray, blockCopyFunGenerator + allocateArray, blockCopy, blockCopyFunGenerator ) where @@ -51,22 +51,35 @@ -- 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 Float = BlockCopyFun Float -type instance BlockCopyFuns Double = BlockCopyFun Double -type instance BlockCopyFuns Bool = BlockCopyFun Word8 -type instance BlockCopyFuns Char = BlockCopyFun Char -type instance BlockCopyFuns (a,b) = (BlockCopyFuns a, BlockCopyFuns b) +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 Int64 +type instance BlockCopyFuns CULong = BlockCopyFun Word64 +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 Int8 +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 @@ -80,22 +93,35 @@ -- 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 Float = Ptr Float -type instance BlockPtrs Double = Ptr Double -type instance BlockPtrs Bool = Ptr Word8 -type instance BlockPtrs Char = Ptr Char -type instance BlockPtrs (a,b) = (BlockPtrs a, BlockPtrs b) +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 Int64 +type instance BlockPtrs CULong = Ptr Word64 +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 Int8 +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 @@ -103,22 +129,36 @@ -- 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 Float = ByteString -type instance ByteStrings Double = ByteString -type instance ByteStrings Bool = ByteString -type instance ByteStrings Char = ByteString -type instance ByteStrings (a,b) = (ByteStrings a, ByteStrings b) +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 () @@ -152,20 +192,33 @@ 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 ArrayEltRfloat ad = base (ptrsOfArrayData ad) (box fLOAT_SCALE sizeA) - aux ArrayEltRdouble ad = base (ptrsOfArrayData ad) (box dOUBLE_SCALE sizeA) - aux ArrayEltRbool ad = base (ptrsOfArrayData ad) sizeA - aux ArrayEltRchar ad = base (ptrsOfArrayData ad) (sizeA * 4) + 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 diff --git a/Data/Array/Accelerate/IO/ByteString.hs b/Data/Array/Accelerate/IO/ByteString.hs --- a/Data/Array/Accelerate/IO/ByteString.hs +++ b/Data/Array/Accelerate/IO/ByteString.hs @@ -10,7 +10,7 @@ module Data.Array.Accelerate.IO.ByteString ( - -- * Copy to/from (strict) ByteString`s + -- ** Data.ByteString ByteStrings, fromByteString, toByteString ) where diff --git a/Data/Array/Accelerate/IO/Ptr.hs b/Data/Array/Accelerate/IO/Ptr.hs --- a/Data/Array/Accelerate/IO/Ptr.hs +++ b/Data/Array/Accelerate/IO/Ptr.hs @@ -10,10 +10,10 @@ module Data.Array.Accelerate.IO.Ptr ( - -- * Copying to/from raw pointers + -- ** Raw pointers BlockPtrs, fromPtr, toPtr, - -- * Direct copying into/from an Accelerate array + -- ** Direct copying functions BlockCopyFun, BlockCopyFuns, fromArray, toArray ) where diff --git a/Data/Array/Accelerate/IO/Repa.hs b/Data/Array/Accelerate/IO/Repa.hs --- a/Data/Array/Accelerate/IO/Repa.hs +++ b/Data/Array/Accelerate/IO/Repa.hs @@ -19,6 +19,18 @@ 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 @@ -36,7 +48,7 @@ -- | 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. +-- 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 @@ -57,12 +69,13 @@ toA (sr R.:. sz) = toA sr A.:. sz --- | An implementation based on `Data.Array.Accelerate` arrays. 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, example, --- further parallel computation on the GPU. +-- | 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 ------------------------------------------------------------------------ @@ -81,14 +94,14 @@ {-# INLINE linearIndex #-} linearIndex (AAccelerate sh adata) ix | ix >= 0 && ix < R.size sh - = A.toElt (adata `A.indexArrayData` ix) + = A.toElt (adata `A.unsafeIndexArrayData` ix) | otherwise = error "Repa: accelerate array out of bounds" {-# INLINE unsafeLinearIndex #-} unsafeLinearIndex (AAccelerate _ adata) ix - = A.toElt (adata `A.indexArrayData` ix) + = A.toElt (adata `A.unsafeIndexArrayData` ix) {-# INLINE deepSeqArray #-} deepSeqArray (AAccelerate sh adata) x @@ -108,7 +121,7 @@ {-# INLINE unsafeWriteMVec #-} unsafeWriteMVec (MAVec mad) n e = unsafeSTToIO - $ A.writeArrayData mad n (A.fromElt e) + $ A.unsafeWriteArrayData mad n (A.fromElt e) {-# INLINE unsafeFreezeMVec #-} unsafeFreezeMVec sh (MAVec mad) @@ -163,3 +176,4 @@ -> 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 --- a/Data/Array/Accelerate/IO/Vector.hs +++ b/Data/Array/Accelerate/IO/Vector.hs @@ -1,6 +1,10 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Array.Accelerate.IO.Vector --- Copyright : [2012] Adam C. Foltzer +-- Copyright : [2012] Adam C. Foltzer, Trevor L. McDonell -- License : BSD3 -- -- Maintainer : Manuel M T Chakravarty @@ -9,47 +13,179 @@ -- -- Helpers for fast conversion of 'Data.Vector.Storable' vectors into -- Accelerate arrays. +-- + module Data.Array.Accelerate.IO.Vector ( - -- * Vector conversions - fromVector - , toVector - , fromVectorIO - , toVectorIO -) where -import Data.Array.Accelerate ( arrayShape - , Array - , DIM1 - , Elt - , Z(..) - , (:.)(..)) -import Data.Array.Accelerate.Array.Sugar (EltRepr) -import Data.Array.Accelerate.IO.Ptr -import Data.Vector.Storable ( unsafeFromForeignPtr0 - , unsafeToForeignPtr0 - , Vector) + -- ** Data.Vector.Storable + Vectors, toVectors, fromVectors, -import Foreign (mallocForeignPtrArray, Ptr, Storable, withForeignPtr) +) where +-- standard libraries +import Data.Int +import Data.Word +import Data.Vector.Storable +import Foreign.Ptr +import Foreign.C.Types +import Foreign.ForeignPtr import System.IO.Unsafe +import GHC.Base ( Int(..), Int# ) +import Data.Array.Base ( wORD_SCALE, fLOAT_SCALE, dOUBLE_SCALE ) -fromVectorIO :: (Storable a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a)) - => Vector a -> IO (Array DIM1 a) -fromVectorIO v = withForeignPtr fp $ \ptr -> fromPtr (Z :. len) ((), ptr) - where (fp, len) = unsafeToForeignPtr0 v +-- friends +import Data.Array.Accelerate.Array.Data +import Data.Array.Accelerate.Array.Sugar hiding ( Vector ) +import Data.Array.Accelerate.IO.BlockCopy -toVectorIO :: (Storable a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a)) - => Array DIM1 a -> IO (Vector a) -toVectorIO arr = do - let (Z :. len) = arrayShape arr - fp <- mallocForeignPtrArray len - withForeignPtr fp $ \ptr -> toPtr arr ((), ptr) - return $ unsafeFromForeignPtr0 fp len -fromVector :: (Storable a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a)) - => Vector a -> Array DIM1 a -fromVector v = unsafePerformIO $ fromVectorIO v +-- | 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 -toVector :: (Storable a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a)) - => Array DIM1 a -> Vector a -toVector arr = unsafePerformIO $ toVectorIO arr +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 Int64 +type instance Vectors CULong = Vector Word64 +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 Int8 +type instance Vectors CSChar = Vector Int8 +type instance Vectors CUChar = Vector Word8 +type instance Vectors (a,b) = (Vectors a, Vectors b) + + +-- | /O(n)/. Copy a set of storable vectors into freshly allocated 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 = unsafePerformIO $! do + aux arrayElt adata vecs + return array + where + sizeA = size sh + array@(Array _ adata) = allocateArray sh + base accPtr bytes vec = unsafeWith vec $ \vecPtr -> blockCopy vecPtr accPtr bytes + + aux :: ArrayEltR e -> ArrayData e -> Vectors e -> IO () + aux ArrayEltRunit _ = return + 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 ae1 ae2) (AD_Pair ad1 ad2) = \(v1, v2) -> do + aux ae1 ad1 v1 + aux ae2 ad2 v2 + + +-- | /O(n)/. 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@(Array _ adata) = unsafePerformIO $! aux arrayElt adata + where + sizeA = size (shape array) + + base :: Storable a => Ptr a -> Int -> IO (Vector a) + base accPtr bytes = do + fp <- mallocForeignPtrBytes bytes + withForeignPtr fp $ \vecPtr -> blockCopy accPtr vecPtr bytes + return $! unsafeFromForeignPtr0 fp sizeA + + aux :: ArrayEltR e -> ArrayData e -> IO (Vectors e) + aux ArrayEltRunit _ = return () + 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 ae1 ae2) (AD_Pair ad1 ad2) = + do v1 <- aux ae1 ad1 + v2 <- aux ae2 ad2 + return (v1, v2) + + +-- Helpers +-- +box :: (Int# -> Int#) -> Int -> Int +box f (I# x) = I# (f x) + diff --git a/accelerate-io.cabal b/accelerate-io.cabal --- a/accelerate-io.cabal +++ b/accelerate-io.cabal @@ -1,12 +1,16 @@ Name: accelerate-io -Version: 0.12.1.0 +Version: 0.13.0.0 Cabal-version: >= 1.6 Tested-with: GHC >= 7.0.3 Build-type: Simple Synopsis: Read and write Accelerate arrays in various formats -Description: This package provides efficient conversion routines between a range of array types - and Accelerate arrays. +Description: + This package provides efficient conversion routines between a range of array + types and Accelerate arrays. + . + Refer to the main /Accelerate/ package for more information: + License: BSD3 License-file: LICENSE @@ -15,10 +19,10 @@ Sean Lee, Trevor L. McDonell Maintainer: Manuel M T Chakravarty -Homepage: http://www.cse.unsw.edu.au/~chak/project/accelerate/ +Homepage: https://github.com/AccelerateHS/accelerate-io Bug-reports: https://github.com/AccelerateHS/accelerate/issues -Category: Compilers/Interpreters, Concurrency, Data +Category: Compilers/Interpreters, Concurrency, Data, Parallelism Stability: Experimental Extra-source-files: include/accelerate.h @@ -37,16 +41,18 @@ Library Include-Dirs: include - Build-depends: accelerate >= 0.12.1 && < 0.13, - array >= 0.3, + Build-depends: accelerate == 0.13.*, base == 4.*, - bytestring >= 0.9, - repa >= 3.2, - vector >= 0.9 + array >= 0.3 && < 0.5, + bmp >= 1.2 && < 1.3, + bytestring >= 0.9 && < 0.11, + repa >= 3.2 && < 3.3, + vector >= 0.9 && < 0.11 Exposed-modules: Data.Array.Accelerate.IO Other-modules: Data.Array.Accelerate.IO.BlockCopy Data.Array.Accelerate.IO.ByteString + Data.Array.Accelerate.IO.BMP Data.Array.Accelerate.IO.Ptr Data.Array.Accelerate.IO.Repa Data.Array.Accelerate.IO.Vector @@ -62,8 +68,14 @@ ghc-options: -O2 -Wall -funbox-strict-fields - Extensions: TypeFamilies + -- 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: + Source-repository head Type: git Location: git://github.com/AccelerateHS/accelerate-io.git +