accelerate-io-vector (empty) → 0.1.0.0
raw patch · 16 files changed
+1661/−0 lines, 16 filesdep +acceleratedep +accelerate-io-vectordep +basesetup-changed
Dependencies added: accelerate, accelerate-io-vector, base, hedgehog, primitive, tasty, tasty-hedgehog, vector
Files
- CHANGELOG.md +12/−0
- LICENSE +23/−0
- README.md +25/−0
- Setup.hs +2/−0
- accelerate-io-vector.cabal +85/−0
- src/Data/Array/Accelerate/IO/Data/Primitive/ByteArray.hs +58/−0
- src/Data/Array/Accelerate/IO/Data/Vector/Generic.hs +62/−0
- src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs +271/−0
- src/Data/Array/Accelerate/IO/Data/Vector/Primitive.hs +196/−0
- src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs +41/−0
- src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs +198/−0
- src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs +235/−0
- test/Test.hs +25/−0
- test/Test/Util.hs +124/−0
- test/Test/Vector/Storable.hs +190/−0
- test/Test/Vector/Unboxed.hs +114/−0
+ CHANGELOG.md view
@@ -0,0 +1,12 @@+# Change Log++Notable changes to the project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/) and the+project adheres to the [Haskell Package Versioning+Policy (PVP)](https://pvp.haskell.org)++## [0.1.0.0] - 2020-08-26+### Changed+ * Split from the `accelerate-io` package+
+ LICENSE view
@@ -0,0 +1,23 @@+Copyright (c) [2007..2012] The Accelerate Team. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the names of the contributors nor of their affiliations may+ be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,25 @@+<div align="center">+<img width="450" src="https://github.com/AccelerateHS/accelerate/raw/master/images/accelerate-logo-text-v.png?raw=true" alt="henlo, my name is Theia"/>++# Array conversion components for the Accelerate language++[](https://github.com/tmcdonell/accelerate-io/actions)+[](https://gitter.im/AccelerateHS/Lobby)+<br>+[](https://stackage.org/lts/package/accelerate-io)+[](https://stackage.org/nightly/package/accelerate-io)+[](https://hackage.haskell.org/package/accelerate-io)++</div>++Efficient conversion routines between Accelerate arrays and a range of data+formats.++For details on Accelerate, refer to the [main repository][GitHub].++Contributions and bug reports are welcome!<br>+Please feel free to contact me through [GitHub][GitHub] or [gitter.im][gitter.im].++ [GitHub]: https://github.com/AccelerateHS/accelerate+ [gitter.im]: https://gitter.im/AccelerateHS/Lobby+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ accelerate-io-vector.cabal view
@@ -0,0 +1,85 @@+name: accelerate-io-vector+version: 0.1.0.0+cabal-version: >= 1.10+build-type: Simple++synopsis: Convert between Accelerate and vector+Description:+ This package provides efficient conversion routines between Accelerate arrays+ and those from the vector package.+ .+ Refer to the main /Accelerate/ package for more information:+ <http://hackage.haskell.org/package/accelerate>++license: BSD3+license-file: LICENSE+author: The Accelerate Team+maintainer: Trevor L. McDonell <trevor.mcdonell@gmail.com>+homepage: https://github.com/AccelerateHS/accelerate-io#readme+bug-reports: https://github.com/AccelerateHS/accelerate-io/issues+category: Accelerate, Data++extra-source-files:+ README.md+ CHANGELOG.md++library+ build-depends:+ base >= 4.8 && < 5+ , accelerate >= 1.3+ , primitive >= 0.6+ , vector >= 0.9++ exposed-modules:+ 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++ other-modules:+ Data.Array.Accelerate.IO.Data.Primitive.ByteArray+ Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal++ ghc-options:+ -O2+ -Wall+ -funbox-strict-fields++ ghc-prof-options:+ -fprof-auto++ hs-source-dirs: src+ default-language: Haskell2010++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++ build-depends:+ base >= 4.8 && < 5+ , accelerate+ , accelerate-io-vector+ , hedgehog >= 0.5+ , tasty >= 0.11+ , tasty-hedgehog >= 0.1+ , vector++ ghc-options:+ -Wall+ -threaded+ -rtsopts++ other-modules:+ Test.Vector.Storable+ Test.Vector.Unboxed+ Test.Util++source-repository head+ type: git+ location: https://github.com/AccelerateHS/accelerate-io++-- vim: nospell
+ src/Data/Array/Accelerate/IO/Data/Primitive/ByteArray.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-}+-- |+-- Module : Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.IO.Data.Primitive.ByteArray+ where++import Data.Primitive.ByteArray++import GHC.Base+import GHC.ForeignPtr+++-- 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# 64# 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# 64# 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/Generic.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module : Data.Array.Accelerate.IO.Data.Vector.Generic+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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 0.1.0.0+--++module Data.Array.Accelerate.IO.Data.Vector.Generic+ where++import Data.Array.Accelerate.Array.Data as A+import Data.Array.Accelerate.IO.Data.Vector.Generic.Mutable as A+import Data.Array.Accelerate.Sugar.Array as A+import Data.Array.Accelerate.Sugar.Elt as A+import qualified Data.Array.Accelerate.Representation.Array as R++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 (R.Array sh mad))++ basicUnsafeThaw (Array (R.Array sh ad)) = return (MArray sh ad)++ basicLength (Array (R.Array ((),n) _)) = n++ basicUnsafeSlice i n (Array (R.Array sh ad)) =+ case M.basicUnsafeSlice i n (MArray sh ad :: MVector s e) of+ MArray sh' mad' -> Array (R.Array sh' mad')++ basicUnsafeIndexM (Array (R.Array _ ad)) i = return $ toElt (indexArrayData (eltR @e) ad i)++ basicUnsafeCopy dst (Array (R.Array sh ad)) = M.basicUnsafeCopy dst (MArray sh ad)+
+ src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Module : Data.Array.Accelerate.IO.Data.Vector.Generic.Mutable+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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 0.1.0.0+--++module Data.Array.Accelerate.IO.Data.Vector.Generic.Mutable+ where++import Data.Array.Accelerate.Array.Data+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Sugar.Elt+import Data.Array.Accelerate.Sugar.Shape+import Data.Array.Accelerate.Type++import qualified Data.Vector.Generic.Mutable as V++import Control.Monad.Primitive+import Data.Typeable+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 :: EltR sh -- extent of dimensions == shape+ -> MutableArrayData (EltR 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 (eltR @e) mad)+ where+ go :: TypeR a -> MutableArrayData a -> MutableArrayData a+ go TupRunit () = ()+ go (TupRpair aR1 aR2) (a1, a2) = (go aR1 a1, go aR2 a2)+ go (TupRsingle aR) a = scalar aR a++ scalar :: ScalarType a -> MutableArrayData a -> MutableArrayData a+ scalar (SingleScalarType t) a = single t a 1+ scalar (VectorScalarType t) a = vector t a++ vector :: VectorType a -> MutableArrayData a -> MutableArrayData a+ vector (VectorType w t) a+ | SingleArrayDict <- singleArrayDict t+ = single t a w++ single :: SingleType a -> MutableArrayData a -> Int -> MutableArrayData a+ single (NumSingleType t) = num t++ num :: NumType a -> MutableArrayData a -> Int -> MutableArrayData a+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> MutableArrayData a -> Int -> MutableArrayData a+ integral TypeInt = slice+ integral TypeInt8 = slice+ integral TypeInt16 = slice+ integral TypeInt32 = slice+ integral TypeInt64 = slice+ integral TypeWord = slice+ integral TypeWord8 = slice+ integral TypeWord16 = slice+ integral TypeWord32 = slice+ integral TypeWord64 = slice++ floating :: FloatingType a -> MutableArrayData a -> Int -> MutableArrayData a+ floating TypeHalf = slice+ floating TypeFloat = slice+ floating TypeDouble = slice++ 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 (eltR @e) mad1 mad2+ where+ go :: TypeR a -> MutableArrayData a -> MutableArrayData a -> Bool+ go TupRunit () () = False+ go (TupRpair aR1 aR2) (a1, a2) (b1, b2) = go aR1 a1 b1 || go aR2 a2 b2+ go (TupRsingle aR) a b = scalar aR a b++ scalar :: ScalarType a -> MutableArrayData a -> MutableArrayData a -> Bool+ scalar (SingleScalarType t) a b = single t a b 1+ scalar (VectorScalarType t) a b = vector t a b++ vector :: VectorType a -> MutableArrayData a -> MutableArrayData a -> Bool+ vector (VectorType w t) a b+ | SingleArrayDict <- singleArrayDict t+ = single t a b w++ single :: SingleType a -> MutableArrayData a -> MutableArrayData a -> Int -> Bool+ single (NumSingleType t) = num t++ num :: NumType a -> MutableArrayData a -> MutableArrayData a -> Int -> Bool+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> MutableArrayData a -> MutableArrayData a -> Int -> Bool+ integral TypeInt = overlaps+ integral TypeInt8 = overlaps+ integral TypeInt16 = overlaps+ integral TypeInt32 = overlaps+ integral TypeInt64 = overlaps+ integral TypeWord = overlaps+ integral TypeWord8 = overlaps+ integral TypeWord16 = overlaps+ integral TypeWord32 = overlaps+ integral TypeWord64 = overlaps++ floating :: FloatingType a -> MutableArrayData a -> MutableArrayData a -> Int -> Bool+ floating TypeHalf = overlaps+ floating TypeFloat = overlaps+ floating TypeDouble = overlaps++ 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 (eltR @e) n++ basicInitialize (MArray ((),n) mad) = unsafePrimToPrim $ go (eltR @e) mad+ where+ go :: TypeR a -> MutableArrayData a -> IO ()+ go TupRunit () = return ()+ go (TupRpair aR1 aR2) (a1, a2) = go aR1 a1 >> go aR2 a2+ go (TupRsingle aR) a = scalar aR a++ scalar :: ScalarType a -> MutableArrayData a -> IO ()+ scalar (SingleScalarType t) a = single t a 1+ scalar (VectorScalarType t) a = vector t a++ vector :: VectorType a -> MutableArrayData a -> IO ()+ vector (VectorType w t) a+ | SingleArrayDict <- singleArrayDict t+ = single t a w++ single :: SingleType a -> MutableArrayData a -> Int -> IO ()+ single (NumSingleType t) = num t++ num :: NumType a -> MutableArrayData a -> Int -> IO ()+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> MutableArrayData a -> Int -> IO ()+ integral TypeInt = initialise+ integral TypeInt8 = initialise+ integral TypeInt16 = initialise+ integral TypeInt32 = initialise+ integral TypeInt64 = initialise+ integral TypeWord = initialise+ integral TypeWord8 = initialise+ integral TypeWord16 = initialise+ integral TypeWord32 = initialise+ integral TypeWord64 = initialise++ floating :: FloatingType a -> MutableArrayData a -> Int -> IO ()+ floating TypeHalf = initialise+ floating TypeFloat = initialise+ floating TypeDouble = initialise++ initialise :: forall a. Storable a => UniqueArray a -> Int -> IO ()+ initialise ua s = withUniqueArrayPtr ua $ \p -> fillBytes p 0 (n * s * sizeOf (undefined::a))++ basicUnsafeRead (MArray _ mad) i = unsafePrimToPrim $ toElt <$> readArrayData (eltR @e) mad i+ basicUnsafeWrite (MArray _ mad) i v = unsafePrimToPrim $ writeArrayData (eltR @e) mad i (fromElt v)++ basicUnsafeCopy (MArray _ dst) (MArray ((),n) src) = unsafePrimToPrim $ go (eltR @e) dst src+ where+ go :: TypeR a -> MutableArrayData a -> MutableArrayData a -> IO ()+ go TupRunit () () = return ()+ go (TupRpair aR1 aR2) (a1, a2) (b1, b2) = go aR1 a1 b1 >> go aR2 a2 b2+ go (TupRsingle aR) a b = scalar aR a b++ scalar :: ScalarType a -> MutableArrayData a -> MutableArrayData a -> IO ()+ scalar (SingleScalarType t) a b = single t a b 1+ scalar (VectorScalarType t) a b = vector t a b++ vector :: VectorType a -> MutableArrayData a -> MutableArrayData a -> IO ()+ vector (VectorType w t) a b+ | SingleArrayDict <- singleArrayDict t+ = single t a b w++ single :: SingleType a -> MutableArrayData a -> MutableArrayData a -> Int -> IO ()+ single (NumSingleType t) = num t++ num :: NumType a -> MutableArrayData a -> MutableArrayData a -> Int -> IO ()+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> MutableArrayData a -> MutableArrayData a -> Int -> IO ()+ integral TypeInt = copy+ integral TypeInt8 = copy+ integral TypeInt16 = copy+ integral TypeInt32 = copy+ integral TypeInt64 = copy+ integral TypeWord = copy+ integral TypeWord8 = copy+ integral TypeWord16 = copy+ integral TypeWord32 = copy+ integral TypeWord64 = copy++ floating :: FloatingType a -> MutableArrayData a -> MutableArrayData a -> Int -> IO ()+ floating TypeHalf = copy+ floating TypeFloat = copy+ floating TypeDouble = copy++ copy :: forall a. Storable a => UniqueArray a -> UniqueArray a -> Int -> IO ()+ copy uu uv s =+ withUniqueArrayPtr uu $ \u ->+ withUniqueArrayPtr uv $ \v ->+ 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,196 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Data.Array.Accelerate.IO.Data.Vector.Primitive+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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 ( ArrayData, GArrayDataR, ScalarArrayDataR )+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Sugar.Array hiding ( Vector )+import Data.Array.Accelerate.Sugar.Elt+import Data.Array.Accelerate.Sugar.Shape+import Data.Array.Accelerate.Type+import qualified Data.Array.Accelerate.Representation.Array as R+import qualified Data.Array.Accelerate.Representation.Shape as R+++-- | 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 Vectors e = GArrayDataR Vector e+++-- | /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 0.1.0.0@+--+{-# INLINE fromVectors #-}+fromVectors :: forall sh e. (HasCallStack, Shape sh, Elt e) => sh -> Vectors (EltR e) -> Array sh e+fromVectors sh vecs = Array (R.Array (fromElt sh) (aux (eltR @e) vecs))+ where+ aux :: TypeR a -> Vectors a -> ArrayData a+ aux TupRunit () = ()+ aux (TupRpair aR1 aR2) (a1, a2) = (aux aR1 a1, aux aR2 a2)+ aux (TupRsingle aR) a = scalar aR a++ scalar :: ScalarType a -> Vectors a -> ArrayData a+ scalar (SingleScalarType t) a = single t a 1+ scalar (VectorScalarType t) a = vector t a++ vector :: VectorType a -> Vectors a -> ArrayData a+ vector (VectorType w t) a+ | SingleArrayDict <- singleArrayDict t+ = single t a w++ single :: SingleType a -> Vectors a -> Int -> ArrayData a+ single (NumSingleType t) = num t++ num :: NumType a -> Vectors a -> Int -> ArrayData a+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> Vectors a -> Int -> ArrayData a+ integral TypeInt = wrap+ integral TypeInt8 = wrap+ integral TypeInt16 = wrap+ integral TypeInt32 = wrap+ integral TypeInt64 = wrap+ integral TypeWord = wrap+ integral TypeWord8 = wrap+ integral TypeWord16 = wrap+ integral TypeWord32 = wrap+ integral TypeWord64 = wrap++ floating :: FloatingType a -> Vectors a -> Int -> ArrayData a+ floating TypeHalf = wrap+ floating TypeFloat = wrap+ floating TypeDouble = wrap++ wrap :: Prim a => Vector a -> Int -> UniqueArray a+ wrap v@(Vector _ l _) w+ = boundsCheck "shape mismatch" (w * size sh == l)+ $ uniqueArrayOfVector v+++-- | /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 0.1.0.0@+--+{-# INLINE toVectors #-}+toVectors :: forall sh e. (HasCallStack, Shape sh, Elt e) => Array sh e -> Vectors (EltR e)+toVectors (Array (R.Array sh adata)) = aux (eltR @e) adata+ where+ aux :: TypeR a -> ArrayData a -> Vectors a+ aux TupRunit () = ()+ aux (TupRpair aR1 aR2) (a1, a2) = (aux aR1 a1, aux aR2 a2)+ aux (TupRsingle aR) a = scalar aR a++ scalar :: ScalarType a -> ArrayData a -> Vectors a+ scalar (SingleScalarType t) a = single t a 1+ scalar (VectorScalarType t) a = vector t a++ vector :: VectorType a -> ArrayData a -> Vectors a+ vector (VectorType w t) a+ | SingleArrayDict <- singleArrayDict t+ = single t a w++ single :: SingleType a -> ArrayData a -> Int -> Vectors a+ single (NumSingleType t) = num t++ num :: NumType a -> ArrayData a -> Int -> Vectors a+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> ArrayData a -> Int -> Vectors a+ integral TypeInt = wrap+ integral TypeInt8 = wrap+ integral TypeInt16 = wrap+ integral TypeInt32 = wrap+ integral TypeInt64 = wrap+ integral TypeWord = wrap+ integral TypeWord8 = wrap+ integral TypeWord16 = wrap+ integral TypeWord32 = wrap+ integral TypeWord64 = wrap++ floating :: FloatingType a -> ArrayData a -> Int -> Vectors a+ floating TypeHalf = wrap+ floating TypeFloat = wrap+ floating TypeDouble = wrap++ n :: Int+ n = R.size (shapeR @sh) sh++ wrap :: Prim a => UniqueArray a -> Int -> Vector a+ wrap ua w = vectorOfUniqueArray (w * n) ua+++data SingleArrayDict a where+ SingleArrayDict :: ( GArrayDataR Vector a ~ Vector (ScalarArrayDataR a)+ , GArrayDataR UniqueArray a ~ UniqueArray (ScalarArrayDataR a)+ , ScalarArrayDataR a ~ a )+ => SingleArrayDict a++singleArrayDict :: SingleType a -> SingleArrayDict a+singleArrayDict = single+ where+ single :: SingleType a -> SingleArrayDict a+ single (NumSingleType t) = num t++ num :: NumType a -> SingleArrayDict a+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> SingleArrayDict a+ integral TypeInt = SingleArrayDict+ integral TypeInt8 = SingleArrayDict+ integral TypeInt16 = SingleArrayDict+ integral TypeInt32 = SingleArrayDict+ integral TypeInt64 = SingleArrayDict+ integral TypeWord = SingleArrayDict+ integral TypeWord8 = SingleArrayDict+ integral TypeWord16 = SingleArrayDict+ integral TypeWord32 = SingleArrayDict+ integral TypeWord64 = SingleArrayDict++ floating :: FloatingType a -> SingleArrayDict a+ floating TypeHalf = SingleArrayDict+ floating TypeFloat = SingleArrayDict+ floating TypeDouble = SingleArrayDict+
+ src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal+ where++import Data.Primitive ( sizeOf )++import Data.Vector.Primitive++import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.IO.Data.Primitive.ByteArray++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))+
+ src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Data.Array.Accelerate.IO.Data.Vector.Storable+-- Copyright : [2012..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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++import Data.Array.Accelerate.Array.Data ( ArrayData, GArrayDataR, ScalarArrayDataR )+import Data.Array.Accelerate.Array.Unique+import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Lifetime+import Data.Array.Accelerate.Representation.Type+import Data.Array.Accelerate.Sugar.Array hiding ( Vector )+import Data.Array.Accelerate.Sugar.Elt+import Data.Array.Accelerate.Sugar.Shape+import Data.Array.Accelerate.Type+import qualified Data.Array.Accelerate.Representation.Array as R+import qualified Data.Array.Accelerate.Representation.Shape as R++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 (EltR e) :: Vector Int@+--+-- * if @e :: (Double, Float)@, then @Vectors (EltR e) :: (((), Vector Double), Vector Float)@+--+type Vectors e = GArrayDataR Vector e+++-- | /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 :: forall sh e. (HasCallStack, Shape sh, Elt e) => sh -> Vectors (EltR e) -> Array sh e+fromVectors sh vecs = Array (R.Array (fromElt sh) (aux (eltR @e) vecs))+ where+ wrap :: Storable a => Vector a -> Int -> UniqueArray a+ wrap v w+ = boundsCheck "shape mismatch" (vsize `quot` w == size sh)+ $ unsafePerformIO $ newUniqueArray fp+ where+ (fp, vsize) = unsafeToForeignPtr0 v++ aux :: TypeR a -> Vectors a -> ArrayData a+ aux TupRunit () = ()+ aux (TupRpair aR1 aR2) (a1,a2) = (aux aR1 a1, aux aR2 a2)+ aux (TupRsingle aR) a = scalar aR a++ scalar :: ScalarType a -> Vectors a -> ArrayData a+ scalar (SingleScalarType t) a = single t a 1+ scalar (VectorScalarType t) a = vector t a++ vector :: VectorType a -> Vectors a -> ArrayData a+ vector (VectorType w t) a+ | SingleArrayDict <- singleArrayDict t+ = single t a w++ single :: SingleType a -> Vectors a -> Int -> ArrayData a+ single (NumSingleType t) = num t++ num :: NumType a -> Vectors a -> Int -> ArrayData a+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> Vectors a -> Int -> ArrayData a+ integral TypeInt = wrap+ integral TypeInt8 = wrap+ integral TypeInt16 = wrap+ integral TypeInt32 = wrap+ integral TypeInt64 = wrap+ integral TypeWord = wrap+ integral TypeWord8 = wrap+ integral TypeWord16 = wrap+ integral TypeWord32 = wrap+ integral TypeWord64 = wrap++ floating :: FloatingType a -> Vectors a -> Int -> ArrayData a+ floating TypeHalf = wrap+ floating TypeFloat = wrap+ floating TypeDouble = wrap+++-- | /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 :: forall sh e. (Shape sh, Elt e) => Array sh e -> Vectors (EltR e)+toVectors (Array (R.Array sh adata)) = aux (eltR @e) adata+ where+ wrap :: Storable a => UniqueArray a -> Int -> Vector a+ wrap ua w = unsafeFromForeignPtr0 (unsafeGetValue (uniqueArrayData ua)) (n * w)+ n = R.size (shapeR @sh) sh++ aux :: TypeR a -> ArrayData a -> Vectors a+ aux TupRunit () = ()+ aux (TupRpair aR1 aR2) (a1,a2) = (aux aR1 a1, aux aR2 a2)+ aux (TupRsingle aR) a = scalar aR a++ scalar :: ScalarType a -> ArrayData a -> Vectors a+ scalar (SingleScalarType t) a = single t a 1+ scalar (VectorScalarType t) a = vector t a++ vector :: VectorType a -> ArrayData a -> Vectors a+ vector (VectorType w t) a+ | SingleArrayDict <- singleArrayDict t+ = single t a w++ single :: SingleType a -> ArrayData a -> Int -> Vectors a+ single (NumSingleType t) = num t++ num :: NumType a -> ArrayData a -> Int -> Vectors a+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> ArrayData a -> Int -> Vectors a+ integral TypeInt = wrap+ integral TypeInt8 = wrap+ integral TypeInt16 = wrap+ integral TypeInt32 = wrap+ integral TypeInt64 = wrap+ integral TypeWord = wrap+ integral TypeWord8 = wrap+ integral TypeWord16 = wrap+ integral TypeWord32 = wrap+ integral TypeWord64 = wrap++ floating :: FloatingType a -> ArrayData a -> Int -> Vectors a+ floating TypeHalf = wrap+ floating TypeFloat = wrap+ floating TypeDouble = wrap++++data SingleArrayDict a where+ SingleArrayDict :: ( GArrayDataR Vector a ~ Vector (ScalarArrayDataR a)+ , GArrayDataR UniqueArray a ~ UniqueArray (ScalarArrayDataR a)+ , ScalarArrayDataR a ~ a )+ => SingleArrayDict a++singleArrayDict :: SingleType a -> SingleArrayDict a+singleArrayDict = single+ where+ single :: SingleType a -> SingleArrayDict a+ single (NumSingleType t) = num t++ num :: NumType a -> SingleArrayDict a+ num (IntegralNumType t) = integral t+ num (FloatingNumType t) = floating t++ integral :: IntegralType a -> SingleArrayDict a+ integral TypeInt = SingleArrayDict+ integral TypeInt8 = SingleArrayDict+ integral TypeInt16 = SingleArrayDict+ integral TypeInt32 = SingleArrayDict+ integral TypeInt64 = SingleArrayDict+ integral TypeWord = SingleArrayDict+ integral TypeWord8 = SingleArrayDict+ integral TypeWord16 = SingleArrayDict+ integral TypeWord32 = SingleArrayDict+ integral TypeWord64 = SingleArrayDict++ floating :: FloatingType a -> SingleArrayDict a+ floating TypeHalf = SingleArrayDict+ floating TypeFloat = SingleArrayDict+ floating TypeDouble = SingleArrayDict+
+ src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.Array.Accelerate.IO.Data.Vector.Unboxed+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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.Sugar.Array as A hiding ( Vector )+import Data.Array.Accelerate.Sugar.Shape+import Data.Array.Accelerate.Sugar.Elt+import qualified Data.Array.Accelerate.Representation.Array as R+import qualified Data.Array.Accelerate.Representation.Shape as R++import Data.Int+import Data.Word+++-- | /O(n)/ (typically). Convert an Unboxed vector into an 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 0.1.0.0@+--+{-# INLINE fromUnboxed #-}+fromUnboxed :: Unbox e => Vector e -> Array DIM1 e+fromUnboxed v = Array (R.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 0.1.0.0@+--+{-# INLINE toUnboxed #-}+toUnboxed :: forall sh e. (Shape sh, Unbox e) => Array sh e -> Vector e+toUnboxed (Array (R.Array sh adata)) = unboxedOfArrayData (R.size (shapeR @sh) sh) adata+++-- Instances+-- ---------++class (U.Unbox e, Elt e) => Unbox e where+ arrayDataOfUnboxed :: U.Vector e -> ArrayData (EltR e)+ unboxedOfArrayData :: Int -> ArrayData (EltR e) -> U.Vector e++instance Unbox () where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed V_Unit{} = ()+ unboxedOfArrayData !n () = V_Unit n++instance Unbox Int where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Int v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Int (vectorOfUniqueArray n v)++instance Unbox Int8 where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Int8 v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Int8 (vectorOfUniqueArray n v)++instance Unbox Int16 where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Int16 v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Int16 (vectorOfUniqueArray n v)++instance Unbox Int32 where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Int32 v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Int32 (vectorOfUniqueArray n v)++instance Unbox Int64 where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Int64 v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Int64 (vectorOfUniqueArray n v)++instance Unbox Word where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Word v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Word (vectorOfUniqueArray n v)++instance Unbox Word8 where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Word8 v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Word8 (vectorOfUniqueArray n v)++instance Unbox Word16 where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Word16 v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Word16 (vectorOfUniqueArray n v)++instance Unbox Word32 where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Word32 v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Word32 (vectorOfUniqueArray n v)++instance Unbox Word64 where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Word64 v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Word64 (vectorOfUniqueArray n v)++instance Unbox Float where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Float v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Float (vectorOfUniqueArray n v)++instance Unbox Double where+ {-# INLINE arrayDataOfUnboxed #-}+ {-# INLINE unboxedOfArrayData #-}+ arrayDataOfUnboxed (V_Double v) = uniqueArrayOfVector v+ unboxedOfArrayData !n v = V_Double (vectorOfUniqueArray n v)++instance (Unbox a, Unbox b) => Unbox (a, b) where+ {-# INLINE arrayDataOfUnboxed #-}+ arrayDataOfUnboxed (V_2 _ a b) =+ (((), arrayDataOfUnboxed a), arrayDataOfUnboxed b)+ --+ {-# INLINE unboxedOfArrayData #-}+ unboxedOfArrayData !n (((), a), 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) =+ ((((), arrayDataOfUnboxed a), arrayDataOfUnboxed b), arrayDataOfUnboxed c)+ --+ {-# INLINE unboxedOfArrayData #-}+ unboxedOfArrayData !n ((((), a), b), 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) =+ (((((), arrayDataOfUnboxed a)+ , arrayDataOfUnboxed b)+ , arrayDataOfUnboxed c)+ , arrayDataOfUnboxed d)+ --+ {-# INLINE unboxedOfArrayData #-}+ unboxedOfArrayData !n (((((), a), b), c), 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) =+ ((((((), arrayDataOfUnboxed a)+ , arrayDataOfUnboxed b)+ , arrayDataOfUnboxed c)+ , arrayDataOfUnboxed d)+ , arrayDataOfUnboxed e)+ --+ {-# INLINE unboxedOfArrayData #-}+ unboxedOfArrayData !n ((((((), a), b), c), d), 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) =+ (((((((), arrayDataOfUnboxed a)+ , arrayDataOfUnboxed b)+ , arrayDataOfUnboxed c)+ , arrayDataOfUnboxed d)+ , arrayDataOfUnboxed e)+ , arrayDataOfUnboxed f)+ --+ {-# INLINE unboxedOfArrayData #-}+ unboxedOfArrayData !n (((((((), a), b), c), d), e), 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)+--}+
+ test/Test.hs view
@@ -0,0 +1,25 @@+-- |+-- Module : Test+-- Copyright : [2017..2020] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Test where++import Test.Tasty++import Test.Vector.Storable+import Test.Vector.Unboxed++main :: IO ()+main+ = defaultMain+ $ testGroup "IO"+ [ test_vector_unboxed+ , test_vector_storable+ ]+
+ test/Test/Util.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Module : Test.Util+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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 )+import Data.Array.Accelerate.Trafo.Sharing ( AfunctionR )+import Data.Array.Accelerate.Sugar.Array ( fromList )+import Data.Array.Accelerate.Sugar.Shape ( DIM1, DIM2, Z(..), (:.)(..), 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,190 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Test.Vector.Storable+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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.Sugar.Elt ( EltR )+import Data.Array.Accelerate.Sugar.Shape ( rank )+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.Char+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++charToWord32 :: Char -> Word32+charToWord32 = fromIntegral . ord++test_s2a+ :: forall e. (Show e, Storable e, Elt e, Eq e, Vectors (EltR 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. ( Show a, Storable a, Elt a, Eq a, Vectors (EltR a) ~ Vector a+ , Show b, Storable b, Elt b, Eq b, Vectors (EltR 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. (Show sh, Shape sh, Show e, Storable e, Elt e, Eq sh, Eq e, Vectors (EltR 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. ( Show sh, Shape sh, Eq sh, Show a, Eq a, Show b, Eq b, Elt a, Elt b, Storable a, Storable b+ , Vectors (EltR (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. ( Show e, Storable e, Elt (Complex e), Eq e+ , Vectors (EltR (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. ( Show sh, Shape sh, Show e, Storable e, Elt (Complex e), Eq sh, Eq e+ , Vectors (EltR (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. (Show sh, Shape sh, Eq sh)+ => Gen sh+ -> TestTree+test_a2s_dim dim =+ testGroup (printf "DIM%d" (rank @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 (charToWord32 <$> 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,114 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Test.Vector.Unboxed+-- Copyright : [2017..2020] The Accelerate Team+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <trevor.mcdonell@gmail.com>+-- 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.Sugar.Shape ( 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, Show sh, Show 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. (Show sh, Shape sh, Eq sh)+ => Gen sh+ -> TestTree+test_a2u_dim dim =+ testGroup (printf "DIM%d" (rank @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+ ]+ ]+