packages feed

accelerate-io 1.0.0.1 → 1.2.0.0

raw patch · 30 files changed

+2955/−998 lines, 30 filesdep +accelerate-iodep +hedgehogdep +primitivedep ~acceleratedep ~arraydep ~base

Dependencies added: accelerate-io, hedgehog, primitive, tasty, tasty-hedgehog

Dependency ranges changed: accelerate, array, base, vector

Files

CHANGELOG.md view
@@ -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
− Data/Array/Accelerate/IO.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/IO/BMP.hs 
@@ -1,62 +0,0 @@--- |--- Module      : Data.Array.Accelerate.IO.BMP--- Copyright   : [2012..2014] Trevor L. McDonell--- License     : BSD3------ Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/IO/BlockCopy.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
− Data/Array/Accelerate/IO/ByteString.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/IO/IArray.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- Stability   : experimental--- Portability : non-portable (GHC extensions)------ Convert immutable arrays of the <https://hackage.haskell.org/package/array--- array> 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"-
− Data/Array/Accelerate/IO/Ptr.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/IO/Repa.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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-
− Data/Array/Accelerate/IO/Vector.hs 
@@ -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 <tmcdonell@cse.unsw.edu.au>--- 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)-
accelerate-io.cabal view
@@ -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-
+ src/Data/Array/Accelerate/IO/Codec/BMP.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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, .. }+
+ src/Data/Array/Accelerate/IO/Data/Array/IArray.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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"+
+ src/Data/Array/Accelerate/IO/Data/Array/Internal.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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"+
+ src/Data/Array/Accelerate/IO/Data/Array/Unboxed.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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: <https://ghc.haskell.org/trac/ghc/ticket/5556>+--+-- @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"+
+ src/Data/Array/Accelerate/IO/Data/ByteString.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/IO/Data/Vector/Generic.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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)+
+ src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/IO/Data/Vector/Primitive.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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: <https://ghc.haskell.org/trac/ghc/ticket/5556>+--+-- @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"+
+ src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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)+
+ src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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: <https://ghc.haskell.org/trac/ghc/ticket/5556>+--+-- @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"+--}+
+ src/Data/Array/Accelerate/IO/Foreign/ForeignPtr.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module      : Data.Array.Accelerate.IO.Foreign.ForeignPtr+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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)+
+ src/Data/Array/Accelerate/IO/Foreign/Ptr.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module      : Data.Array.Accelerate.IO.Foreign.Ptr+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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+
+ src/Data/Array/Repa/Repr/Accelerate.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+
+ test/Test.hs view
@@ -0,0 +1,29 @@+-- |+-- Module      : Test+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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+    ]+
+ test/Test/Array/IArray.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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)+        ]+      ]+    ]+
+ test/Test/Array/Unboxed.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+        ]+      ]+    ]+
+ test/Test/Util.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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)+
+ test/Test/Vector/Storable.hs view
@@ -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 <tmcdonell@cse.unsw.edu.au>+-- 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+      ]+    ]+
+ test/Test/Vector/Unboxed.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Test.Vector.Unboxed+-- Copyright   : [2017] Trevor L. McDonell+-- License     : BSD3+--+-- Maintainer  : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- 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+      ]+    ]+