diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) [2007..2012] The Accelerate Team. All rights reserved. +Copyright (c) [2007..2020] 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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,12 +1,30 @@ -FFT Component for the Accelerate Array Language -=============================================== +
+henlo, my name is Theia -[![Build Status](https://travis-ci.org/tmcdonell/accelerate-fft.svg?branch=master)](https://travis-ci.org/tmcdonell/accelerate-fft) +# FFT components for the Accelerate language + +[![GitHub CI](https://github.com/tmcdonell/accelerate-fft/workflows/CI/badge.svg)](https://github.com/tmcdonell/accelerate-fft/actions) +[![Gitter](https://img.shields.io/gitter/room/nwjs/nw.js.svg)](https://gitter.im/AccelerateHS/Lobby) +
+[![Stackage LTS](https://stackage.org/package/accelerate-fft/badge/lts)](https://stackage.org/lts/package/accelerate-fft) +[![Stackage Nightly](https://stackage.org/package/accelerate-fft/badge/nightly)](https://stackage.org/nightly/package/accelerate-fft) [![Hackage](https://img.shields.io/hackage/v/accelerate-fft.svg)](https://hackage.haskell.org/package/accelerate-fft) -FFT library for the embedded array language Accelerate. This will use optimised -backend implementations where available. For details on Accelerate, refer to the -[main repository][GitHub]. +
- [GitHub]: https://github.com/AccelerateHS/accelerate +FFT library for the embedded array language Accelerate. For details on +Accelerate, refer to the [main repository][GitHub]. + +The following build flags control whether optimised implementations are used. +Note that enabling these (which is the default) will require the corresponding +Accelerate backend as a dependency: + + - `llvm-ptx`: For NVIDIA GPUs + - `llvm-cpu`: For multicore CPUs + +Contributions and bug reports are welcome!
+Please feel free to contact me through GitHub or [gitter.im][gitter.im]. + + [GitHub]: https://github.com/AccelerateHS/accelerate + [gitter.im]: https://gitter.im/AccelerateHS/Lobby diff --git a/accelerate-fft.cabal b/accelerate-fft.cabal --- a/accelerate-fft.cabal +++ b/accelerate-fft.cabal @@ -1,32 +1,29 @@ -Name: accelerate-fft -Version: 1.2.0.0 -Cabal-version: >= 1.8 -Tested-with: GHC >= 7.10 -Build-type: Simple +name: accelerate-fft +version: 1.3.0.0 +cabal-version: >= 1.10 +tested-with: GHC >= 7.10 +build-type: Simple -Synopsis: FFT using the Accelerate library -Description: +synopsis: FFT using the Accelerate library +description: Rank-polymorphic discrete Fourier transform (DFT), computed with a fast Fourier transform (FFT) algorithm using the Accelerate library. Note that - optimised implementations are available via foreign libraries, but must be - explicitly enabled. + optimised implementations are available via foreign libraries (enabled by + default). . Refer to the main /Accelerate/ package for more information: . -License: BSD3 -License-file: LICENSE -Author: Manuel M T Chakravarty, - Gabriele Keller, - Trevor L. McDonell, - Robert Clifton-Everest -Maintainer: Trevor L. McDonell -Homepage: https://github.com/AccelerateHS/accelerate-fft -Bug-reports: https://github.com/AccelerateHS/accelerate/issues +license: BSD3 +license-file: LICENSE +author: The Accelerate Team +maintainer: Trevor L. McDonell +homepage: https://github.com/AccelerateHS/accelerate-fft +bug-reports: https://github.com/AccelerateHS/accelerate/issues -Category: Compilers/Interpreters, Concurrency, Data, Parallelism -Stability: Experimental +category: Accelerate, Math +stability: Experimental extra-source-files: README.md @@ -43,8 +40,8 @@ library build-depends: - base >= 4.7 && < 4.12 - , accelerate >= 1.2 && < 1.3 + base >= 4.9 && < 5 + , accelerate >= 1.3 , bytestring >= 0.9 , lens-accelerate >= 0.2 @@ -54,19 +51,26 @@ Data.Array.Accelerate.Math.DFT.Centre Data.Array.Accelerate.Math.DFT.Roots + -- Internals + Data.Array.Accelerate.Math.FFT.Type + other-modules: Data.Array.Accelerate.Math.FFT.Adhoc Data.Array.Accelerate.Math.FFT.Mode - Data.Array.Accelerate.Math.FFT.Type hs-source-dirs: src - ghc-options: -O2 -Wall -funbox-strict-fields + default-language: Haskell2010 + ghc-options: + -O2 + -Wall + -funbox-strict-fields + if flag(llvm-cpu) cpp-options: -DACCELERATE_LLVM_NATIVE_BACKEND build-depends: - accelerate-llvm >= 1.0 && < 1.3 - , accelerate-llvm-native >= 1.0 && < 1.3 + accelerate-llvm >= 1.3 + , accelerate-llvm-native >= 1.3 , carray >= 0.1.5 , fft >= 0.1.8 @@ -78,8 +82,8 @@ if flag(llvm-ptx) cpp-options: -DACCELERATE_LLVM_PTX_BACKEND build-depends: - accelerate-llvm >= 1.0 && < 1.3 - , accelerate-llvm-ptx >= 1.0 && < 1.3 + accelerate-llvm >= 1.3 + , accelerate-llvm-ptx >= 1.3 , containers >= 0.5 , hashable >= 1.0 , unordered-containers >= 0.2 @@ -102,6 +106,7 @@ test-suite test-llvm-native type: exitcode-stdio-1.0 + default-language: Haskell2010 hs-source-dirs: test main-is: TestNative.hs ghc-options: -main-is TestNative @@ -110,7 +115,7 @@ buildable: False build-depends: - base >= 4.7 && < 4.12 + base >= 4.9 && < 5 , accelerate , accelerate-fft , accelerate-llvm-native @@ -131,6 +136,7 @@ test-suite test-llvm-ptx type: exitcode-stdio-1.0 + default-language: Haskell2010 hs-source-dirs: test main-is: TestPTX.hs ghc-options: -main-is TestPTX @@ -139,7 +145,7 @@ buildable: False build-depends: - base >= 4.7 && < 4.12 + base >= 4.9 && < 5 , accelerate , accelerate-fft , accelerate-llvm-ptx @@ -159,12 +165,12 @@ source-repository head - Type: git - Location: git://github.com/AccelerateHS/accelerate-fft.git + type: git + location: git://github.com/AccelerateHS/accelerate-fft.git source-repository this - Type: git - Tag: 1.2.0.0 - Location: git://github.com/AccelerateHS/accelerate-fft.git + type: git + tag: v1.3.0.0 + location: git://github.com/AccelerateHS/accelerate-fft.git -- vim: nospell diff --git a/src/Data/Array/Accelerate/Math/DFT.hs b/src/Data/Array/Accelerate/Math/DFT.hs --- a/src/Data/Array/Accelerate/Math/DFT.hs +++ b/src/Data/Array/Accelerate/Math/DFT.hs @@ -4,11 +4,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Math.DFT --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- [2013..2017] Robert Clifton-Everest +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -40,7 +39,7 @@ -- | Compute the DFT along the low order dimension of an array -- -dft :: (Shape sh, Slice sh, Elt (Complex e), A.RealFloat e, A.FromIntegral Int e) +dft :: (Shape sh, Slice sh, A.RealFloat e, A.FromIntegral Int e) => Acc (Array (sh:.Int) (Complex e)) -> Acc (Array (sh:.Int) (Complex e)) dft v = dftG (rootsOfUnity (shape v)) v @@ -48,7 +47,7 @@ -- | Compute the inverse DFT along the low order dimension of an array -- -idft :: (Shape sh, Slice sh, Elt (Complex e), A.RealFloat e, A.FromIntegral Int e) +idft :: (Shape sh, Slice sh, A.RealFloat e, A.FromIntegral Int e) => Acc (Array (sh:.Int) (Complex e)) -> Acc (Array (sh:.Int) (Complex e)) idft v @@ -66,7 +65,7 @@ -- -- The extent of the input and roots must match. -- -dftG :: forall sh e. (Shape sh, Slice sh, Elt (Complex e), A.RealFloat e) +dftG :: forall sh e. (Shape sh, Slice sh, A.RealFloat e) => Acc (Array (sh:.Int) (Complex e)) -- ^ roots of unity -> Acc (Array (sh:.Int) (Complex e)) -- ^ input array -> Acc (Array (sh:.Int) (Complex e)) @@ -95,7 +94,7 @@ -- | Compute a single value of the DFT. -- -dftGS :: forall sh e. (Shape sh, Slice sh, Elt (Complex e), A.RealFloat e) +dftGS :: forall sh e. (Shape sh, Slice sh, A.RealFloat e) => Exp (sh :. Int) -- ^ index of the value we want -> Acc (Array (sh:.Int) (Complex e)) -- ^ roots of unity -> Acc (Array (sh:.Int) (Complex e)) -- ^ input array diff --git a/src/Data/Array/Accelerate/Math/DFT/Centre.hs b/src/Data/Array/Accelerate/Math/DFT/Centre.hs --- a/src/Data/Array/Accelerate/Math/DFT/Centre.hs +++ b/src/Data/Array/Accelerate/Math/DFT/Centre.hs @@ -3,11 +3,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Math.DFT.Centre --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- [2013..2017] Robert Clifton-Everest +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -23,6 +22,7 @@ centre1D, centre2D, centre3D, shift1D, shift2D, shift3D, + ishift1D, ishift2D, ishift3D, ) where @@ -34,7 +34,7 @@ -- | Apply the centring transform to a vector -- centre1D - :: (Elt (Complex e), A.RealFloat e, A.FromIntegral Int e) + :: (A.RealFloat e, A.FromIntegral Int e) => Acc (Array DIM1 (Complex e)) -> Acc (Array DIM1 (Complex e)) centre1D arr @@ -45,7 +45,7 @@ -- | Apply the centring transform to a matrix -- centre2D - :: (Elt (Complex e), A.RealFloat e, A.FromIntegral Int e) + :: (A.RealFloat e, A.FromIntegral Int e) => Acc (Array DIM2 (Complex e)) -> Acc (Array DIM2 (Complex e)) centre2D arr @@ -56,7 +56,7 @@ -- | Apply the centring transform to a 3D array -- centre3D - :: (Elt (Complex e), A.RealFloat e, A.FromIntegral Int e) + :: (A.RealFloat e, A.FromIntegral Int e) => Acc (Array DIM3 (Complex e)) -> Acc (Array DIM3 (Complex e)) centre3D arr @@ -68,41 +68,97 @@ -- | Apply the shifting transform to a vector -- shift1D :: Elt e => Acc (Vector e) -> Acc (Vector e) -shift1D arr - = A.backpermute (A.shape arr) p arr - where - p ix - = let Z:.x = unlift ix :: Z :. Exp Int - in index1 (x A.< mw ? (x + mw, x - mw)) - Z:.w = unlift (A.shape arr) - mw = w `div` 2 +shift1D arr = backpermute sh p arr + where + sh = shape arr + n = indexHead sh + -- + shift = (n `quot` 2) + boolToInt (A.odd n) + roll i = (i+shift) `rem` n + p = ilift1 roll +-- | The inverse of the shift1D function, such that +-- > ishift1D (shift1D v) = ishift1D (shift1D v) = v +-- for all vectors +-- +ishift1D :: Elt e => Acc (Vector e) -> Acc (Vector e) +ishift1D arr = backpermute sh p arr + where + sh = shape arr + n = indexHead sh + -- + shift = (n `quot` 2)-- + boolToInt (A.odd n) + roll i = (i+shift) `rem` n + p = ilift1 roll -- | Apply the shifting transform to a 2D array -- shift2D :: Elt e => Acc (Array DIM2 e) -> Acc (Array DIM2 e) shift2D arr - = A.backpermute (A.shape arr) p arr + = backpermute sh p arr where + sh = shape arr + Z :. h :. w = unlift sh + -- + shifth = (h `quot` 2) + boolToInt (A.odd h) + shiftw = (w `quot` 2) + boolToInt (A.odd w) + p ix = let Z:.y:.x = unlift ix :: Z :. Exp Int :. Exp Int - in index2 (y A.< mh ? (y + mh, y - mh)) - (x A.< mw ? (x + mw, x - mw)) - Z:.h:.w = unlift (A.shape arr) - (mh,mw) = (h `div` 2, w `div` 2) + in index2 ((y + shifth) `rem` h) + ((x + shiftw) `rem` w) +-- | The inverse of the shift2D function +-- +ishift2D :: Elt e => Acc (Array DIM2 e) -> Acc (Array DIM2 e) +ishift2D arr + = backpermute sh p arr + where + sh = shape arr + Z :. h :. w = unlift sh + -- + shifth = (h `quot` 2) + shiftw = (w `quot` 2) + p ix + = let Z:.y:.x = unlift ix :: Z :. Exp Int :. Exp Int + in index2 ((y + shifth) `rem` h) + ((x + shiftw) `rem` w) + -- | Apply the shifting transform to a 3D array -- shift3D :: Elt e => Acc (Array DIM3 e) -> Acc (Array DIM3 e) shift3D arr - = A.backpermute (A.shape arr) p arr + = backpermute sh p arr where + sh = shape arr + Z :. d :. h :. w = unlift sh + -- + shiftd = (d `quot` 2) + boolToInt (A.odd d) + shifth = (h `quot` 2) + boolToInt (A.odd h) + shiftw = (w `quot` 2) + boolToInt (A.odd w) + p ix = let Z:.z:.y:.x = unlift ix :: Z :. Exp Int :. Exp Int :. Exp Int - in index3 (z A.< md ? (z + md, z - md)) - (y A.< mh ? (y + mh, y - mh)) - (x A.< mw ? (x + mw, x - mw)) - Z:.h:.w:.d = unlift (A.shape arr) - (mh,mw,md) = (h `div` 2, w `div` 2, d `div` 2) + in index3 ((z + shiftd) `rem` d) + ((y + shifth) `rem` h) + ((x + shiftw) `rem` w) +-- | The inverse of the shift3D function +-- +ishift3D :: Elt e => Acc (Array DIM3 e) -> Acc (Array DIM3 e) +ishift3D arr + = backpermute sh p arr + where + sh = shape arr + Z :. d :. h :. w = unlift sh + -- + shiftd = (d `quot` 2) + shifth = (h `quot` 2) + shiftw = (w `quot` 2) + + p ix + = let Z:.z:.y:.x = unlift ix :: Z :. Exp Int :. Exp Int :. Exp Int + in index3 ((z + shiftd) `rem` d) + ((y + shifth) `rem` h) + ((x + shiftw) `rem` w) diff --git a/src/Data/Array/Accelerate/Math/DFT/Roots.hs b/src/Data/Array/Accelerate/Math/DFT/Roots.hs --- a/src/Data/Array/Accelerate/Math/DFT/Roots.hs +++ b/src/Data/Array/Accelerate/Math/DFT/Roots.hs @@ -3,11 +3,10 @@ {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Math.DFT.Roots --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- [2013..2017] Robert Clifton-Everest +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -25,7 +24,7 @@ -- | Calculate the roots of unity for the forward transform -- rootsOfUnity - :: (Shape sh, Slice sh, Elt (Complex e), A.Floating e, A.FromIntegral Int e) + :: (Shape sh, Slice sh, A.Floating e, A.FromIntegral Int e) => Exp (sh :. Int) -> Acc (Array (sh:.Int) (Complex e)) rootsOfUnity sh = @@ -40,7 +39,7 @@ -- | Calculate the roots of unity for an inverse transform -- inverseRootsOfUnity - :: (Shape sh, Slice sh, Elt (Complex e), A.Floating e, A.FromIntegral Int e) + :: (Shape sh, Slice sh, A.Floating e, A.FromIntegral Int e) => Exp (sh :. Int) -> Acc (Array (sh:.Int) (Complex e)) inverseRootsOfUnity sh = diff --git a/src/Data/Array/Accelerate/Math/FFT.hs b/src/Data/Array/Accelerate/Math/FFT.hs --- a/src/Data/Array/Accelerate/Math/FFT.hs +++ b/src/Data/Array/Accelerate/Math/FFT.hs @@ -4,16 +4,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Math.FFT --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- [2013..2017] Robert Clifton-Everest +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -38,7 +38,7 @@ import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Math.FFT.Type import Data.Array.Accelerate.Math.FFT.Mode -import qualified Data.Array.Accelerate.Array.Sugar as A ( rank ) +import qualified Data.Array.Accelerate.Sugar.Shape as A ( rank, shapeR ) import qualified Data.Array.Accelerate.Math.FFT.Adhoc as Adhoc #ifdef ACCELERATE_LLVM_NATIVE_BACKEND @@ -67,13 +67,15 @@ fft mode arr = let scale = A.fromIntegral (indexHead (shape arr)) - rank = A.rank (undefined :: sh:.Int) + rank = A.rank @(sh:.Int) + shR = A.shapeR @(sh:.Int) + eR = numericR @e go = #ifdef ACCELERATE_LLVM_NATIVE_BACKEND - (if rank P.<= 5 then foreignAcc (Native.fft mode) else id) $ + (if rank P.<= 5 then foreignAcc (Native.fft mode shR eR) else id) $ #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND - (if rank P.<= 3 then foreignAcc (PTX.fft mode) else id) $ + (if rank P.<= 3 then foreignAcc (PTX.fft mode shR eR) else id) $ #endif Adhoc.fft mode in @@ -94,12 +96,13 @@ fft1D mode arr = let scale = A.fromIntegral (A.length arr) + eR = numericR @e go = #ifdef ACCELERATE_LLVM_NATIVE_BACKEND - foreignAcc (Native.fft1D mode) $ + foreignAcc (Native.fft1D mode eR) $ #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND - foreignAcc (PTX.fft1D mode) $ + foreignAcc (PTX.fft1D mode eR) $ #endif Adhoc.fft mode in @@ -120,12 +123,13 @@ fft2D mode arr = let scale = A.fromIntegral (A.size arr) + eR = numericR @e go = #ifdef ACCELERATE_LLVM_NATIVE_BACKEND - foreignAcc (Native.fft2D mode) $ + foreignAcc (Native.fft2D mode eR) $ #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND - foreignAcc (PTX.fft2D mode) $ + foreignAcc (PTX.fft2D mode eR) $ #endif fft' @@ -149,12 +153,13 @@ -> Acc (Array DIM3 (Complex e)) fft3D mode arr = let scale = A.fromIntegral (A.size arr) + eR = numericR @e go = #ifdef ACCELERATE_LLVM_NATIVE_BACKEND - foreignAcc (Native.fft3D mode) $ + foreignAcc (Native.fft3D mode eR) $ #endif #ifdef ACCELERATE_LLVM_PTX_BACKEND - foreignAcc (PTX.fft3D mode) $ + foreignAcc (PTX.fft3D mode eR) $ #endif fft' diff --git a/src/Data/Array/Accelerate/Math/FFT/Adhoc.hs b/src/Data/Array/Accelerate/Math/FFT/Adhoc.hs --- a/src/Data/Array/Accelerate/Math/FFT/Adhoc.hs +++ b/src/Data/Array/Accelerate/Math/FFT/Adhoc.hs @@ -8,11 +8,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Math.FFT.Adhoc --- Copyright : [2017] Henning Thielemann --- [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -24,7 +23,7 @@ module Data.Array.Accelerate.Math.FFT.Adhoc ( fft ) where -import Data.Array.Accelerate hiding ( transpose ) +import Data.Array.Accelerate hiding ( transpose, fromInteger ) import Data.Array.Accelerate.Data.Bits import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Control.Lens.Shape @@ -32,7 +31,9 @@ import Data.Array.Accelerate.Math.FFT.Mode import Data.Array.Accelerate.Math.FFT.Type +import qualified Prelude as P + fft :: (Shape sh, Slice sh, Numeric e) => Mode -> Acc (Array (sh:.Int) (Complex e)) @@ -68,7 +69,7 @@ -- -- | Split-radix for power-of-two sizes -- -- -- ditSplitRadix --- :: (Shape sh, Slice sh, Numeric e) +-- :: (Shape sh, Numeric e) -- => Mode -- -> Acc (Array (sh:.Int) (Complex e)) -- -> Acc (Array (sh:.Int) (Complex e)) @@ -143,7 +144,7 @@ -> Acc (Array (sh:.Int) (Complex e)) dit235 mode arr = let - merge :: forall sh' a. (Shape sh', Slice sh', Elt a) + merge :: forall sh' a. (Shape sh', Elt a) => Acc (Array (sh':.Int:.Int) a) -> Acc (Array (sh':.Int) a) merge xs = @@ -157,9 +158,11 @@ step fac xs = let sh :. count :. len = unlift (shape xs) :: Exp sh :. Exp Int :. Exp Int - twiddled = transpose - $ zipWithExtrude2 (*) (twiddleFactors fac len) - $ reshape (lift (sh :. count `quot` fac :. fac :. len)) xs + -- + twiddled :: Acc (Array (sh:.Int:.Int:.Int) (Complex e)) + twiddled = transpose + $ zipWithExtrude2 (*) (twiddleFactors fac len) + $ reshape (lift (sh :. count `quot` fac :. fac :. len)) xs in merge $ if fac == 5 then transform5 cache5 twiddled else if fac == 4 then transform4 cache4 twiddled else @@ -319,7 +322,7 @@ (\ip -> lift (fst ip + 1, snd ip * x)) (lift (0,1)) -pad :: (Shape sh, Slice sh, Elt e) +pad :: (Shape sh, Elt e) => Exp Int -> Exp e -> Acc (Array (sh:.Int) e) @@ -330,7 +333,7 @@ in xs ++ fill sh x -cons :: forall sh e. (Shape sh, Slice sh, Elt e) +cons :: forall sh e. (Shape sh, Elt e) => Acc (Array sh e) -> Acc (Array (sh:.Int) e) -> Acc (Array (sh:.Int) e) @@ -338,7 +341,7 @@ let x' = reshape (lift (shape x :. 1)) x in x' ++ xs -consV :: forall sh e. (Shape sh, Slice sh, Elt e) +consV :: forall sh e. (Shape sh, Elt e) => Acc (Array (sh:.Int) e) -> Acc (Array (sh:.Int:.Int) e) -> Acc (Array (sh:.Int:.Int) e) @@ -346,24 +349,24 @@ let sh :. n = unlift (shape x) :: Exp sh :. Exp Int in reshape (lift (sh :. 1 :. n)) x ++^ xs -headV :: (Shape sh, Slice sh, Elt e) +headV :: (Shape sh, Elt e) => Acc (Array (sh:.Int:.Int) e) -> Acc (Array (sh:.Int) e) headV xs = slice xs (lift (Any :. (0 :: Exp Int) :. All)) -tailV :: forall sh e. (Shape sh, Slice sh, Elt e) +tailV :: forall sh e. (Shape sh, Elt e) => Acc (Array (sh:.Int:.Int) e) -> Acc (Array (sh:.Int:.Int) e) tailV = tailOn _2 -dropV :: forall sh e. (Shape sh, Slice sh, Elt e) +dropV :: forall sh e. (Shape sh, Elt e) => Exp Int -> Acc (Array (sh:.Int:.Int) e) -> Acc (Array (sh:.Int:.Int) e) dropV = dropOn _2 sieve - :: forall sh e. (Shape sh, Slice sh, Elt e) + :: forall sh e. (Shape sh, Elt e) => Exp Int -> Exp Int -> Acc (Array (sh:.Int) e) @@ -377,7 +380,7 @@ xs sieveV - :: forall sh e. (Shape sh, Slice sh, Elt e) + :: forall sh e. (Shape sh, Elt e) => Exp Int -> Exp Int -> Acc (Array (sh:.Int:.Int) e) @@ -390,7 +393,7 @@ (\(unlift -> ix :. j :. i :: Exp sh :. Exp Int :. Exp Int) -> lift (ix :. fac*j+start :. i)) xs -twist :: forall sh e. (Shape sh, Slice sh, Elt e) +twist :: forall sh e. (Shape sh, Elt e) => Exp Int -> Acc (Array (sh:.Int:.Int) e) -> Acc (Array (sh:.Int:.Int) e) @@ -404,7 +407,7 @@ infixr 5 ++^ -(++^) :: forall sh e. (Slice sh, Shape sh, Elt e) +(++^) :: forall sh e. (Shape sh, Elt e) => Acc (Array (sh:.Int:.Int) e) -> Acc (Array (sh:.Int:.Int) e) -> Acc (Array (sh:.Int:.Int) e) @@ -429,13 +432,13 @@ zipWith f (replicate (lift (indexTail (indexTail (shape ys)) :. All :. All)) xs) ys transpose - :: forall sh e. (Shape sh, Slice sh, Elt e) + :: forall sh e. (Shape sh, Elt e) => Acc (Array (sh:.Int:.Int) e) -> Acc (Array (sh:.Int:.Int) e) transpose = transposeOn _1 _2 transform2 - :: (Shape sh, Slice sh, Num e) + :: (Shape sh, Num e) => Exp e -> Acc (Array (sh:.Int) e) -> Acc (Array (sh:.Int) e) @@ -450,7 +453,7 @@ else x0+v*x1) transform3 - :: forall sh e. (Shape sh, Slice sh, Num e) + :: forall sh e. (Shape sh, Num e) => Exp (e,e) -> Acc (Array (sh:.Int) e) -> Acc (Array (sh:.Int) e) @@ -470,7 +473,7 @@ {- k == 2 -} else x0 + zx2) transform4 - :: forall sh e. (Shape sh, Slice sh, Num e) + :: forall sh e. (Shape sh, Num e) => Exp (e,e,e) -> Acc (Array (sh:.Int) e) -> Acc (Array (sh:.Int) e) @@ -512,7 +515,7 @@ -- 0 3 1 2 4 -- transform5 - :: forall sh e. (Shape sh, Slice sh, Num e) + :: forall sh e. (Shape sh, Num e) => Exp (e,e,e,e) -> Acc (Array (sh:.Int) e) -> Acc (Array (sh:.Int) e) @@ -600,4 +603,7 @@ d3 = ab0123 - c1 in ((sa0123, sb0123), (d0, d1, d2, d3)) + +fromInteger :: Num a => P.Integer -> Exp a +fromInteger = P.fromInteger diff --git a/src/Data/Array/Accelerate/Math/FFT/LLVM/Native.hs b/src/Data/Array/Accelerate/Math/FFT/LLVM/Native.hs --- a/src/Data/Array/Accelerate/Math/FFT/LLVM/Native.hs +++ b/src/Data/Array/Accelerate/Math/FFT/LLVM/Native.hs @@ -1,15 +1,15 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Math.FFT.LLVM.Native --- Copyright : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -28,83 +28,86 @@ import Data.Array.Accelerate.Math.FFT.LLVM.Native.Ix import Data.Array.Accelerate.Math.FFT.LLVM.Native.Base -import Data.Array.Accelerate import Data.Array.Accelerate.Analysis.Match -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Sugar.Elt +import Data.Primitive.Vec + import Data.Array.Accelerate.LLVM.Native.Foreign +import Data.Proxy import Data.Array.CArray ( CArray ) import Math.FFT.Base ( FFTWReal ) import Prelude as P import qualified Math.FFT as FFT -fft :: forall sh e. (Shape sh, Numeric e) +fft :: forall sh e. HasCallStack => Mode - -> ForeignAcc (Array sh (Complex e) -> Array sh (Complex e)) -fft mode - = ForeignAcc (nameOf mode (undefined::sh)) - $ case numericR::NumericR e of + -> ShapeR sh + -> NumericR e + -> ForeignAcc (Array sh (Vec2 e) -> Array sh (Vec2 e)) +fft mode shR eR + = ForeignAcc (nameOf mode shR) + $ case eR of NumericRfloat32 -> go NumericRfloat64 -> go where - go :: FFTWReal e => Array sh (Complex e) -> LLVM Native (Array sh (Complex e)) - go | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM1) = liftCtoA (FFT.dftGU (signOf mode) flags [0] `ix` (undefined :: (Int))) - | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM2) = liftCtoA (FFT.dftGU (signOf mode) flags [1] `ix` (undefined :: (Int,Int))) - | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM3) = liftCtoA (FFT.dftGU (signOf mode) flags [2] `ix` (undefined :: (Int,Int,Int))) - | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM4) = liftCtoA (FFT.dftGU (signOf mode) flags [3] `ix` (undefined :: (Int,Int,Int,Int))) - | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM5) = liftCtoA (FFT.dftGU (signOf mode) flags [4] `ix` (undefined :: (Int,Int,Int,Int,Int))) - | otherwise = $internalError "fft" "only for 1D..5D inner-dimension transforms" + go :: FFTWReal e => Array sh (Vec2 e) -> Par Native (Future (Array sh (Vec2 e))) + go | Just Refl <- matchShapeR shR dim1 = liftCtoA shR eR (FFT.dftGU (signOf mode) flags [0] `ix` (Proxy :: Proxy (Int))) + | Just Refl <- matchShapeR shR dim2 = liftCtoA shR eR (FFT.dftGU (signOf mode) flags [1] `ix` (Proxy :: Proxy (Int,Int))) + | Just Refl <- matchShapeR shR dim3 = liftCtoA shR eR (FFT.dftGU (signOf mode) flags [2] `ix` (Proxy :: Proxy (Int,Int,Int))) + | Just Refl <- matchShapeR shR dim4 = liftCtoA shR eR (FFT.dftGU (signOf mode) flags [3] `ix` (Proxy :: Proxy (Int,Int,Int,Int))) + | Just Refl <- matchShapeR shR dim5 = liftCtoA shR eR (FFT.dftGU (signOf mode) flags [4] `ix` (Proxy :: Proxy (Int,Int,Int,Int,Int))) + | otherwise = internalError "only for 1D..5D inner-dimension transforms" -- - ix :: (a i r -> a i r) -> i -> (a i r -> a i r) + ix :: (a i r -> a i r) -> proxy i -> (a i r -> a i r) ix f _ = f + dim4 = ShapeRsnoc dim3 + dim5 = ShapeRsnoc dim4 -fft1D :: forall e. Numeric e - => Mode - -> ForeignAcc (Array DIM1 (Complex e) -> Array DIM1 (Complex e)) -fft1D mode - = ForeignAcc (nameOf mode (undefined::DIM1)) - $ case numericR::NumericR e of - NumericRfloat32 -> liftCtoA go - NumericRfloat64 -> liftCtoA go +fft1D :: Mode -> NumericR e -> ForeignAcc (Array DIM1 (Vec2 e) -> Array DIM1 (Vec2 e)) +fft1D mode eR + = ForeignAcc (nameOf mode dim1) + $ case eR of + NumericRfloat32 -> liftCtoA dim1 eR go + NumericRfloat64 -> liftCtoA dim1 eR go where go :: FFTWReal r => CArray Int (Complex r) -> CArray Int (Complex r) go = FFT.dftGU (signOf mode) flags [0] -fft2D :: forall e. Numeric e - => Mode - -> ForeignAcc (Array DIM2 (Complex e) -> Array DIM2 (Complex e)) -fft2D mode - = ForeignAcc (nameOf mode (undefined::DIM2)) - $ case numericR::NumericR e of - NumericRfloat32 -> liftCtoA go - NumericRfloat64 -> liftCtoA go +fft2D :: Mode -> NumericR e -> ForeignAcc (Array DIM2 (Vec2 e) -> Array DIM2 (Vec2 e)) +fft2D mode eR + = ForeignAcc (nameOf mode dim2) + $ case eR of + NumericRfloat32 -> liftCtoA dim2 eR go + NumericRfloat64 -> liftCtoA dim2 eR go where go :: FFTWReal r => CArray (Int,Int) (Complex r) -> CArray (Int,Int) (Complex r) go = FFT.dftGU (signOf mode) flags [0,1] -fft3D :: forall e. Numeric e - => Mode - -> ForeignAcc (Array DIM3 (Complex e) -> Array DIM3 (Complex e)) -fft3D mode - = ForeignAcc (nameOf mode (undefined::DIM3)) - $ case numericR::NumericR e of - NumericRfloat32 -> liftCtoA go - NumericRfloat64 -> liftCtoA go +fft3D :: Mode -> NumericR e -> ForeignAcc (Array DIM3 (Vec2 e) -> Array DIM3 (Vec2 e)) +fft3D mode eR + = ForeignAcc (nameOf mode dim3) + $ case eR of + NumericRfloat32 -> liftCtoA dim3 eR go + NumericRfloat64 -> liftCtoA dim3 eR go where go :: FFTWReal r => CArray (Int,Int,Int) (Complex r) -> CArray (Int,Int,Int) (Complex r) go = FFT.dftGU (signOf mode) flags [0,1,2] -{-# INLINE liftCtoA #-} liftCtoA - :: forall ix sh e. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix, Numeric e) - => (CArray ix (Complex e) -> CArray ix (Complex e)) - -> Array sh (Complex e) - -> LLVM Native (Array sh (Complex e)) -liftCtoA f a = - liftIO $ withCArray a (fromCArray . f) + :: forall ix sh e. (IxShapeR (EltR ix) ~ sh, Elt ix) + => ShapeR sh + -> NumericR e + -> (CArray ix (Complex e) -> CArray ix (Complex e)) + -> Array sh (Vec2 e) + -> Par Native (Future (Array sh (Vec2 e))) +liftCtoA shR eR f a = + newFull =<< liftIO (withCArray shR eR a (fromCArray shR eR . f)) diff --git a/src/Data/Array/Accelerate/Math/FFT/LLVM/Native/Base.hs b/src/Data/Array/Accelerate/Math/FFT/LLVM/Native/Base.hs --- a/src/Data/Array/Accelerate/Math/FFT/LLVM/Native/Base.hs +++ b/src/Data/Array/Accelerate/Math/FFT/LLVM/Native/Base.hs @@ -1,13 +1,15 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Math.FFT.LLVM.Native.Base --- Copyright : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -15,23 +17,23 @@ module Data.Array.Accelerate.Math.FFT.LLVM.Native.Base where -import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Array.Unique import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Sugar.Elt +import Data.Primitive.Vec import Data.Array.Accelerate.Math.FFT.Mode import Data.Array.Accelerate.Math.FFT.Type - import Data.Array.Accelerate.Math.FFT.LLVM.Native.Ix import Data.Array.CArray.Base ( CArray(..) ) import Math.FFT.Base ( Sign(..), Flag, measure, preserveInput ) import Data.Bits -import Data.Typeable import Foreign.ForeignPtr import Text.Printf import Prelude as P @@ -44,76 +46,55 @@ flags :: Flag flags = measure .|. preserveInput -nameOf :: forall sh. Shape sh => Mode -> sh -> String -nameOf Forward _ = printf "FFTW.dft%dD" (rank (undefined::sh)) -nameOf _ _ = printf "FFTW.idft%dD" (rank (undefined::sh)) +nameOf :: forall sh. Mode -> ShapeR sh -> String +nameOf Forward shR = printf "FFTW.dft%dD" (rank shR) +nameOf _ shR = printf "FFTW.idft%dD" (rank shR) -- /O(1)/ Convert a CArray to an Accelerate array -- {-# INLINE fromCArray #-} fromCArray - :: forall ix sh e. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix, Numeric e) - => CArray ix (Complex e) - -> IO (Array sh (Complex e)) -fromCArray (CArray lo hi _ fp) = do + :: forall ix sh e. (IxShapeR (EltR ix) ~ sh, Elt ix) + => ShapeR sh + -> NumericR e + -> CArray ix (Complex e) + -> IO (Array sh (Vec2 e)) +fromCArray shR eR (CArray lo hi _ fp) = do -- - sh <- return $ rangeToShape (toIxShapeRepr lo, toIxShapeRepr hi) :: IO sh + sh <- return $ rangeToShape shR (toIxShapeR lo, toIxShapeR hi) :: IO sh ua <- newUniqueArray (castForeignPtr fp :: ForeignPtr e) -- - case numericR::NumericR e of - NumericRfloat32 -> return $ Array (fromElt sh) (AD_V2 (AD_Float ua)) - NumericRfloat64 -> return $ Array (fromElt sh) (AD_V2 (AD_Double ua)) + case eR of + NumericRfloat32 -> return $ Array sh ua + NumericRfloat64 -> return $ Array sh ua -- /O(1)/ Use an Accelerate array as a CArray -- {-# INLINE withCArray #-} withCArray - :: forall ix sh e a. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix, Numeric e) - => Array sh (Complex e) + :: forall ix sh e a. (IxShapeR (EltR ix) ~ sh, Elt ix) + => ShapeR sh + -> NumericR e + -> Array sh (Vec2 e) -> (CArray ix (Complex e) -> IO a) -> IO a -withCArray arr f = +withCArray shR eR (Array sh adata) f = let - sh = shape arr - (lo, hi) = shapeToRange sh - wrap fp = CArray (fromIxShapeRepr lo) (fromIxShapeRepr hi) (size sh) (castForeignPtr fp) + (lo, hi) = shapeToRange shR sh + wrap fp = CArray (fromIxShapeR lo) (fromIxShapeR hi) (size shR sh) (castForeignPtr fp) in - withArray arr (f . wrap) + withArrayData eR adata (f . wrap) -- Use underlying array pointers -- -{-# INLINE withArray #-} -withArray - :: forall sh e a. Numeric e - => Array sh (Complex e) - -> (ForeignPtr e -> IO a) - -> IO a -withArray (Array _ adata) = withArrayData (numericR::NumericR e) adata - {-# INLINE withArrayData #-} withArrayData :: NumericR e - -> ArrayData (EltRepr (Complex e)) + -> ArrayData (Vec2 e) -> (ForeignPtr e -> IO a) -> IO a -withArrayData NumericRfloat32 (AD_V2 (AD_Float ua)) = withLifetime (uniqueArrayData ua) -withArrayData NumericRfloat64 (AD_V2 (AD_Double ua)) = withLifetime (uniqueArrayData ua) - - --- Match shape surface types --- -{-# INLINE matchShapeType #-} -matchShapeType - :: forall sh sh'. (Shape sh, Shape sh') - => sh - -> sh' - -> Maybe (sh :~: sh') -matchShapeType _ _ - | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::sh')) - = gcast Refl - -matchShapeType _ _ - = Nothing +withArrayData NumericRfloat32 ua = withLifetime (uniqueArrayData ua) +withArrayData NumericRfloat64 ua = withLifetime (uniqueArrayData ua) diff --git a/src/Data/Array/Accelerate/Math/FFT/LLVM/Native/Ix.hs b/src/Data/Array/Accelerate/Math/FFT/LLVM/Native/Ix.hs --- a/src/Data/Array/Accelerate/Math/FFT/LLVM/Native/Ix.hs +++ b/src/Data/Array/Accelerate/Math/FFT/LLVM/Native/Ix.hs @@ -1,12 +1,12 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Array.Accelerate.Math.FFT.LLVM.Native.Ix --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -14,44 +14,45 @@ module Data.Array.Accelerate.Math.FFT.LLVM.Native.Ix where -import Data.Array.Accelerate.Array.Sugar import Data.Array.Accelerate.Error +import Data.Array.Accelerate.Representation.Type +import Data.Array.Accelerate.Sugar.Elt import Data.Array.Accelerate.Type -- Converting between Accelerate multidimensional shapes/indices and those used -- by the CArray package (Data.Ix) -- -type family IxShapeRepr e where - IxShapeRepr () = () - IxShapeRepr Int = ((),Int) - IxShapeRepr (t,h) = (IxShapeRepr t, h) +type family IxShapeR e where + IxShapeR () = () + IxShapeR Int = ((),Int) + IxShapeR (t,h) = (IxShapeR t, h) -{-# INLINE fromIxShapeRepr #-} -fromIxShapeRepr - :: forall ix sh. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix) +{-# INLINE fromIxShapeR #-} +fromIxShapeR + :: forall ix sh. (HasCallStack, IxShapeR (EltR ix) ~ sh, Elt ix) => sh -> ix -fromIxShapeRepr = liftToElt (go (eltType (undefined::ix))) +fromIxShapeR = toElt . go (eltR @ix) where - go :: forall ix'. TupleType ix' -> IxShapeRepr ix' -> ix' - go TypeRunit () = () - go (TypeRpair tt _) (t, h) = (go tt t, h) - go (TypeRscalar (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) ((),h) = h + go :: forall ix'. TypeR ix' -> IxShapeR ix' -> ix' + go TupRunit () = () + go (TupRpair tt _) (t, h) = (go tt t, h) + go (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) ((),h) = h go _ _ - = $internalError "fromIxShapeRepr" "expected Int dimensions" + = internalError "expected Int dimensions" -{-# INLINE toIxShapeRepr #-} -toIxShapeRepr - :: forall ix sh. (IxShapeRepr (EltRepr ix) ~ EltRepr sh, Shape sh, Elt ix) +{-# INLINE toIxShapeR #-} +toIxShapeR + :: forall ix sh. (HasCallStack, IxShapeR (EltR ix) ~ sh, Elt ix) => ix -> sh -toIxShapeRepr = liftToElt (go (eltType (undefined::ix))) +toIxShapeR = go (eltR @ix) . fromElt where - go :: forall ix'. TupleType ix' -> ix' -> IxShapeRepr ix' - go TypeRunit () = () - go (TypeRscalar (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) h = ((), h) - go (TypeRpair tt _) (t, h) = (go tt t, h) + go :: forall ix'. TypeR ix' -> ix' -> IxShapeR ix' + go TupRunit () = () + go (TupRsingle (SingleScalarType (NumSingleType (IntegralNumType TypeInt{})))) h = ((), h) + go (TupRpair tt _) (t, h) = (go tt t, h) go _ _ - = $internalError "toIxShapeRepr" "not a valid Data.Ix index" + = internalError "not a valid Data.Ix index" diff --git a/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX.hs b/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX.hs --- a/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX.hs +++ b/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX.hs @@ -2,16 +2,16 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Array.Accelerate.Math.FFT.LLVM.PTX --- Copyright : [2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -30,106 +30,107 @@ import Data.Array.Accelerate.Math.FFT.LLVM.PTX.Base import Data.Array.Accelerate.Math.FFT.LLVM.PTX.Plans -import Data.Array.Accelerate.Array.Sugar +import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Error import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Representation.Shape +import Data.Array.Accelerate.Sugar.Elt +import Data.Primitive.Vec import Data.Array.Accelerate.LLVM.PTX.Foreign import Foreign.CUDA.Ptr ( DevicePtr, castDevPtr ) import qualified Foreign.CUDA.FFT as FFT +import Control.Monad.Reader import Data.Hashable -import Data.Proxy -import Data.Typeable import System.IO.Unsafe -fft :: forall sh e. (Shape sh, Numeric e) +fft :: forall sh e. HasCallStack => Mode - -> ForeignAcc (Array (sh:.Int) (Complex e) -> Array (sh:.Int) (Complex e)) -fft mode - | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM0) = fft1D mode - | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM1) = ForeignAcc "cuda.fft2.many" $ fft' fft2DMany_plans mode - | Just Refl <- matchShapeType (undefined::sh) (undefined::DIM2) = ForeignAcc "cuda.fft3.many" $ fft' fft3DMany_plans mode - | otherwise = $internalError "fft" "only for 1D..3D inner-dimension transforms" + -> ShapeR sh + -> NumericR e + -> ForeignAcc (Array sh (Vec2 e) -> Array sh (Vec2 e)) +fft mode shR eR + | Just Refl <- matchShapeR shR dim1 = fft1D mode eR + | Just Refl <- matchShapeR shR dim2 = ForeignAcc "cuda.fft2.many" $ fft' fft2DMany_plans mode shR eR + | Just Refl <- matchShapeR shR dim3 = ForeignAcc "cuda.fft3.many" $ fft' fft3DMany_plans mode shR eR + | otherwise = internalError "only for 1D..3D inner-dimension transforms" -fft1D :: Numeric e - => Mode - -> ForeignAcc (Vector (Complex e) -> Vector (Complex e)) -fft1D mode = ForeignAcc "cuda.fft1d" $ fft' fft1D_plans mode +fft1D :: Mode -> NumericR e -> ForeignAcc (Array DIM1 (Vec2 e) -> Array DIM1 (Vec2 e)) +fft1D mode eR = ForeignAcc "cuda.fft1d" $ fft' fft1D_plans mode dim1 eR -fft2D :: Numeric e - => Mode - -> ForeignAcc (Array DIM2 (Complex e) -> Array DIM2 (Complex e)) -fft2D mode = ForeignAcc "cuda.fft2d" $ fft' fft2D_plans mode +fft2D :: Mode -> NumericR e -> ForeignAcc (Array DIM2 (Vec2 e) -> Array DIM2 (Vec2 e)) +fft2D mode eR = ForeignAcc "cuda.fft2d" $ fft' fft2D_plans mode dim2 eR -fft3D :: Numeric e - => Mode - -> ForeignAcc (Array DIM3 (Complex e) -> Array DIM3 (Complex e)) -fft3D mode = ForeignAcc "cuda.fft3d" $ fft' fft3D_plans mode +fft3D :: Mode -> NumericR e -> ForeignAcc (Array DIM3 (Vec2 e) -> Array DIM3 (Vec2 e)) +fft3D mode eR = ForeignAcc "cuda.fft3d" $ fft' fft3D_plans mode dim3 eR -- Internals -- --------- {-# INLINEABLE fft' #-} -fft' :: forall sh e. (Shape sh, Numeric e) - => Plans (sh, FFT.Type) +fft' :: forall sh e. + Plans (sh, FFT.Type) -> Mode - -> Stream - -> Array sh (Complex e) - -> LLVM PTX (Array sh (Complex e)) -fft' plans mode stream = + -> ShapeR sh + -> NumericR e + -> Array sh (Vec2 e) + -> Par PTX (Future (Array sh (Vec2 e))) +fft' plans mode shR eR = let - go :: Numeric e => Array sh (Complex e) -> LLVM PTX (Array sh (Complex e)) - go ain = do + go :: ArrayR (Array sh (Vec2 e)) -> Array sh (Vec2 e) -> Par PTX (Future (Array sh (Vec2 e))) + go aR ain = do let sh = shape ain - t = fftType (Proxy::Proxy e) + t = fftType eR -- - aout <- allocateRemote sh - withArray ain stream $ \d_in -> do - withArray aout stream $ \d_out -> do - withPlan plans (sh,t) $ \h -> do - liftIO $ cuFFT (Proxy::Proxy e) h mode stream (castDevPtr d_in) (castDevPtr d_out) - return aout + aout <- allocateRemote aR sh + stream <- asks ptxStream + future <- new + liftPar $ + withArray eR ain stream $ \d_in -> do + withArray eR aout stream $ \d_out -> do + withPlan plans (sh,t) $ \h -> do + liftIO $ cuFFT eR h mode stream (castDevPtr d_in) (castDevPtr d_out) + -- + put future aout + return future in - case numericR::NumericR e of - NumericRfloat32 -> go - NumericRfloat64 -> go - + case eR of + NumericRfloat32 -> go (ArrayR shR (eltR @(Complex Float))) + NumericRfloat64 -> go (ArrayR shR (eltR @(Complex Double))) +-- -- Execute the FFT -- {-# INLINE cuFFT #-} -cuFFT :: forall e. Numeric e - => Proxy e +cuFFT :: NumericR e -> FFT.Handle -> Mode -> Stream -> DevicePtr (Complex e) -> DevicePtr (Complex e) -> IO () -cuFFT _ p mode stream d_in d_out = +cuFFT eR p mode stream d_in d_out = withLifetime stream $ \s -> do FFT.setStream p s - case numericR::NumericR e of + case eR of NumericRfloat32 -> FFT.execC2C p (fftMode mode) d_in d_out NumericRfloat64 -> FFT.execZ2Z p (fftMode mode) d_in d_out -fftType :: forall e. Numeric e => Proxy e -> FFT.Type -fftType _ = - case numericR::NumericR e of - NumericRfloat32 -> FFT.C2C - NumericRfloat64 -> FFT.Z2Z +fftType :: NumericR e -> FFT.Type +fftType NumericRfloat32 = FFT.C2C +fftType NumericRfloat64 = FFT.Z2Z fftMode :: Mode -> FFT.Mode fftMode Forward = FFT.Forward fftMode _ = FFT.Inverse - -- Plan caches -- ----------- @@ -137,34 +138,34 @@ fft1D_plans :: Plans (DIM1, FFT.Type) fft1D_plans = unsafePerformIO - $ createPlan (\(Z:.n, t) -> FFT.plan1D n t 1) - (\(Z:.n, t) -> fromEnum t `hashWithSalt` n) + $ createPlan (\(((), n), t) -> FFT.plan1D n t 1) + (\(((), n), t) -> fromEnum t `hashWithSalt` n) {-# NOINLINE fft2D_plans #-} fft2D_plans :: Plans (DIM2, FFT.Type) fft2D_plans = unsafePerformIO - $ createPlan (\(Z:.h:.w, t) -> FFT.plan2D h w t) - (\(Z:.h:.w, t) -> fromEnum t `hashWithSalt` h `hashWithSalt` w) + $ createPlan (\((((),h),w), t) -> FFT.plan2D h w t) + (\((((),h),w), t) -> fromEnum t `hashWithSalt` h `hashWithSalt` w) {-# NOINLINE fft3D_plans #-} fft3D_plans :: Plans (DIM3, FFT.Type) fft3D_plans = unsafePerformIO - $ createPlan (\(Z:.d:.h:.w, t) -> FFT.plan3D d h w t) - (\(Z:.d:.h:.w, t) -> fromEnum t `hashWithSalt` d `hashWithSalt` h `hashWithSalt` w) + $ createPlan (\(((((),d),h),w), t) -> FFT.plan3D d h w t) + (\(((((),d),h),w), t) -> fromEnum t `hashWithSalt` d `hashWithSalt` h `hashWithSalt` w) {-# NOINLINE fft2DMany_plans #-} fft2DMany_plans :: Plans (DIM2, FFT.Type) fft2DMany_plans = unsafePerformIO - $ createPlan (\(Z:.h:.w, t) -> FFT.planMany [h,w] Nothing Nothing t 1) - (\(Z:.h:.w, t) -> fromEnum t `hashWithSalt` h `hashWithSalt` w) + $ createPlan (\((((),h),w), t) -> FFT.planMany [w] Nothing Nothing t h) + (\((((),h),w), t) -> fromEnum t `hashWithSalt` h `hashWithSalt` w) {-# NOINLINE fft3DMany_plans #-} fft3DMany_plans :: Plans (DIM3, FFT.Type) fft3DMany_plans = unsafePerformIO - $ createPlan (\(Z:.d:.h:.w, t) -> FFT.planMany [d,h,w] Nothing Nothing t 1) - (\(Z:.d:.h:.w, t) -> fromEnum t `hashWithSalt` d `hashWithSalt` h `hashWithSalt` w) + $ createPlan (\(((((()),d),h),w), t) -> FFT.planMany [w] Nothing Nothing t (d*h)) + (\(((((()),d),h),w), t) -> fromEnum t `hashWithSalt` d `hashWithSalt` h `hashWithSalt` w) diff --git a/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX/Base.hs b/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX/Base.hs --- a/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX/Base.hs +++ b/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX/Base.hs @@ -1,13 +1,14 @@ {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | -- Module : Data.Array.Accelerate.Math.FFT.LLVM.PTX.Base --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -17,44 +18,42 @@ import Data.Array.Accelerate.Math.FFT.Type -import Data.Array.Accelerate.Analysis.Match import Data.Array.Accelerate.Array.Data -import Data.Array.Accelerate.Array.Sugar -import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Lifetime +import Data.Array.Accelerate.Representation.Array +import Data.Array.Accelerate.Type +import Data.Primitive.Vec import Data.Array.Accelerate.LLVM.PTX.Foreign import Foreign.CUDA.Ptr ( DevicePtr ) -import Data.Typeable - {-# INLINE withArray #-} withArray - :: forall sh e b. Numeric e - => Array sh (Complex e) + :: NumericR e + -> Array sh (Vec2 e) -> Stream -> (DevicePtr e -> LLVM PTX b) -> LLVM PTX b -withArray (Array _ adata) = withArrayData (numericR::NumericR e) adata +withArray eR (Array _ adata) = withArrayData eR adata {-# INLINE withArrayData #-} withArrayData :: NumericR e - -> ArrayData (EltRepr (Complex e)) + -> ArrayData (Vec2 e) -> Stream -> (DevicePtr e -> LLVM PTX b) -> LLVM PTX b -withArrayData NumericRfloat32 (AD_V2 ad) s k = - withDevicePtr ad $ \p -> do +withArrayData NumericRfloat32 ad s k = + withDevicePtr (singleType @Float) ad $ \p -> do r <- k p - e <- checkpoint s + e <- waypoint s return (Just e,r) -withArrayData NumericRfloat64 (AD_V2 ad) s k = - withDevicePtr ad $ \p -> do +withArrayData NumericRfloat64 ad s k = + withDevicePtr (singleType @Double) ad $ \p -> do r <- k p - e <- checkpoint s + e <- waypoint s return (Just e, r) {-# INLINE withLifetime' #-} @@ -63,20 +62,4 @@ r <- k (unsafeGetValue l) liftIO $ touchLifetime l return r - - --- Match shape surface types --- -{-# INLINE matchShapeType #-} -matchShapeType - :: forall sh sh'. (Shape sh, Shape sh') - => sh - -> sh' - -> Maybe (sh :~: sh') -matchShapeType _ _ - | Just Refl <- matchTupleType (eltType (undefined::sh)) (eltType (undefined::sh')) - = gcast Refl - -matchShapeType _ _ - = Nothing diff --git a/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX/Plans.hs b/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX/Plans.hs --- a/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX/Plans.hs +++ b/src/Data/Array/Accelerate/Math/FFT/LLVM/PTX/Plans.hs @@ -2,10 +2,10 @@ {-# LANGUAGE RecordWildCards #-} -- | -- Module : Data.Array.Accelerate.Math.FFT.LLVM.PTX.Plans --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Math/FFT/Mode.hs b/src/Data/Array/Accelerate/Math/FFT/Mode.hs --- a/src/Data/Array/Accelerate/Math/FFT/Mode.hs +++ b/src/Data/Array/Accelerate/Math/FFT/Mode.hs @@ -1,10 +1,9 @@ -- | -- Module : Data.Array.Accelerate.Math.FFT.Mode --- Copyright : [2012..2017] Manuel M T Chakravarty, Gabriele Keller, Trevor L. McDonell --- [2013..2017] Robert Clifton-Everest +-- Copyright : [2012..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/src/Data/Array/Accelerate/Math/FFT/Type.hs b/src/Data/Array/Accelerate/Math/FFT/Type.hs --- a/src/Data/Array/Accelerate/Math/FFT/Type.hs +++ b/src/Data/Array/Accelerate/Math/FFT/Type.hs @@ -1,13 +1,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} -- | -- Module : Data.Array.Accelerate.Math.FFT.Type --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -17,6 +18,8 @@ import Data.Array.Accelerate as A import Data.Array.Accelerate.Data.Complex as A +import Data.Array.Accelerate.Sugar.Elt +import Data.Primitive.Vec -- For explicit dictionary reification, to discover the concrete type the @@ -26,7 +29,7 @@ NumericRfloat32 :: NumericR Float NumericRfloat64 :: NumericR Double -class (RealFloat a, FromIntegral Int a, Elt (Complex a)) => Numeric a where +class (RealFloat a, FromIntegral Int a, Elt a, EltR (Complex a) ~ Vec2 a) => Numeric a where numericR :: NumericR a instance Numeric Float where diff --git a/test/Test/Base.hs b/test/Test/Base.hs --- a/test/Test/Base.hs +++ b/test/Test/Base.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RankNTypes #-} -- | -- Module : Test.Base --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -13,8 +13,10 @@ where import Data.Array.Accelerate ( Z(..), (:.)(..), DIM1, DIM2, DIM3, Shape, Elt, Acc, Array ) -import Data.Array.Accelerate.Array.Sugar ( fromList, size ) -import Data.Array.Accelerate.Trafo ( Afunction, AfunctionR ) +import Data.Array.Accelerate.Sugar.Array ( fromList ) +import Data.Array.Accelerate.Sugar.Shape ( size ) +import Data.Array.Accelerate.Trafo ( Afunction ) +import Data.Array.Accelerate.Trafo.Sharing ( AfunctionR ) import Data.Array.Accelerate.Data.Complex import Data.Array.Accelerate.Math.FFT diff --git a/test/Test/FFT.hs b/test/Test/FFT.hs --- a/test/Test/FFT.hs +++ b/test/Test/FFT.hs @@ -7,10 +7,10 @@ {-# LANGUAGE ViewPatterns #-} -- | -- Module : Test.FFT --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- @@ -44,7 +44,7 @@ ] testFFT' - :: forall e. (Numeric e, Similar e, RealFloat e, Show (ArgType e)) + :: forall e. (Show e, Numeric e, Similar e, RealFloat e, Show (ArgType e)) => Gen e -> RunN -> TestTree @@ -110,7 +110,7 @@ test_homogeneity - :: (Numeric e, Similar e, Shape sh, Eq sh) + :: (Show e, Numeric e, Similar e, Show sh, Shape sh, Eq sh) => RunN -> Transform sh (Complex e) -> Gen sh @@ -129,7 +129,7 @@ go1 (scalar x) arr ~~~ go2 (scalar x) arr test_additivity - :: (Numeric e, Similar e, Shape sh, Eq sh) + :: (Show e, Numeric e, Similar e, Show sh, Shape sh, Eq sh) => RunN -> Transform sh (Complex e) -> Gen sh @@ -148,7 +148,7 @@ go1 xs ys ~~~ go2 xs ys test_inverse - :: (Numeric e, Similar e, Shape sh, Eq sh) + :: (Show e, Numeric e, Similar e, Show sh, Shape sh, Eq sh) => RunN -> Transform sh (Complex e) -> Gen sh @@ -163,7 +163,7 @@ xs ~~~ go xs test_reverse - :: (Numeric e, Similar e, Shape sh, Slice sh, Eq sh) + :: (Show e, Numeric e, Similar e, Show sh, Shape sh, Slice sh, Eq sh) => RunN -> Transform (sh:.Int) (Complex e) -> Gen (sh:.Int) @@ -181,7 +181,7 @@ go1 xs ~~~ go2 xs test_conjugate - :: (Numeric e, Similar e, Shape sh, Slice sh, Eq sh) + :: (Show e, Numeric e, Similar e, Show sh, Shape sh, Slice sh, Eq sh) => RunN -> Transform (sh:.Int) (Complex e) -> Gen (sh:.Int) @@ -199,7 +199,7 @@ go1 xs ~~~ go2 xs test_isometry - :: forall sh e. (Numeric e, Similar e, Shape sh, Slice sh, Eq sh, P.Floating e) + :: forall sh e. (Show e, Numeric e, Similar e, Show sh, Shape sh, Slice sh, Eq sh, P.Floating e) => RunN -> Transform (sh:.Int) (Complex e) -> Gen (sh:.Int) @@ -217,7 +217,7 @@ go1 xs ~~~ go2 (scalar (sqrt (P.fromIntegral n))) xs test_unitarity - :: forall sh e. (Numeric e, Similar e, RealFloat e, Shape sh, Slice sh, Eq sh) + :: forall sh e. (Show e, Numeric e, Similar e, RealFloat e, Show sh, Shape sh, Slice sh, Eq sh) => RunN -> Transform (sh:.Int) (Complex e) -> Gen (sh:.Int) diff --git a/test/Test/ShowType.hs b/test/Test/ShowType.hs --- a/test/Test/ShowType.hs +++ b/test/Test/ShowType.hs @@ -4,10 +4,10 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Test.ShowType --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/TestNative.hs b/test/TestNative.hs --- a/test/TestNative.hs +++ b/test/TestNative.hs @@ -1,9 +1,9 @@ -- | -- Module : TestNative --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) -- diff --git a/test/TestPTX.hs b/test/TestPTX.hs --- a/test/TestPTX.hs +++ b/test/TestPTX.hs @@ -1,9 +1,9 @@ -- | -- Module : TestPTX --- Copyright : [2017] Trevor L. McDonell +-- Copyright : [2017..2020] The Accelerate Team -- License : BSD3 -- --- Maintainer : Trevor L. McDonell +-- Maintainer : Trevor L. McDonell -- Stability : experimental -- Portability : non-portable (GHC extensions) --