diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +
+henlo, my name is Theia + +# Array conversion components for the Accelerate language + +[![GitHub CI](https://github.com/tmcdonell/accelerate-io/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate-io/actions) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
+[![Stackage LTS](https://stackage.org/package/accelerate-io/badge/lts)](https://stackage.org/lts/package/accelerate-io) +[![Stackage Nightly](https://stackage.org/package/accelerate-io/badge/nightly)](https://stackage.org/nightly/package/accelerate-io) +[![Hackage](https://img.shields.io/hackage/v/accelerate-io.svg)](https://hackage.haskell.org/package/accelerate-io) + +
+ +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!
+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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/accelerate-io-vector.cabal b/accelerate-io-vector.cabal new file mode 100644 --- /dev/null +++ b/accelerate-io-vector.cabal @@ -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: + + +license: BSD3 +license-file: LICENSE +author: The Accelerate Team +maintainer: Trevor L. McDonell +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 diff --git a/src/Data/Array/Accelerate/IO/Data/Primitive/ByteArray.hs b/src/Data/Array/Accelerate/IO/Data/Primitive/ByteArray.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Primitive/ByteArray.hs @@ -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 +-- 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 + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Generic.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Generic.hs @@ -0,0 +1,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 +-- 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) + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Generic/Mutable.hs @@ -0,0 +1,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 +-- 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 + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Primitive.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Primitive.hs @@ -0,0 +1,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 +-- 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: +-- +-- @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 + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Primitive/Internal.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Data.Array.Accelerate.IO.Data.Vector.Primitive.Internal + where + +import Data.Primitive ( sizeOf ) + +import Data.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)) + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Storable.hs @@ -0,0 +1,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 +-- 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 + diff --git a/src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs b/src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/src/Data/Array/Accelerate/IO/Data/Vector/Unboxed.hs @@ -0,0 +1,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 +-- 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: +-- +-- @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) +--} + diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,25 @@ +-- | +-- Module : Test +-- Copyright : [2017..2020] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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 + ] + diff --git a/test/Test/Util.hs b/test/Test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Util.hs @@ -0,0 +1,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 +-- 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) + diff --git a/test/Test/Vector/Storable.hs b/test/Test/Vector/Storable.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vector/Storable.hs @@ -0,0 +1,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 +-- 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 + ] + ] + diff --git a/test/Test/Vector/Unboxed.hs b/test/Test/Vector/Unboxed.hs new file mode 100644 --- /dev/null +++ b/test/Test/Vector/Unboxed.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Test.Vector.Unboxed +-- Copyright : [2017..2020] The Accelerate Team +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- + +module Test.Vector.Unboxed + where + +import Test.Util +import Test.Tasty +import Test.Tasty.Hedgehog + +import Data.Array.Accelerate ( Shape, Elt, Z(..), (:.)(..) ) +import Data.Array.Accelerate.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 + ] + ] +