diff --git a/Data/Array/Accelerate/IO.hs b/Data/Array/Accelerate/IO.hs --- a/Data/Array/Accelerate/IO.hs +++ b/Data/Array/Accelerate/IO.hs @@ -1,10 +1,10 @@ -- | -- Module : Data.Array.Accelerate.IO -- Copyright : [2010..2012] Sean Seefried --- [2010..2014] Trevor L. McDonell +-- [2010..2016] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -17,6 +17,7 @@ -- * Array libraries module Data.Array.Accelerate.IO.Repa, module Data.Array.Accelerate.IO.Vector, + module Data.Array.Accelerate.IO.IArray, -- * Specialised file IO module Data.Array.Accelerate.IO.BMP, @@ -37,8 +38,9 @@ ) where -import Data.Array.Accelerate.IO.ByteString import Data.Array.Accelerate.IO.BMP +import Data.Array.Accelerate.IO.ByteString +import Data.Array.Accelerate.IO.IArray import Data.Array.Accelerate.IO.Ptr import Data.Array.Accelerate.IO.Repa import Data.Array.Accelerate.IO.Vector diff --git a/Data/Array/Accelerate/IO/BMP.hs b/Data/Array/Accelerate/IO/BMP.hs --- a/Data/Array/Accelerate/IO/BMP.hs +++ b/Data/Array/Accelerate/IO/BMP.hs @@ -1,14 +1,16 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.IO.BMP -- Copyright : [2012..2014] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- +-- Read and write BMP images into a packed-word RGBA format. See the +-- /colour-accelerate/ package for colour representations and utilities such as +-- packing and unpacking. +-- module Data.Array.Accelerate.IO.BMP ( @@ -20,12 +22,8 @@ RGBA32, readImageFromBMP, writeImageToBMP, - -- *** Manipulating pixels - unpackRGBA32, packRGBA32, luminanceOfRGBA32, rgba32OfLuminance, rgba32OfFloat, - ) where -import Data.Bits import Data.Word import Codec.BMP @@ -33,6 +31,10 @@ import Data.Array.Accelerate.IO.ByteString as A +-- | Packed RGBA pixel data +-- +type RGBA32 = Word32 + -- File IO --------------------------------------------------------------------- -- | Read RGBA components from a BMP file. @@ -46,7 +48,7 @@ let (w,h) = bmpDimensions bmp bs = unpackBMPToRGBA32 bmp -- - Right `fmap` A.fromByteString (Z :. h :. w) ((), bs) + Right `fmap` A.fromByteString (Z :. h :. w) bs -- | Write the image data to a file. @@ -54,96 +56,7 @@ writeImageToBMP :: FilePath -> Array DIM2 RGBA32 -> IO () writeImageToBMP file rgba = do let Z :. h :. w = A.arrayShape rgba - ((), bs) <- A.toByteString rgba + bs <- A.toByteString rgba -- writeBMP file (packRGBA32ToBMP w h bs) - - --- Manipulating pixels --------------------------------------------------------- --- --- TLM: perhaps this should be moved into something like: --- accelerate-algorithms:Data.Array.Accelerate.Algorithms.Pixel --- - --- | Packed RGBA pixel data --- -type RGBA32 = Word32 - --- | Unpack a (little-endian) 'RGBA32' value into a tuple of (Red, Green, Blue, --- Alpha) values. --- -unpackRGBA32, unpackRGBA32le, unpackRGBA32be - :: Exp RGBA32 - -> Exp (Word8, Word8, Word8, Word8) -unpackRGBA32 = unpackRGBA32le - -unpackRGBA32le rgba = - let a = A.fromIntegral (rgba `A.shiftR` 24) - b = A.fromIntegral (rgba `A.shiftR` 16) - g = A.fromIntegral (rgba `A.shiftR` 8) - r = A.fromIntegral rgba - in - lift (r, g, b, a) - -unpackRGBA32be rgba = - let r = A.fromIntegral (rgba `A.shiftR` 24) - g = A.fromIntegral (rgba `A.shiftR` 16) - b = A.fromIntegral (rgba `A.shiftR` 8) - a = A.fromIntegral rgba - in - lift (r, g, b, a) - - --- | Promote a tuple of (Red, Green, Blue, Alpha) values into a packed --- (little-endian) 'RGBA32' value. --- -packRGBA32, packRGBA32le, packRGBA32be - :: Exp (Word8, Word8, Word8, Word8) - -> Exp RGBA32 -packRGBA32 = packRGBA32le - -packRGBA32le (unlift -> (r, g, b, a)) - = A.fromIntegral a `A.shiftL` 24 - .|. A.fromIntegral b `A.shiftL` 16 - .|. A.fromIntegral g `A.shiftL` 8 - .|. A.fromIntegral r - -packRGBA32be (unlift -> (r, g, b, a)) - = A.fromIntegral r `A.shiftL` 24 - .|. A.fromIntegral g `A.shiftL` 16 - .|. A.fromIntegral b `A.shiftL` 8 - .|. A.fromIntegral a - - --- | Convert an RGBA colour to its luminance value in the range [0..1]. --- -luminanceOfRGBA32 :: (Elt a, IsFloating a) => Exp RGBA32 -> Exp a -luminanceOfRGBA32 (unlift . unpackRGBA32 -> (r, g, b, _a :: Exp Word8)) = - let r' = 0.3 * A.fromIntegral r - g' = 0.59 * A.fromIntegral g - b' = 0.11 * A.fromIntegral b - in - (r' + g' + b') / 255 - - --- | Convert a value in the range [0..1] to a grey RGB colour. --- -rgba32OfLuminance :: (Elt a, IsFloating a) => Exp a -> Exp RGBA32 -rgba32OfLuminance val = - let v = A.truncate (255 * val) -- (0 `A.max` val `A.min` 1) - in - packRGBA32 (lift (v, v, v, constant 0xFF)) - - --- | Promote a tuple of (Red, Green, Blue, Alpha) values in the range [0..1] --- into a packed 'RGBA32'. --- -rgba32OfFloat :: (Elt a, IsFloating a) => Exp (a, a, a, a) -> Exp RGBA32 -rgba32OfFloat (unlift -> (r,g,b,a)) = - let r' = A.truncate (255 * r) - g' = A.truncate (255 * g) - b' = A.truncate (255 * b) - a' = A.truncate (255 * a) - in - packRGBA32 (lift (r', g', b', a')) diff --git a/Data/Array/Accelerate/IO/BlockCopy.hs b/Data/Array/Accelerate/IO/BlockCopy.hs --- a/Data/Array/Accelerate/IO/BlockCopy.hs +++ b/Data/Array/Accelerate/IO/BlockCopy.hs @@ -9,7 +9,7 @@ -- [2010..2014] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/Data/Array/Accelerate/IO/ByteString.hs b/Data/Array/Accelerate/IO/ByteString.hs --- a/Data/Array/Accelerate/IO/ByteString.hs +++ b/Data/Array/Accelerate/IO/ByteString.hs @@ -4,7 +4,7 @@ -- [2010..2014] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/Data/Array/Accelerate/IO/IArray.hs b/Data/Array/Accelerate/IO/IArray.hs new file mode 100644 --- /dev/null +++ b/Data/Array/Accelerate/IO/IArray.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Data.Array.Accelerate.IO.IArray +-- Copyright : [2016] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- Stability : experimental +-- Portability : non-portable (GHC extensions) +-- +-- Convert immutable arrays of the library into Accelerate 'Array's. +-- + +module Data.Array.Accelerate.IO.IArray ( + + -- ** 'Data.Array.IArray.IArray' + fromIArray, + toIArray, + +) where + +import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Type + +import Data.Array.IArray ( IArray ) +import qualified Data.Array.IArray as IArray + + +-- | Convert an 'IArray' to an accelerated array. +-- +-- While the type signature mentions Accelerate internals that are not exported, +-- in practice satisfying the type equality is straight forward. The index type +-- @ix@ must be the unit type @()@ for singleton arrays, or an @Int@ or tuple of +-- @Int@'s for multidimensional arrays. +-- +fromIArray + :: (IxShapeRepr (EltRepr ix) ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix, Elt e) + => a ix e + -> Array sh e +fromIArray iarr = fromFunction sh (\ix -> iarr IArray.! fromIxShapeRepr ix) + where + (lo,hi) = IArray.bounds iarr + sh = rangeToShape (toIxShapeRepr lo, toIxShapeRepr hi) + +-- | Convert an accelerated array to an 'IArray'. +-- +toIArray + :: (IxShapeRepr (EltRepr ix) ~ EltRepr sh, IArray a e, IArray.Ix ix, Shape sh, Elt ix) + => Array sh e + -> a ix e +toIArray arr = IArray.array bnds [(ix, arr ! toIxShapeRepr ix) | ix <- IArray.range bnds] + where + (lo,hi) = shapeToRange (shape arr) + bnds = (fromIxShapeRepr lo, fromIxShapeRepr hi) + + +type family IxShapeRepr e where + IxShapeRepr () = () + IxShapeRepr Int = ((),Int) + IxShapeRepr (t,h) = (IxShapeRepr t, h) + +fromIxShapeRepr :: forall ix sh. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix) => sh -> ix +fromIxShapeRepr sh = toElt (go (eltType (undefined::ix)) (fromElt sh)) + where + go :: forall ix'. TupleType ix' -> IxShapeRepr ix' -> ix' + go UnitTuple () = () + go (SingleTuple (NumScalarType (IntegralNumType TypeInt{}))) ((),h) = h + go (PairTuple tt _) (t, h) = (go tt t, h) + go _ _ = error "Not a valid IArray.Ix" + +toIxShapeRepr :: forall ix sh. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix) => ix -> sh +toIxShapeRepr ix = toElt (go (eltType (undefined::ix)) (fromElt ix)) + where + go :: forall ix'. TupleType ix' -> ix' -> IxShapeRepr ix' + go UnitTuple () = () + go (SingleTuple (NumScalarType (IntegralNumType TypeInt{}))) h = ((), h) + go (PairTuple tt _) (t, h) = (go tt t, h) + go _ _ = error "Not a valid IArray.Ix" + diff --git a/Data/Array/Accelerate/IO/Ptr.hs b/Data/Array/Accelerate/IO/Ptr.hs --- a/Data/Array/Accelerate/IO/Ptr.hs +++ b/Data/Array/Accelerate/IO/Ptr.hs @@ -4,7 +4,7 @@ -- [2010..2014] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -21,7 +21,6 @@ import Data.Array.Accelerate.IO.BlockCopy import Data.Array.Accelerate.Array.Sugar - -- | Block copy regions of memory into a freshly allocated Accelerate array. The diff --git a/Data/Array/Accelerate/IO/Repa.hs b/Data/Array/Accelerate/IO/Repa.hs --- a/Data/Array/Accelerate/IO/Repa.hs +++ b/Data/Array/Accelerate/IO/Repa.hs @@ -13,7 +13,7 @@ -- Copyright : [2012..2014] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -85,7 +85,6 @@ instance A.Elt e => R.Source A e where data Array A sh e = AAccelerate !sh !(A.ArrayData (A.EltRepr e)) - {-# INLINE extent #-} extent (AAccelerate sh _) diff --git a/Data/Array/Accelerate/IO/Vector.hs b/Data/Array/Accelerate/IO/Vector.hs --- a/Data/Array/Accelerate/IO/Vector.hs +++ b/Data/Array/Accelerate/IO/Vector.hs @@ -3,10 +3,10 @@ -- | -- Module : Data.Array.Accelerate.IO.Vector -- Copyright : [2012] Adam C. Foltzer --- [2012..2014] Trevor L. McDonell +-- [2012..2015] Trevor L. McDonell -- License : BSD3 -- --- Maintainer : Manuel M T Chakravarty +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -30,11 +30,14 @@ import Data.Word import Foreign.C.Types import Data.Vector.Storable -import Data.Array.Storable.Internals ( StorableArray(..) ) +import System.IO.Unsafe -- friends +import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Array.Unique import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Sugar hiding ( Vector ) +import Data.Array.Accelerate.Array.Sugar hiding ( Vector, size ) +import Data.Array.Accelerate.Array.Representation ( size ) -- | A family of types that represents a collection of storable 'Vector's. The @@ -89,8 +92,8 @@ fromVectors :: (Shape sh, Elt e) => sh -> Vectors (EltRepr e) -> Array sh e fromVectors sh vecs = Array (fromElt sh) (aux arrayElt vecs) where - wrap k v = let (p,n) = unsafeToForeignPtr0 v - in k (StorableArray 0 n n p) + wrap k v = let (fp,_) = unsafeToForeignPtr0 v + in k (unsafePerformIO $ newUniqueArray fp) aux :: ArrayEltR e -> Vectors e -> ArrayData e aux ArrayEltRunit = const AD_Unit @@ -131,9 +134,10 @@ -- Data will be output in row-major order. -- toVectors :: (Shape sh, Elt e) => Array sh e -> Vectors (EltRepr e) -toVectors (Array _ adata) = aux arrayElt adata +toVectors (Array sh adata) = aux arrayElt adata where - wrap (StorableArray _ _ n p) = unsafeFromForeignPtr0 p n + wrap :: Storable a => UniqueArray a -> Vector a + wrap ua = unsafeFromForeignPtr0 (unsafeGetValue (uniqueArrayData ua)) (size sh) aux :: ArrayEltR e -> ArrayData e -> Vectors e aux ArrayEltRunit AD_Unit = () diff --git a/accelerate-io.cabal b/accelerate-io.cabal --- a/accelerate-io.cabal +++ b/accelerate-io.cabal @@ -1,5 +1,5 @@ Name: accelerate-io -Version: 0.15.1.0 +Version: 1.0.0.0 Cabal-version: >= 1.6 Tested-with: GHC >= 7.8 Build-type: Simple @@ -18,7 +18,7 @@ Gabriele Keller, Sean Seefried, Trevor L. McDonell -Maintainer: Manuel M T Chakravarty +Maintainer: Trevor L. McDonell Homepage: https://github.com/AccelerateHS/accelerate-io Bug-reports: https://github.com/AccelerateHS/accelerate/issues @@ -39,22 +39,32 @@ Default: False Library - Build-depends: accelerate == 0.15.1.*, - array >= 0.3, - base >= 4.7 && < 4.9, - bmp >= 1.2, - bytestring >= 0.9, - repa >= 3.2, - vector >= 0.9 + Build-depends: + base >= 4.7 && < 4.10 + , accelerate == 1.0.* + , array >= 0.3 + , bmp >= 1.2 + , bytestring >= 0.9 + , repa >= 3.2 + , vector >= 0.9 - Exposed-modules: Data.Array.Accelerate.IO - Other-modules: Data.Array.Accelerate.IO.BlockCopy - Data.Array.Accelerate.IO.ByteString - Data.Array.Accelerate.IO.BMP - Data.Array.Accelerate.IO.Ptr - Data.Array.Accelerate.IO.Repa - Data.Array.Accelerate.IO.Vector + Exposed-modules: + Data.Array.Accelerate.IO + Other-modules: + Data.Array.Accelerate.IO.BlockCopy + Data.Array.Accelerate.IO.BMP + Data.Array.Accelerate.IO.ByteString + Data.Array.Accelerate.IO.IArray + Data.Array.Accelerate.IO.Ptr + Data.Array.Accelerate.IO.Repa + Data.Array.Accelerate.IO.Vector + + ghc-options: + -O2 + -Wall + -funbox-strict-fields + if flag(bounds-checks) cpp-options: -DACCELERATE_BOUNDS_CHECKS @@ -64,18 +74,20 @@ if flag(internal-checks) cpp-options: -DACCELERATE_INTERNAL_CHECKS - ghc-options: -O2 -Wall -funbox-strict-fields - - -- Don't add the extensions list here. Instead, place individual LANGUAGE -- pragmas in the files that require a specific extension. This means the -- project loads in GHCi, and avoids extension clashes. -- -- Extensions: +Source-repository head + Type: git + Location: git://github.com/AccelerateHS/accelerate-io.git + Source-repository this - type: git - location: git://github.com/AccelerateHS/accelerate-io.git - branch: release/0.15 - tag: 0.15.1.0 + Type: git + Tag: 1.0.0.0 + Location: git://github.com/AccelerateHS/accelerate-io.git + +-- vim: nospell