diff --git a/accelerate-examples.cabal b/accelerate-examples.cabal --- a/accelerate-examples.cabal +++ b/accelerate-examples.cabal @@ -1,7 +1,7 @@ Name: accelerate-examples -Version: 0.13.0.0 +Version: 0.14.0.0 Cabal-version: >=1.6 -Tested-with: GHC >= 7.6 +Tested-with: GHC == 7.6.* Build-type: Simple Synopsis: Examples using the Accelerate library @@ -24,11 +24,18 @@ Category: Compilers/Interpreters, Concurrency, Data, Parallelism Stability: Experimental +Extra-source-files: data/hashcat/README.md + data/matrices/README.md + Flag gui Description: Enable gloss-based GUIs, where applicable. If not enabled, the application always runs in benchmark mode. Default: True +Flag ekg + Description: Enable EKG remote monitoring server at + Default: True + Flag cuda Description: Enable the CUDA parallel backend for NVIDIA GPUs Default: True @@ -38,81 +45,118 @@ Default: False --- Run some basic randomised tests of the primitive library operations, and unit --- tests of known (hopefully prior) failures. +-- Flags to specify which programs to build (all true by default) -- -Executable accelerate-quickcheck +Flag nofib +Flag smvm +Flag crystal +Flag canny +Flag mandelbrot +Flag fluid +Flag nbody +Flag smoothlife +Flag hashcat +Flag fft + + +-- The main test program. This includes randomised quickcheck testing for array +-- primitives, unit tests, imaginary/spectral/real programs, and benchmarks. +-- +-- TODO: add an analysis script to scrape benchmark results +-- +Executable accelerate-nofib Main-is: Main.hs - hs-source-dirs: examples/quickcheck/ + hs-source-dirs: lib + examples/nofib + examples/smvm - other-modules: Config - Arbitrary.Array - Arbitrary.Shape + other-modules: Config ParseArgs Monitoring + QuickCheck.Arbitrary.Array + QuickCheck.Arbitrary.Shape Test.Base - Test.IndexSpace - Test.Mapping - Test.PrefixSum - Test.Reduction + Test.IO + Test.IO.Ptr + Test.IO.Vector + Test.Imaginary + Test.Imaginary.DotP + Test.Imaginary.SASUM + Test.Imaginary.SAXPY + Test.Prelude + Test.Prelude.Filter + Test.Prelude.IndexSpace + Test.Prelude.Mapping + Test.Prelude.PrefixSum + Test.Prelude.Reduction + Test.Prelude.Replicate + Test.Prelude.Stencil + Test.Sharing + Test.Spectral + Test.Spectral.BlackScholes + Test.Spectral.SMVM + Test.Spectral.RadixSort ghc-options: -Wall -O2 -threaded -fpedantic-bottoms - -fno-warn-orphans -fno-full-laziness -fno-excess-precision + ghc-prof-options: -auto-all + + extra-libraries: stdc++ + c-sources: examples/nofib/Test/IO/fill_with_values.cpp + examples/nofib/Test/Spectral/BlackScholes.cpp + if impl(ghc >= 7.0) ghc-options: -rtsopts if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.*, - cuda >= 0.5 && < 0.6 + build-depends: accelerate-cuda == 0.14.* + other-modules: Test.Foreign if flag(opencl) CPP-options: -DACCELERATE_OPENCL_BACKEND build-depends: accelerate-opencl == 0.1.* - build-depends: accelerate == 0.13.*, - QuickCheck >= 2.0 && < 2.6, - test-framework >= 0.5 && < 0.9, - test-framework-quickcheck2 >= 0.2 && < 0.4, + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + + if !flag(nofib) + buildable: False + else + build-depends: accelerate == 0.14.*, + accelerate-io == 0.14.*, + base == 4.6.*, + array >= 0.3, + containers >= 0.5, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + HUnit >= 1.2 && < 1.3, + QuickCheck >= 2.0 && < 2.7, + test-framework >= 0.5 && < 0.9, + test-framework-hunit >= 0.3 && < 0.4, + test-framework-quickcheck2 >= 0.2 && < 0.4, random --- The main examples program including verification and timing tests for several --- simple accelerate programs --- -Executable accelerate-examples - Main-is: Main.hs - hs-source-dirs: examples/tests - examples/tests/io - examples/tests/image-processing - examples/tests/primitives - examples/tests/simple - - other-modules: Benchmark, Config, PGM, Random, Test, Util, Validate, - - -- tests: - -- image-processing - Canny, IntegralImage, - - -- io - BlockCopy, VectorCopy, - - -- primitives - Backpermute, Fold, FoldSeg, Gather, Map, Permute, ScanSeg, - Scatter, Stencil, Stencil2, Vector, Zip, ZipWith, - - -- simple - BlackScholes, DotP, Filter, Radix, SASUM, SAXPY, - SharingRecovery, SliceExamples, SMVM, SMVM.Matrix, SMVM.MatrixMarket +-- Sparse matrix vector multiplication +-- ----------------------------------- +Executable accelerate-smvm + hs-source-dirs: examples/smvm lib + Main-is: Main.hs + other-modules: ParseArgs Monitoring + Config + Matrix + MatrixMarket + SMVM - c-sources: examples/tests/io/fill_with_values.cpp - extra-libraries: stdc++ + ghc-options: -O2 -Wall -threaded + ghc-prof-options: -auto-all - ghc-options: -Wall -O2 -threaded -fno-excess-precision if impl(ghc >= 7.0) ghc-options: -rtsopts @@ -121,42 +165,44 @@ if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.* + build-depends: accelerate-cuda == 0.14.* if flag(opencl) CPP-options: -DACCELERATE_OPENCL_BACKEND build-depends: accelerate-opencl == 0.1.* - build-depends: accelerate == 0.13.*, - accelerate-io == 0.13.*, - base == 4.*, - array >= 0.3 && < 0.5, - attoparsec >= 0.10 && < 0.11, - bytestring >= 0.9 && < 0.11, - bytestring-lexing >= 0.2 && < 0.5, - cmdargs >= 0.6 && < 0.11, - criterion >= 0.5 && < 0.9, - deepseq >= 1.1 && < 1.4, - directory >= 1.0 && < 1.3, - filepath >= 1.0 && < 1.4, - hashtables >= 1.0 && < 1.2, - mtl >= 1.1 && < 2.2, - mwc-random >= 0.8 && < 0.13, - pgm >= 0.1 && < 0.2, - pretty >= 1.0 && < 1.2, - repa >= 3.1 && < 3.3, - vector >= 0.7 && < 0.11, - vector-algorithms >= 0.4 && < 0.6 + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + if !flag(smvm) + buildable: False + else + build-depends: accelerate == 0.14.*, + base == 4.6.*, + attoparsec >= 0.10 && < 0.11, + bytestring >= 0.9 && < 0.11, + bytestring-lexing >= 0.2 && < 0.5, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + primitive >= 0.5 && < 0.6, + mwc-random >= 0.8 && < 0.14, + vector >= 0.7 && < 0.11, + vector-algorithms >= 0.4 && < 0.6 + -- A quasicrystal demo as the sum of waves in a plane -- -------------------------------------------------- Executable accelerate-crystal hs-source-dirs: examples/crystal lib Main-is: Main.hs - other-modules: Config ParseArgs + other-modules: Config ParseArgs Monitoring + ghc-options: -O2 -Wall -threaded + ghc-prof-options: -auto-all + if impl(ghc >= 7.0) ghc-options: -rtsopts @@ -165,57 +211,78 @@ if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.* + build-depends: accelerate-cuda == 0.14.* if flag(opencl) CPP-options: -DACCELERATE_OPENCL_BACKEND build-depends: accelerate-opencl == 0.1.* - build-depends: accelerate == 0.13.*, - base == 4.*, - criterion >= 0.5 && < 0.9, - fclabels >= 1.0 && < 1.2, - gloss >= 1.7 && < 1.8 + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + if !flag(crystal) + buildable: False + else + build-depends: accelerate == 0.14.*, + base == 4.6.*, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + gloss-raster-accelerate >= 1.8 && < 1.9 + -- Image edge detection -- -------------------- Executable accelerate-canny hs-source-dirs: examples/canny/src-acc lib Main-is: Main.hs - other-modules: Config ParseArgs Canny Wildfire + other-modules: Config ParseArgs Canny Wildfire Monitoring + ghc-options: -Wall -threaded -Odph -fllvm -optlo-O3 + ghc-prof-options: -auto-all if impl(ghc >= 7.0) ghc-options: -rtsopts if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.* + build-depends: accelerate-cuda == 0.14.* if flag(opencl) CPP-options: -DACCELERATE_OPENCL_BACKEND build-depends: accelerate-opencl == 0.1.* - build-depends: accelerate == 0.13.*, - accelerate-io == 0.13.*, - base == 4.*, - criterion >= 0.5 && < 0.9, - fclabels >= 1.0 && < 1.2, - repa >= 3.1 && < 3.3, - repa-io >= 3.1 && < 3.3, - vector >= 0.7 && < 0.11 + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + if !flag(canny) + buildable: False + else + build-depends: accelerate == 0.14.*, + accelerate-io == 0.14.*, + base == 4.6.*, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + repa >= 3.1 && < 3.3, + repa-io >= 3.1 && < 3.3, + vector >= 0.7 && < 0.11 + -- A simple mandelbrot generator -- ----------------------------- Executable accelerate-mandelbrot hs-source-dirs: examples/mandelbrot lib Main-is: Main.hs - other-modules: Config World Mandel ParseArgs + other-modules: Config World Mandel ParseArgs Monitoring + ghc-options: -O2 -Wall -threaded + ghc-prof-options: -auto-all + if impl(ghc >= 7.0) ghc-options: -rtsopts @@ -224,33 +291,45 @@ if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.* + build-depends: accelerate-cuda == 0.14.* if flag(opencl) CPP-options: -DACCELERATE_OPENCL_BACKEND build-depends: accelerate-opencl == 0.1.* - build-depends: accelerate == 0.13.*, - base == 4.*, - criterion >= 0.5 && < 0.9, - fclabels >= 1.0 && < 1.2, - gloss >= 1.7 && < 1.8 + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + if !flag(mandelbrot) + buildable: False + else + build-depends: accelerate == 0.14.*, + accelerate-fft == 0.14.*, + accelerate-io == 0.14.*, + base == 4.6.*, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + gloss >= 1.7 && < 1.9, + gloss-accelerate >= 1.7 && < 1.9 + -- A stable fluid simulation -- ------------------------- Executable accelerate-fluid Main-is: Main.hs hs-source-dirs: examples/fluid/src-acc lib - other-modules: Config - ParseArgs + other-modules: Config ParseArgs Monitoring Event Fluid Type World ghc-options: -O2 -Wall -threaded + ghc-prof-options: -auto-all + if impl(ghc >= 7.0) ghc-options: -rtsopts @@ -259,25 +338,32 @@ if flag(cuda) cpp-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.* + build-depends: accelerate-cuda == 0.14.* - Build-depends: accelerate == 0.13.*, - accelerate-io == 0.13.*, - base == 4.*, - bmp >= 1.2 && < 1.3, - criterion >= 0.5 && < 0.9, - fclabels >= 1.0 && < 1.2, - gloss >= 1.7 && < 1.8 + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + if !flag(fluid) + buildable: False + else + build-depends: accelerate == 0.14.*, + accelerate-io == 0.14.*, + base == 4.6.*, + bmp >= 1.2, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + gloss >= 1.7 && < 1.9 + -- Simulation of gravitational attraction between solid particles -- -------------------------------------------------------------- Executable accelerate-nbody Main-is: Main.hs hs-source-dirs: examples/n-body lib - other-modules: Config - ParseArgs + other-modules: Config ParseArgs Monitoring Common.Body Common.Dump Common.Tree @@ -290,9 +376,12 @@ Random.Array Random.Position Solver.BarnsHut - Solver.Naive + Solver.Naive1 + Solver.Naive2 ghc-options: -O2 -Wall -threaded + ghc-prof-options: -auto-all + if impl(ghc >= 7.0) ghc-options: -rtsopts @@ -301,23 +390,31 @@ if flag(cuda) cpp-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.* + build-depends: accelerate-cuda == 0.14.* - Build-depends: accelerate == 0.13.*, - base == 4.*, - criterion >= 0.5 && < 0.9, - fclabels >= 1.0 && < 1.2, - gloss >= 1.7 && < 1.8 + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + if !flag(nbody) + buildable: False + else + build-depends: accelerate == 0.14.*, + base == 4.6.*, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + gloss >= 1.7 && < 1.9, + mwc-random >= 0.8 && < 0.14 + -- A celular automata -- ------------------ Executable accelerate-smoothlife Main-is: Main.hs hs-source-dirs: examples/smoothlife lib - other-modules: Config - ParseArgs + other-modules: Config ParseArgs Monitoring SmoothLife Gloss.Draw Gloss.Event @@ -326,6 +423,8 @@ Random.Splat ghc-options: -O2 -Wall -threaded + ghc-prof-options: -auto-all + if impl(ghc >= 7.0) ghc-options: -rtsopts @@ -334,43 +433,94 @@ if flag(cuda) cpp-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.* + build-depends: accelerate-cuda == 0.14.* - Build-depends: accelerate == 0.13.*, - accelerate-fft == 0.13.*, - base == 4.*, - criterion >= 0.5 && < 0.9, - fclabels >= 1.0 && < 1.2, - gloss >= 1.7 && < 1.8 + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + if !flag(smoothlife) + buildable: False + else + build-depends: accelerate == 0.14.*, + accelerate-fft == 0.14.*, + accelerate-io == 0.14.*, + base == 4.6.*, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + gloss >= 1.7 && < 1.9, + gloss-accelerate >= 1.7 && < 1.9, + mwc-random >= 0.8 && < 0.14 + -- A password recovery tool -- ------------------------ Executable accelerate-hashcat Main-is: Main.hs hs-source-dirs: examples/hashcat lib - other-modules: Config - ParseArgs + other-modules: Config ParseArgs Monitoring Digest MD5 Util ghc-options: -O2 -Wall -threaded + ghc-prof-options: -auto-all + if impl(ghc >= 7.0) ghc-options: -rtsopts if flag(cuda) cpp-options: -DACCELERATE_CUDA_BACKEND - build-depends: accelerate-cuda == 0.13.* + build-depends: accelerate-cuda == 0.14.* - Build-depends: accelerate == 0.13.*, - base == 4.*, - bytestring >= 0.9 && < 0.11, - bytestring-lexing >= 0.2 && < 0.5, - cereal >= 0.3 && < 0.4, - criterion >= 0.5 && < 0.9, - fclabels >= 1.0 && < 1.2 + if flag(ekg) + CPP-options: -DACCELERATE_ENABLE_EKG + build-depends: ekg >= 0.3 && < 0.4 + ghc-options: -with-rtsopts=-T + + if !flag(hashcat) + buildable: False + else + build-depends: accelerate == 0.14.*, + base == 4.6.*, + bytestring >= 0.9 && < 0.11, + bytestring-lexing >= 0.2 && < 0.5, + cereal >= 0.3 && < 0.5, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + mwc-random >= 0.8 && < 0.14 + +-- FFT examples +-- ------------ + +Executable accelerate-fft + Main-is: Main.hs + hs-source-dirs: examples/fft/src-acc lib + other-modules: Config + ParseArgs + HighPass + FFT + + ghc-options: -O2 -Wall -threaded + if impl(ghc >= 7.0) + ghc-options: -rtsopts + + if flag(cuda) + cpp-options: -DACCELERATE_CUDA_BACKEND + build-depends: accelerate-cuda == 0.14.* + + if !flag(fft) + buildable: False + else + build-depends: accelerate == 0.14.*, + accelerate-io == 0.14.*, + accelerate-fft == 0.14.*, + base == 4.6.*, + criterion >= 0.5 && < 0.9, + fclabels >= 2.0 && < 2.1, + filepath >= 1.0 source-repository head diff --git a/data/hashcat/README.md b/data/hashcat/README.md new file mode 100644 --- /dev/null +++ b/data/hashcat/README.md @@ -0,0 +1,30 @@ +The `accelerate-hashcat` program attempts to recover the plain text of an MD5 +hash by comparing the unknown to the hash of every entry in a given dictionary, +which contains one word per line. + +Some \*nix systems ship with an MD5 implementation which can be used to generate +hashes, try one of: + + $ md5 -s password + MD5 ("password") = 5f4dcc3b5aa765d61d8327deb882cf99 + + $ echo -n password | md5sum + 5f4dcc3b5aa765d61d8327deb882cf99 - + +In the second example the `-n` argument to `echo` is required to omit the +trailing newline, which will change the computed hash value. + +Standard dictionaries can also be found on most systems, and can be fed directly +into the program. + + $ accelerate-hashcat -s 5f4dcc3b5aa765d61d8327deb882cf99 -d /usr/share/dict/english + +The program will also accept multiple unknowns to recover, either via multiple +`-s` arguments or read from file, one per line. + +Of course, it is more fun if we don't know what what results to expect +beforehand, in which case a dictionary of standard words won't get us too far. +Luckily, the Internet is a playground... + + $ accelerate-hashcat -d rockyou.txt md5.txt + diff --git a/data/matrices/README.md b/data/matrices/README.md new file mode 100644 --- /dev/null +++ b/data/matrices/README.md @@ -0,0 +1,21 @@ +Download from: http://www.nvidia.com/content/NV_Research/matrices.zip + +More information about these matrices is available in the following paper by +Williams et al.: + +S. Williams, L. Oliker, R. Vuduc, J. Shalf, K. Yelick, J. Demmel, "Optimization +of Sparse Matrix-Vector Multiplication on Emerging Multicore Platforms", +Supercomputing (SC), 2007. +http://www.cs.berkeley.edu/~samw/research/papers/sc07.pdf + + +GPU performance results are available in this paper: + +N. Bell and M. Garland "Efficient Sparse Matrix-Vector Multiplication on CUDA" +Technical Report NVR-2008-004, NVIDIA Corporation, Dec. 2008 +http://forums.nvidia.com/index.php?showtopic=83825 + + +All matrices are stored in the MatrixMarket file format: +http://math.nist.gov/MatrixMarket/formats.html + diff --git a/examples/canny/src-acc/Canny.hs b/examples/canny/src-acc/Canny.hs --- a/examples/canny/src-acc/Canny.hs +++ b/examples/canny/src-acc/Canny.hs @@ -131,7 +131,7 @@ dy = v0 + (2*v1) + v2 - v5 - (2*v6) - v7 -- Magnitude - mag = sqrt (dx * dx + dy + dy) + mag = sqrt (dx * dx + dy * dy) -- Direction -- @@ -145,7 +145,7 @@ -- Try to avoid doing explicit tests, to avoid warp divergence undef = abs dx <=* low &&* abs dy <=* low - dir = boolToInt (A.not undef) * ((64 * (1 + A.floor norm `mod` 4)) `A.min` 255) + dir = boolToInt (A.not undef) * ((64 * (1 + A.floor norm `mod` 4)) `min` 255) in lift (mag, dir) @@ -184,7 +184,7 @@ (fwd, _) = unlift $ magdir ! lift (clamp (Z :. y+offsety :. x+offsetx)) :: (Exp Float, Exp Int) (rev, _) = unlift $ magdir ! lift (clamp (Z :. y-offsety :. x-offsetx)) :: (Exp Float, Exp Int) - clamp (Z:.u:.v) = Z :. 0 `A.max` u `A.min` (h-1) :. 0 `A.max` v `A.min` (w-1) + clamp (Z:.u:.v) = Z :. 0 `max` u `min` (h-1) :. 0 `max` v `min` (w-1) -- Try to avoid doing explicit tests to avoid warp divergence. -- diff --git a/examples/canny/src-acc/Main.hs b/examples/canny/src-acc/Main.hs --- a/examples/canny/src-acc/Main.hs +++ b/examples/canny/src-acc/Main.hs @@ -2,8 +2,9 @@ import Canny import Config -import Wildfire +import Monitoring import ParseArgs +import Wildfire import Prelude as P import Data.Label @@ -21,7 +22,9 @@ main :: IO () main - = do argv <- getArgs + = do + beginMonitoring + argv <- getArgs (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv (fileIn, fileOut) <- case nops of (i:o:_) -> return (i,o) diff --git a/examples/crystal/Main.hs b/examples/crystal/Main.hs --- a/examples/crystal/Main.hs +++ b/examples/crystal/Main.hs @@ -8,35 +8,22 @@ module Main where +import Prelude as P import Config +import Monitoring import ParseArgs -import Data.Word -import Data.Label -import Foreign.Ptr -import Control.Monad -import Control.Exception +import Data.Label ( get ) import Criterion.Main ( defaultMainWith, bench, whnf ) -import Foreign.ForeignPtr import System.Environment -import System.IO.Unsafe -import Data.Array.Accelerate ( Array, Scalar, Exp, Acc, DIM2, Z(..), (:.)(..) ) -import qualified Data.Array.Accelerate as A -import qualified Graphics.Gloss as G -import Data.Array.Accelerate.Array.Data ( ptrsOfArrayData ) -import Data.Array.Accelerate.Array.Sugar ( Array(..) ) +import Data.Array.Accelerate as A hiding ( size ) +import Graphics.Gloss.Accelerate.Raster.Field as G -- Types ---------------------------------------------------------------------- --- | Real value -type R = Float - --- | Point on the 2D plane. -type R2 = (R, R) - -- | Angle in radians. -type Angle = R +type Angle = Float -- | Angle offset used for animation. type Phi = Float @@ -47,149 +34,87 @@ -- | Feature size of visualisation. type Scale = Float --- | Size of image to render. -type Size = Int - --- | How many times to duplicate each pixel / image zoom. -type Zoom = Int - --- | Type of the generated image data -type RGBA = Word32 -type Bitmap = Array DIM2 RGBA - --- | Action to render a frame -type Render = Scalar Phi -> Bitmap +-- | Time in seconds since the program started. +type Time = Float -- Point ---------------------------------------------------------------------- -- | Compute a single point of the visualisation. -quasicrystal :: Size -> Scale -> Degree -> Acc (Scalar Phi) -> Exp DIM2 -> Exp R -quasicrystal size scale degree phi p - = waves degree phi $ point size scale p +quasicrystal :: Scale -> Degree -> Exp Time -> Exp Point -> Exp Color +quasicrystal scale degree time p + = let -- Scale the time to be the phi value of the animation. + -- The action seems to slow down at increasing phi values, so we + -- increase phi faster as time moves on. + phi = 1 + (time ** 1.5) * 0.005 + in rampColour + $ waves degree phi + $ point scale p + -- | Sum up all the waves at a particular point. -waves :: Degree -> Acc (Scalar Phi) -> Exp R2 -> Exp R +waves :: Degree -> Exp Phi -> Exp Point -> Exp Float waves degree phi x = wrap $ waver degree 0 where + th = pi / phi + waver :: Int -> Exp Float -> Exp Float waver n acc | n == 0 = acc - | otherwise = waver (n - 1) (acc + wave (A.constant (fromIntegral n) * phi') x) - - phi' - = A.the phi + | otherwise = waver (n - 1) (acc + wave (A.constant (P.fromIntegral n) * th) x) wrap n = let n_ = A.truncate n :: Exp Int n' = n - A.fromIntegral n_ in - (n_ `rem` 2 A./=* 0) A.? (1-n', n') - + A.odd n_ A.? (1-n', n') -- | Generate the value for a single wave. -wave :: Exp Angle -> Exp R2 -> Exp R +wave :: Exp Angle -> Exp Point -> Exp Float wave th pt = (cos (cth*x + sth*y) + 1) / 2 where - (x,y) = A.unlift pt + (x, y) = xyOfPoint pt cth = cos th sth = sin th -- | Convert an image point to a point on our wave plane. -point :: Size -> Scale -> Exp DIM2 -> Exp R2 -point size scale ix = A.lift (adj x, adj y) - where - (Z:.x:.y) = A.unlift ix - denom = A.constant (fromIntegral size - 1) - adj n = A.constant scale * ((2 * A.fromIntegral n / denom) - 1) - - --- Computation ---------------------------------------------------------------- --- | Compute a single frame -makeImage :: Size -> Scale -> Degree -> Acc (Scalar Phi) -> Acc Bitmap -makeImage size scale degree phi = arrPixels +point :: Scale -> Exp Point -> Exp Point +point scale pt = makePoint (x * scale') (y * scale') where - -- Compute values for the wave density at each point in the range [0..1] - arrVals :: Acc (Array DIM2 Float) - arrVals = A.generate - (A.constant $ Z :. size :. size) - (quasicrystal size scale degree phi) - - -- Convert the [0..1] values of wave density to an RGBA flat image - arrPixels :: Acc Bitmap - arrPixels = A.map rampColour arrVals - + (x, y) = xyOfPoint pt + scale' = A.constant scale -- | Colour ramp from red to white, convert into RGBA -rampColour :: Exp Float -> Exp RGBA -rampColour v = ra + g + b - where - u = 0 `A.max` v `A.min` 1 - ra = 0xFF0000FF - g = A.truncate ((0.4 + (u * 0.6)) * 0xFF) * 0x10000 - b = A.truncate (u * 0xFF) * 0x100 - - --- Rendering ------------------------------------------------------------------ - --- | Compute a single frame of the animation as a Gloss picture. --- -frame :: Render -> Size -> Zoom -> Float -> G.Picture -frame render size zoom time = G.scale zoom' zoom' pic - where - -- Scale the time to be the phi value of the animation. The action seems to - -- slow down at increasing phi values, so we increase phi faster as time - -- moves on. - x = 1 + (time ** 1.5) * 0.005 - - -- lift to a singleton array, else we would generate new code with the - -- constant embedded at every frame - phi = A.fromList Z [pi / x] - - -- Compute the image - arrPixels = render phi - - -- Wrap the array data in a Foreign pointer and turn into a Gloss picture - {-# NOINLINE rawData #-} - rawData = let (Array _ adata) = arrPixels - ((),ptr) = ptrsOfArrayData adata - in - unsafePerformIO $ newForeignPtr_ (castPtr ptr) - - pic = G.bitmapOfForeignPtr - size size -- raw image size - rawData -- the image data - False -- don't cache this in texture memory - - -- Zoom the image so we get a bigger window. - zoom' = fromIntegral zoom +rampColour :: Exp Float -> Exp Color +rampColour v = rawColor 1 (0.4 + (v * 0.6)) v 1 -- Main ----------------------------------------------------------------------- main :: IO () -main - = do argv <- getArgs - (config, crit, nops) <- parseArgs optHelp optBackend options defaults header footer argv - let size = get optSize config - zoom = get optZoom config - scale = get optScale config - degree = get optDegree config - backend = get optBackend config - render = run1 backend $ makeImage size scale degree - force arr = A.indexArray arr (Z:.0:.0) `seq` arr +main = do - void . evaluate $ render (A.fromList Z [0]) + beginMonitoring + argv <- getArgs + (config, crit, nops) <- parseArgs optHelp optBackend options defaults header footer argv - if get optBench config - then withArgs nops $ defaultMainWith crit (return ()) - [ bench "crystal" $ whnf (force . render) (A.fromList Z [1.0]) ] + let size = get optSize config + zoom = get optZoom config + scale = get optScale config + degree = get optDegree config + backend = get optBackend config -#ifndef ACCELERATE_ENABLE_GUI - else return () -#else - else G.animate - (G.InWindow "Quasicrystals" (size * zoom, size * zoom) (10, 10)) - (G.black) - (frame render size zoom) -#endif + -- for benchmarking + force arr = A.indexArray arr (Z:.0:.0) `seq` arr + frame = run1 backend + $ makeField size size (\time -> quasicrystal scale degree (the time)) + + if get optBench config + then withArgs nops $ defaultMainWith crit (return ()) + [ bench "crystal" $ whnf (force . frame) (A.fromList Z [1.0]) ] + + else G.animateFieldWith + (run1 backend) + (InWindow "Quasicrystals" (size * zoom, size * zoom) (10, 10)) + (zoom, zoom) + (quasicrystal scale degree) diff --git a/examples/fft/src-acc/Config.hs b/examples/fft/src-acc/Config.hs new file mode 100644 --- /dev/null +++ b/examples/fft/src-acc/Config.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Config where + +import ParseArgs +import Data.Label + +data Config + = Config + { + -- Standard options + _configBackend :: Backend + , _configHelp :: Bool + , _configBenchmark :: Bool + + -- How to execute the program + , _configCutoff :: Int + , _configClip :: Int + + } + +$(mkLabels [''Config]) + +defaults :: Config +defaults = Config + { + _configBackend = maxBound + , _configHelp = False + , _configBenchmark = False + + , _configCutoff = 100 + , _configClip = 128 + } + + +options :: [OptDescr (Config -> Config)] +options = + [ Option [] ["cutoff"] + (ReqArg (set configCutoff . read) "INT") + (describe configCutoff "high-pass filtering cut-off value") + + , Option [] ["clip"] + (ReqArg (set configClip . read) "INT") + (describe configClip "fft magnitude clipping value") + + , Option [] ["benchmark"] + (NoArg (set configBenchmark True)) + (describe configBenchmark "run criterion benchmark") + + , Option ['h', '?'] ["help"] + (NoArg (set configHelp True)) + "show this help message" + ] + where + describe f msg + = msg ++ " (" ++ show (get f defaults) ++ ")" + + +-- | Process the command line options +-- + +header :: [String] +header = + [ "accelerate-fft (c) [2007..2013] The Accelerate Team" + , "" + , "Usage: accelerate-fft [OPTIONS] fileIn.bmp fileOut.bmp" + , "" + , "Image dimensions must be a power of two, eg 128x512 or 64x256" + , "" + , "For FFT, the output magnitude has a high dynamic range. We need to clip it" + , "otherwise most of the pixels in the output BMP will be black. Start with a" + , "value equal to about the width of the image (eg 512)" + , "" + ] + +footer :: [String] +footer = [] + diff --git a/examples/fft/src-acc/FFT.hs b/examples/fft/src-acc/FFT.hs new file mode 100644 --- /dev/null +++ b/examples/fft/src-acc/FFT.hs @@ -0,0 +1,36 @@ + +module FFT + where + +import Prelude as P +import Data.Array.Accelerate as A +import Data.Array.Accelerate.IO as A +import Data.Array.Accelerate.Math.FFT as A +import Data.Array.Accelerate.Math.Complex as A +import Data.Array.Accelerate.Math.DFT.Centre as A + + +imageFFT :: Int -> Int -> Int -> Acc (Array DIM2 RGBA32) -> Acc (Array DIM2 RGBA32, Array DIM2 RGBA32) +imageFFT width height cutoff img = lift (arrMag, arrPhase) + where + -- Load in the image luminance + arrComplex :: Acc (Array DIM2 (Complex Float)) + arrComplex = A.map (\r -> lift (r :+ constant 0)) + $ A.map luminanceOfRGBA32 img + + -- Apply the centering transform so that the output has the zero frequency + -- in the middle of the image + arrCentered = centre2D arrComplex + + -- Do the transform + arrFreq = fft2D' Forward width height arrCentered + + -- Clip the magnitude of the transformed array + clipMag = the (unit (constant (P.fromIntegral cutoff))) + clip x = x >* clipMag ? ( 1 , x / clipMag ) + arrMag = A.map (rgba32OfLuminance . clip . magnitude) arrFreq + + -- Get the phase of the transformed array + scale x = (phase x + pi) / (2 * pi) + arrPhase = A.map (rgba32OfLuminance . scale) arrFreq + diff --git a/examples/fft/src-acc/HighPass.hs b/examples/fft/src-acc/HighPass.hs new file mode 100644 --- /dev/null +++ b/examples/fft/src-acc/HighPass.hs @@ -0,0 +1,51 @@ + +module HighPass + where + +import Prelude as P +import Data.Array.Accelerate as A +import Data.Array.Accelerate.IO as A +import Data.Array.Accelerate.Math.FFT as A +import Data.Array.Accelerate.Math.Complex as A +import Data.Array.Accelerate.Math.DFT.Centre as A + + +highpassFFT :: Int -> Int -> Int -> Acc (Array DIM2 RGBA32) -> Acc (Array DIM2 RGBA32) +highpassFFT width height cutoff img = A.map A.packRGBA32 (A.zip4 r' g' b' a) + where + (r,g,b,a) = A.unzip4 $ A.map unpackRGBA32 img + r' = transform width height cutoff r + g' = transform width height cutoff g + b' = transform width height cutoff b + + +transform :: Int -> Int -> Int -> Acc (Array DIM2 Word8) -> Acc (Array DIM2 Word8) +transform width height cutoff' arrReal = arrResult + where + cutoff = the (unit (constant cutoff')) + + arrComplex :: Acc (Array DIM2 (Complex Float)) + arrComplex = A.map (\r -> lift (A.fromIntegral r :+ constant 0)) arrReal + + -- Do the 2D transform + arrCentered = centre2D arrComplex + arrFreq = fft2D' Forward width height arrCentered + + -- Zap out the low-frequency components + centreX = constant (width `div` 2) + centreY = constant (height `div` 2) + + zap ix = let (Z :. y :. x) = unlift ix + inx = x >* centreX - cutoff &&* x <* centreX + cutoff + iny = y >* centreY - cutoff &&* y <* centreY + cutoff + in + inx &&* iny ? (constant (0 :+ 0), arrFreq A.! ix) + + arrFilt = A.generate (A.shape arrFreq) zap + + -- Do the inverse transform to get back to image space + arrInv = fft2D' Inverse width height arrFilt + + -- The magnitude of the transformed array + arrResult = A.map (A.truncate . magnitude) arrInv + diff --git a/examples/fft/src-acc/Main.hs b/examples/fft/src-acc/Main.hs new file mode 100644 --- /dev/null +++ b/examples/fft/src-acc/Main.hs @@ -0,0 +1,62 @@ + +module Main where + +import Config +import FFT +import HighPass +import ParseArgs + +import Prelude as P +import Data.Label +import Criterion.Main ( defaultMainWith, bench, whnf ) +import System.Exit +import System.Environment +import System.FilePath + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.IO as A + +-- Main routine ---------------------------------------------------------------- + +main :: IO () +main + = do argv <- getArgs + (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv + (fileIn, fileOut) <- case nops of + (i:o:_) -> return (i,o) + _ -> parseArgs configHelp configBackend options defaults header footer ("--help":argv) + >> exitSuccess + + -- Read in the image file + img <- either (error . show) id `fmap` A.readImageFromBMP fileIn + let Z :. height :. width = A.arrayShape img + + -- Set up the operations + let (file,bmp) = splitExtension fileOut + fileMag = file P.++ "-mag" <.> bmp + filePhase = file P.++ "-phase" <.> bmp + fileHP = file P.++ "-hp" <.> bmp + + cutoff = get configCutoff conf + clip = get configClip conf + backend = get configBackend conf + + if P.not (get configBenchmark conf) + then do + -- Write out the images to file + -- + let highpass = run backend $ highpassFFT width height cutoff (use img) + (mag, phase) = run backend $ imageFFT width height clip (use img) + + writeImageToBMP fileHP highpass + writeImageToBMP fileMag mag + writeImageToBMP filePhase phase + + else do + -- Run the operations through criterion + -- + withArgs (P.drop 2 nops) $ defaultMainWith cconf (return ()) + [ bench "highpass" $ whnf (run1 backend (highpassFFT width height cutoff)) img + , bench "fft" $ whnf (run1 backend (imageFFT width height clip)) img + ] + diff --git a/examples/fluid/src-acc/Config.hs b/examples/fluid/src-acc/Config.hs --- a/examples/fluid/src-acc/Config.hs +++ b/examples/fluid/src-acc/Config.hs @@ -58,7 +58,7 @@ { _viscosity = 0 , _diffusion = 0 , _timestep = 0.1 - , _inputDensity = 100 + , _inputDensity = 50 , _inputVelocity = 20 , _simulationSteps = 40 , _simulationWidth = 100 @@ -156,7 +156,7 @@ ] where parse f x = set f (read x) - describe f msg = msg ++ " (" ++ show (get f defaults) ++ ")" + describe f msg = msg P.++ " (" P.++ show (get f defaults) P.++ ")" init_checks = set setupDensity (FromFunction makeDensity_checks) . set setupVelocity (FromFunction makeField_empty) @@ -233,7 +233,7 @@ yk1 = abs ty >* 3*pi/2 ? (0 , cos ty) d1 = xk1 * yk1 in - 0 `A.max` d1 + 0 `max` d1 in run backend $ A.generate (constant (Z:.height:.width)) checks diff --git a/examples/fluid/src-acc/Fluid.hs b/examples/fluid/src-acc/Fluid.hs --- a/examples/fluid/src-acc/Fluid.hs +++ b/examples/fluid/src-acc/Fluid.hs @@ -144,7 +144,7 @@ (u, v) = A.unlift (vf A.! ix) -- backtrack densities based on velocity field - clamp z = A.max (-0.5) . A.min (z + 0.5) + clamp z = max (-0.5) . min (z + 0.5) x = width `clamp` (A.fromIntegral i - A.constant dt * width * u) y = height `clamp` (A.fromIntegral j - A.constant dt * height * v) diff --git a/examples/fluid/src-acc/Main.hs b/examples/fluid/src-acc/Main.hs --- a/examples/fluid/src-acc/Main.hs +++ b/examples/fluid/src-acc/Main.hs @@ -8,6 +8,7 @@ module Main where import Config +import Monitoring import ParseArgs import World import Fluid @@ -24,6 +25,7 @@ main :: IO () main = do + beginMonitoring argv <- getArgs (c,crit,noms) <- parseArgs optHelp optBackend options defaults header footer argv opt <- initialiseConfig c diff --git a/examples/hashcat/Main.hs b/examples/hashcat/Main.hs --- a/examples/hashcat/Main.hs +++ b/examples/hashcat/Main.hs @@ -1,9 +1,10 @@ module Main where -import MD5 -import Digest import Config +import Digest +import MD5 +import Monitoring import ParseArgs import Util @@ -21,6 +22,7 @@ main :: IO () main = do + beginMonitoring argv <- getArgs (conf, _cconf, files) <- parseArgs configHelp configBackend options defaults header footer argv @@ -70,7 +72,7 @@ -- And print a summary of results -- let percent = fromIntegral r / fromIntegral t * 100.0 :: Double - persec = fromIntegral (t * entries) / trec + persec = (fromIntegral t * fromIntegral entries) / trec putStrLn $ printf "\nRecovered %d/%d (%.2f %%) digests in %s, %s" r t percent (showFFloatSIBase (Just 2) 1000 trec "s") diff --git a/examples/mandelbrot/Main.hs b/examples/mandelbrot/Main.hs --- a/examples/mandelbrot/Main.hs +++ b/examples/mandelbrot/Main.hs @@ -6,43 +6,30 @@ import World import Config +import Monitoring import ParseArgs import Data.Label import Control.Monad -import Foreign.Ptr -import Foreign.ForeignPtr -import System.IO.Unsafe import System.Environment ( getArgs, withArgs ) import Criterion.Main ( defaultMainWith, bench, whnf ) -import Data.Array.Accelerate.Array.Data ( ptrsOfArrayData ) -import Data.Array.Accelerate.Array.Sugar ( Array(..) ) import Prelude as P import Data.Array.Accelerate as A +import Graphics.Gloss.Accelerate.Data.Picture as G import qualified Graphics.Gloss as G -- Main ------------------------------------------------------------------------ makePicture :: World -> G.Picture -makePicture world = pic - where - arrPixels = renderWorld world - (Z:.h:.w) = arrayShape arrPixels - - {-# NOINLINE rawData #-} - rawData = let (Array _ adata) = arrPixels - ((), ptr) = ptrsOfArrayData adata - in - unsafePerformIO $ newForeignPtr_ (castPtr ptr) - - pic = G.bitmapOfForeignPtr w h rawData False +makePicture world = bitmapOfArray (renderWorld world) False main :: IO () main = do + beginMonitoring argv <- getArgs (conf, cconf, rest) <- parseArgs optHelp optBackend options defaults header footer argv @@ -84,7 +71,7 @@ unless (P.null rest) $ - putStrLn $ "Warning: unrecognized options: " ++ show rest + putStrLn $ "Warning: unrecognized options: " P.++ show rest mandel diff --git a/examples/mandelbrot/Mandel.hs b/examples/mandelbrot/Mandel.hs --- a/examples/mandelbrot/Mandel.hs +++ b/examples/mandelbrot/Mandel.hs @@ -16,16 +16,13 @@ import Prelude as P import Data.Array.Accelerate as A import Data.Array.Accelerate.IO as A +import Data.Array.Accelerate.Math.Complex -- Types ----------------------------------------------------------------------- -- Current view into the complex plane type View a = (a, a, a, a) --- Complex numbers -type Complex a = (a, a) -type ComplexPlane a = Array DIM2 (Complex a) - -- Image data type Bitmap = Array DIM2 RGBA32 @@ -39,9 +36,7 @@ -- -- Z_{n+1} = c + Z_n^2 -- --- This is applied until the iteration limit is reached, regardless of whether --- or not the pixel has diverged. This implies wasted work, but no thread --- divergence. +-- This returns the iteration depth 'i' at divergence. -- mandelbrot :: forall a. (Elt a, IsFloating a) @@ -49,82 +44,50 @@ -> Int -> Int -> Acc (Scalar (View a)) - -> Acc (Array DIM2 (Complex a,Int)) -mandelbrot screenX screenY depth view - = foldr ($) zs0 (P.take depth (repeat go)) - where - cs = genPlane screenX screenY view - zs0 = mkinit cs - - go :: Acc (Array DIM2 (Complex a, Int)) -> Acc (Array DIM2 (Complex a, Int)) - go = A.zipWith iter cs - - -genPlane :: (Elt a, IsFloating a) => Int -> Int -> Acc (Scalar (View a)) -> Acc (ComplexPlane a) -genPlane screenX screenY view - = generate (constant (Z:.screenY:.screenX)) - (\ix -> let pr = unindex2 ix - x = A.fromIntegral (A.snd pr :: Exp Int) - y = A.fromIntegral (A.fst pr :: Exp Int) - in - lift ( xmin + (x * sizex) / viewx - , ymin + (y * sizey) / viewy)) + -> Acc (Array DIM2 Int32) +mandelbrot screenX screenY depth view = + generate (constant (Z:.screenY:.screenX)) + (\ix -> let c = initial ix + in A.snd $ A.while (\zi -> A.snd zi <* lIMIT &&* dot (A.fst zi) <* 4) + (\zi -> lift1 (next c) zi) + (lift (c, constant 0))) where - (xmin,ymin,xmax,ymax) = unlift (the view) - - sizex = xmax - xmin - sizey = ymax - ymin - - viewx = constant (P.fromIntegral screenX) - viewy = constant (P.fromIntegral screenY) - - -next :: (Elt a, IsNum a) => Exp (Complex a) -> Exp (Complex a) -> Exp (Complex a) -next c z = c `plus` (z `times` z) - - -plus :: (Elt a, IsNum a) => Exp (Complex a) -> Exp (Complex a) -> Exp (Complex a) -plus = lift2 f - where f :: (Elt a, IsNum a) => (Exp a, Exp a) -> (Exp a, Exp a) -> (Exp a, Exp a) - f (x1,y1) (x2,y2) = (x1+x2, y1+y2) - -times :: forall a. (Elt a, IsNum a) => Exp (Complex a) -> Exp (Complex a) -> Exp (Complex a) -times = lift2 f - where f :: (Elt a, IsNum a) => (Exp a, Exp a) -> (Exp a, Exp a) -> (Exp a, Exp a) - f (x,y) (x',y') = (x*x'-y*y', x*y'+y*x') + -- The view plane + (xmin,ymin,xmax,ymax) = unlift (the view) + sizex = xmax - xmin + sizey = ymax - ymin -dot :: forall a. (Elt a, IsNum a) => Exp (Complex a) -> Exp a -dot = lift1 f - where f :: (Elt a, IsNum a) => (Exp a, Exp a) -> Exp a - f (x,y) = x*x + y*y + viewx = constant (P.fromIntegral screenX) + viewy = constant (P.fromIntegral screenY) + -- initial conditions for a given pixel in the window, translated to the + -- corresponding point in the complex plane + initial :: Exp DIM2 -> Exp (Complex a) + initial ix = lift ( (xmin + (x * sizex) / viewx) :+ (ymin + (y * sizey) / viewy) ) + where + pr = unindex2 ix + x = A.fromIntegral (A.snd pr :: Exp Int) + y = A.fromIntegral (A.fst pr :: Exp Int) -iter :: forall a. (Elt a, IsNum a) => Exp (Complex a) -> Exp (Complex a, Int) -> Exp (Complex a, Int) -iter c zi = f (A.fst zi) (A.snd zi) - where - f :: Exp (Complex a) -> Exp Int -> Exp (Complex a, Int) - f z i = - let z' = next c z - in (dot z' >* 4) ? ( zi , lift (z', i+1) ) + -- take a single step of the iteration + next :: Exp (Complex a) -> (Exp (Complex a), Exp Int32) -> (Exp (Complex a), Exp Int32) + next c (z, i) = (c + (z * z), i+1) + dot c = let r :+ i = unlift c + in r*r + i*i -mkinit :: Elt a => Acc (ComplexPlane a) -> Acc (Array DIM2 (Complex a, Int)) -mkinit cs = A.zip cs (A.fill (A.shape cs) 0) + lIMIT = constant (P.fromIntegral depth) -- Rendering ------------------------------------------------------------------- -prettyRGBA :: forall a. (Elt a, IsFloating a) => Exp Int -> Exp (Complex a, Int) -> Exp RGBA32 -prettyRGBA lIMIT s = - let cmax = A.fromIntegral lIMIT - c = A.fromIntegral (A.snd s) - in - c ==* cmax ? ( 0xFF000000, escapeToColour (cmax - c) ) +prettyRGBA :: Exp Int32 -> Exp Int32 -> Exp RGBA32 +prettyRGBA cmax c = c ==* cmax ? ( 0xFF000000, escapeToColour (cmax - c) ) -- Directly convert the iteration count on escape to a colour. The base set -- (x,y,z) yields a dark background with light highlights. -- -escapeToColour :: Exp Int -> Exp RGBA32 +escapeToColour :: Exp Int32 -> Exp RGBA32 escapeToColour m = constant 0xFFFFFFFF - (packRGBA32 $ lift (x,y,z,w)) where x = constant 0 diff --git a/examples/mandelbrot/World.hs b/examples/mandelbrot/World.hs --- a/examples/mandelbrot/World.hs +++ b/examples/mandelbrot/World.hs @@ -15,6 +15,7 @@ import Config import ParseArgs +import Prelude as P import Data.Char import Data.Label import Data.Array.Accelerate as A @@ -65,7 +66,7 @@ render :: (Elt a, IsFloating a) => Render a render = run1 backend - $ A.map (prettyRGBA (constant limit)) + $ A.map (prettyRGBA (constant (P.fromIntegral limit))) . mandelbrot width height limit in case f of @@ -161,13 +162,13 @@ -- ------------- zooming :: World :-> Maybe Zoom -zooming = lens (\(World _ _ z _ _) -> z) (\z (World p r _ h v) -> World p r z h v) +zooming = lens (\(World _ _ z _ _) -> z) (\f (World p r z h v) -> World p r (f z) h v) horizontal :: World :-> Maybe Move -horizontal = lens (\(World _ _ _ h _) -> h) (\h (World p r z _ v) -> World p r z h v) +horizontal = lens (\(World _ _ _ h _) -> h) (\f (World p r z h v) -> World p r z (f h) v) vertical :: World :-> Maybe Move -vertical = lens (\(World _ _ _ _ v) -> v) (\v (World p r z h _) -> World p r z h v) +vertical = lens (\(World _ _ _ _ v) -> v) (\f (World p r z h v) -> World p r z h (f v)) convertView :: (Real a, Fractional b) => View a -> View b convertView (x,y,x',y') = (realToFrac x, realToFrac y, realToFrac x', realToFrac y') diff --git a/examples/n-body/Common/Body.hs b/examples/n-body/Common/Body.hs --- a/examples/n-body/Common/Body.hs +++ b/examples/n-body/Common/Body.hs @@ -63,14 +63,12 @@ -- computes the component of the Sum for two bodies i and j. -- accel :: Exp R -- ^ Smoothing parameter - -> Exp Body -- ^ The point being accelerated - -> Exp Body -- ^ Neighbouring point + -> Exp PointMass -- ^ The point being accelerated + -> Exp PointMass -- ^ Neighbouring point -> Exp Accel -accel epsilon bodyi bodyj = s *. r +accel epsilon pmi pmj = s *. r where - pmi = pointMassOfBody bodyi - pmj = pointMassOfBody bodyj mj = massOfPointMass pmj r = positionOfPointMass pmj .-. positionOfPointMass pmi diff --git a/examples/n-body/Common/World.hs b/examples/n-body/Common/World.hs --- a/examples/n-body/Common/World.hs +++ b/examples/n-body/Common/World.hs @@ -24,14 +24,15 @@ -- | Move bodies under the influence of acceleration -- advanceBodies - :: (Acc (Vector Body) -> Acc (Vector Accel)) -- ^ Function to compute accelerations at each point + :: (Acc (Vector PointMass) -> Acc (Vector Accel)) -- ^ Function to compute accelerations at each point -> Acc (Scalar Time) -- ^ Time step -> Acc (Vector Body) -- ^ Bodies -> Acc (Vector Body) advanceBodies calcAccels timeStep bodies = let -- Calculate the accelerations on each body. - accels = calcAccels bodies + accels = calcAccels + $ A.map pointMassOfBody bodies -- Apply the accelerations to the bodies and advance them advance b a = let m = massOfPointMass (pointMassOfBody b) diff --git a/examples/n-body/Config.hs b/examples/n-body/Config.hs --- a/examples/n-body/Config.hs +++ b/examples/n-body/Config.hs @@ -10,7 +10,7 @@ import Data.Label -data Solver = Naive | BarnsHut +data Solver = Naive1 | Naive2 | BarnsHut deriving (Enum, Bounded, Show) @@ -53,7 +53,7 @@ defaults = Config { _configBackend = maxBound - , _configSolver = Naive -- no barns-hut yet! + , _configSolver = Naive2 -- no barns-hut yet! , _configWindowSize = 1000 , _configShouldDrawTree = False -- no barns-hut yet! @@ -137,7 +137,8 @@ ] where solver algorithm - | a `elem` ["n", "naive"] = Naive + | a `elem` ["n1", "naive1"] = Naive1 + | a `elem` ["n2", "naive2"] = Naive2 | a `elem` ["bh", "barnshut", "barns-hut"] = BarnsHut | otherwise = error $ "Unknown solver method: " ++ algorithm where diff --git a/examples/n-body/Main.hs b/examples/n-body/Main.hs --- a/examples/n-body/Main.hs +++ b/examples/n-body/Main.hs @@ -4,6 +4,7 @@ -- friends import Config +import Monitoring import ParseArgs import Common.Body import Common.World @@ -12,7 +13,8 @@ import Gloss.Simulate import Random.Array import Random.Position -import qualified Solver.Naive as Naive +import qualified Solver.Naive1 as Naive1 +import qualified Solver.Naive2 as Naive2 import qualified Solver.BarnsHut as BarnsHut import Data.Array.Accelerate as A hiding ( size ) @@ -27,11 +29,13 @@ main :: IO () main - = do argv <- getArgs + = do beginMonitoring + argv <- getArgs (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv let solver = case get configSolver conf of - Naive -> Naive.calcAccels + Naive1 -> Naive1.calcAccels + Naive2 -> Naive2.calcAccels BarnsHut -> BarnsHut.calcAccels n = get configBodyCount conf diff --git a/examples/n-body/Solver/BarnsHut.hs b/examples/n-body/Solver/BarnsHut.hs --- a/examples/n-body/Solver/BarnsHut.hs +++ b/examples/n-body/Solver/BarnsHut.hs @@ -7,6 +7,6 @@ -- | Calculate accelerations on the particles using the Barns-Hut algorithm -- -calcAccels :: Exp R -> Acc (Vector Body) -> Acc (Vector Accel) +calcAccels :: Exp R -> Acc (Vector PointMass) -> Acc (Vector Accel) calcAccels = error "BarnsHut.calcAccels: not implemented yet!" diff --git a/examples/n-body/Solver/Naive.hs b/examples/n-body/Solver/Naive.hs deleted file mode 100644 --- a/examples/n-body/Solver/Naive.hs +++ /dev/null @@ -1,23 +0,0 @@ - -module Solver.Naive - where - -import Common.Type -import Common.Body -import Common.Util - -import Data.Array.Accelerate as A - - --- | Calculate accelerations on these particles in a naïve O(n^2) way --- -calcAccels :: Exp R -> Acc (Vector Body) -> Acc (Vector Accel) -calcAccels epsilon bodies - = let n = A.size bodies - - cols = A.replicate (lift $ Z :. n :. All) bodies - rows = A.replicate (lift $ Z :. All :. n) bodies - - in - A.fold (.+.) (vec 0) $ A.zipWith (accel epsilon) rows cols - diff --git a/examples/n-body/Solver/Naive1.hs b/examples/n-body/Solver/Naive1.hs new file mode 100644 --- /dev/null +++ b/examples/n-body/Solver/Naive1.hs @@ -0,0 +1,30 @@ + +module Solver.Naive1 + where + +import Common.Type +import Common.Body +import Common.Util + +import Data.Array.Accelerate as A + + +-- | Calculate accelerations on these particles in a naïve O(n^2) way. +-- +-- Replicate the bodies out by rows and columns, zip them together to get all +-- interactions, and then perform a parallel reduce along innermost dimension +-- to get the total contribution for each particle. +-- +-- This relies on array fusion to combine the replicates into the body of the +-- reduction, otherwise we quickly exhaust the device memory. +-- +calcAccels :: Exp R -> Acc (Vector PointMass) -> Acc (Vector Accel) +calcAccels epsilon bodies + = let n = A.size bodies + + cols = A.replicate (lift $ Z :. n :. All) bodies + rows = A.replicate (lift $ Z :. All :. n) bodies + + in + A.fold (.+.) (vec 0) $ A.zipWith (accel epsilon) rows cols + diff --git a/examples/n-body/Solver/Naive2.hs b/examples/n-body/Solver/Naive2.hs new file mode 100644 --- /dev/null +++ b/examples/n-body/Solver/Naive2.hs @@ -0,0 +1,25 @@ + +module Solver.Naive2 + where + +import Common.Type +import Common.Body +import Common.Util + +import Data.Array.Accelerate as A + + +-- | Calculate accelerations on these particles in a naïve O(n^2) way. +-- +-- This maps a _sequential_ reduction to get the total contribution for this +-- body from all other bodies in the system. +-- +calcAccels :: Exp R -> Acc (Vector PointMass) -> Acc (Vector Accel) +calcAccels epsilon bodies + = let move body = A.sfoldl (\acc next -> acc .+. accel epsilon body next) + (vec 0) + (constant Z) + bodies + in + A.map move bodies + diff --git a/examples/nofib/Config.hs b/examples/nofib/Config.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Config.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Config where + +import ParseArgs +import Data.Label +import Data.Maybe +import Data.Monoid +import System.Exit + +import qualified Test.Framework as TestFramework +import qualified Criterion.Main as Criterion +import qualified Criterion.Config as Criterion + + +data Config + = Config + { + -- Standard options + _configBackend :: Backend + , _configHelp :: Bool + , _configBenchmark :: Bool + , _configQuickCheck :: Bool + + -- Which QuickCheck test types to enable? + , _configDouble :: Bool + , _configFloat :: Bool + , _configInt64 :: Bool + , _configInt32 :: Bool + , _configInt16 :: Bool + , _configInt8 :: Bool + , _configWord64 :: Bool + , _configWord32 :: Bool + , _configWord16 :: Bool + , _configWord8 :: Bool + } + deriving Show + +$(mkLabels [''Config]) + + +defaults :: Config +defaults = Config + { + _configBackend = maxBound + , _configHelp = False + , _configBenchmark = True + , _configQuickCheck = True + + , _configDouble = False + , _configFloat = False + , _configInt64 = True + , _configInt32 = True + , _configInt16 = False + , _configInt8 = False + , _configWord64 = False + , _configWord32 = False + , _configWord16 = False + , _configWord8 = False + } + +options :: [OptDescr (Config -> Config)] +options = + [ Option [] ["no-quickcheck"] + (NoArg (set configQuickCheck False)) + "disable QuickCheck tests" + + , Option [] ["no-benchmark"] + (NoArg (set configBenchmark False)) + "disable Criterion benchmarks" + + , Option [] ["double"] + (OptArg (set configDouble . read . fromMaybe "True") "BOOL") + (describe configDouble "enable double-precision tests") + + , Option [] ["float"] + (OptArg (set configFloat . read . fromMaybe "True") "BOOL") + (describe configDouble "enable single-precision tests") + + , Option [] ["int64"] + (OptArg (set configInt64 . read . fromMaybe "True") "BOOL") + (describe configInt64 "enable 64-bit integer tests") + + , Option [] ["int32"] + (OptArg (set configInt32 . read . fromMaybe "True") "BOOL") + (describe configInt32 "enable 32-bit integer tests") + + , Option [] ["int16"] + (OptArg (set configInt16 . read . fromMaybe "True") "BOOL") + (describe configInt16 "enable 16-bit integer tests") + + , Option [] ["int8"] + (OptArg (set configInt8 . read . fromMaybe "True") "BOOL") + (describe configInt8 "enable 8-bit integer tests") + + , Option [] ["word64"] + (OptArg (set configWord64 . read . fromMaybe "True") "BOOL") + (describe configWord64 "enable 64-bit unsigned integer tests") + + , Option [] ["word32"] + (OptArg (set configWord32 . read . fromMaybe "True") "BOOL") + (describe configWord32 "enable 32-bit unsigned integer tests") + + , Option [] ["word16"] + (OptArg (set configWord16 . read . fromMaybe "True") "BOOL") + (describe configWord16 "enable 16-bit unsigned integer tests") + + , Option [] ["word8"] + (OptArg (set configWord8 . read . fromMaybe "True") "BOOL") + (describe configWord8 "enable 8-bit unsigned integer tests") + + , Option ['h', '?'] ["help"] + (NoArg (set configHelp True)) + "show this help message" + ] + where + describe f msg + = msg ++ " (" ++ show (get f defaults) ++ ")" + +header :: [String] +header = + [ "accelerate-nofib (c) [2013] The Accelerate Team" + , "" + , "Usage: accelerate-nofib [OPTIONS]" + , "" + ] + +footer :: [String] +footer = [] + + +-- | Same as 'parseArgs', but also return options for test-framework. +-- +-- Since Criterion and test-framework both bail if they encounter unrecognised +-- options, we run getOpt' ourselves. This means error messages might be a bit +-- different. +-- +-- We split this out of the common ParseArgs infrastructure so we don't add an +-- unnecessary dependency on test-framework to all the other example programs. +-- +parseArgs' :: (config :-> Bool) -- ^ access a help flag from the options structure + -> (config :-> Backend) -- ^ access the chosen backend from the options structure + -> [OptDescr (config -> config)] -- ^ the option descriptions + -> config -- ^ default option set + -> [String] -- ^ header text + -> [String] -- ^ footer text + -> [String] -- ^ command line arguments + -> IO (config, Criterion.Config, TestFramework.RunnerOptions, [String]) +parseArgs' help backend (withBackends backend -> options) config header footer (takeWhile (/= "--") -> argv) = + let + criterionOptions = stripShortOpts Criterion.defaultOptions + testframeworkOptions = stripShortOpts TestFramework.optionsDescription + + helpMsg err = concat err + ++ usageInfo (unlines header) options + ++ usageInfo "\nGeneric criterion options:" criterionOptions + ++ usageInfo "\nGeneric test-framework options:" testframeworkOptions + + in do + + -- In the first round process options for the main program. Any non-options + -- will be split out here so we can ignore them later. Unrecognised options + -- get passed to criterion and test-framework. + -- + (conf,non,u) <- case getOpt' Permute options argv of + (opts,n,u,[]) -> case foldr id config opts of + conf | False <- get help conf + -> putStrLn (fancyHeader backend conf header footer) >> return (conf,n,u) + _ -> putStrLn (helpMsg []) >> exitSuccess + -- + (_,_,_,err) -> error (helpMsg err) + + -- Test Framework + (tfconf, u') <- case getOpt' Permute testframeworkOptions u of + (oas,_,u',[]) | Just os <- sequence oas + -> return (mconcat os, u') + (_,_,_,err) -> error (helpMsg err) + + -- Criterion + (cconf, _) <- Criterion.parseArgs Criterion.defaultConfig criterionOptions u' + + return (conf, cconf, tfconf, non) + diff --git a/examples/nofib/Main.hs b/examples/nofib/Main.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Main.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +module Main where + +import Test.Framework +import Control.Exception +import System.Exit +import System.Environment + +import Config +import Monitoring +import Test.IO +import Test.Prelude +import Test.Sharing +import Test.Imaginary +import Test.Spectral +#ifdef ACCELERATE_CUDA_BACKEND +import Test.Foreign +#endif + + +main :: IO () +main = do + + -- Kick off EKG monitoring. Perhaps not particularly useful since we spend a + -- lot of time just generating random data, etc. + -- + beginMonitoring + + -- process command line args, and print a brief usage message + -- + argv <- getArgs + (conf, cconf, tfconf, nops) <- parseArgs' configHelp configBackend options defaults header footer argv + + -- Run tests, executing the simplest first. More complex operations, such as + -- segmented operations, generally depend on simpler tests. We build up to the + -- larger test programs. + -- + defaultMainWithOpts + [ test_prelude conf + , test_sharing conf + , test_io conf + , test_imaginary conf + , test_spectral conf +#ifdef ACCELERATE_CUDA_BACKEND + , test_foreign conf +#endif + ] + tfconf + -- test-framework wants to have a nap on success; don't let it. + `catch` \e -> case e of + ExitSuccess -> return() + _ -> throwIO e + + -- Now run some criterion benchmarks. + -- + -- TODO: We should dump the results to file so that they can be analysed and + -- checked for regressions. + -- + diff --git a/examples/nofib/QuickCheck/Arbitrary/Array.hs b/examples/nofib/QuickCheck/Arbitrary/Array.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/QuickCheck/Arbitrary/Array.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module QuickCheck.Arbitrary.Array where + +import QuickCheck.Arbitrary.Shape + +import Data.List +import Test.QuickCheck +import System.Random ( Random ) +import Data.Array.Accelerate.Array.Sugar ( Array, Segments, Shape, Elt, Z(..), (:.)(..), (!), DIM0, DIM1, DIM2 ) +import qualified Data.Array.Accelerate.Array.Sugar as Sugar +import qualified Data.Set as Set + + + +instance (Elt e, Arbitrary e) => Arbitrary (Array DIM0 e) where + arbitrary = arbitraryArray Z + shrink arr = [ Sugar.fromList Z [x] | x <- shrink (arr ! Z) ] + + +instance (Elt e, Arbitrary e) => Arbitrary (Array DIM1 e) where + arbitrary = arbitraryArray =<< sized arbitraryShape + shrink arr = + let (Z :. n) = Sugar.shape arr + indices = [ map (Z:.) (nub sz) | sz <- shrink [0 .. n-1] ] + in + [ Sugar.fromList (Z :. length sl) (map (arr!) sl) | sl <- indices ] + + +instance (Elt e, Arbitrary e) => Arbitrary (Array DIM2 e) where + arbitrary = arbitraryArray =<< sized arbitraryShape + shrink arr = + let (Z :. width :. height) = Sugar.shape arr + in + [ Sugar.fromList (Z :. length slx :. length sly) [ arr ! (Z:.x:.y) | x <- slx, y <- sly ] + | slx <- map nub $ shrink [0 .. width - 1] + , sly <- map nub $ shrink [0 .. height - 1] + ] + + +-- Generate an arbitrary array of the given shape using the default element +-- generator +-- +arbitraryArray :: (Shape sh, Elt e, Arbitrary e) => sh -> Gen (Array sh e) +arbitraryArray sh = arbitraryArrayOf sh arbitrary + +-- Generate an array of the given shape using the supplied element generator +-- function. +-- +arbitraryArrayOf :: (Shape sh, Elt e, Arbitrary e) => sh -> Gen e -> Gen (Array sh e) +arbitraryArrayOf sh gen = Sugar.fromList sh `fmap` vectorOf (Sugar.size sh) gen + +{-- + -- A version that does not use fromList. It does not gain us anything while + -- being much more complex in implementation. + -- +arbitraryArrayOf :: (Shape sh, Elt e, Arbitrary e) => sh -> Gen e -> Gen (Array sh e) +arbitraryArrayOf sh (MkGen gen) + = MkGen + $ \g k -> let !n = Sugar.size sh + (adata, _) = runArrayData $ do + arr <- newArrayData n + let go _ !i | i >= n = return () + go !r !i = + let (r1,r2) = split r + v = gen r1 k + in + unsafeWriteArrayData arr i (Sugar.fromElt v) >> go r2 (i+1) + -- + go g 0 + return (arr, undefined) + in + adata `seq` Sugar.Array (Sugar.fromElt sh) adata +--} + +-- Generate an array where the outermost dimension satisfies the given segmented +-- array descriptor. +-- +arbitrarySegmentedArray + :: (Integral i, Shape sh, Elt e, Arbitrary sh, Arbitrary e) + => Segments i + -> Gen (Array (sh :. Int) e) +arbitrarySegmentedArray segs = do + let sz = fromIntegral . sum $ Sugar.toList segs + sh <- sized $ \n -> arbitraryShape (n `div` 2) + arbitraryArray (sh :. sz) + + +-- Generate a segment descriptor. Both the array and individual segments might +-- be empty. +-- +arbitrarySegments :: (Elt i, Integral i, Arbitrary i, Random i) => Gen (Segments i) +arbitrarySegments = + sized $ \n -> do + k <- choose (0,n) + arbitraryArrayOf (Z:.k) (choose (0, fromIntegral n)) + +-- Generate a possibly empty segment descriptor, where each segment is non-empty +-- +arbitrarySegments1 :: (Elt i, Integral i, Arbitrary i, Random i) => Gen (Segments i) +arbitrarySegments1 = + sized $ \n -> do + k <- choose (0,n) + arbitraryArrayOf (Z:.k) (choose (1, 1 `max` fromIntegral n)) + + +-- Generate an vector where every element in the array is unique. The maximum +-- size is based on the current 'sized' parameter. +-- +arbitraryUniqueVectorOf :: (Elt e, Arbitrary e, Ord e) => Gen e -> Gen (Array DIM1 e) +arbitraryUniqueVectorOf gen = + sized $ \n -> do + set <- fmap Set.fromList (vectorOf n gen) + k <- choose (0, Set.size set) + return $! Sugar.fromList (Z :. k) (Set.toList set) + + +-- Generate an arbitrary CSR matrix. The first parameter is the segment +-- descriptor, the second a sparse vector of (index,value) pairs, and the third +-- the matrix width (number of columns). +-- +-- The matrix size is based on the current `sized` parameter. +-- +arbitraryCSRMatrix + :: (Elt i, Integral i, Arbitrary i, Random i, Elt e, Arbitrary e) + => Gen ( Array DIM1 i, Array DIM1 (i,e), Int ) +arbitraryCSRMatrix = + sized $ \cols -> do + segd <- arbitrarySegments + let nnz = fromIntegral . sum $ Sugar.toList segd + smat <- arbitraryArrayOf (Z :. nnz) $ do + val <- arbitrary + ind <- choose (0, fromIntegral cols - 1) + return (ind, val) + return (segd, smat, cols) + diff --git a/examples/nofib/QuickCheck/Arbitrary/Shape.hs b/examples/nofib/QuickCheck/Arbitrary/Shape.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/QuickCheck/Arbitrary/Shape.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module QuickCheck.Arbitrary.Shape where + +import Test.QuickCheck +import Data.Array.Accelerate ( Shape, Z(..), (:.)(..), DIM0, DIM1, DIM2 ) +import qualified Data.Array.Accelerate.Array.Sugar as Sugar + + +instance Arbitrary DIM0 where + arbitrary = return Z + shrink = return + +instance Arbitrary DIM1 where + arbitrary = do + n <- sized $ \n -> choose (0, 2*n) + return (Z :. n) + + shrink (Z :. n) = [ Z :. n' | n' <- shrink n ] + +instance Arbitrary DIM2 where + arbitrary = sized $ \n -> do + w <- choose (0, n) + h <- choose (0, n) + return (Z :. h :. w) + + shrink (Z :. h :. w) = [ Z :. h' :. w' | h' <- shrink h, w' <- shrink w ] + + +-- Generate an arbitrary shape with approximately this many elements in each +-- dimension. If the generated shape does not contain approximately the +-- specified number of elements (within 10%), the shape is thrown out and a new +-- one is generated. +-- +-- NOTE: +-- * Shapes of zero dimension ignore the target size. +-- * Requesting high dimension shapes of very few elements may take same time +-- to generate an appropriate random instance. +-- +arbitraryShape :: forall sh. (Shape sh, Arbitrary sh) => Int -> Gen sh +arbitraryShape size = + let + eps = 0.1 :: Double + dim = Sugar.dim (undefined :: sh) + target + | dim == 0 = 1 + | otherwise = size * dim + + wiggle = round $ fromIntegral target * eps + minsize = target - wiggle + maxsize = target + wiggle + in + arbitrary `suchThat` \sh -> let n = Sugar.size sh + in n >= minsize && n <= maxsize + diff --git a/examples/nofib/Test/Base.hs b/examples/nofib/Test/Base.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Base.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Base where + +import Prelude as P +import Test.QuickCheck +import Data.Array.Accelerate +import Data.Array.Accelerate.Array.Sugar as Sugar + + +-- A class of things that support almost-equality, so that we can disregard +-- small amounts of floating-point round-off error. +-- +class Similar a where + {-# INLINE (~=) #-} + (~=) :: a -> a -> Bool + default (~=) :: Eq a => a -> a -> Bool + (~=) = (==) + +infix 4 ~= + +instance Similar a => Similar [a] where + [] ~= [] = True + (x:xs) ~= (y:ys) = x ~= y && xs ~= ys + _ ~= _ = False + +instance (Similar a, Similar b) => Similar (a, b) where + (x1, y1) ~= (x2, y2) = x1 ~= x2 && y1 ~= y2 + + +instance Similar Int +instance Similar Int8 +instance Similar Int16 +instance Similar Int32 +instance Similar Int64 +instance Similar Word +instance Similar Word8 +instance Similar Word16 +instance Similar Word32 +instance Similar Word64 + +instance Similar Float where (~=) = absRelTol +instance Similar Double where (~=) = absRelTol + +{-# INLINE relTol #-} +relTol :: (Fractional a, Ord a) => a -> a -> a -> Bool +relTol epsilon x y = abs ((x-y) / (x+y+epsilon)) < epsilon + +{-# INLINE absRelTol #-} +absRelTol :: (RealFloat a, Ord a) => a -> a -> Bool +absRelTol u v + | isInfinite u + && isInfinite v = True + | isNaN u + && isNaN v = True + | abs (u-v) < epsilonAbs = True + | abs u > abs v = abs ((u-v) / u) < epsilonRel + | otherwise = abs ((v-u) / v) < epsilonRel + where + epsilonRel = 0.001 + epsilonAbs = 0.00001 + +instance (Eq e, Eq sh, Shape sh) => Eq (Array sh e) where + a1 == a2 = arrayShape a1 == arrayShape a2 + && toList a1 == toList a2 + + a1 /= a2 = arrayShape a1 /= arrayShape a2 + || toList a1 /= toList a2 + +instance (Similar e, Eq sh, Shape sh) => Similar (Array sh e) where + a1 ~= a2 = arrayShape a1 == arrayShape a2 + && toList a1 ~= toList a2 + + +-- | Assert that the specified actual value is equal-ish to the expected value. +-- If we are in verbose mode, the output message will contain the expected and +-- actual values. +-- +assertEqual + :: (Similar a, Show a) + => Bool -- ^ Print the test case as well? + -> a -- ^ The expected value + -> a -- ^ The actual value + -> Property +assertEqual v expected actual = + printTestCase message (expected ~= actual) + where + message + | P.not v = [] + | otherwise = unlines [ "*** Expected:", show expected + , "*** Received:", show actual ] + +infix 1 ~=?, ~?= + +-- Short hand for a test case that asserts similarity, with the actual value on +-- the right hand side and the expected value on the left. +-- +(~=?) :: (Similar a, Show a) => a -> a -> Property +(~=?) = assertEqual True + +-- Short hand for a test case that asserts similarity, with the actual value on +-- the left hand side and the expected value on the right. +-- +(~?=) :: (Similar a, Show a) => a -> a -> Property +(~?=) = flip (~=?) + + + +-- Miscellaneous +-- + +indexHead :: Shape sh => (sh:.Int) -> Int +indexHead (_ :. sz) = sz + +indexTail :: Shape sh => (sh:.Int) -> sh +indexTail (sh :. _) = sh + +isEmptyArray :: Shape sh => Array sh e -> Bool +isEmptyArray arr = arraySize (arrayShape arr) == 0 + +mkDim :: Shape sh => Int -> sh +mkDim n = listToShape (P.replicate n 0) + +dim0 :: DIM0 +dim0 = mkDim 0 + +dim1 :: DIM1 +dim1 = mkDim 1 + +dim2 :: DIM2 +dim2 = mkDim 2 + +splitEvery :: Int -> [a] -> [[a]] +splitEvery _ [] = cycle [[]] +splitEvery n xs = + let (h,t) = splitAt n xs + in h : splitEvery n t + +splitPlaces :: Integral i => [i] -> [a] -> [[a]] +splitPlaces [] _ = [] +splitPlaces (i:is) vs = + let (h,t) = splitAt (P.fromIntegral i) vs + in h : splitPlaces is t + diff --git a/examples/nofib/Test/Foreign.hs b/examples/nofib/Test/Foreign.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Foreign.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} +module Test.Foreign ( + + test_foreign + +) where + +import Config + +import Data.Label + +import Prelude as P +import Data.Array.Accelerate as A +import Data.Array.Accelerate.CUDA.Foreign as A +import Test.Prelude.Mapping +import Test.Framework +import Test.QuickCheck +import Test.Framework.Providers.QuickCheck2 +import Test.Base + +import ParseArgs + +test_foreign :: Config -> Test +test_foreign conf = testGroup "foreign" + [ testExpf + , testFmaf + ] + where + backend = get configBackend conf + + testExpf :: Test + testExpf = testProperty "expf" test_expf + where + test_expf :: Array DIM1 Float -> Property + test_expf xs = run backend (A.map (A.foreignExp (A.CUDAForeignExp [] "__expf") exp) (A.use xs)) + ~?= mapRef exp xs + + testFmaf :: Test + testFmaf = testProperty "fmaf" test_fmaf + where + test_fmaf :: Array DIM1 (Float, Float, Float) -> Property + test_fmaf xs = run backend (A.map (A.foreignExp (A.CUDAForeignExp [] "__fmaf_rz") fmaf) (A.use xs)) + ~?= mapRef (\(x,y,z) -> x * y + z) xs + where + fmaf v = let (x,y,z) = unlift v in x * y + z diff --git a/examples/nofib/Test/IO.hs b/examples/nofib/Test/IO.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/IO.hs @@ -0,0 +1,17 @@ + +module Test.IO where + +import Config + +import Test.Framework +import Test.IO.Ptr +import Test.IO.Vector + + +test_io :: Config -> Test +test_io conf = + testGroup "io" + [ test_ptr conf + , test_vector conf + ] + diff --git a/examples/nofib/Test/IO/Ptr.hs b/examples/nofib/Test/IO/Ptr.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/IO/Ptr.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.IO.Ptr ( + + test_ptr, + +) where + +import Config + +import Prelude as P +import Foreign.C +import Foreign.Ptr +import Test.Framework +import Test.HUnit ( Assertion, (@?=) ) +import Test.Framework.Providers.HUnit + +import Data.Array.Accelerate +import Data.Array.Accelerate.IO + + +test_ptr :: Config -> Test +test_ptr _ = + testGroup "block copy" + [ + testCase "toPtr Int16" toPtrInt16 + , testCase "toPtr Int32" toPtrInt32 + , testCase "toPtr Int64" toPtrInt64 + , testCase "fromPtr Int32" fromPtrInt32 + , testCase "fromPtr (Int32,Double)" fromPtrIntDouble + , testCase "fromArray Int32" fromArrayInt32 + ] + + +-- Unit tests ------------------------------------------------------------------ +-- +intToBool :: Integral a => a -> Bool +intToBool 0 = False +intToBool _ = True + +fromPtrInt32 :: Assertion +fromPtrInt32 = do + ptr <- oneToTen + arr <- fromPtr (Z :. 10) ((), ptr) :: IO (Vector Int32) + toList arr @?= [1..10] + +fromPtrIntDouble :: Assertion +fromPtrIntDouble = do + intPtr <- oneToTen + doublePtr <- tenToOne + arr <- fromPtr (Z :. 10) (((), intPtr), doublePtr) :: IO (Vector (Int32, Double)) + toList arr @?= [ (x, P.fromIntegral (11 - x)) | x <- [1..10]] + + +toPtrInt16 :: IO () +toPtrInt16 = do + let n = 50 + arr :: Vector Int16 + arr = fromList (Z:.n) [2 * P.fromIntegral x | x <- [0..n-1]] + -- + ohi <- nInt16s (P.fromIntegral n) + toPtr arr ((), ohi) + b <- isFilledWithEvens16 ohi (P.fromIntegral n) + intToBool b @?= True + +toPtrInt32 :: IO () +toPtrInt32 = do + let n = 100 + arr :: Array DIM2 Int32 + arr = fromList (Z:.10:.10) [2 * P.fromIntegral x | x <- [0..n-1]] + -- + ohi <- nInt32s n + toPtr arr ((), ohi) + b <- isFilledWithEvens32 ohi n + intToBool b @?= True + +toPtrInt64 :: IO () +toPtrInt64 = do + let n = 73 + arr :: Vector Int64 + arr = fromList (Z:.n) [2 * P.fromIntegral x | x <- [0..n-1]] + -- + ohi <- nInt64s (P.fromIntegral n) + toPtr arr ((), ohi) + b <- isFilledWithEvens64 ohi (P.fromIntegral n) + intToBool b @?= True + + +fromArrayInt32 :: IO () +fromArrayInt32 = do + let n = 5^(3::Int) + arr :: Array DIM3 Int32 + arr = fromList (Z:.5:.5:.5) [2*x | x <- [0..n-1]] + -- + ohi <- nInt32s (P.fromIntegral n) + fromArray arr ((), memcpy ohi) + b <- isFilledWithEvens32 ohi (P.fromIntegral n) + intToBool b @?= True + + +-- Foreign functions ----------------------------------------------------------- +-- +foreign import ccall "one_to_ten" oneToTen :: IO (Ptr Int32) +foreign import ccall "ten_to_one" tenToOne :: IO (Ptr Double) +foreign import ccall "n_int_16s" nInt16s :: CInt -> IO (Ptr Int16) +foreign import ccall "n_int_32s" nInt32s :: CInt -> IO (Ptr Int32) +foreign import ccall "n_int_64s" nInt64s :: CInt -> IO (Ptr Int64) +foreign import ccall "is_filled_with_evens_16" isFilledWithEvens16 :: Ptr Int16 -> CInt -> IO CInt +foreign import ccall "is_filled_with_evens_32" isFilledWithEvens32 :: Ptr Int32 -> CInt -> IO CInt +foreign import ccall "is_filled_with_evens_64" isFilledWithEvens64 :: Ptr Int64 -> CInt -> IO CInt +foreign import ccall memcpy :: Ptr a -> Ptr b -> Int -> IO () + diff --git a/examples/nofib/Test/IO/Vector.hs b/examples/nofib/Test/IO/Vector.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/IO/Vector.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.IO.Vector (test_vector) + where + +import Prelude as P +import Config +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.Base +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import QuickCheck.Arbitrary.Array () + +import Data.Array.Accelerate +import Data.Array.Accelerate.IO ( toVectors, fromVectors ) +import Data.Array.Accelerate.Array.Sugar as Sugar + + +test_vector :: Config -> Test +test_vector opt = testGroup "vector" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + testElt :: forall a. (Elt a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) + [ testDim dim0 + , testDim dim1 + , testDim dim2 + ] + where + testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test + testDim sh = testProperty ("DIM" P.++ show (dim sh)) (roundtrip :: Array sh a -> Property) + + roundtrip arr = + let sh = arrayShape arr + in fromVectors sh (toVectors arr) ~?= arr + diff --git a/examples/nofib/Test/IO/fill_with_values.cpp b/examples/nofib/Test/IO/fill_with_values.cpp new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/IO/fill_with_values.cpp @@ -0,0 +1,81 @@ +#include +#include +#include + +/* Returns one if it's filled with even values starting at 0 */ +template +int is_filled_with_evens(T *p, int size) { + T prev = 0; + int result = 1; // default to true + int i; + + if (p[0] != 0) { + result = 0; + } + + for (i=1; result && i < size; i++) { + if (p[i] != prev + 2) { + result = 0; + } + else { + prev = p[i]; + } + } + + return result; +} + + +#ifdef __cplusplus +extern "C" { +#endif + +int32_t *one_to_ten() { + int32_t *p = (int32_t*) malloc(sizeof(int32_t) * 10); + int i; + for (i=0; i<10; i++) { + p[i] = i+1; + } + return p; +} + +double *ten_to_one() { + double *p = (double*) malloc(sizeof(double) * 10); + int i; + for (i=0; i< 10; i++) { + p[i] = 10.0 - (double) i; + } + return p; +} + +int32_t *n_int_32s (int n) { + return (int32_t*) malloc(sizeof(int32_t) * n); +} + +int16_t *n_int_16s(int n) { + return (int16_t*) malloc(sizeof(int16_t) * n); +} + +int64_t *n_int_64s(int n) { + return (int64_t*) malloc(sizeof(int64_t) * n); +} + +int is_filled_with_evens_16(int16_t *p, int size) +{ + return is_filled_with_evens(p, size); +} + +int is_filled_with_evens_32(int32_t *p, int size) +{ + return is_filled_with_evens(p, size); +} + +int is_filled_with_evens_64(int64_t *p, int size) +{ + return is_filled_with_evens(p, size); +} + +#ifdef __cplusplus +} +#endif + diff --git a/examples/nofib/Test/Imaginary.hs b/examples/nofib/Test/Imaginary.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Imaginary.hs @@ -0,0 +1,23 @@ + +module Test.Imaginary ( + + test_imaginary + +) where + +import Config + +import Test.Framework +import Test.Imaginary.DotP +import Test.Imaginary.SASUM +import Test.Imaginary.SAXPY + + +test_imaginary :: Config -> Test +test_imaginary conf = + testGroup "imaginary" + [ test_sasum conf + , test_saxpy conf + , test_dotp conf + ] + diff --git a/examples/nofib/Test/Imaginary/DotP.hs b/examples/nofib/Test/Imaginary/DotP.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Imaginary/DotP.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Imaginary.DotP ( + + test_dotp, + +) where + +import Prelude as P +import Data.Array.Accelerate as A +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array () + + +test_dotp :: Config -> Test +test_dotp opt = testGroup "dot-product" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + + testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) + => (Config :-> Bool) + -> a + -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just + $ testProperty (show (typeOf (undefined :: a))) (run_dotp :: Vector a -> Vector a -> Property) + + run_dotp xs ys = + run2 backend dotp xs ys `indexArray` Z + ~?= + P.sum [ x * y | x <- toList xs | y <- toList ys ] + + +-- Accelerate implementation --------------------------------------------------- + +dotp :: (Elt e, IsNum e) + => Acc (Vector e) + -> Acc (Vector e) + -> Acc (Scalar e) +dotp xs ys + = A.fold (+) 0 + $ A.zipWith (*) xs ys + diff --git a/examples/nofib/Test/Imaginary/SASUM.hs b/examples/nofib/Test/Imaginary/SASUM.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Imaginary/SASUM.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Imaginary.SASUM ( + + test_sasum, + +) where + +import Prelude as P +import Data.Array.Accelerate as A +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array () + + +test_sasum :: Config -> Test +test_sasum opt = testGroup "sasum" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + + testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) + => (Config :-> Bool) + -> a + -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just + $ testProperty (show (typeOf (undefined :: a))) (run_sasum :: Vector a -> Property) + + run_sasum xs = + run1 backend sasum xs `indexArray` Z + ~?= + P.sum (P.map abs (toList xs)) + + +-- Accelerate implementation --------------------------------------------------- + +sasum :: (Elt e, IsNum e) => Acc (Vector e) -> Acc (Scalar e) +sasum = A.fold (+) 0 . A.map abs + diff --git a/examples/nofib/Test/Imaginary/SAXPY.hs b/examples/nofib/Test/Imaginary/SAXPY.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Imaginary/SAXPY.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Imaginary.SAXPY ( + + test_saxpy, + +) where + +import Prelude as P +import Data.Array.Accelerate as A +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array () + + +test_saxpy :: Config -> Test +test_saxpy opt = testGroup "saxpy" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + + testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) + => (Config :-> Bool) + -> a + -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just + $ testProperty (show (typeOf (undefined :: a))) (run_saxpy :: a -> Vector a -> Vector a -> Property) + + run_saxpy alpha xs ys = + toList (run2 backend (saxpy (constant alpha)) xs ys) + ~?= + [ alpha * x + y | x <- toList xs | y <- toList ys ] + + +-- Accelerate implementation --------------------------------------------------- + +saxpy :: (Elt e, IsNum e) + => Exp e + -> Acc (Vector e) + -> Acc (Vector e) + -> Acc (Vector e) +saxpy alpha xs ys = + let alpha' = the (unit alpha) + in + A.zipWith (\x y -> alpha' * x + y) xs ys + diff --git a/examples/nofib/Test/Prelude.hs b/examples/nofib/Test/Prelude.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude.hs @@ -0,0 +1,31 @@ + +module Test.Prelude where + +import Config + +import Test.Framework +import Test.Prelude.Filter +import Test.Prelude.IndexSpace +import Test.Prelude.Mapping +import Test.Prelude.PrefixSum +import Test.Prelude.Reduction +import Test.Prelude.Replicate +import Test.Prelude.Stencil + + +test_prelude :: Config -> Test +test_prelude conf = + testGroup "prelude" + [ test_map conf + , test_zipWith conf + , test_foldAll conf + , test_fold conf + , test_backpermute conf + , test_permute conf + , test_prefixsum conf -- requires fold + , test_foldSeg conf -- requires scan + , test_stencil conf + , test_replicate conf + , test_filter conf + ] + diff --git a/examples/nofib/Test/Prelude/Filter.hs b/examples/nofib/Test/Prelude/Filter.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Filter.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Prelude.Filter ( + + test_filter + +) where + +import Prelude as P +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array () +import Data.Array.Accelerate as A + +-- +-- Filter ---------------------------------------------------------------------- +-- + +test_filter :: Config -> Test +test_filter opt = testGroup "filter" $ catMaybes + [ testIntegralElt configInt8 (undefined :: Int8) + , testIntegralElt configInt16 (undefined :: Int16) + , testIntegralElt configInt32 (undefined :: Int32) + , testIntegralElt configInt64 (undefined :: Int64) + , testIntegralElt configWord8 (undefined :: Word8) + , testIntegralElt configWord16 (undefined :: Word16) + , testIntegralElt configWord32 (undefined :: Word32) + , testIntegralElt configWord64 (undefined :: Word64) + , testFloatingElt configFloat (undefined :: Float) + , testFloatingElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + + testIntegralElt :: forall e. (Elt e, Integral e, IsIntegral e, Arbitrary e, Similar e) => (Config :-> Bool) -> e -> Maybe Test + testIntegralElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just + $ testProperty (show (typeOf (undefined :: e))) (run_filter A.even P.even :: Vector e -> Property) + + testFloatingElt :: forall e. (Elt e, RealFrac e, IsFloating e, Arbitrary e, Similar e) => (Config :-> Bool) -> e -> Maybe Test + testFloatingElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just + $ testProperty (show (typeOf (undefined :: e))) (run_filter (>* 0) (> 0) :: Vector e -> Property) + + run_filter f g xs + = toList (run1 backend (A.filter f) xs) ~?= P.filter g (toList xs) + diff --git a/examples/nofib/Test/Prelude/IndexSpace.hs b/examples/nofib/Test/Prelude/IndexSpace.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/IndexSpace.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Prelude.IndexSpace ( + + test_permute, + test_backpermute + +) where + +import Prelude as P +import Data.Label +import Data.Maybe +import Data.Typeable +import Control.Monad +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array + +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Array.Sugar ( newArray, dim ) + +import Data.Array.ST ( runSTArray ) +import qualified Data.Array.Unboxed as IArray +import qualified Data.Array.MArray as M + + +-- +-- Forward permutation --------------------------------------------------------- +-- + +test_permute :: Config -> Test +test_permute opt = testGroup "permute" $ catMaybes + [ testIntegralElt configInt8 (undefined :: Int8) + , testIntegralElt configInt16 (undefined :: Int16) + , testIntegralElt configInt32 (undefined :: Int32) + , testIntegralElt configInt64 (undefined :: Int64) + , testIntegralElt configWord8 (undefined :: Word8) + , testIntegralElt configWord16 (undefined :: Word16) + , testIntegralElt configWord32 (undefined :: Word32) + , testIntegralElt configWord64 (undefined :: Word64) + , testFloatingElt configFloat (undefined :: Float) + , testFloatingElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + + testIntegralElt :: forall e. (Elt e, Integral e, IsIntegral e, Arbitrary e, Similar e) => (Config :-> Bool) -> e -> Maybe Test + testIntegralElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) + [ + test_fill (undefined :: e) + , testProperty "scatter" (test_scatter :: e -> Property) + , testProperty "scatterIf" (test_scatterIf :: e -> Property) + , testProperty "histogram" (test_histogram A.fromIntegral P.fromIntegral :: Vector e -> Property) + ] + + testFloatingElt :: forall e. (Elt e, RealFrac e, IsFloating e, Arbitrary e, Similar e) => (Config :-> Bool) -> e -> Maybe Test + testFloatingElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) + [ + test_fill (undefined :: e) + , testProperty "scatter" (test_scatter :: e -> Property) + , testProperty "scatterIf" (test_scatterIf :: e -> Property) + , testProperty "histogram" (test_histogram A.floor P.floor :: Vector e -> Property) + ] + + -- Test is permutation works by just copying elements directly from one + -- array to the other. Does not attempt to use elements from the defaults + -- array. Additionally, works for any dimension. (c.f. Issue #93) + -- + test_fill :: forall e. (Elt e, IsNum e, Arbitrary e, Similar e) => e -> Test + test_fill _ = testGroup "fill" + [ -- testDim dim0 -- Accelerate issue #87 + testDim dim1 + , testDim dim2 + ] + where + testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh e)) => sh -> Test + testDim sh = testProperty ("DIM" P.++ show (dim sh)) (push_fill :: Array sh e -> Property) + + push_fill xs = + let xs' = use xs + zeros = A.fill (A.shape xs') (constant 0) + in + run backend (permute const zeros id xs') ~?= xs + + -- Test if the combining operation for forward permutation works, by + -- building a histogram. Often tricky for parallel backends. + -- + test_histogram f g xs = + sized $ \n -> run backend (histogramAcc n f xs) ~?= histogramRef n g xs + + histogramAcc n f xs = + let n' = unit (constant n) + xs' = use xs + zeros = generate (constant (Z :. n)) (const 0) + ones = generate (shape xs') (const 1) + in + permute (+) zeros (\ix -> index1 $ f (xs' A.! ix) `mod` the n') ones + + histogramRef n f xs = + let arr :: IArray.UArray Int Int32 + arr = IArray.accumArray (+) 0 (0, n-1) [ (f e `mod` n, 1) | e <- toList xs ] + in + fromIArray arr + + -- Test for scattering functions + -- + test_scatter :: forall e. (Elt e, Similar e, Arbitrary e) => e -> Property + test_scatter _ = + forAll (sized $ \n -> choose (0,n)) $ \k -> let m = 2*k in + forAll (arbitraryArray (Z:.m+1)) $ \defaultV -> + forAll (arbitraryUniqueVectorOf (choose (0, m))) $ \mapV -> let n = arraySize (arrayShape mapV) in + forAll (arbitraryArray (Z:.n)) $ \(inputV :: Vector e) -> + toList (run backend $ A.scatter (use mapV) (use defaultV) (use inputV)) + ~?= + IArray.elems (scatterRef (toIArray mapV) (toIArray defaultV) (toIArray inputV)) + + test_scatterIf :: forall e. (Elt e, Similar e, Arbitrary e) => e -> Property + test_scatterIf _ = + forAll (sized $ \n -> choose (0,n)) $ \k -> let m = 2*k in + forAll (arbitraryArray (Z:.m+1)) $ \defaultV -> + forAll (arbitraryUniqueVectorOf (choose (0, m))) $ \mapV -> let n = arraySize (arrayShape mapV) in + forAll (arbitraryArray (Z:.n)) $ \(maskV :: Vector Int) -> + forAll (arbitraryArray (Z:.n)) $ \(inputV :: Vector e) -> + toList (run backend $ A.scatterIf (use mapV) (use maskV) A.even (use defaultV) (use inputV)) + ~?= + IArray.elems (scatterIfRef (toIArray mapV) (toIArray maskV) P.even (toIArray defaultV) (toIArray inputV)) + + +-- +-- Backward permutation -------------------------------------------------------- +-- + +test_backpermute :: Config -> Test +test_backpermute opt = testGroup "backpermute" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + testElt :: forall e. (Elt e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined::e))) + [ testProperty "reverse" (test_reverse :: Array DIM1 e -> Property) + , testProperty "transpose" (test_transpose :: Array DIM2 e -> Property) + , testProperty "init" (test_init :: Array DIM1 e -> Property) + , testProperty "tail" (test_tail :: Array DIM1 e -> Property) + , testProperty "take" (test_take :: Array DIM1 e -> Property) + , testProperty "drop" (test_drop :: Array DIM1 e -> Property) + , testProperty "slit" (test_slit :: Array DIM1 e -> Property) + , testProperty "gather" (test_gather :: Array DIM1 e -> Property) + , testProperty "gatherIf" (test_gatherIf :: Array DIM1 e -> Property) + ] + + backend = get configBackend opt + test_reverse xs = run backend (reverseAcc xs) ~?= reverseRef xs + test_transpose xs = run backend (transposeAcc xs) ~?= transposeRef xs + + -- Reverse a vector + -- + reverseAcc xs = A.reverse (use xs) + reverseRef xs = fromList (arrayShape xs) (P.reverse $ toList xs) + + -- Transpose a 2D matrix + -- + transposeAcc xs = A.transpose (use xs) + transposeRef xs = + let swap (Z:.x:.y) = Z :. y :. x + in newArray (swap (arrayShape xs)) (\ix -> indexArray xs (swap ix)) + + -- Extracting sub-vectors + -- + test_init xs = + P.not (isEmptyArray xs) + ==> toList (run backend (A.init (A.use xs))) ~?= P.init (toList xs) + + test_tail xs = + P.not (isEmptyArray xs) + ==> toList (run backend (A.tail (A.use xs))) ~?= P.tail (toList xs) + + test_drop xs = + let n = arraySize (arrayShape xs) + in forAll (choose (0, 0 `P.max` (n-1))) $ \i -> + toList (run backend (A.drop (constant i) (use xs))) ~?= P.drop i (toList xs) + + test_take xs = + let n = arraySize (arrayShape xs) + in forAll (choose (0, 0 `P.max` (n-1))) $ \i -> + toList (run backend (A.take (constant i) (use xs))) ~?= P.take i (toList xs) + + test_slit xs = + let n = arraySize (arrayShape xs) + in forAll (choose (0, 0 `P.max` (n-1))) $ \i -> + forAll (choose (0, 0 `P.max` (n-1-i))) $ \j -> + toList (run backend (A.slit (constant i) (constant j) (use xs))) ~?= P.take j (P.drop i (toList xs)) + + -- Gathering + -- + test_gather xs = + let n = arraySize (arrayShape xs) + n' = 0 `P.max` (n-1) + in + forAll arbitrary $ \sh' -> + forAll (arbitraryArrayOf sh' (choose (0,n'))) $ \mapv -> + toList (run backend (A.gather (use mapv) (use xs))) + ~?= + [ xs `indexArray` (Z:.i) | i <- toList mapv ] + + test_gatherIf xs = + let n = arraySize (arrayShape xs) + n' = 0 `P.max` (n-1) + in + forAll arbitrary $ \sh' -> + forAll (arbitraryArrayOf sh' (choose (0,n'))) $ \mapv -> + forAll (arbitraryArray sh') $ \(maskv :: Vector Int) -> + forAll (arbitraryArray sh') $ \defaultv -> + toList (run backend $ A.gatherIf (use mapv) (use maskv) A.even (use defaultv) (use xs)) + ~?= + gatherIfRef P.even mapv maskv defaultv xs + + +-- Reference Implementation +-- ------------------------ + +gatherIfRef :: (e -> Bool) -> Vector Int -> Vector e -> Vector t -> Vector t -> [t] +gatherIfRef g mapv maskv defaultv inputv + = let n = arraySize (arrayShape defaultv) + select ix + | g (maskv `indexArray` ix) = inputv `indexArray` (Z :. mapv `indexArray` ix) + | otherwise = defaultv `indexArray` ix + in + [ select ix | i <- [0 .. n-1], let ix = Z :. i ] + + +scatterRef + :: IArray.UArray Int Int + -> IArray.Array Int e + -> IArray.Array Int e + -> IArray.Array Int e +scatterRef mapV defaultV inputV + = runSTArray + $ do mu <- M.thaw defaultV + forM_ (IArray.assocs mapV) $ \(inIx, outIx) -> M.writeArray mu outIx (inputV IArray.! inIx) + return mu + + +scatterIfRef + :: IArray.UArray Int Int + -> IArray.Array Int e + -> (e -> Bool) + -> IArray.Array Int t + -> IArray.Array Int t + -> IArray.Array Int t +scatterIfRef mapV maskV f defaultV inputV + = runSTArray + $ do mu <- M.thaw defaultV + forM_ (IArray.assocs mapV) $ \(inIx, outIx) -> + when (f (maskV IArray.! inIx)) $ + M.writeArray mu outIx (inputV IArray.! inIx) + return mu + diff --git a/examples/nofib/Test/Prelude/Mapping.hs b/examples/nofib/Test/Prelude/Mapping.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Mapping.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Prelude.Mapping ( + + test_map, + test_zipWith, + mapRef, + zipWithRef, + +) where + +import Prelude as P +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array () +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Array.Sugar as Sugar +import qualified Data.Array.Accelerate.Array.Representation as R + +-- +-- Map ------------------------------------------------------------------------- +-- + +test_map :: Config -> Test +test_map opt = testGroup "map" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + test_square xs = run1 backend (A.map (\x -> x*x)) xs ~?= mapRef (\x -> x*x) xs + test_abs xs = run1 backend (A.map abs) xs ~?= mapRef abs xs + test_plus z xs = + let z' = unit (constant z) + in run1 backend (A.map (+ the z')) xs ~?= mapRef (+ z) xs + + testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) + => (Config :-> Bool) + -> a + -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) + [ testDim dim0 + , testDim dim1 + , testDim dim2 + ] + where + testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test + testDim sh = testGroup ("DIM" P.++ show (dim sh)) + [ testProperty "abs" (test_abs :: Array sh a -> Property) + , testProperty "plus" (test_plus :: a -> Array sh a -> Property) + , testProperty "square" (test_square :: Array sh a -> Property) + ] + + +test_zipWith :: Config -> Test +test_zipWith opt = testGroup "zipWith" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + test_zip xs ys = run2 backend A.zip xs ys ~?= zipWithRef (,) xs ys + test_plus xs ys = run2 backend (A.zipWith (+)) xs ys ~?= zipWithRef (+) xs ys + test_min xs ys = run2 backend (A.zipWith min) xs ys ~?= zipWithRef min xs ys + + testElt :: forall a. (Elt a, IsNum a, Ord a, Similar a, Arbitrary a) + => (Config :-> Bool) + -> a + -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) + [ testDim dim0 + , testDim dim1 + , testDim dim2 + ] + where + testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test + testDim sh = testGroup ("DIM" P.++ show (dim sh)) + [ testProperty "zip" (test_zip :: Array sh a -> Array sh a -> Property) + , testProperty "plus" (test_plus :: Array sh a -> Array sh a -> Property) + , testProperty "min" (test_min :: Array sh a -> Array sh a -> Property) + ] + + +-- Reference Implementation +-- ------------------------ + +mapRef :: (Shape sh, Elt b) => (a -> b) -> Array sh a -> Array sh b +mapRef f xs + = fromList (arrayShape xs) + $ P.map f + $ toList xs + +zipWithRef :: (Shape sh, Elt c) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c +zipWithRef f xs ys = + let shx = fromElt (arrayShape xs) + shy = fromElt (arrayShape ys) + sh = toElt (R.intersect shx shy) + in + newArray sh (\ix -> f (xs Sugar.! ix) (ys Sugar.! ix)) + diff --git a/examples/nofib/Test/Prelude/PrefixSum.hs b/examples/nofib/Test/Prelude/PrefixSum.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/PrefixSum.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Prelude.PrefixSum ( + + test_prefixsum, + +) where + +import Prelude as P +import Test.QuickCheck +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array +import Data.Array.Accelerate as A + + +-- +-- prefix sum ------------------------------------------------------------------ +-- + +test_prefixsum :: Config -> Test +test_prefixsum opt = testGroup "prefix sum" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) + [ testProperty "scanl" (test_scanl :: Vector e -> Property) + , testProperty "scanl'" (test_scanl' :: Vector e -> Property) + , testProperty "scanl1" (test_scanl1 :: Vector e -> Property) + , testProperty "scanr" (test_scanr :: Vector e -> Property) + , testProperty "scanr'" (test_scanr' :: Vector e -> Property) + , testProperty "scanr1" (test_scanr1 :: Vector e -> Property) + -- + , testProperty "scanl1Seg" (test_scanl1seg :: Vector e -> Property) + , testProperty "scanr1Seg" (test_scanr1seg :: Vector e -> Property) + , testProperty "scanlSeg" (test_scanlseg :: Vector e -> Property) + , testProperty "scanrSeg" (test_scanrseg :: Vector e -> Property) + , testProperty "scanl'Seg" (test_scanl'seg :: Vector e -> Property) + , testProperty "scanr'Seg" (test_scanr'seg :: Vector e -> Property) + ] + + backend = get configBackend opt + + -- left scan + -- + test_scanl xs = run backend (A.scanl (+) 0 (use xs)) ~?= scanlRef (+) 0 xs + test_scanl1 xs = run backend (A.scanl1 min (use xs)) ~?= scanl1Ref min xs + test_scanl' xs = run backend (A.lift $ A.scanl' (+) 0 (use xs)) ~?= scanl'Ref (+) 0 xs + + -- right scan + -- + test_scanr xs = run backend (A.scanr (+) 0 (use xs)) ~?= scanrRef (+) 0 xs + test_scanr1 xs = run backend (A.scanr1 max (use xs)) ~?= scanr1Ref max xs + test_scanr' xs = run backend (A.lift $ A.scanr' (+) 0 (use xs)) ~?= scanr'Ref (+) 0 xs + + -- segmented left/right scan + -- + test_scanl1seg elt = + forAll arbitrarySegments1 $ \(seg :: Vector Int32) -> + forAll (arbitrarySegmentedArray seg) $ \xs -> + run backend (A.scanl1Seg (+) (use xs) (use seg)) + ~?= + scanl1SegRef (+) (xs `asTypeOf` elt) seg + + test_scanr1seg elt = + forAll arbitrarySegments1 $ \(seg :: Vector Int32) -> + forAll (arbitrarySegmentedArray seg) $ \xs -> + run backend (A.scanr1Seg (+) (use xs) (use seg)) + ~?= + scanr1SegRef (+) (xs `asTypeOf` elt) seg + + test_scanlseg elt = + forAll arbitrarySegments $ \(seg :: Vector Int32) -> + forAll (arbitrarySegmentedArray seg) $ \xs -> + run backend (A.scanlSeg (+) 0 (use xs) (use seg)) + ~?= + scanlSegRef (+) 0 (xs `asTypeOf` elt) seg + + test_scanrseg elt = + forAll arbitrarySegments $ \(seg :: Vector Int32) -> + forAll (arbitrarySegmentedArray seg) $ \xs -> + run backend (A.scanrSeg (+) 0 (use xs) (use seg)) + ~?= + scanrSegRef (+) 0 (xs `asTypeOf` elt) seg + + test_scanl'seg elt = + forAll arbitrarySegments $ \(seg :: Vector Int32) -> + forAll (arbitrarySegmentedArray seg) $ \xs -> + run backend (lift $ A.scanl'Seg (+) 0 (use xs) (use seg)) + ~?= + scanl'SegRef (+) 0 (xs `asTypeOf` elt) seg + + test_scanr'seg elt = + forAll arbitrarySegments $ \(seg :: Vector Int32) -> + forAll (arbitrarySegmentedArray seg) $ \xs -> + run backend (lift $ A.scanr'Seg (+) 0 (use xs) (use seg)) + ~?= + scanr'SegRef (+) 0 (xs `asTypeOf` elt) seg + + +-- Reference implementation +-- ------------------------ + +scanlRef :: Elt e => (e -> e -> e) -> e -> Vector e -> Vector e +scanlRef f z vec = + let (Z :. n) = arrayShape vec + in A.fromList (Z :. n+1) . P.scanl f z . A.toList $ vec + +scanl'Ref :: Elt e => (e -> e -> e) -> e -> Vector e -> (Vector e, Scalar e) +scanl'Ref f z vec = + let (Z :. n) = arrayShape vec + result = P.scanl f z (A.toList vec) + in (A.fromList (Z :. n) result, A.fromList Z (P.drop n result)) + +scanl1Ref :: Elt e => (e -> e -> e) -> Vector e -> Vector e +scanl1Ref f vec + = A.fromList (arrayShape vec) + . P.scanl1 f + . A.toList $ vec + +scanrRef :: Elt e => (e -> e -> e) -> e -> Vector e -> Vector e +scanrRef f z vec = + let (Z :. n) = arrayShape vec + in A.fromList (Z :. n+1) . P.scanr f z . A.toList $ vec + +scanr'Ref :: Elt e => (e -> e -> e) -> e -> Vector e -> (Vector e, Scalar e) +scanr'Ref f z vec = + let (Z :. n) = arrayShape vec + result = P.scanr f z (A.toList vec) + in (A.fromList (Z :. n) (P.tail result), A.fromList Z result) + +scanr1Ref :: Elt e => (e -> e -> e) -> Vector e -> Vector e +scanr1Ref f vec + = A.fromList (arrayShape vec) + . P.scanr1 f + . A.toList $ vec + + +-- segmented operations +-- +scanlSegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> Vector e +scanlSegRef f z vec seg = + let seg' = toList seg + vec' = toList vec + n = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg' + in fromList (Z :. n) $ + concat [ P.scanl f z v | v <- splitPlaces seg' vec' ] + +scanl1SegRef :: (Elt e, Integral i) => (e -> e -> e) -> Vector e -> Vector i -> Vector e +scanl1SegRef f vec seg = + let seg' = toList seg + vec' = toList vec + n = P.sum $ P.map P.fromIntegral seg' + in fromList (Z :. n) $ + concat [ P.scanl1 f v | v <- splitPlaces seg' vec' ] + +scanl'SegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> (Vector e, Vector e) +scanl'SegRef f z vec seg = + let seg' = toList seg + vec' = toList vec + scanl'_ v = let res = P.scanl f z v in (P.init res, P.last res) + (scans, sums) = P.unzip [ scanl'_ v | v <- splitPlaces seg' vec'] + in ( fromList (arrayShape vec) (concat scans) + , fromList (arrayShape seg) sums ) + +scanrSegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> Vector e +scanrSegRef f z vec seg = + let seg' = toList seg + vec' = toList vec + n = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg' + in fromList (Z :. n) $ + concat [ P.scanr f z v | v <- splitPlaces seg' vec' ] + +scanr1SegRef :: (Elt e, Integral i) => (e -> e -> e) -> Vector e -> Vector i -> Vector e +scanr1SegRef f vec seg = + let seg' = toList seg + vec' = toList vec + n = P.sum $ P.map P.fromIntegral seg' + in fromList (Z :. n) $ + concat [ P.scanr1 f v | v <- splitPlaces seg' vec' ] + +scanr'SegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> (Vector e, Vector e) +scanr'SegRef f z vec seg = + let seg' = toList seg + vec' = toList vec + scanr'_ v = let res = P.scanr f z v in (P.tail res, P.head res) + (scans, sums) = P.unzip [ scanr'_ v | v <- splitPlaces seg' vec'] + in ( fromList (arrayShape vec) (concat scans) + , fromList (arrayShape seg) sums ) + diff --git a/examples/nofib/Test/Prelude/Reduction.hs b/examples/nofib/Test/Prelude/Reduction.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Reduction.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Prelude.Reduction ( + + test_fold, + test_foldAll, + test_foldSeg, + +) where + +import Prelude as P +import Data.List +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Data.Array.Accelerate as A hiding (indexHead, indexTail) +import Data.Array.Accelerate.Array.Sugar as Sugar + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array + + + +-- +-- Reduction ------------------------------------------------------------------- +-- + +-- foldAll +-- ------- + +test_foldAll :: Config -> Test +test_foldAll opt = testGroup "foldAll" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) + [ testDim dim0 + , testDim dim1 + , testDim dim2 + ] + where + testDim :: forall sh. (Shape sh, Arbitrary sh, Arbitrary (Array sh e)) => sh -> Test + testDim sh = testGroup ("DIM" P.++ show (dim sh)) + [ + testProperty "sum" (test_sum :: Array sh e -> Property) + , testProperty "non-neutral sum" (test_sum' :: Array sh e -> e -> Property) + , testProperty "minimum" (test_min :: Array sh e -> Property) + , testProperty "maximum" (test_max :: Array sh e -> Property) + ] + -- + -- The tests + -- + test_min xs + = arraySize (arrayShape xs) > 0 + ==> run backend (A.fold1All min (use xs)) ~?= fold1AllRef min xs + + test_max xs + = arraySize (arrayShape xs) > 0 + ==> run backend (A.fold1All max (use xs)) ~?= fold1AllRef max xs + + test_sum xs = run backend (A.foldAll (+) 0 (use xs)) ~?= foldAllRef (+) 0 xs + test_sum' xs z = + let z' = unit (constant z) + in run backend (A.foldAll (+) (the z') (use xs)) ~?= foldAllRef (+) z xs + + backend = get configBackend opt + + +-- multidimensional fold +-- --------------------- + +test_fold :: Config -> Test +test_fold opt = testGroup "fold" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) + [ testDim dim1 + , testDim dim2 + ] + where + testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test + testDim sh = testGroup ("DIM" P.++ show (dim sh)) + [ + testProperty "sum" (test_sum :: Array (sh :. Int) e -> Property) + , testProperty "non-neutral sum" (test_sum' :: Array (sh :. Int) e -> e -> Property) + , testProperty "minimum" (test_min :: Array (sh :. Int) e -> Property) + , testProperty "maximum" (test_max :: Array (sh :. Int) e -> Property) + ] + -- + -- The tests + -- + test_min xs + = indexHead (arrayShape xs) > 0 + ==> run backend (A.fold1 min (use xs)) ~?= fold1Ref min xs + + test_max xs + = indexHead (arrayShape xs) > 0 + ==> run backend (A.fold1 max (use xs)) ~?= fold1Ref max xs + + test_sum xs = run backend (A.fold (+) 0 (use xs)) ~?= foldRef (+) 0 xs + test_sum' xs z = + let z' = unit (constant z) + in run backend (A.fold (+) (the z') (use xs)) ~?= foldRef (+) z xs + + backend = get configBackend opt + + +-- segmented fold +-- -------------- + +test_foldSeg :: Config -> Test +test_foldSeg opt = testGroup "foldSeg" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Config :-> Bool) -> e -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) + [ testDim dim1 + , testDim dim2 + ] + where + testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test + testDim sh = testGroup ("DIM" P.++ show (dim sh)) + [ + testProperty "sum" + $ forAll arbitrarySegments $ \(seg :: Segments Int32) -> + forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) -> + run backend (A.foldSeg (+) 0 (use xs) (use seg)) ~?= foldSegRef (+) 0 xs seg + + , testProperty "non-neutral sum" + $ forAll arbitrarySegments $ \(seg :: Segments Int32) -> + forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) -> + forAll arbitrary $ \z -> + let z' = unit (constant z) + in run backend (A.foldSeg (+) (the z') (use xs) (use seg)) ~?= foldSegRef (+) z xs seg + + , testProperty "minimum" + $ forAll arbitrarySegments1 $ \(seg :: Segments Int32) -> + forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) -> + run backend (A.fold1Seg min (use xs) (use seg)) ~?= fold1SegRef min xs seg + ] + + backend = get configBackend opt + + +-- Reference implementation +-- ------------------------ + +foldAllRef :: Elt e => (e -> e -> e) -> e -> Array sh e -> Array Z e +foldAllRef f z + = A.fromList Z + . return + . foldl f z + . A.toList + +fold1AllRef :: Elt e => (e -> e -> e) -> Array sh e -> Array Z e +fold1AllRef f + = A.fromList Z + . return + . foldl1 f + . A.toList + +foldRef :: (Shape sh, Elt e) => (e -> e -> e) -> e -> Array (sh :. Int) e -> Array sh e +foldRef f z arr = + let (sh :. n) = arrayShape arr + sh' = listToShape . P.map (max 1) . shapeToList $ sh + in fromList sh' [ foldl f z sub | sub <- splitEvery n (toList arr) ] + +fold1Ref :: (Shape sh, Elt e) => (e -> e -> e) -> Array (sh :. Int) e -> Array sh e +fold1Ref f arr = + let (sh :. n) = arrayShape arr + in fromList sh [ foldl1 f sub | sub <- splitEvery n (toList arr) ] + +foldSegRef :: (Shape sh, Elt e, Elt i, Integral i) => (e -> e -> e) -> e -> Array (sh :. Int) e -> Segments i -> Array (sh :. Int) e +foldSegRef f z arr seg = fromList (sh :. sz) $ concat [ foldseg sub | sub <- splitEvery n (toList arr) ] + where + (sh :. n) = arrayShape arr + (Z :. sz) = arrayShape seg + seg' = toList seg + foldseg xs = P.map (foldl' f z) (splitPlaces seg' xs) + +fold1SegRef :: (Shape sh, Elt e, Elt i, Integral i) => (e -> e -> e) -> Array (sh :. Int) e -> Segments i -> Array (sh :. Int) e +fold1SegRef f arr seg = fromList (sh :. sz) $ concat [ foldseg sub | sub <- splitEvery n (toList arr) ] + where + (sh :. n) = arrayShape arr + (Z :. sz) = arrayShape seg + seg' = toList seg + foldseg xs = P.map (foldl1' f) (splitPlaces seg' xs) + diff --git a/examples/nofib/Test/Prelude/Replicate.hs b/examples/nofib/Test/Prelude/Replicate.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Replicate.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Prelude.Replicate ( + + test_replicate, + +) where + +import Prelude as P +import Data.Array.Accelerate as A +import Data.Array.Unboxed as IArray hiding ( Array ) +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.HUnit hiding ( Test ) +import Test.Framework +import Test.Framework.Providers.HUnit + +import Config +import ParseArgs + + +-- +-- Slice ----------------------------------------------------------------------- +-- + +test_replicate :: Config -> Test +test_replicate opt = testGroup "replicate" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + + testElt :: forall e. (Elt e, IsNum e, Num e, Eq e, IArray UArray e) => (Config :-> Bool) -> e -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) + [ + testCase "(Z:.2:.All:.All)" $ ref1 @=? run' test1 + , testCase "(Z:.All:.2:.All)" $ ref2 @=? run' test2 + , testCase "(Z:.All:.All:.2)" $ ref3 @=? run' test3 + , testCase "(Any:.2)" $ ref4 @=? run' test4 + ] + + where + arr :: Acc (Array DIM2 e) + arr = use $ fromList (Z:.2:.2) [1,2,3,4] + + run' = toIArray . run backend + + -- Replicate into z-axis + -- should produce [1,2,3,4,1,2,3,4] + test1 :: Acc (Array DIM3 e) + test1 = A.replicate slice1 arr + + slice1 :: Exp (Z:.Int:.All:.All) + slice1 = lift $ Z:.(2::Int):.All:.All + + ref1 :: UArray (Int,Int,Int) e + ref1 = array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) + , ((0,0,1), 2) + , ((0,1,0), 3) + , ((0,1,1), 4) + , ((1,0,0), 1) + , ((1,0,1), 2) + , ((1,1,0), 3) + , ((1,1,1), 4) ] + + -- Replicate into y-axis + -- should produce [1,2,1,2,3,4,3,4] + test2 :: Acc (Array DIM3 e) + test2 = A.replicate slice2 arr + + slice2 :: Exp (Z:.All:.Int:.All) + slice2 = lift $ Z:.All:.(2::Int):.All + + ref2 :: UArray (Int,Int,Int) e + ref2 = array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) + , ((0,0,1), 2) + , ((0,1,0), 1) + , ((0,1,1), 2) + , ((1,0,0), 3) + , ((1,0,1), 4) + , ((1,1,0), 3) + , ((1,1,1), 4) ] + + -- Replicate into x-axis + -- should produce [1,1,2,2,3,3,4,4] + test3 :: Acc (Array DIM3 e) + test3 = A.replicate slice3 arr + + slice3 :: Exp (Z:.All:.All:.Int) + slice3 = lift $ Z:.All:.All:.(2::Int) + + ref3 :: UArray (Int,Int,Int) e + ref3 = array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) + , ((0,0,1), 1) + , ((0,1,0), 2) + , ((0,1,1), 2) + , ((1,0,0), 3) + , ((1,0,1), 3) + , ((1,1,0), 4) + , ((1,1,1), 4) ] + + -- Replicates an array into the rightmost dimension of the result array. + -- + repN :: forall sh a. (Shape sh, Elt a) + => Int + -> Acc (Array sh a) + -> Acc (Array (sh:.Int) a) + repN n a = A.replicate (lift (Any:.n :: Any sh:.Int)) a + + test4 :: Acc (Array DIM3 e) + test4 = repN 2 arr + + ref4 :: UArray (Int,Int,Int) e + ref4 = array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) + , ((0,0,1), 1) + , ((0,1,0), 2) + , ((0,1,1), 2) + , ((1,0,0), 3) + , ((1,0,1), 3) + , ((1,1,0), 4) + , ((1,1,1), 4) ] + diff --git a/examples/nofib/Test/Prelude/Stencil.hs b/examples/nofib/Test/Prelude/Stencil.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Prelude/Stencil.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +module Test.Prelude.Stencil ( + + test_stencil, + +) where + +import Prelude as P +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array () + +import Data.Array.Accelerate as A +import Data.Array.Unboxed as IArray hiding ( Array ) +import qualified Data.Array.IArray as IArray + + +-- TODO: +-- +-- * Tests for boundary conditions: Mirror and Wrap +-- * Higher dimensional stencils +-- + +-- +-- Stencil --------------------------------------------------------------------- +-- + +test_stencil :: Config -> Test +test_stencil opt = testGroup "stencil" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + , testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + + testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a, IArray UArray a) + => (Config :-> Bool) + -> a + -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) + [ testProperty "1D" (test_stencil1D :: Array DIM1 a -> Property) + , testProperty "2D 3x3 dense" (test_stencil2D1 :: Array DIM2 a -> Property) + , testProperty "2D 3x3 cross" (test_stencil2D2 :: Array DIM2 a -> Property) + , testProperty "2D non-symmetric" (test_stencil2D3 :: Array DIM2 (a,a) -> Property) + ] + + -- 1D Stencil + -- + test_stencil1D :: (Num a, IsNum a, Elt a, Similar a, IArray UArray a) => Vector a -> Property + test_stencil1D vec = toList (acc vec) ~?= elems (ref (toIArray vec)) + where + pattern (x,y,z) = x + z - 2 * y + + acc xs = run backend $ stencil pattern Clamp (use xs) + + ref :: (Num e, IArray UArray e) => UArray Int e -> UArray Int e + ref xs = + let (minx,maxx) = bounds xs + clamp x = Right (minx `P.max` x `P.min` maxx) + in + stencil1DRef pattern clamp xs + + -- 2D Stencil + -- + test_stencil2D1 :: (Num a, IsNum a, Elt a, Similar a, IArray UArray a) => Array DIM2 a -> Property + test_stencil2D1 vec = toList (acc vec) ~?= elems (ref (toIArray vec)) + where + pattern ( (t1, t2, t3) + , (l , m, r ) + , (b1, b2, b3) + ) + = (t1 + t2 + t3 - l + 4*m - r - b1 - b2 - b3) + + acc xs = run backend $ stencil pattern (Constant 0) (use xs) + + ref :: (Num a, IArray UArray a) => UArray (Int,Int) a -> UArray (Int,Int) a + ref xs = + let + sh = bounds xs + constant ix + | inRange sh ix = Right ix + | otherwise = Left 0 + + in + stencil2DRef pattern constant xs + + + test_stencil2D2 :: (Num a, IsNum a, Elt a, Similar a, IArray UArray a) => Array DIM2 a -> Property + test_stencil2D2 vec = toList (acc vec) ~?= elems (ref (toIArray vec)) + where + pattern ( (_, t, _) + , (l, m, r) + , (_, b, _) + ) + = (t + l + r + b - 4 * m) + + acc xs = + let pattern' :: (Elt a, IsNum a) => Stencil3x3 a -> Exp a + pattern' = pattern + in + run backend $ stencil pattern' Clamp (use xs) + + ref :: (Num a, IArray UArray a) => UArray (Int,Int) a -> UArray (Int,Int) a + ref xs = + let ((minu,minv),(maxu,maxv)) = bounds xs + clamp (u,v) = Right (minu `P.max` u `P.min` maxu + ,minv `P.max` v `P.min` maxv) + in + stencil2DRef pattern clamp xs + + test_stencil2D3 :: (Num a, IsNum a, Elt a, Similar a, IArray UArray a) => Array DIM2 (a,a) -> Property + test_stencil2D3 vec = toList (acc vec) ~?= elems (ref (toIArray vec)) + where + pattern :: forall a. (Elt a, IsNum a) => Stencil3x3 (a,a) -> Exp a + pattern ( (_, _, _) , (x, _, _) , (y, _, z)) + = let (x1,x2) = unlift x + (y1,y2) = unlift y + (z1,z2) = unlift z + in + x1 - y2 + y1 - z2 + z1 - x2 + + pattern' ( (_, _, _) , (x, _, _) , (y, _, z)) + = let (x1,x2) = x + (y1,y2) = y + (z1,z2) = z + in + x1 - y2 + y1 - z2 + z1 - x2 + + acc xs = run backend $ stencil pattern (Constant (0,0)) (use xs) + + ref :: Num a => IArray.Array (Int,Int) (a,a) -> IArray.Array (Int,Int) a + ref xs = + let + sh = bounds xs + constant ix + | inRange sh ix = Right ix + | otherwise = Left (0,0) + in + stencil2DRef pattern' constant xs + + +-- +-- Reference implementation +-- +stencil1DRef + :: (IArray array a, IArray array b) + => ((a,a,a) -> b) + -> (Int -> Either a Int) + -> array Int a + -> array Int b +stencil1DRef pattern boundary xs = + let + indexAt ix = case boundary ix of + Left e -> e + Right ix' -> xs IArray.! ix' + + f ix = let x = indexAt (ix-1) + y = indexAt ix + z = indexAt (ix+1) + in + pattern (x,y,z) + in + array (bounds xs) [(ix, f ix) | ix <- indices xs] + + +stencil2DRef :: (IArray array a, IArray array b) + => (((a,a,a), (a,a,a), (a,a,a)) -> b) + -> ((Int,Int) -> Either a (Int,Int)) + -> array (Int,Int) a + -> array (Int,Int) b +stencil2DRef pattern boundary xs = + let + indexAt ix = case boundary ix of + Left e -> e + Right ix' -> xs IArray.! ix' + + f (y,x) = let t1 = indexAt (y-1,x-1) + t2 = indexAt (y-1,x ) + t3 = indexAt (y-1,x+1) + l = indexAt (y, x-1) + m = indexAt (y, x ) + r = indexAt (y, x+1) + b1 = indexAt (y+1,x-1) + b2 = indexAt (y+1,x ) + b3 = indexAt (y+1,x+1) + in + pattern ((t1,t2,t3), (l,m,r), (b1,b2,b3)) + in + array (bounds xs) [(ix, f ix) | ix <- indices xs] + diff --git a/examples/nofib/Test/Sharing.hs b/examples/nofib/Test/Sharing.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Sharing.hs @@ -0,0 +1,298 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Sharing ( + + test_sharing + +) where + +import Config + +import Prelude as P +import Data.Array.Accelerate as A +import Test.Framework +import Test.Framework.Providers.HUnit + + +test_sharing :: Config -> Test +test_sharing _ = + testGroup "sharing recovery" + [ + sharing "simple" simple + , sharing "order fail" orderFail + , sharing "test sort" testSort + , sharing "much sharing" (muchSharing 20) + , sharing "bfs fail" bfsFail + , sharing "two lets same level" twoLetsSameLevel + , sharing "two lets same level" twoLetsSameLevel2 + , sharing "no let at top" noLetAtTop + , sharing "no let at top" noLetAtTop2 + , sharing "pipe" pipe + , sharing "bound variables" varUse + , sharing "big tuple" bigTuple + , iteration + ] + where + sharing :: Show a => TestName -> a -> Test + sharing name acc = + testCase name (length (show acc) `seq` return ()) + + + +-------------------------------------------------------------------------------- +-- +-- Some tests to make sure that sharing recovery is working. +-- + +mkArray :: Int -> Acc (Array DIM1 Int) +mkArray n = use $ fromList (Z:.1) [n] + +muchSharing :: Int -> Acc (Array DIM1 Int) +muchSharing 0 = (mkArray 0) +muchSharing n = A.map (\_ -> newArr ! (lift (Z:.(0::Int))) + + newArr ! (lift (Z:.(1::Int)))) (mkArray n) + where + newArr = muchSharing (n-1) + +idx :: Int -> Exp DIM1 +idx i = lift (Z:.i) + +bfsFail :: Acc (Array DIM1 Int) +bfsFail = A.map (\x -> (map2 ! (idx 1)) + (map1 ! (idx 2)) + x) arr + where + map1 :: Acc (Array DIM1 Int) + map1 = A.map (\y -> (map2 ! (idx 3)) + y) arr + + map2 :: Acc (Array DIM1 Int) + map2 = A.map (\z -> z + 1) arr + + arr :: Acc (Array DIM1 Int) + arr = mkArray 666 + +twoLetsSameLevel :: Acc (Array DIM1 Int) +twoLetsSameLevel = + let arr1 = mkArray 1 + in let arr2 = mkArray 2 + in A.map (\_ -> arr1!(idx 1) + arr1!(idx 2) + arr2!(idx 3) + arr2!(idx 4)) (mkArray 3) + +twoLetsSameLevel2 :: Acc (Array DIM1 Int) +twoLetsSameLevel2 = + let arr2 = mkArray 2 + in let arr1 = mkArray 1 + in A.map (\_ -> arr1!(idx 1) + arr1!(idx 2) + arr2!(idx 3) + arr2!(idx 4)) (mkArray 3) + + +-- These two programs test that lets can be introduced not just at the top of a AST +-- but in intermediate nodes. +-- +noLetAtTop :: Acc (Array DIM1 Int) +noLetAtTop = A.map (\x -> x + 1) bfsFail + +noLetAtTop2 :: Acc (Array DIM1 Int) +noLetAtTop2 + = A.map (\x -> x + 2) + $ A.map (\x -> x + 1) bfsFail + +-- +-- +-- +simple :: Acc (Array DIM1 (Int,Int)) +simple = A.map (\_ -> a ! (idx 1)) d + where + c = use $ A.fromList (Z :. 3) [1..] + d = A.map (+1) c + a = A.zip d c + + +-- sortKey is a real program that Ben Lever wrote. It has some pretty interesting +-- sharing going on. +-- +sortKey :: (Elt e) + => (Exp e -> Exp Int) -- ^mapping function to produce key array from input array + -> Acc (Vector e) + -> Acc (Vector e) +sortKey keyFun arr = foldl sortOneBit arr (P.map lift ([0..31] :: [Int])) + where + sortOneBit inArr bitNum = outArr + where + keys = A.map keyFun inArr + + bits = A.map (\a -> (A.testBit a bitNum) ? (1, 0)) keys + bitsInv = A.map (\b -> (b ==* 0) ? (1, 0)) bits + + (falses, numZeroes) = A.scanl' (+) 0 bitsInv + trues = A.map (\x -> (A.the numZeroes) + (A.fst x) - (A.snd x)) + $ A.zip ixs falses + + dstIxs = A.map (\x -> let (b, t, f) = unlift x in (b ==* (constant (0::Int))) ? (f, t)) + $ A.zip3 bits trues falses + outArr = scatter dstIxs inArr inArr -- just use input as default array + --(we're writing over everything anyway) + -- + ixs = enumeratedArray (shape arr) + +-- Create an array where each element is the value of its corresponding +-- row-major index. +-- +--enumeratedArray :: (Shape sh) => Exp sh -> Acc (Array sh Int) +--enumeratedArray sh = A.reshape sh +-- $ A.generate (index1 $ shapeSize sh) unindex1 + +enumeratedArray :: Exp DIM1 -> Acc (Array DIM1 Int) +enumeratedArray sh = A.generate sh unindex1 + +testSort :: Acc (Vector Int) +testSort = sortKey id $ use $ fromList (Z:.10) [9,8,7,6,5,4,3,2,1,0] + + +-- map1 has children map3 and map2. +-- map2 has child map3. +-- Back when we still used a list for the NodeCounts data structure this mean that +-- you would be merging [1,3,2] with [2,3] which violated precondition of (+++). +-- This tests that the new algorithm works just fine on this. +-- +orderFail :: Acc (Array DIM1 Int) +orderFail = A.map (\_ -> map1 ! (idx 1) + map2 ! (idx 1)) arr + where + map1 = A.map (\_ -> map3 ! (idx 1) + map2 ! (idx 2)) arr + map2 = A.map (\_ -> map3 ! (idx 3)) arr + map3 = A.map (+1) arr + arr = mkArray 42 + + +-- Tests array-valued lambdas in conjunction with sharing recovery. +-- +pipe :: Acc (Vector Int) +pipe = (acc1 >-> acc2) xs + where + z :: Acc (Scalar Int) + z = unit 0 + + xs :: Acc (Vector Int) + xs = use $ fromList (Z:.10) [0..] + + acc1 :: Acc (Vector Int) -> Acc (Vector Int) + acc1 = A.map (\_ -> the z) + + acc2 :: Acc (Vector Int) -> Acc (Vector Int) + acc2 arr = let arr2 = use $ fromList (Z:.10) [10..] + in A.map (\_ -> arr2!constant (Z:.(0::Int))) (A.zip arr arr2) + + +-- Test for bound variables +-- +varUse :: (Acc (Array DIM2 Int), Acc (Array DIM2 Float), Acc (Array DIM2 Float)) +varUse = (first, both, second) + where + is :: Array DIM2 Int + is = fromList (Z:.10:.10) [0..] + + fs :: Array DIM2 Float + fs = fromList (Z:.10:.10) [0..] + + -- Ignoring the first parameter + first = stencil2 centre Clamp (use fs) Clamp (use is) + where + centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Int + centre _ (_,(_,y,_),_) = y + + -- Using both + both = stencil2 centre Clamp (use fs) Clamp (use is) + where + centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Float + centre (_,(_,x,_),_) (_,(_,y,_),_) = x + A.fromIntegral y + + -- Not using the second parameter + second = stencil2 centre Clamp (use fs) Clamp (use is) + where + centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Float + centre (_,(_,x,_),_) _ = x + +-- Test for 8 and 9 tuples +-- +bigTuple :: (Exp (Int,Int,Int,Int,Int,Int,Int,Int), Exp (Int,Int,Int,Int,Int,Int,Int,Int,Int)) +bigTuple = (A.constant (0,0,0,0,0,0,0,0), A.constant (0,0,0,0,0,0,0,0,0)) + +-- Tests for sharing recovery of iteration +-- +iteration :: Test +iteration = testGroup "iteration" + [ + iter "simple" test1 + , iter "outside" test2 + , iter "body and condition" test3 + , iter "awhile" awhile_test + , iter "iterate" iterate_test + , iter "nested" nested + , iter "unused" unused + ] + where + iter :: Show a => TestName -> a -> Test + iter name acc = testCase name (length (show acc) `seq` return ()) + + vec :: Acc (Vector Float) + vec = use $ fromList (Z:.10) [0..] + + test1 :: Acc (Vector Float) + test1 = flip A.map vec + $ \x -> A.while (<* x) (+1) 0 + + test2 :: Acc (Vector Float) + test2 = flip A.map vec + $ \x -> let y = 2*pi + in y + A.while (<* 10) (+y) x + + test3 :: Acc (Vector Float) + test3 = flip A.map vec + $ \x -> A.while (<* x) (+x) 0 + + awhile_test :: Acc (Vector Float) + awhile_test = A.awhile (\a -> A.unit (the (A.sum a) <* 200)) (A.map (+1)) vec + + iterate_test :: Acc (Vector Float) + iterate_test = flip A.map vec + $ \x -> let y = 2*x + in y + A.iterate (constant 10) (\x' -> y + x' + 10) x + + for :: Elt a => Exp Int -> (Exp Int -> Exp a -> Exp a) -> Exp a -> Exp a + for n f seed + = A.snd + $ A.iterate n (\v -> let (i, x) = unlift v + in lift (i+1, f i x)) + (lift (constant 0, seed)) + + nested :: Exp Int + nested + = for 64 (\i _ -> + for 64 (\j acc' -> i + j + acc') 0) 0 + + unused :: Exp Int + = A.while (==* 10) (const 10) 5 + +---------------------------------------------------------------------- + +-- This program contains nested data-parallelism and thus sharing recovery +-- will fail. +-- +_shouldFail :: Acc (Vector Float) +_shouldFail = mvm (use $ fromList (Z:.10:.10) [0..]) (use $ fromList (Z:.10) [0..]) + where + dotp :: (Elt e, IsNum e) => Acc (Vector e) -> Acc (Vector e) -> Acc (Scalar e) + dotp xs ys = A.fold (+) 0 $ A.zipWith (*) xs ys + + takeRow :: Elt e => Exp Int -> Acc (Array DIM2 e) -> Acc (Vector e) + takeRow n mat = + let Z :. _ :. cols = unlift (shape mat) :: Z:. Exp Int :. Exp Int + in backpermute (index1 cols) + (\ix -> index2 n (unindex1 ix)) + mat + + mvm :: (Elt e, IsNum e) => Acc (Array DIM2 e) -> Acc (Vector e) -> Acc (Vector e) + mvm mat vec = + let Z :. rows :. _ = unlift (shape mat) :: Z :. Exp Int :. Exp Int + in generate (index1 rows) + (\ix -> the (vec `dotp` takeRow (unindex1 ix) mat)) + + + diff --git a/examples/nofib/Test/Spectral.hs b/examples/nofib/Test/Spectral.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Spectral.hs @@ -0,0 +1,23 @@ + +module Test.Spectral ( + + test_spectral + +) where + +import Config + +import Test.Framework +import Test.Spectral.BlackScholes +import Test.Spectral.SMVM +import Test.Spectral.RadixSort + + +test_spectral :: Config -> Test +test_spectral conf = + testGroup "spectral" + [ test_blackscholes conf + , test_smvm conf + , test_radixsort conf + ] + diff --git a/examples/nofib/Test/Spectral/BlackScholes.cpp b/examples/nofib/Test/Spectral/BlackScholes.cpp new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Spectral/BlackScholes.cpp @@ -0,0 +1,116 @@ + +#include + + +/* + * Polynomial approximation of cumulative normal distribution function + */ +template +static T CND(T d) +{ + const T a1 = 0.31938153; + const T a2 = -0.356563782; + const T a3 = 1.781477937; + const T a4 = -1.821255978; + const T a5 = 1.330274429; + const T rsqrt2pi = 0.39894228040143267793994605993438; + + T k = 1.0 / (1.0 + 0.2316419 * fabs(d)); + + T cnd = rsqrt2pi * exp(- 0.5 * d * d) + * (k * (a1 + k * (a2 + k * (a3 + k * (a4 + k * a5))))); + + if (d > 0) + cnd = 1.0 - cnd; + + return cnd; +} + + +/* + * Black-Scholes formula for both call and put + */ +template +static void BlackScholesBody +( + T &callResult, + T &putResult, + T sf, // Stock price + T xf, // Option strike + T tf, // Option years + T rf, // Riskless rate + T vf // Volatility rate +) +{ + T s = sf, x = xf, t = tf, r = rf, v = vf; + + T sqrtT = sqrt(t); + T d1 = (log(s / x) + (r + 0.5 * v * v) * t) / (v * sqrtT); + T d2 = d1 - v * sqrtT; + T CNDD1 = CND(d1); + T CNDD2 = CND(d2); + + //Calculate Call and Put simultaneously + T expRT = exp(- r * t); + callResult = (s * CNDD1 - x * expRT * CNDD2); + putResult = (x * expRT * (1.0 - CNDD2) - s * (1.0 - CNDD1)); +} + + +/* + * Process an array of optN options + */ +extern "C" +void BlackScholes_f +( + float *CallResult, + float *PutResult, + float *StockPrice, + float *OptionStrike, + float *OptionYears, + float Riskfree, + float Volatility, + int optN +) +{ + for (int opt = 0; opt < optN; opt++) { + BlackScholesBody + ( + CallResult[opt], + PutResult[opt], + StockPrice[opt], + OptionStrike[opt], + OptionYears[opt], + Riskfree, + Volatility + ); + } +} + +extern "C" +void BlackScholes_d +( + double *CallResult, + double *PutResult, + double *StockPrice, + double *OptionStrike, + double *OptionYears, + double Riskfree, + double Volatility, + int optN +) +{ + for (int opt = 0; opt < optN; opt++) { + BlackScholesBody + ( + CallResult[opt], + PutResult[opt], + StockPrice[opt], + OptionStrike[opt], + OptionYears[opt], + Riskfree, + Volatility + ); + } +} + diff --git a/examples/nofib/Test/Spectral/BlackScholes.hs b/examples/nofib/Test/Spectral/BlackScholes.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Spectral/BlackScholes.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Spectral.BlackScholes ( + + test_blackscholes + +) where + +import Prelude as P +import Control.Applicative +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.QuickCheck.Property ( morallyDubiousIOProperty ) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 +import Foreign.Ptr +import Foreign.Marshal +import Foreign.Storable +import System.Random + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array +import Data.Array.Accelerate as A +import Data.Array.Accelerate.Array.Sugar as A +import Data.Array.Accelerate.IO as A + + +test_blackscholes :: Config -> Test +test_blackscholes opt = testGroup "black-scholes" $ catMaybes + [ testElt configFloat c_BlackScholes_f + , testElt configDouble c_BlackScholes_d + ] + where + backend = get configBackend opt + + testElt :: forall a. ( Elt a, IsFloating a, Similar a, Arbitrary a, Random a, Storable a + , BlockPtrs (EltRepr a) ~ ((), Ptr a), BlockPtrs (EltRepr' a) ~ Ptr a) + => (Config :-> Bool) + -> BlackScholes a + -> Maybe Test + testElt ok cfun + | P.not (get ok opt) = Nothing + | otherwise = Just + $ testProperty (show (typeOf (undefined :: a))) (run_blackscholes cfun) + + opts :: (Floating a, Random a) => Gen (a,a,a) + opts = (,,) <$> choose (5,30) <*> choose (1,100) <*> choose (0.25,10) + + run_blackscholes :: forall a. ( Elt a, IsFloating a, Similar a, Storable a, Random a, Arbitrary a + , BlockPtrs (EltRepr a) ~ ((), Ptr a), BlockPtrs (EltRepr' a) ~ Ptr a) + => BlackScholes a -> Property + run_blackscholes cfun = sized $ \nmax -> + forAll (choose (0,nmax)) $ \n -> + forAll (arbitraryArrayOf (Z:.n) opts) $ \psy -> morallyDubiousIOProperty $ do + let actual = run1 backend blackscholes psy + expected <- blackScholesRef cfun psy + return $ expected ~?= actual + + +-- +-- Black-Scholes option pricing ------------------------------------------------ +-- + +riskfree, volatility :: Floating a => a +riskfree = 0.02 +volatility = 0.30 + +horner :: Num a => [a] -> a -> a +horner coeff x = x * foldr1 madd coeff + where + madd a b = a + x*b + +cnd' :: Floating a => a -> a +cnd' d = + let poly = horner coeff + coeff = [0.31938153,-0.356563782,1.781477937,-1.821255978,1.330274429] + rsqrt2pi = 0.39894228040143267793994605993438 + k = 1.0 / (1.0 + 0.2316419 * abs d) + in + rsqrt2pi * exp (-0.5*d*d) * poly k + + +blackscholes :: (Elt a, IsFloating a) => Acc (Vector (a, a, a)) -> Acc (Vector (a, a)) +blackscholes = A.map go + where + go x = + let (price, strike, years) = A.unlift x + r = A.constant riskfree + v = A.constant volatility + v_sqrtT = v * sqrt years + d1 = (log (price / strike) + (r + 0.5 * v * v) * years) / v_sqrtT + d2 = d1 - v_sqrtT + cnd d = let c = cnd' d in d >* 0 ? (1.0 - c, c) + cndD1 = cnd d1 + cndD2 = cnd d2 + x_expRT = strike * exp (-r * years) + in + A.lift ( price * cndD1 - x_expRT * cndD2 + , x_expRT * (1.0 - cndD2) - price * (1.0 - cndD1)) + + +-- Reference implementation, stolen from the CUDA SDK examples reference +-- implementation and modified for our purposes. +-- +type BlackScholes a = Ptr a -> Ptr a -> Ptr a -> Ptr a -> Ptr a -> a -> a -> Int32 -> IO () + +blackScholesRef + :: forall a. (Storable a, Floating a, Elt a, BlockPtrs (EltRepr a) ~ ((), Ptr a), BlockPtrs (EltRepr' a) ~ Ptr a) + => BlackScholes a + -> Vector (a,a,a) + -> IO (Vector (a,a)) +blackScholesRef cfun xs = + let (Z :. n) = arrayShape xs + in + allocaArray n $ \p_call -> + allocaArray n $ \p_put -> + allocaArray n $ \p_price -> + allocaArray n $ \p_strike -> + allocaArray n $ \p_years -> do + toPtr xs ((((), p_price), p_strike), p_years) + cfun p_call p_put p_price p_strike p_years riskfree volatility (P.fromIntegral n) + fromPtr (Z :. n) (((), p_call), p_put) + + +foreign import ccall unsafe "BlackScholes_f" c_BlackScholes_f :: Ptr Float -> Ptr Float -> Ptr Float -> Ptr Float -> Ptr Float -> Float -> Float -> Int32 -> IO () +foreign import ccall unsafe "BlackScholes_d" c_BlackScholes_d :: Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Ptr Double -> Double -> Double -> Int32 -> IO () + diff --git a/examples/nofib/Test/Spectral/RadixSort.hs b/examples/nofib/Test/Spectral/RadixSort.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Spectral/RadixSort.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +-- +-- Radix sort for a subclass of element types +-- + +module Test.Spectral.RadixSort ( + + test_radixsort, + +) where + +import Prelude as P +import Data.Bits +import Data.List +import Data.Label +import Data.Maybe +import Data.Function +import Data.Typeable +import Test.QuickCheck ( Arbitrary, Property ) +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array () +import Data.Array.Accelerate as A + + +-- +-- Radix sort ------------------------------------------------------------------ +-- +-- This is rather slow. Speeding up the reference implementation by using, say, +-- vector-algorithms, does not significantly change the runtime. Thus, we stick +-- to the simple list-based representation for the time being. +-- + +test_radixsort :: Config -> Test +test_radixsort opt = testGroup "radix sort" $ catMaybes + [ testElt configInt8 (undefined :: Int8) + , testElt configInt16 (undefined :: Int16) + , testElt configInt32 (undefined :: Int32) + , testElt configInt64 (undefined :: Int64) + , testElt configWord8 (undefined :: Word8) + , testElt configWord16 (undefined :: Word16) + , testElt configWord32 (undefined :: Word32) + , testElt configWord64 (undefined :: Word64) + ] + where + backend = get configBackend opt + + testElt :: forall a. (Radix a, Ord a, Elt a, IsIntegral a, Similar a, Arbitrary a) + => (Config :-> Bool) + -> a + -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) + [ + testProperty "ascending" (test_ascending :: Vector a -> Property) + , testProperty "descending" (test_descending :: Vector a -> Property) + , testProperty "(key,val)" (test_keyval :: Vector (a,Float) -> Property) + ] + + test_ascending xs = toList (run1 backend radixsort xs) ~?= sort (toList xs) + test_descending xs = toList (run1 backend (radixsortBy complement) xs) ~?= sortBy (flip compare) (toList xs) + test_keyval xs = toList (run1 backend (radixsortBy A.fst) xs) ~?= sortBy (compare `on` P.fst) (toList xs) + + +-- Implementation +-- -------------- + +class Elt e => Radix e where + passes :: e {- dummy -} -> Int + radix :: Exp Int -> Exp e -> Exp Int + +#define signed(ty) \ +instance Radix ty where ; \ + passes = bitSize ; \ + radix = radixOfSigned ; + +#define unsigned(ty) \ +instance Radix ty where ; \ + passes = bitSize ; \ + radix = radixOfUnsigned ; + +signed(Int) +signed(Int8) +signed(Int16) +signed(Int32) +signed(Int64) +unsigned(Word) +unsigned(Word8) +unsigned(Word16) +unsigned(Word32) +unsigned(Word64) + +radixOfSigned :: forall e. (Radix e, IsIntegral e) => Exp Int -> Exp e -> Exp Int +radixOfSigned i e = i ==* (passes' - 1) ? (radix' (e `xor` minBound), radix' e) + where + radix' x = A.fromIntegral $ (x `A.shiftR` i) .&. 1 + passes' = constant (passes (undefined :: e)) + +radixOfUnsigned :: (Radix e, IsIntegral e) => Exp Int -> Exp e -> Exp Int +radixOfUnsigned i e = A.fromIntegral $ (e `A.shiftR` i) .&. 1 + + +-- A simple (parallel) radix sort implementation [1]. +-- +-- [1] G. E. Blelloch. "Prefix sums and their applications." Technical Report +-- CMU-CS-90-190. Carnegie Mellon University. 1990. +-- +radixsort :: Radix a => Acc (Vector a) -> Acc (Vector a) +radixsort = radixsortBy id + +radixsortBy :: forall a r. (Elt a, Radix r) => (Exp a -> Exp r) -> Acc (Vector a) -> Acc (Vector a) +radixsortBy rdx arr = foldr1 (>->) (P.map radixPass [0..p-1]) arr + where + p = passes (undefined :: r) + -- + deal f x = let (a,b) = unlift x in (f ==* 0) ? (a,b) + radixPass k v = let k' = unit (constant k) + flags = A.map (radix (the k') . rdx) v + idown = prescanl (+) 0 . A.map (xor 1) $ flags + iup = A.map (size v - 1 -) . prescanr (+) 0 $ flags + index = A.zipWith deal flags (A.zip idown iup) + in + permute const v (\ix -> index1 (index!ix)) v + + diff --git a/examples/nofib/Test/Spectral/SMVM.hs b/examples/nofib/Test/Spectral/SMVM.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Spectral/SMVM.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Spectral.SMVM ( + + test_smvm + +) where + +-- from the accelerate-smvm program +import SMVM + +import Prelude as P +import Data.Array.Accelerate as A +import Data.Label +import Data.Maybe +import Data.Typeable +import Test.QuickCheck +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +import Config +import ParseArgs +import Test.Base +import QuickCheck.Arbitrary.Array + + +test_smvm :: Config -> Test +test_smvm opt = testGroup "smvm" $ catMaybes +-- [ testElt configInt8 (undefined :: Int8) +-- , testElt configInt16 (undefined :: Int16) +-- , testElt configInt32 (undefined :: Int32) +-- , testElt configInt64 (undefined :: Int64) +-- , testElt configWord8 (undefined :: Word8) +-- , testElt configWord16 (undefined :: Word16) +-- , testElt configWord32 (undefined :: Word32) +-- , testElt configWord64 (undefined :: Word64) + [ testElt configFloat (undefined :: Float) + , testElt configDouble (undefined :: Double) + ] + where + backend = get configBackend opt + + testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) + => (Config :-> Bool) + -> a + -> Maybe Test + testElt ok _ + | P.not (get ok opt) = Nothing + | otherwise = Just + $ testProperty (show (typeOf (undefined :: a))) (run_smvm (undefined :: a)) + + run_smvm :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) => a -> Property + run_smvm _ = + forAll arbitraryCSRMatrix $ \(segd, svec :: Vector (Int32,a), cols) -> + forAll (arbitraryArray (Z :. cols)) $ \vec -> + run2 backend smvm (segd, svec) vec + ~?= + smvmRef segd svec vec + + +-- Reference implementation +-- ------------------------ + +smvmRef :: (Elt a, IsNum a) + => Segments Int32 + -> Vector (Int32, a) + -> Vector a + -> Vector a +smvmRef segd smat vec = + fromList (arrayShape segd) + [ P.sum [ val * indexArray vec (Z :. P.fromIntegral i) | (i,val) <- row ] + | row <- splitPlaces (toList segd) (toList smat) ] + diff --git a/examples/quickcheck/Arbitrary/Array.hs b/examples/quickcheck/Arbitrary/Array.hs deleted file mode 100644 --- a/examples/quickcheck/Arbitrary/Array.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Arbitrary.Array where - -import Arbitrary.Shape - -import Data.List -import Test.QuickCheck -import Data.Array.Accelerate.Array.Sugar -import System.Random ( Random ) - - -instance (Elt e, Arbitrary e) => Arbitrary (Array DIM0 e) where - arbitrary = do - e <- arbitrary - return $! fromList Z [e] - -- - shrink arr = - [ fromList Z [x] | x <- shrink (arr ! Z) ] - - -instance (Elt e, Arbitrary e) => Arbitrary (Array DIM1 e) where - arbitrary = do - sh <- sized arbitrarySmallShape - adata <- vectorOf (size sh) arbitrary - return $! fromList sh adata - -- - shrink arr = - let (Z :. n) = shape arr - indices = [ map (Z:.) (nub sz) | sz <- shrink [0 .. n-1] ] - in - [ fromList (Z :. length sl) (map (arr!) sl) | sl <- indices ] - - -instance (Elt e, Arbitrary e) => Arbitrary (Array DIM2 e) where - arbitrary = do - sh <- sized arbitrarySmallShape - adata <- vectorOf (size sh) arbitrary - return $! fromList sh adata - -- - shrink arr = - let (Z :. width :. height) = shape arr - in - [ fromList (Z :. length slx :. length sly) [ arr ! (Z:.x:.y) | x <- slx, y <- sly ] - | slx <- map nub $ shrink [0 .. width - 1] - , sly <- map nub $ shrink [0 .. height - 1] - ] - - -arbitraryArrayOfShape - :: (Shape sh, Elt e, Arbitrary e) - => sh - -> Gen (Array sh e) -arbitraryArrayOfShape sh = do - adata <- vectorOf (size sh) arbitrary - return $! fromList sh adata - -arbitrarySegmentedArray - :: (Integral i, Shape sh, Elt e, Arbitrary sh, Arbitrary e) - => Segments i -> Gen (Array (sh :. Int) e) -arbitrarySegmentedArray segs = do - let sz = fromIntegral . sum $ toList segs - sh <- sized $ \n -> arbitrarySmallShape (n `div` 2) - adata <- vectorOf (size sh * sz) arbitrary - return $! fromList (sh :. sz) adata - -arbitrarySegments :: (Elt i, Integral i, Arbitrary i, Random i) => Gen (Segments i) -arbitrarySegments = do - seg <- listOf (sized $ \n -> choose (0, fromIntegral n)) - return $! fromList (Z :. length seg) seg - -arbitrarySegments1 :: (Elt i, Integral i, Arbitrary i, Random i) => Gen (Segments i) -arbitrarySegments1 = do - seg <- listOf (sized $ \n -> choose (1, fromIntegral n)) - return $! fromList (Z :. length seg) seg - diff --git a/examples/quickcheck/Arbitrary/Shape.hs b/examples/quickcheck/Arbitrary/Shape.hs deleted file mode 100644 --- a/examples/quickcheck/Arbitrary/Shape.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Arbitrary.Shape where - -import Test.QuickCheck -import Data.Array.Accelerate.Array.Sugar - - -instance Arbitrary Z where - arbitrary = return Z - shrink = return - --- Keep shapes relatively small, because we are generating arrays via lists, but --- scale the 'sized' parameter so we still get non-trivial test vectors. --- -instance (Shape sh, Arbitrary sh) => Arbitrary (sh :. Int) where - arbitrary = do - sh <- arbitrary - sz <- sized $ \n -> - let nMax = 2048 `div` max 1 (size sh) - nMaxed = (n*4) `mod` nMax - in - choose (0, nMaxed) - -- - return (sh :. sz) - - shrink (sh :. sz) = [ sh' :. sz' | sh' <- shrink sh, sz' <- shrink sz ] - - --- Generate an arbitrary shape, where each dimension is less than some specific --- value. This will generate zero-sized shapes, but will take care not to --- generate too many of them. --- -arbitrarySmallShape :: forall sh. (Shape sh, Arbitrary sh) => Int -> Gen sh -arbitrarySmallShape maxDim = resize maxDim arbitrary - --- Generate a shape as above, but also restrict the dimensions to be either all --- zero, or all non-zero. --- -arbitrarySmallNonEmptyShape :: forall sh. (Shape sh, Arbitrary sh) => Int -> Gen sh -arbitrarySmallNonEmptyShape maxDim = do - sh <- resize maxDim arbitrary :: Gen sh - let ix = map (`mod` max 1 maxDim) (shapeToList sh) - sh' - | all (== 0) ix = ix - | otherwise = map (max 1) ix - -- - return (listToShape sh' :: sh) - diff --git a/examples/quickcheck/Config.hs b/examples/quickcheck/Config.hs deleted file mode 100644 --- a/examples/quickcheck/Config.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -module Config ( - - -- options & test configuration - Options, - parseArgs, - optBackend, double, float, int64, int32, int16, int8, - - -- running tests - run, run1 - -) where - -import Data.Char -import Data.List -import Data.Label -import Control.Monad -import Test.Framework -import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) ) - -import Data.Array.Accelerate ( Arrays, Acc ) -import qualified Data.Array.Accelerate.Interpreter as Interp - -#ifdef ACCELERATE_CUDA_BACKEND -import qualified Foreign.CUDA.Analysis as CUDA -import qualified Foreign.CUDA.Driver as CUDA -import qualified Data.Array.Accelerate.CUDA as CUDA -#endif - -data Backend = Interpreter -#ifdef ACCELERATE_CUDA_BACKEND - | CUDA -#endif - deriving (Eq, Enum, Bounded, Show) - - -data Options = Options - { - _optBackend :: !Backend, - _double :: !Bool, - _float :: !Bool, - _int64 :: !Bool, - _int32 :: !Bool, - _int16 :: !Bool, - _int8 :: !Bool - } - deriving Show - -$( mkLabels [''Options] ) - -defaultOptions :: Options -defaultOptions = Options - { _optBackend = maxBound - , _double = True - , _float = True - , _int64 = True - , _int32 = True - , _int16 = False - , _int8 = False - } - - -backends :: [OptDescr (Options -> Options)] -backends = - [ Option [] ["interpreter"] (NoArg (set optBackend Interpreter)) "reference implementation (sequential)" -#ifdef ACCELERATE_CUDA_BACKEND - , Option [] ["cuda"] (NoArg (set optBackend CUDA)) "implementation for NVIDIA GPUs (parallel)" -#endif - ] - - -run :: Arrays a => Options -> Acc a -> a -run opts = case _optBackend opts of - Interpreter -> Interp.run -#ifdef ACCELERATE_CUDA_BACKEND - CUDA -> CUDA.run -#endif - -run1 :: (Arrays a, Arrays b) => Options -> (Acc a -> Acc b) -> a -> b -run1 opts f = case _optBackend opts of - Interpreter -> head . Interp.stream f . return -#ifdef ACCELERATE_CUDA_BACKEND - CUDA -> CUDA.run1 f -#endif - - --- Display a very basic usage message info: specifically, list the available --- backends and highlight the active one. --- -usageInfo :: Options -> String -usageInfo opts = unlines (header : table) - where - active this = if this == map toLower (show $ get optBackend opts) then "*" else "" - (ss,bs,ds) = unzip3 $ map (\(b,d) -> (active b, b, d)) $ concatMap extract backends - table = zipWith3 paste (sameLen ss) (sameLen bs) ds - paste x y z = " " ++ x ++ " " ++ y ++ " " ++ z - sameLen xs = flushLeft ((maximum . map length) xs) xs - flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ] - -- - extract (Option _ los _ descr) = - let losFmt = intercalate ", " los - in case lines descr of - [] -> [(losFmt, "")] - (x:xs) -> (losFmt, x) : [ ("",x') | x' <- xs ] - -- - header = intercalate "\n" $ - [ "accelerate-quickcheck (c) 2012 The Accelerate Team" - , "" - , "Usage: accelerate-quickcheck [BACKEND] [OPTIONS]" - , "" - , "Available backends:" - ] - --- Once the backend has been selected, we might need to enable or disable --- certain classes of tests. --- --- CUDA: double precision is only supported on certain kinds of hardware. We --- can't get the exact device the backend will choose to run on, but we do --- know that it will pick the most capable device available. --- -configureBackend :: Options -> IO Options -configureBackend opts = case _optBackend opts of - Interpreter -> return opts -#ifdef ACCELERATE_CUDA_BACKEND - CUDA -> do - CUDA.initialise [] - n <- CUDA.count - devs <- mapM CUDA.device [0 .. n-1] - props <- mapM CUDA.props devs - return $! opts { _double = any (\dev -> CUDA.computeCapability dev >= CUDA.Compute 1 3) props } -#endif - - -parseArgs :: [String] -> IO (Options, RunnerOptions) -parseArgs argv = do - args <- interpretArgs argv - (options, runner) <- case args of - Left msg -> error msg - Right (opts, rest) -> (,opts) `liftM` configureBackend (foldl parse1 defaultOptions rest) - -- - putStrLn $ usageInfo options - return $ (options, runner) - where - parse1 opts x = - case filter (\(Option _ [f] _ _) -> map toLower x `isPrefixOf` f) backends of - [Option _ _ (NoArg go) _] -> go opts - _ -> opts - diff --git a/examples/quickcheck/Main.hs b/examples/quickcheck/Main.hs deleted file mode 100644 --- a/examples/quickcheck/Main.hs +++ /dev/null @@ -1,34 +0,0 @@ - -module Main where - -import Test.Framework -import System.Environment - -import Config -import Test.Mapping -import Test.Reduction -import Test.PrefixSum -import Test.IndexSpace - - -main :: IO () -main = do - -- process command line args, and print a brief usage message - -- - (options, runner) <- parseArgs =<< getArgs - - -- the default execution order uses some knowledge of what functionality is - -- required for each operation in the CUDA backend. - -- - defaultMainWithOpts - [ test_map options - , test_zipWith options - , test_foldAll options - , test_fold options - , test_prefixsum options -- requires fold - , test_foldSeg options -- requires scan - , test_permute options - , test_backpermute options - ] - runner - diff --git a/examples/quickcheck/Test/Base.hs b/examples/quickcheck/Test/Base.hs deleted file mode 100644 --- a/examples/quickcheck/Test/Base.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} - -module Test.Base where - -import Prelude as P -import Test.QuickCheck -import Data.Array.Accelerate -import Data.Array.Accelerate.Array.Sugar as Sugar - - --- A class of things that support almost-equality, so that we can disregard --- small amounts of floating-point round-off error. --- -class Similar a where - {-# INLINE (~=) #-} - (~=) :: a -> a -> Bool - default (~=) :: Eq a => a -> a -> Bool - (~=) = (==) - -infix 4 ~= - -instance Similar a => Similar [a] where - [] ~= [] = True - (x:xs) ~= (y:ys) = x ~= y && xs ~= ys - _ ~= _ = False - -instance (Similar a, Similar b) => Similar (a, b) where - (x1, y1) ~= (x2, y2) = x1 ~= x2 && y1 ~= y2 - - -instance Similar Int -instance Similar Int8 -instance Similar Int16 -instance Similar Int32 -instance Similar Int64 -instance Similar Word -instance Similar Word8 -instance Similar Word16 -instance Similar Word32 -instance Similar Word64 - -instance Similar Float where (~=) = absRelTol -instance Similar Double where (~=) = absRelTol - -{-# INLINE relTol #-} -relTol :: (Fractional a, Ord a) => a -> a -> a -> Bool -relTol epsilon x y = abs ((x-y) / (x+y+epsilon)) < epsilon - -{-# INLINE absRelTol #-} -absRelTol :: (Fractional a, Ord a) => a -> a -> Bool -absRelTol u v - | abs (u-v) < epsilonAbs = True - | abs u > abs v = abs ((u-v) / u) < epsilonRel - | otherwise = abs ((v-u) / v) < epsilonRel - where - epsilonRel = 0.001 - epsilonAbs = 0.00001 - -instance (Eq e, Eq sh, Shape sh) => Eq (Array sh e) where - a1 == a2 = arrayShape a1 == arrayShape a2 - && toList a1 == toList a2 - - a1 /= a2 = arrayShape a1 /= arrayShape a2 - || toList a1 /= toList a2 - -instance (Similar e, Eq sh, Shape sh) => Similar (Array sh e) where - a1 ~= a2 = arrayShape a1 == arrayShape a2 - && toList a1 ~= toList a2 - - --- Print expected/received message on inequality --- -infix 4 .==. -(.==.) :: (Similar a, Show a) => a -> a -> Property -(.==.) ans ref = printTestCase message (ref ~= ans) - where - message = unlines ["*** Expected:", show ref - ,"*** Received:", show ans ] - - --- Miscellaneous --- - -indexHead :: Shape sh => (sh:.Int) -> Int -indexHead (_ :. sz) = sz - -indexTail :: Shape sh => (sh:.Int) -> sh -indexTail (sh :. _) = sh - -isEmptyArray :: Shape sh => Array sh e -> Bool -isEmptyArray arr = arraySize (arrayShape arr) == 0 - -mkDim :: Shape sh => Int -> sh -mkDim n = listToShape (P.replicate n 0) - -dim0 :: DIM0 -dim0 = mkDim 0 - -dim1 :: DIM1 -dim1 = mkDim 1 - -dim2 :: DIM2 -dim2 = mkDim 2 - -splitEvery :: Int -> [a] -> [[a]] -splitEvery _ [] = cycle [[]] -splitEvery n xs = - let (h,t) = splitAt n xs - in h : splitEvery n t - -splitPlaces :: Integral i => [i] -> [a] -> [[a]] -splitPlaces [] _ = [] -splitPlaces (i:is) vs = - let (h,t) = splitAt (P.fromIntegral i) vs - in h : splitPlaces is t - diff --git a/examples/quickcheck/Test/IndexSpace.hs b/examples/quickcheck/Test/IndexSpace.hs deleted file mode 100644 --- a/examples/quickcheck/Test/IndexSpace.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Test.IndexSpace where - -import Prelude as P -import Data.Label -import Data.Maybe -import Data.Typeable -import Test.QuickCheck -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -import Config -import Test.Base -import Arbitrary.Array ( ) -import Data.Array.Unboxed as IArray hiding ( Array ) -import Data.Array.Accelerate as Acc -import Data.Array.Accelerate.Array.Sugar ( newArray ) - - --- --- Forward permutation --------------------------------------------------------- --- - -test_permute :: Options -> Test -test_permute opt = testGroup "permute" $ catMaybes - [ testIntegralElt int8 (undefined :: Int8) - , testIntegralElt int16 (undefined :: Int16) - , testIntegralElt int32 (undefined :: Int32) - , testIntegralElt int64 (undefined :: Int64) - , testIntegralElt int8 (undefined :: Word8) - , testIntegralElt int16 (undefined :: Word16) - , testIntegralElt int32 (undefined :: Word32) - , testIntegralElt int64 (undefined :: Word64) - , testFloatingElt float (undefined :: Float) - , testFloatingElt double (undefined :: Double) - ] - where - testIntegralElt :: forall e. (Elt e, Integral e, IsIntegral e, Arbitrary e) => (Options :-> Bool) -> e -> Maybe Test - testIntegralElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) - [ testProperty "histogram" (test_histogram Acc.fromIntegral P.fromIntegral :: Vector e -> Property) - ] - - testFloatingElt :: forall e. (Elt e, RealFrac e, IsFloating e, Arbitrary e) => (Options :-> Bool) -> e -> Maybe Test - testFloatingElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) - [ testProperty "histogram" (test_histogram Acc.floor P.floor :: Vector e -> Property) - ] - - test_histogram f g xs = - sized $ \n -> run opt (histogramAcc n f xs) .==. histogramRef n g xs - - histogramAcc n f xs = - let n' = unit (constant n) - xs' = use xs - zeros = generate (constant (Z :. n)) (const 0) - ones = generate (shape xs') (const 1) - in - permute (+) zeros (\ix -> index1 $ f (xs' Acc.! ix) `mod` the n') ones - - histogramRef n f xs = - let arr :: UArray Int Int32 - arr = accumArray (+) 0 (0, n-1) [ (f e `mod` n, 1) | e <- toList xs ] - in - fromIArray arr - - --- --- Backward permutation -------------------------------------------------------- --- - -test_backpermute :: Options -> Test -test_backpermute opt = testGroup "backpermute" $ catMaybes - [ testElt int8 (undefined :: Int8) - , testElt int16 (undefined :: Int16) - , testElt int32 (undefined :: Int32) - , testElt int64 (undefined :: Int64) - , testElt int8 (undefined :: Word8) - , testElt int16 (undefined :: Word16) - , testElt int32 (undefined :: Word32) - , testElt int64 (undefined :: Word64) - , testElt float (undefined :: Float) - , testElt double (undefined :: Double) - ] - where - testElt :: forall e. (Elt e, Similar e, Arbitrary e) => (Options :-> Bool) -> e -> Maybe Test - testElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined::e))) - [ testProperty "reverse" (test_reverse :: Array DIM1 e -> Property) - , testProperty "transpose" (test_transpose :: Array DIM2 e -> Property) - ] - - test_reverse xs = run opt (reverseAcc xs) .==. reverseRef xs - test_transpose xs = run opt (transposeAcc xs) .==. transposeRef xs - - -- Reverse a vector - -- - reverseAcc xs = Acc.reverse (use xs) - reverseRef xs = fromList (arrayShape xs) (P.reverse $ toList xs) - - -- Transpose a 2D matrix - -- - transposeAcc xs = Acc.transpose (use xs) - transposeRef xs = - let swap (Z:.x:.y) = Z :. y :. x - in newArray (swap (arrayShape xs)) (\ix -> indexArray xs (swap ix)) - diff --git a/examples/quickcheck/Test/Mapping.hs b/examples/quickcheck/Test/Mapping.hs deleted file mode 100644 --- a/examples/quickcheck/Test/Mapping.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Test.Mapping where - -import Prelude as P -import Data.Label -import Data.Maybe -import Data.Typeable -import Test.QuickCheck -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -import Config -import Test.Base -import Arbitrary.Array () -import Data.Array.Accelerate as Acc -import Data.Array.Accelerate.Array.Sugar as Sugar -import qualified Data.Array.Accelerate.Array.Representation as R - --- --- Map ------------------------------------------------------------------------- --- - -test_map :: Options -> Test -test_map opt = testGroup "map" $ catMaybes - [ testElt int8 (undefined :: Int8) - , testElt int16 (undefined :: Int16) - , testElt int32 (undefined :: Int32) - , testElt int64 (undefined :: Int64) - , testElt int8 (undefined :: Word8) - , testElt int16 (undefined :: Word16) - , testElt int32 (undefined :: Word32) - , testElt int64 (undefined :: Word64) - , testElt float (undefined :: Float) - , testElt double (undefined :: Double) - ] - where - test_square xs = run opt (Acc.map (\x -> x*x) (use xs)) .==. mapRef (\x -> x*x) xs - test_abs xs = run opt (Acc.map abs (use xs)) .==. mapRef abs xs - test_plus z xs = - let z' = unit (constant z) - in run opt (Acc.map (+ the z') (use xs)) .==. mapRef (+ z) xs - - testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) - => (Options :-> Bool) - -> a - -> Maybe Test - testElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) - [ testDim dim0 - , testDim dim1 - , testDim dim2 - ] - where - testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test - testDim sh = testGroup ("DIM" ++ show (dim sh)) - [ testProperty "abs" (test_abs :: Array sh a -> Property) - , testProperty "plus" (test_plus :: a -> Array sh a -> Property) - , testProperty "square" (test_square :: Array sh a -> Property) - ] - - -test_zipWith :: Options -> Test -test_zipWith opt = testGroup "zipWith" $ catMaybes - [ testElt int8 (undefined :: Int8) - , testElt int16 (undefined :: Int16) - , testElt int32 (undefined :: Int32) - , testElt int64 (undefined :: Int64) - , testElt int8 (undefined :: Word8) - , testElt int16 (undefined :: Word16) - , testElt int32 (undefined :: Word32) - , testElt int64 (undefined :: Word64) - , testElt float (undefined :: Float) - , testElt double (undefined :: Double) - ] - where - test_zip xs ys = run opt (Acc.zip (use xs) (use ys)) .==. zipWithRef (,) xs ys - test_plus xs ys = run opt (Acc.zipWith (+) (use xs) (use ys)) .==. zipWithRef (+) xs ys - test_min xs ys = run opt (Acc.zipWith Acc.min (use xs) (use ys)) .==. zipWithRef P.min xs ys - - testElt :: forall a. (Elt a, IsNum a, Ord a, Similar a, Arbitrary a) - => (Options :-> Bool) - -> a - -> Maybe Test - testElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) - [ testDim dim0 - , testDim dim1 - , testDim dim2 - ] - where - testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array sh a)) => sh -> Test - testDim sh = testGroup ("DIM" ++ show (dim sh)) - [ testProperty "zip" (test_zip :: Array sh a -> Array sh a -> Property) - , testProperty "plus" (test_plus :: Array sh a -> Array sh a -> Property) - , testProperty "min" (test_min :: Array sh a -> Array sh a -> Property) - ] - - --- Reference Implementation --- ------------------------ - -mapRef :: (Shape sh, Elt b) => (a -> b) -> Array sh a -> Array sh b -mapRef f xs - = fromList (arrayShape xs) - $ P.map f - $ toList xs - -zipWithRef :: (Shape sh, Elt c) => (a -> b -> c) -> Array sh a -> Array sh b -> Array sh c -zipWithRef f xs ys = - let shx = fromElt (arrayShape xs) - shy = fromElt (arrayShape ys) - sh = toElt (R.intersect shx shy) - in - newArray sh (\ix -> f (xs Sugar.! ix) (ys Sugar.! ix)) - diff --git a/examples/quickcheck/Test/PrefixSum.hs b/examples/quickcheck/Test/PrefixSum.hs deleted file mode 100644 --- a/examples/quickcheck/Test/PrefixSum.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Test.PrefixSum where - -import Prelude as P -import Test.QuickCheck -import Data.Label -import Data.Maybe -import Data.Typeable -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -import Config -import Test.Base -import Arbitrary.Array -import Data.Array.Accelerate as Acc - - --- --- prefix sum ------------------------------------------------------------------ --- - -test_prefixsum :: Options -> Test -test_prefixsum opt = testGroup "prefix sum" $ catMaybes - [ testElt int8 (undefined :: Int8) - , testElt int16 (undefined :: Int16) - , testElt int32 (undefined :: Int32) - , testElt int64 (undefined :: Int64) - , testElt int8 (undefined :: Word8) - , testElt int16 (undefined :: Word16) - , testElt int32 (undefined :: Word32) - , testElt int64 (undefined :: Word64) - , testElt float (undefined :: Float) - , testElt double (undefined :: Double) - ] - where - testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Options :-> Bool) -> e -> Maybe Test - testElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) - [ testProperty "scanl" (test_scanl :: Vector e -> Property) - , testProperty "scanl'" (test_scanl' :: Vector e -> Property) - , testProperty "scanl1" (test_scanl1 :: Vector e -> Property) - , testProperty "scanr" (test_scanr :: Vector e -> Property) - , testProperty "scanr'" (test_scanr' :: Vector e -> Property) - , testProperty "scanr1" (test_scanr1 :: Vector e -> Property) - -- - , testProperty "scanl1Seg" (test_scanl1seg :: Vector e -> Property) - , testProperty "scanr1Seg" (test_scanr1seg :: Vector e -> Property) - , testProperty "scanlSeg" (test_scanlseg :: Vector e -> Property) - , testProperty "scanrSeg" (test_scanrseg :: Vector e -> Property) - , testProperty "scanl'Seg" (test_scanl'seg :: Vector e -> Property) - , testProperty "scanr'Seg" (test_scanr'seg :: Vector e -> Property) - ] - - -- left scan - -- - test_scanl xs = run opt (Acc.scanl (+) 0 (use xs)) .==. scanlRef (+) 0 xs - test_scanl1 xs = run opt (Acc.scanl1 Acc.min (use xs)) .==. scanl1Ref P.min xs - test_scanl' xs = run opt (Acc.lift $ Acc.scanl' (+) 0 (use xs)) .==. scanl'Ref (+) 0 xs - - -- right scan - -- - test_scanr xs = run opt (Acc.scanr (+) 0 (use xs)) .==. scanrRef (+) 0 xs - test_scanr1 xs = run opt (Acc.scanr1 Acc.max (use xs)) .==. scanr1Ref P.max xs - test_scanr' xs = run opt (Acc.lift $ Acc.scanr' (+) 0 (use xs)) .==. scanr'Ref (+) 0 xs - - -- segmented left/right scan - -- - test_scanl1seg elt = - forAll arbitrarySegments1 $ \(seg :: Vector Int32) -> - forAll (arbitrarySegmentedArray seg) $ \xs -> - run opt (Acc.scanl1Seg (+) (use xs) (use seg)) .==. scanl1SegRef (+) (xs `asTypeOf` elt) seg - - test_scanr1seg elt = - forAll arbitrarySegments1 $ \(seg :: Vector Int32) -> - forAll (arbitrarySegmentedArray seg) $ \xs -> - run opt (Acc.scanr1Seg (+) (use xs) (use seg)) .==. scanr1SegRef (+) (xs `asTypeOf` elt) seg - - test_scanlseg elt = - forAll arbitrarySegments $ \(seg :: Vector Int32) -> - forAll (arbitrarySegmentedArray seg) $ \xs -> - run opt (Acc.scanlSeg (+) 0 (use xs) (use seg)) .==. scanlSegRef (+) 0 (xs `asTypeOf` elt) seg - - test_scanrseg elt = - forAll arbitrarySegments $ \(seg :: Vector Int32) -> - forAll (arbitrarySegmentedArray seg) $ \xs -> - run opt (Acc.scanrSeg (+) 0 (use xs) (use seg)) .==. scanrSegRef (+) 0 (xs `asTypeOf` elt) seg - - test_scanl'seg elt = - forAll arbitrarySegments $ \(seg :: Vector Int32) -> - forAll (arbitrarySegmentedArray seg) $ \xs -> - run opt (lift $ Acc.scanl'Seg (+) 0 (use xs) (use seg)) .==. scanl'SegRef (+) 0 (xs `asTypeOf` elt) seg - - test_scanr'seg elt = - forAll arbitrarySegments $ \(seg :: Vector Int32) -> - forAll (arbitrarySegmentedArray seg) $ \xs -> - run opt (lift $ Acc.scanr'Seg (+) 0 (use xs) (use seg)) .==. scanr'SegRef (+) 0 (xs `asTypeOf` elt) seg - - --- Reference implementation --- ------------------------ - -scanlRef :: Elt e => (e -> e -> e) -> e -> Vector e -> Vector e -scanlRef f z vec = - let (Z :. n) = arrayShape vec - in Acc.fromList (Z :. n+1) . P.scanl f z . Acc.toList $ vec - -scanl'Ref :: Elt e => (e -> e -> e) -> e -> Vector e -> (Vector e, Scalar e) -scanl'Ref f z vec = - let (Z :. n) = arrayShape vec - result = P.scanl f z (Acc.toList vec) - in (Acc.fromList (Z :. n) result, Acc.fromList Z (P.drop n result)) - -scanl1Ref :: Elt e => (e -> e -> e) -> Vector e -> Vector e -scanl1Ref f vec - = Acc.fromList (arrayShape vec) - . P.scanl1 f - . Acc.toList $ vec - -scanrRef :: Elt e => (e -> e -> e) -> e -> Vector e -> Vector e -scanrRef f z vec = - let (Z :. n) = arrayShape vec - in Acc.fromList (Z :. n+1) . P.scanr f z . Acc.toList $ vec - -scanr'Ref :: Elt e => (e -> e -> e) -> e -> Vector e -> (Vector e, Scalar e) -scanr'Ref f z vec = - let (Z :. n) = arrayShape vec - result = P.scanr f z (Acc.toList vec) - in (Acc.fromList (Z :. n) (P.tail result), Acc.fromList Z result) - -scanr1Ref :: Elt e => (e -> e -> e) -> Vector e -> Vector e -scanr1Ref f vec - = Acc.fromList (arrayShape vec) - . P.scanr1 f - . Acc.toList $ vec - - --- segmented operations --- -scanlSegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> Vector e -scanlSegRef f z vec seg = - let seg' = toList seg - vec' = toList vec - n = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg' - in fromList (Z :. n) $ - concat [ P.scanl f z v | v <- splitPlaces seg' vec' ] - -scanl1SegRef :: (Elt e, Integral i) => (e -> e -> e) -> Vector e -> Vector i -> Vector e -scanl1SegRef f vec seg = - let seg' = toList seg - vec' = toList vec - n = P.sum $ P.map P.fromIntegral seg' - in fromList (Z :. n) $ - concat [ P.scanl1 f v | v <- splitPlaces seg' vec' ] - -scanl'SegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> (Vector e, Vector e) -scanl'SegRef f z vec seg = - let seg' = toList seg - vec' = toList vec - scanl'_ v = let res = P.scanl f z v in (P.init res, P.last res) - (scans, sums) = P.unzip [ scanl'_ v | v <- splitPlaces seg' vec'] - in ( fromList (arrayShape vec) (concat scans) - , fromList (arrayShape seg) sums ) - -scanrSegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> Vector e -scanrSegRef f z vec seg = - let seg' = toList seg - vec' = toList vec - n = P.sum $ P.map (\x -> P.fromIntegral x + 1) seg' - in fromList (Z :. n) $ - concat [ P.scanr f z v | v <- splitPlaces seg' vec' ] - -scanr1SegRef :: (Elt e, Integral i) => (e -> e -> e) -> Vector e -> Vector i -> Vector e -scanr1SegRef f vec seg = - let seg' = toList seg - vec' = toList vec - n = P.sum $ P.map P.fromIntegral seg' - in fromList (Z :. n) $ - concat [ P.scanr1 f v | v <- splitPlaces seg' vec' ] - -scanr'SegRef :: (Elt e, Integral i) => (e -> e -> e) -> e -> Vector e -> Vector i -> (Vector e, Vector e) -scanr'SegRef f z vec seg = - let seg' = toList seg - vec' = toList vec - scanr'_ v = let res = P.scanr f z v in (P.tail res, P.head res) - (scans, sums) = P.unzip [ scanr'_ v | v <- splitPlaces seg' vec'] - in ( fromList (arrayShape vec) (concat scans) - , fromList (arrayShape seg) sums ) - diff --git a/examples/quickcheck/Test/Reduction.hs b/examples/quickcheck/Test/Reduction.hs deleted file mode 100644 --- a/examples/quickcheck/Test/Reduction.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Test.Reduction where - -import Prelude as P -import Data.List -import Data.Label -import Data.Maybe -import Data.Typeable -import Test.QuickCheck -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -import Config -import Test.Base -import Arbitrary.Array -import Data.Array.Accelerate as Acc hiding (indexHead, indexTail) -import Data.Array.Accelerate.Array.Sugar as Sugar - - - --- --- Reduction ------------------------------------------------------------------- --- - --- foldAll --- ------- - -test_foldAll :: Options -> Test -test_foldAll opt = testGroup "foldAll" $ catMaybes - [ testElt int8 (undefined :: Int8) - , testElt int16 (undefined :: Int16) - , testElt int32 (undefined :: Int32) - , testElt int64 (undefined :: Int64) - , testElt int8 (undefined :: Word8) - , testElt int16 (undefined :: Word16) - , testElt int32 (undefined :: Word32) - , testElt int64 (undefined :: Word64) - , testElt float (undefined :: Float) - , testElt double (undefined :: Double) - ] - where - testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Options :-> Bool) -> e -> Maybe Test - testElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) - [ testDim dim0 - , testDim dim1 - , testDim dim2 - ] - where - testDim :: forall sh. (Shape sh, Arbitrary sh, Arbitrary (Array sh e)) => sh -> Test - testDim sh = testGroup ("DIM" ++ show (dim sh)) - [ - testProperty "sum" (test_sum :: Array sh e -> Property) - , testProperty "non-neutral sum" (test_sum' :: Array sh e -> e -> Property) - , testProperty "minimum" (test_min :: Array sh e -> Property) - , testProperty "maximum" (test_max :: Array sh e -> Property) - ] - -- - -- The tests - -- - test_min xs - = arraySize (arrayShape xs) > 0 - ==> run opt (Acc.fold1All Acc.min (use xs)) .==. fold1AllRef P.min xs - - test_max xs - = arraySize (arrayShape xs) > 0 - ==> run opt (Acc.fold1All Acc.max (use xs)) .==. fold1AllRef P.max xs - - test_sum xs = run opt (Acc.foldAll (+) 0 (use xs)) .==. foldAllRef (+) 0 xs - test_sum' xs z = - let z' = unit (constant z) - in run opt (Acc.foldAll (+) (the z') (use xs)) .==. foldAllRef (+) z xs - - - --- multidimensional fold --- --------------------- - -test_fold :: Options -> Test -test_fold opt = testGroup "fold" $ catMaybes - [ testElt int8 (undefined :: Int8) - , testElt int16 (undefined :: Int16) - , testElt int32 (undefined :: Int32) - , testElt int64 (undefined :: Int64) - , testElt int8 (undefined :: Word8) - , testElt int16 (undefined :: Word16) - , testElt int32 (undefined :: Word32) - , testElt int64 (undefined :: Word64) - , testElt float (undefined :: Float) - , testElt double (undefined :: Double) - ] - where - testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Options :-> Bool) -> e -> Maybe Test - testElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) - [ testDim dim1 - , testDim dim2 - ] - where - testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test - testDim sh = testGroup ("DIM" ++ show (dim sh)) - [ - testProperty "sum" (test_sum :: Array (sh :. Int) e -> Property) - , testProperty "non-neutral sum" (test_sum' :: Array (sh :. Int) e -> e -> Property) - , testProperty "minimum" (test_min :: Array (sh :. Int) e -> Property) - , testProperty "maximum" (test_max :: Array (sh :. Int) e -> Property) - ] - -- - -- The tests - -- - test_min xs - = indexHead (arrayShape xs) > 0 - ==> run opt (Acc.fold1 Acc.min (use xs)) .==. fold1Ref P.min xs - - test_max xs - = indexHead (arrayShape xs) > 0 - ==> run opt (Acc.fold1 Acc.max (use xs)) .==. fold1Ref P.max xs - - test_sum xs = run opt (Acc.fold (+) 0 (use xs)) .==. foldRef (+) 0 xs - test_sum' xs z = - let z' = unit (constant z) - in run opt (Acc.fold (+) (the z') (use xs)) .==. foldRef (+) z xs - - --- segmented fold --- -------------- - -test_foldSeg :: Options -> Test -test_foldSeg opt = testGroup "foldSeg" $ catMaybes - [ testElt int8 (undefined :: Int8) - , testElt int16 (undefined :: Int16) - , testElt int32 (undefined :: Int32) - , testElt int64 (undefined :: Int64) - , testElt int8 (undefined :: Word8) - , testElt int16 (undefined :: Word16) - , testElt int32 (undefined :: Word32) - , testElt int64 (undefined :: Word64) - , testElt float (undefined :: Float) - , testElt double (undefined :: Double) - ] - where - testElt :: forall e. (Elt e, IsNum e, Ord e, Similar e, Arbitrary e) => (Options :-> Bool) -> e -> Maybe Test - testElt ok _ - | P.not (get ok opt) = Nothing - | otherwise = Just $ testGroup (show (typeOf (undefined :: e))) - [ testDim dim1 - , testDim dim2 - ] - where - testDim :: forall sh. (Shape sh, Eq sh, Arbitrary sh, Arbitrary (Array (sh:.Int) e)) => (sh:.Int) -> Test - testDim sh = testGroup ("DIM" ++ show (dim sh)) - [ - testProperty "sum" - $ forAll arbitrarySegments $ \(seg :: Segments Int32) -> - forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) -> - run opt (Acc.foldSeg (+) 0 (use xs) (use seg)) .==. foldSegRef (+) 0 xs seg - - , testProperty "non-neutral sum" - $ forAll arbitrarySegments $ \(seg :: Segments Int32) -> - forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) -> - forAll arbitrary $ \z -> - let z' = unit (constant z) - in run opt (Acc.foldSeg (+) (the z') (use xs) (use seg)) .==. foldSegRef (+) z xs seg - - , testProperty "minimum" - $ forAll arbitrarySegments1 $ \(seg :: Segments Int32) -> - forAll (arbitrarySegmentedArray seg) $ \(xs :: Array (sh:.Int) e) -> - run opt (Acc.fold1Seg Acc.min (use xs) (use seg)) .==. fold1SegRef P.min xs seg - ] - - --- Reference implementation --- ------------------------ - -foldAllRef :: Elt e => (e -> e -> e) -> e -> Array sh e -> Array Z e -foldAllRef f z - = Acc.fromList Z - . return - . foldl f z - . Acc.toList - -fold1AllRef :: Elt e => (e -> e -> e) -> Array sh e -> Array Z e -fold1AllRef f - = Acc.fromList Z - . return - . foldl1 f - . Acc.toList - -foldRef :: (Shape sh, Elt e) => (e -> e -> e) -> e -> Array (sh :. Int) e -> Array sh e -foldRef f z arr = - let (sh :. n) = arrayShape arr - in fromList sh [ foldl f z sub | sub <- splitEvery n (toList arr) ] - -fold1Ref :: (Shape sh, Elt e) => (e -> e -> e) -> Array (sh :. Int) e -> Array sh e -fold1Ref f arr = - let (sh :. n) = arrayShape arr - in fromList sh [ foldl1 f sub | sub <- splitEvery n (toList arr) ] - -foldSegRef :: (Shape sh, Elt e, Elt i, Integral i) => (e -> e -> e) -> e -> Array (sh :. Int) e -> Segments i -> Array (sh :. Int) e -foldSegRef f z arr seg = fromList (sh :. sz) $ concat [ foldseg sub | sub <- splitEvery n (toList arr) ] - where - (sh :. n) = arrayShape arr - (Z :. sz) = arrayShape seg - seg' = toList seg - foldseg xs = P.map (foldl' f z) (splitPlaces seg' xs) - -fold1SegRef :: (Shape sh, Elt e, Elt i, Integral i) => (e -> e -> e) -> Array (sh :. Int) e -> Segments i -> Array (sh :. Int) e -fold1SegRef f arr seg = fromList (sh :. sz) $ concat [ foldseg sub | sub <- splitEvery n (toList arr) ] - where - (sh :. n) = arrayShape arr - (Z :. sz) = arrayShape seg - seg' = toList seg - foldseg xs = P.map (foldl1' f) (splitPlaces seg' xs) - diff --git a/examples/smoothlife/Config.hs b/examples/smoothlife/Config.hs --- a/examples/smoothlife/Config.hs +++ b/examples/smoothlife/Config.hs @@ -209,8 +209,8 @@ describe f msg = msg ++ " (" ++ show (get f defaults) ++ ")" - fst = lens P.fst (\a (_,b) -> (a,b)) - snd = lens P.snd (\b (a,_) -> (a,b)) + fst = lens P.fst (\f (a,b) -> (f a,b)) + snd = lens P.snd (\f (a,b) -> (a,f b)) header :: [String] header = diff --git a/examples/smoothlife/Gloss/Draw.hs b/examples/smoothlife/Gloss/Draw.hs --- a/examples/smoothlife/Gloss/Draw.hs +++ b/examples/smoothlife/Gloss/Draw.hs @@ -7,16 +7,11 @@ import Prelude as P import Data.Label import Graphics.Gloss +import Graphics.Gloss.Accelerate.Data.Picture import Data.Array.Accelerate as A hiding ( size ) import Data.Array.Accelerate.IO as A -import Foreign.Ptr -import Foreign.ForeignPtr -import System.IO.Unsafe -import Data.Array.Accelerate.Array.Data ( ptrsOfArrayData ) -import Data.Array.Accelerate.Array.Sugar ( Array(..) ) - colourise :: ColourScheme -> Acc (Matrix R) -> Acc (Matrix RGBA32) colourise scheme = A.map (rgba32OfFloat . colour scheme) where @@ -56,17 +51,8 @@ draw :: Config -> Matrix RGBA32 -> Picture -draw conf (Array _ adata) = scale zoom zoom pic +draw conf arr = scale zoom zoom pic where - zoom = P.fromIntegral - $ get configWindowZoom conf - size = get configWindowSize conf - - rawData = let ((), ptr) = ptrsOfArrayData adata - in unsafePerformIO $ newForeignPtr_ (castPtr ptr) - - pic = bitmapOfForeignPtr - size size -- raw image size - rawData -- the image data - False -- don't cache in texture memory + zoom = P.fromIntegral (get configWindowZoom conf) + pic = bitmapOfArray arr False diff --git a/examples/smoothlife/Main.hs b/examples/smoothlife/Main.hs --- a/examples/smoothlife/Main.hs +++ b/examples/smoothlife/Main.hs @@ -5,6 +5,7 @@ -- friends import Config +import Monitoring import ParseArgs import SmoothLife import Gloss.Draw @@ -23,7 +24,8 @@ main :: IO () main - = do argv <- getArgs + = do beginMonitoring + argv <- getArgs (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv let -- visualisation configuration diff --git a/examples/smoothlife/Random/Splat.hs b/examples/smoothlife/Random/Splat.hs --- a/examples/smoothlife/Random/Splat.hs +++ b/examples/smoothlife/Random/Splat.hs @@ -52,5 +52,5 @@ dx = fromIntegral $ cx - x dy = fromIntegral $ cy - y in - dx*dx + dy*dx <= r*r + dx*dx + dy*dy <= r*r diff --git a/examples/smoothlife/SmoothLife.hs b/examples/smoothlife/SmoothLife.hs --- a/examples/smoothlife/SmoothLife.hs +++ b/examples/smoothlife/SmoothLife.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} -- -- A cellular automata simulation over a smooth domain. -- @@ -20,7 +21,9 @@ import Data.Array.Accelerate.Math.DFT.Centre import Data.Array.Accelerate.Math.Complex +#ifdef ACCELERATE_CUDA_BACKEND import Data.Array.Accelerate.CUDA.Foreign +#endif -- Smooth life -- ~~~~~~~~~~~ @@ -77,7 +80,7 @@ get1 f c = constant $ get f c get2 f c = let (x,y) = get f c in (constant x, constant y) - complex = A.map (\x -> lift (x, constant 0)) + complex = A.map (\x -> lift (x :+ constant 0)) radius ix = let Z:.y':.x' = unlift ix :: Z :. Exp Int :. Exp Int @@ -92,7 +95,7 @@ , (x - l + u / 2) / u )) clamp = A.map - (\x -> A.min (A.max x 0.0) 1.0) + (\x -> min (max x 0.0) 1.0) timestepModes f g = [ f @@ -140,7 +143,12 @@ getSigmoidFunction f x a ea = let -- __expf is CUDA's faster but less precise version of exp. - cexp = foreignExp (cudaExp "math_functions.h __expf") exp + cexp = +#ifdef ACCELERATE_CUDA_BACKEND + foreignExp (CUDAForeignExp [] "__expf") exp +#else + exp +#endif in case f of Hard -> x >=* a ? (1, 0) diff --git a/examples/smvm/Config.hs b/examples/smvm/Config.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/Config.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Config where + +import ParseArgs +import Data.Label + +data Config + = Config + { + -- Standard options + _configBackend :: Backend + , _configHelp :: Bool + } + +$(mkLabels [''Config]) + +defaults :: Config +defaults = Config + { + _configBackend = maxBound + , _configHelp = False + } + +options :: [OptDescr (Config -> Config)] +options = + [ Option ['h', '?'] ["help"] + (NoArg (set configHelp True)) + "show this help message" + ] + where + _describe f msg + = msg ++ " (" ++ show (get f defaults) ++ ")" + + +header :: [String] +header = + [ "accelerate-smvm (c) [2013] The Accelerate Team" + , "" + , "Usage: accelerate-smvm [OPTIONS] matrix.mtx" + , "" + ] + +footer :: [String] +footer = [] + + diff --git a/examples/smvm/Main.hs b/examples/smvm/Main.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/Main.hs @@ -0,0 +1,51 @@ + +import SMVM +import Matrix +import Config +import ParseArgs +import Monitoring + +import Prelude as P +import Data.Label ( get ) +import Criterion.Main ( defaultMainWith, bench, whnf ) +import System.Random.MWC +import System.Exit +import System.Environment +import Data.Array.Accelerate as A +import qualified Data.Vector.Unboxed as V + + +main :: IO () +main = withSystemRandom $ \gen -> do + beginMonitoring + + argv <- getArgs + (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv + fileIn <- case nops of + (i:_) -> return i + _ -> parseArgs configHelp configBackend options defaults [] [] ("--help":argv) + >> exitSuccess + + -- Read in the matrix file, and generate a random vector to multiply against + -- + (segd', svec', cols) <- readCSRMatrix gen fileIn + vec' <- uniformVector gen cols + + -- Convert to Accelerate arrays + -- + let vec = fromFunction (Z :. V.length vec') (\(Z:.i) -> vec' V.! i) + segd = fromFunction (Z :. V.length segd') (\(Z:.i) -> segd' V.! i) + svec = fromFunction (Z :. V.length svec') (\(Z:.i) -> svec' V.! i) + smat = lift (use segd, svec) + + backend = get configBackend conf + + putStrLn $ "Reading matrix: " P.++ fileIn + putStrLn $ " with shape: " P.++ shows (V.length segd') " x " P.++ shows cols " and " + P.++ shows (V.length svec') " entries\n" + + -- Benchmark + -- + withArgs (P.tail nops) $ defaultMainWith cconf (return ()) + [ bench "smvm" $ whnf (run1 backend (smvm smat)) vec ] + diff --git a/examples/smvm/Matrix.hs b/examples/smvm/Matrix.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/Matrix.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module Matrix where + +import Data.Int +import MatrixMarket +import System.Random.MWC +import System.IO.Unsafe +import Control.Monad.Primitive + +import Data.Vector.Unboxed ( Vector, Unbox ) +import qualified Data.Vector.Unboxed as V +import qualified Data.Vector.Unboxed.Mutable as M +import qualified Data.Vector.Algorithms.Intro as V + +type CSRMatrix a = + ( Vector Int32 -- segment descriptor + , Vector (Int32, a) -- sparse vector for the (flattened) rows + , Int -- number of columns + ) + +-- Read a sparse matrix from a MatrixMarket file. Pattern matrices are filled +-- with random numbers in the range (-1,1). +-- +{-# INLINE readCSRMatrix #-} +readCSRMatrix + :: GenIO + -> FilePath + -> IO (CSRMatrix Float) +readCSRMatrix gen file = do + mtx <- readMatrix file + case mtx of + (RealMatrix dim l vals) -> csr dim l vals + (PatternMatrix dim l ix) -> csr dim l =<< mapM' (\(a,b) -> (a,b,) `fmap` uniformR (-1,1) gen) ix + (IntMatrix _ _ _) -> error "IntMatrix type not supported" + (ComplexMatrix _ _ _) -> error "ComplexMatrix type not supported" + + +-- A randomly generated matrix of given size +-- +{-# INLINE randomCSRMatrix #-} +randomCSRMatrix + :: (PrimMonad m, Variate a, Num a, Unbox a) + => Gen (PrimState m) + -> Int + -> Int + -> m (CSRMatrix a) +randomCSRMatrix gen rows cols = do + segd <- randomVectorR ( 0, fromIntegral cols-1) gen rows + let nnz = fromIntegral $ V.sum segd + inds <- randomVectorR ( 0, fromIntegral cols-1) gen nnz + vals <- randomVectorR (-1,1) gen nnz + return (segd, V.zip inds vals, cols) + + +{-# INLINE randomVectorR #-} +randomVectorR + :: (PrimMonad m, Variate a, Unbox a) + => (a, a) + -> Gen (PrimState m) + -> Int + -> m (Vector a) +randomVectorR r g n = V.replicateM n (uniformR r g) + + +-- Read elements into unboxed arrays, convert to zero-indexed compressed sparse +-- row format. +-- +{-# INLINE csr #-} +csr :: forall a. (Fractional a, Unbox a) + => (Int,Int) + -> Int + -> [(Int32,Int32,a)] + -> IO (Vector Int32, Vector (Int32,a), Int) +csr (m,_n) l elems = do + mu <- M.new l :: IO (M.IOVector (Int32,Int32,a)) + + let goe :: Int -> [(Int32,Int32,a)] -> IO () + goe _ [] = return () + goe !n (x:xs) = let (i,j,v) = x in M.unsafeWrite mu n (i-1,j-1,v) >> goe (n+1) xs + goe 0 elems + + let cmp (x1,y1,_) (x2,y2,_) | x1 == x2 = compare y1 y2 + | otherwise = compare x1 x2 + V.sortBy cmp mu + + (i,j,v) <- V.unzip3 `fmap` V.unsafeFreeze mu + mseg <- M.new m + + let gos :: Int -> Vector Int32 -> IO (Vector Int32) + gos !n rows + | n >= m = V.unsafeFreeze mseg + | otherwise = let (s,ss) = V.span (== fromIntegral n) rows + in M.unsafeWrite mseg n (fromIntegral $ V.length s) >> gos (n+1) ss + + seg <- gos 0 i + return (seg , V.zip j v, _n) + + +-- Lazier versions of things in Control.Monad +-- +sequence' :: [IO a] -> IO [a] +sequence' ms = foldr k (return []) ms + where k m m' = do { x <- m; xs <- unsafeInterleaveIO m'; return (x:xs) } + +mapM' :: (a -> IO b) -> [a] -> IO [b] +mapM' f as = sequence' (map f as) + diff --git a/examples/smvm/MatrixMarket.hs b/examples/smvm/MatrixMarket.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/MatrixMarket.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +module MatrixMarket (Matrix(..), readMatrix) where + +import Control.Applicative hiding ( many ) + +import Data.Int +import Data.Complex +import Data.Attoparsec.Char8 +import Data.ByteString.Lex.Double +import qualified Data.Attoparsec.Lazy as L +import qualified Data.ByteString.Lazy as L + + +-- | Specifies the element type. Pattern matrices do not have any elements, +-- only indices, and only make sense for coordinate matrices and vectors. +-- +data Field = Real | Complex | Integer | Pattern + deriving (Eq, Show) + +-- | Specifies either sparse or dense storage. In sparse (\"coordinate\") +-- storage, elements are given in (i,j,x) triplets for matrices (or (i,x) for +-- vectors). Indices are 1-based, so that A(1,1) is the first element of a +-- matrix, and x(1) is the first element of a vector. +-- +-- In dense (\"array\") storage, elements are given in column-major order. +-- +-- In both cases, each element is given on a separate line. +-- +data Format = Coordinate | Array + deriving (Eq, Show) + +-- | Specifies any special structure in the matrix. For symmetric and hermition +-- matrices, only the lower-triangular part of the matrix is given. For skew +-- matrices, only the entries below the diagonal are stored. +-- +data Structure = General | Symmetric | Hermitian | Skew + deriving (Eq, Show) + + +-- We really want a type parameter to Matrix, but I think that requires some +-- kind of dynamic typing so that we can determine (a ~ Integral) or (a ~ +-- RealFloat), and so forth, depending on the file being read. This will do for +-- our purposes... +-- +-- Format is: (rows,columns) nnz [(row,column,value)] +-- +data Matrix + = PatternMatrix (Int,Int) Int [(Int32,Int32)] + | IntMatrix (Int,Int) Int [(Int32,Int32,Int)] + | RealMatrix (Int,Int) Int [(Int32,Int32,Float)] + | ComplexMatrix (Int,Int) Int [(Int32,Int32,Complex Float)] + deriving Show + + +-------------------------------------------------------------------------------- +-- Combinators +-------------------------------------------------------------------------------- + +comment :: Parser () +comment = char '%' *> skipWhile (not . eol) *> endOfLine + where eol w = w `elem` "\n\r" + +floating :: Fractional a => Parser a +floating = do + mv <- readDouble <$> (skipSpace *> takeTill isSpace) -- readDouble does the fancy stuff + case mv of + Just (v,_) -> return . realToFrac $ v + Nothing -> fail "floating-point number" + +integral :: Integral a => Parser a +integral = skipSpace *> decimal + +format :: Parser Format +format = string "coordinate" *> pure Coordinate + <|> string "array" *> pure Array + "matrix format" + +field :: Parser Field +field = string "real" *> pure Real + <|> string "complex" *> pure Complex + <|> string "integer" *> pure Integer + <|> string "pattern" *> pure Pattern + "matrix field" + +structure :: Parser Structure +structure = string "general" *> pure General + <|> string "symmetric" *> pure Symmetric + <|> string "hermitian" *> pure Hermitian + <|> string "skew-symmetric" *> pure Skew + "matrix structure" + +header :: Parser (Format,Field,Structure) +header = string "%%MatrixMarket matrix" + >> (,,) <$> (skipSpace *> format) + <*> (skipSpace *> field) + <*> (skipSpace *> structure) + <* endOfLine + "MatrixMarket header" + +extent :: Parser (Int,Int,Int) +extent = do + [m,n,l] <- skipWhile isSpace *> count 3 integral <* endOfLine + return (m,n,l) + +line :: Integral i => Parser a -> Parser (i,i,a) +line f = (,,) <$> integral + <*> integral + <*> f + <* endOfLine + +-------------------------------------------------------------------------------- +-- Matrix Market +-------------------------------------------------------------------------------- + +matrix :: Parser Matrix +matrix = do + (_,t,_) <- header + (m,n,l) <- skipMany comment *> extent + case t of + Real -> RealMatrix (m,n) l `fmap` many1 (line floating) + Complex -> ComplexMatrix (m,n) l `fmap` many1 (line ((:+) <$> floating <*> floating)) + Integer -> IntMatrix (m,n) l `fmap` many1 (line integral) + Pattern -> PatternMatrix (m,n) l `fmap` many1 ((,) <$> integral <*> integral) + + +readMatrix :: FilePath -> IO Matrix +readMatrix file = do + chunks <- L.readFile file + case L.parse matrix chunks of + L.Fail _ _ msg -> error $ file ++ ": " ++ msg + L.Done _ mtx -> return mtx + diff --git a/examples/smvm/SMVM.hs b/examples/smvm/SMVM.hs new file mode 100644 --- /dev/null +++ b/examples/smvm/SMVM.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module SMVM where + +import Data.Array.Accelerate as A + + +-- Sparse-matrix vector multiplication +-- ----------------------------------- + +type SparseVector e = Vector (Int32, e) +type SparseMatrix e = (Segments Int32, SparseVector e) + + +smvm :: (Elt a, IsNum a) => Acc (SparseMatrix a) -> Acc (Vector a) -> Acc (Vector a) +smvm smat vec + = let (segd, svec) = unlift smat + (inds, vals) = A.unzip svec + + vecVals = gather (A.map A.fromIntegral inds) vec + products = A.zipWith (*) vecVals vals + in + foldSeg (+) 0 products segd + diff --git a/examples/tests/Benchmark.hs b/examples/tests/Benchmark.hs deleted file mode 100644 --- a/examples/tests/Benchmark.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Benchmark where - -import Data.Array.IArray -import Data.Array.Unboxed (UArray) - -import Data.List -import Data.Monoid -import Criterion -import Criterion.Config -import Criterion.Main -import Criterion.Monad -import Criterion.Types -import Criterion.Environment -import Control.Monad -import Control.Monad.Trans (liftIO) -import Control.DeepSeq -import System.IO -import System.Directory -import System.Environment - -#if MIN_VERSION_criterion(0,8,0) -import Criterion.IO.Printf -#else -import Criterion.IO -#endif - - -instance (Ix dim, IArray UArray e) => NFData (UArray dim e) where - rnf a = a ! head (indices a) `seq` () - - --- Much like defaultMain, but we ignore any non-flag command line arguments, --- which we take as the inputs to the program itself (returned via getArg') --- -runBenchmark :: [Benchmark] -> IO () -runBenchmark = runBenchmarkWith defaultConfig (return ()) - -runBenchmarkWith :: Config -> Criterion () -> [Benchmark] -> IO () -runBenchmarkWith defCfg prep bs = do - (cfg, _) <- parseArgs defCfg defaultOptions =<< getArgs - withConfig cfg $ - if cfgPrintExit cfg == List - then do - _ <- note "Benchmarks:\n" - mapM_ (note " %s\n") (sort $ concatMap benchNames bs) - else do - case getLast $ cfgSummaryFile cfg of - Just fn -> liftIO $ writeFileOnce fn "Name,Mean,MeanLB,MeanUB,Stddev,StddevLB,StddevUB\n" - Nothing -> return () - env <- measureEnvironment - let shouldRun = const True - prep - runAndAnalyse shouldRun env $ BenchGroup "" bs - -writeFileOnce :: FilePath -> String -> IO () -writeFileOnce fn line = do - exists <- doesFileExist fn - size <- withFile fn ReadWriteMode hFileSize - unless (exists && size > 0) $ writeFile fn line - diff --git a/examples/tests/Config.hs b/examples/tests/Config.hs deleted file mode 100644 --- a/examples/tests/Config.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# LANGUAGE CPP, DeriveDataTypeable #-} - -module Config where - -import Data.Version -import Text.PrettyPrint -import System.Console.CmdArgs -import Paths_accelerate_examples - -import Data.Array.Accelerate ( Arrays, Acc ) -import qualified Data.Array.Accelerate.Interpreter as Interpreter - --- ----------------------------------------------------------------------------- --- [NOTE: Adding backend support] --- --- To add support for additional Accelerate backends: --- --- 1. Edit the cabal file so that the backend can be optionally included via --- CPP macros, as has been done for the CUDA backend. Add the appropriate --- import statement below. --- --- 2. Add a new constructor to the 'Backend' data type, and add this case to --- the 'backend' dispatch function. This function is called to evaluate an --- Accelerate expression. --- --- 3. Add the new constructor to the 'cfgBackend' list in 'defaultConfig'. --- This will make the backend appear in the command-line options. --- -#ifdef ACCELERATE_CUDA_BACKEND -import qualified Data.Array.Accelerate.CUDA as CUDA -#endif - -#ifdef ACCELERATE_OPENCL_BACKEND -import qualified Data.Array.Accelerate.OpenCL as OpenCL -#endif - --- The Accelerate backends available to test, which should be no larger than the --- build configuration for the Accelerate library itself. --- -data Backend - = Interpreter -#ifdef ACCELERATE_CUDA_BACKEND - | CUDA -#endif -#ifdef ACCELERATE_OPENCL_BACKEND - | OpenCL -#endif - deriving (Show, Data, Typeable) - - --- How to evaluate Accelerate programs with the chosen backend? --- -backend :: Arrays a => Config -> Acc a -> a -backend cfg = - case cfgBackend cfg of - Interpreter -> Interpreter.run -#ifdef ACCELERATE_CUDA_BACKEND - CUDA -> CUDA.run -#endif -#ifdef ACCELERATE_OPENCL_BACKEND - OpenCL -> OpenCL.run -#endif - --- --- ----------------------------------------------------------------------------- --- - --- Program configuration options --- -data Config = Config - { - -- common options - cfgBackend :: Backend - , cfgVerify :: Bool - , cfgElements :: Int - , cfgImage :: Maybe FilePath - , cfgMatrix :: Maybe FilePath - - -- criterion hooks - , cfgPerformGC :: Bool - , cfgConfidence :: Maybe Double - , cfgSamples :: Maybe Int - , cfgResamples :: Maybe Int - , cfgSummaryFile :: Maybe FilePath - - -- names of tests to run (all non-option arguments) - , cfgArgs :: [String] - } - deriving (Show, Data, Typeable) - - --- With list of (name,description) pairs for the available tests --- -defaultConfig :: [(String,String)] -> Config -defaultConfig testPrograms = - let numElements = 100000 - in Config - { - cfgBackend = enum - [ Interpreter - &= help "Reference implementation (sequential)" -#ifdef ACCELERATE_CUDA_BACKEND - , CUDA - &= explicit - &= name "cuda" - &= help "Implementation for NVIDIA GPUs (parallel)" -#endif -#ifdef ACCELERATE_OPENCL_BACKEND - , OpenCL - &= explicit - &= name "opencl" - &= help "Implementation for OpenCL (parallel)" -#endif - - ] - - , cfgVerify = def - &= explicit - &= name "k" - &= name "verify" - &= help "Only verify examples, do not run timing tests" - - , cfgElements = numElements - &= explicit - &= name "n" - &= name "size" - &= help ("Canonical test data size (" ++ shows numElements ")") - - , cfgImage = def - &= explicit - &= name "i" - &= name "image" - &= help "PGM image file to use for image-processing tests" - &= typFile - - , cfgMatrix = def - &= name "m" - &= name "matrix" - &= explicit - &= help "MatrixMarket file to use for SMVM test" - &= typFile - - , cfgPerformGC = enum - [ False - &= name "G" - &= name "no-gc" - &= explicit - &= help "Do not collect garbage between iterations" - , True - &= name "g" - &= name "gc" - &= explicit - &= help "Collect garbage between iterations" - ] - - , cfgConfidence = def - &= explicit - &= name "I" - &= name "ci" - &= help "Bootstrap confidence interval" - &= typ "CI" - - , cfgResamples = def - &= explicit - &= name "resamples" - &= help "Number of bootstrap resamples to perform" - - , cfgSamples = def - &= explicit - &= name "s" - &= name "samples" - &= help "Number of samples to collect" - - , cfgSummaryFile = def - &= name "u" - &= name "summary" - &= explicit - &= help "Produce a summary CSV file of all results" - &= typFile - - , cfgArgs = def - &= args - &= typ "TESTS" - } - &= program "accelerate-examples" - &= summary "accelerate-examples (c) 2011 The Accelerate Team" - &= versionArg [summary $ "accelerate-examples-" ++ showVersion version] - &= verbosityArgs [help "Print more output"] [help "Print less output"] - &= details ( - [ "Available tests, by prefix match:" - , " run all tests" - ] - ++ - map (\(n,d) -> render . nest 2 $ text n $$ nest 22 (text d)) testPrograms) - -- - -- magic number to make the second columns of the help text align - diff --git a/examples/tests/Main.hs b/examples/tests/Main.hs deleted file mode 100644 --- a/examples/tests/Main.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -module Main where - -import Test -import Config -import Benchmark - -import Prelude hiding (catch) -import Data.List -import Data.Maybe -import Control.Arrow -import Control.Monad -import System.Environment -import System.Console.CmdArgs (cmdArgs, whenNormal, getVerbosity, Verbosity(..)) - - --- Process command line options, prepare selected test programs for benchmarking --- or verification --- -processArgs :: IO (Config, [Test]) -processArgs = do - testInfo <- map (title &&& description) `fmap` allTests undefined - config <- cmdArgs $ defaultConfig testInfo - tests <- filter (selected config) `fmap` allTests config - -- - return (config, tests) - where - selected a = case cfgArgs a of - [] -> const True - ps -> \x -> any (\p -> p `isPrefixOf` title x) ps - - --- Verify results with the chosen backend, turning exceptions into failures. --- Pass back the tests which succeeded. --- -runVerify :: Config -> [Test] -> IO [Test] -runVerify cfg tests = do - results <- forM tests $ \t -> (t,) `fmap` verifyTest cfg t - return . map fst - $ filter (\(_,r) -> r `elem` [Ok, Skipped]) results - - --- Run criterion timing tests in the chosen backend --- -runTiming :: Config -> [Test] -> IO () -runTiming cfg tests = do - verbose <- getVerbosity - unless (verbose == Quiet) $ putStrLn "" - let args = [ maybe "" (\ci -> "--ci=" ++ show ci) (cfgConfidence cfg) - , maybe "" (\r -> "--resamples=" ++ show r) (cfgResamples cfg) - , maybe "" (\r -> "--samples=" ++ show r) (cfgSamples cfg) - , maybe "" (\f -> "--summary=" ++ f) (cfgSummaryFile cfg) - , if cfgPerformGC cfg then "-g" else "-G" - , case verbose of - Loud -> "--verbose" - Quiet -> "--quiet" - Normal -> "" - ] - -- - withArgs args - . runBenchmark - . catMaybes - $ map (benchmarkTest cfg) tests - - --- Main --- ==== - -main :: IO () -main = do - (config, tests) <- processArgs - whenNormal . putStrLn $ - unlines ["running with " ++ shows (cfgBackend config) " backend" - ,"to display available options, rerun with '--help'" - ] - valid <- runVerify config tests - -- - unless (null valid || cfgVerify config) $ runTiming config valid diff --git a/examples/tests/PGM.hs b/examples/tests/PGM.hs deleted file mode 100644 --- a/examples/tests/PGM.hs +++ /dev/null @@ -1,32 +0,0 @@ --- --- Load a PGM file. MacOS X users might find the following quicklook plugin --- useful for viewing PGM files: --- --- http://code.google.com/p/quicklook-pfm/ --- - -module PGM where - -import Control.Applicative -import Graphics.Pgm - -import Prelude as P -import Data.Array.Accelerate as Acc -import Data.Array.Unboxed hiding (Array) -import qualified Data.ByteString as B - - --- Read an 8-bit PGM file, and marshal to an Accelerate array as floating-point --- data in the range [0,1]. --- -readPGM :: FilePath -> IO (Array DIM2 Float) -readPGM fp = do - img <- either (error . show) head . pgmsToArrays <$> B.readFile fp :: IO (UArray (Int,Int) Word8) - return . fromIArray $ amap (\x -> P.fromIntegral x / 255) img - - -writePGM :: FilePath -> Array DIM2 Float -> IO () -writePGM fp img = - let arr = toIArray img :: UArray (Int,Int) Float - in arrayToFile fp $ amap (\x -> P.round (255 * x)) arr - diff --git a/examples/tests/Random.hs b/examples/tests/Random.hs deleted file mode 100644 --- a/examples/tests/Random.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE BangPatterns, FlexibleContexts #-} - -module Random where - -import System.Random.MWC -import Data.Array.IArray -import Data.Array.Unboxed (UArray) -import Data.Array.IO (MArray, IOUArray) -import Control.Exception (evaluate) -import Data.Array.Accelerate (Z(..),(:.)(..)) -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Generic.Mutable as GM -import qualified Data.Array.MArray as M -import qualified Data.Array.Unsafe as U -import qualified Data.Array.Accelerate as Acc - - --- Convert an Unboxed Data.Array to an Accelerate Array --- -convertUArray :: (IArray UArray e, Acc.Elt e) => UArray Int e -> IO (Acc.Vector e) -convertUArray v = - let arr = Acc.fromIArray v - in evaluate (arr `Acc.indexArray` (Z:.0)) >> return arr - - --- Convert a Data.Vector to an Accelerate Array --- -convertVector - :: (IArray UArray a, MArray IOUArray a IO, G.Vector v a, Acc.Elt a) - => v a - -> IO (Acc.Vector a) - -convertVector vec = do - arr <- Acc.fromIArray `fmap` toIArray vec - evaluate (arr `Acc.indexArray` (Z:.0)) >> return arr - where - toIArray :: (MArray IOUArray a IO, IArray UArray a, G.Vector v a) => v a -> IO (UArray Int a) - toIArray v = do - let n = G.length v - mu <- M.newArray_ (0,n-1) :: MArray IOUArray a IO => IO (IOUArray Int a) - let go !i | i < n = M.writeArray mu i (G.unsafeIndex v i) >> go (i+1) - | otherwise = U.unsafeFreeze mu - go 0 - - --- Generate a random, uniformly distributed vector of specified size over the --- range. For integral types the range is inclusive, for floating point numbers --- the range (a,b] is used, if one ignores rounding errors. --- -randomUArrayR - :: (Variate a, MArray IOUArray a IO, IArray UArray a) - => (a,a) - -> GenIO - -> Int - -> IO (UArray Int a) - -randomUArrayR lim gen n = do - mu <- M.newArray_ (0,n-1) :: MArray IOUArray e IO => IO (IOUArray Int e) - let go !i | i < n = uniformR lim gen >>= M.writeArray mu i >> go (i+1) - | otherwise = U.unsafeFreeze mu - go 0 - - --- Generate a uniformly distributed Data.Vector of specified range and size --- -randomVectorR :: (G.Vector v a, Variate a) => (a,a) -> GenIO -> Int -> IO (v a) -randomVectorR lim gen n = do - mu <- GM.unsafeNew n - let go !i | i < n = uniformR lim gen >>= GM.unsafeWrite mu i >> go (i+1) - | otherwise = G.unsafeFreeze mu - go 0 - - diff --git a/examples/tests/Test.hs b/examples/tests/Test.hs deleted file mode 100644 --- a/examples/tests/Test.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE CPP, ExistentialQuantification #-} - -module Test ( - - Title, Description, Test(..), Status(..), - allTests, verifyTest, benchmarkTest - -) where - --- individual test implementations -import qualified Map -import qualified Zip -import qualified ZipWith -import qualified Fold -import qualified FoldSeg -import qualified ScanSeg -import qualified Stencil -import qualified Stencil2 -import qualified Permute -import qualified Backpermute -import qualified Vector -import qualified Gather -import qualified Scatter - -import qualified SASUM -import qualified SAXPY -import qualified DotP -import qualified Filter -import qualified SMVM -import qualified BlackScholes -import qualified Radix -import qualified SliceExamples - -import qualified BlockCopy -import qualified VectorCopy - -import qualified Canny -import qualified IntegralImage -import qualified SharingRecovery - --- friends -import Util -import Config -import Validate - --- libraries -import Prelude hiding (catch) -import Criterion (Benchmark, bench, whnf) -import Data.Maybe -import Data.Array.IArray -import Control.Exception -import System.IO -import System.IO.Unsafe -import System.Console.CmdArgs (getVerbosity, Verbosity(..)) - -import Data.Array.Accelerate (Acc) -import qualified Data.Array.Accelerate as Acc - - -data Status - = Ok - | Skipped - | Failed String - -instance Eq Status where - Ok == Ok = True - Skipped == Skipped = True - _ == _ = False - -instance Show Status where - show Ok = "Ok" - show Skipped = "Skipped" - show (Failed s) = "Failed: " ++ s - - -type Title = String -type Description = String - -data Test - -- A cannonical test program, where we have a reference implementation that - -- the Accelerate program must match. The 'convert' field is slightly magic: - -- we need to carry it around as a proof that ELtRepr sh ~ EltRepr ix. - -- - = forall array ix sh e. (Similar e, Acc.Elt e, Acc.Shape sh, Show ix, Show e, IArray array e, Ix ix) => Test - { title :: Title - , description :: Description - , reference :: () -> array ix e - , accelerate :: () -> Acc (Acc.Array sh e) - , convert :: Acc.Array sh e -> array ix e - } - - -- No reference implementation, so the result can not be validated, but we can - -- check that no exceptions are thrown, and benchmark the operation. - -- - | forall sh e. (Acc.Elt e, Acc.Shape sh) => TestNoRef - { title :: Title - , description :: Description - , accelerate :: () -> Acc (Acc.Array sh e) - } - - -- An IO action. Run once to verify that no exceptions are thrown, do not - -- benchmark. - -- - | forall a. TestIO - { title :: Title - , description :: Description - , action :: IO a - } - - -allTests :: Config -> IO [Test] -allTests cfg = sequence' - [ - - -- primitive functions - mkTest "map-abs" "absolute value of each element" $ Map.run "abs" n - , mkTest "map-plus" "add a constant to each element" $ Map.run "plus" n - , mkTest "map-square" "square of each element" $ Map.run "square" n - , mkTest "zip" "vector zip" $ Zip.run n - , mkTest "zipWith-plus" "element-wise addition" $ ZipWith.run "plus" n - , mkTest "fold-sum" "vector reduction: fold (+) 0" $ Fold.run "sum" n - , mkTest "fold-product" "vector product: fold (*) 1" $ Fold.run "product" n - , mkTest "fold-maximum" "maximum of a vector: fold1 max" $ Fold.run "maximum" n - , mkTest "fold-minimum" "minimum of a vector: fold1 min" $ Fold.run "minimum" n - , mkTest "fold-2d-sum" "reduction along innermost matrix dimension" $ Fold.run2d "sum-2d" n - , mkTest "fold-2d-product" "product along innermost matrix dimension" $ Fold.run2d "product-2d" n - , mkTest "fold-2d-maximum" "maximum along innermost matrix dimension" $ Fold.run2d "maximum-2d" n - , mkTest "fold-2d-minimum" "minimum along innermost matrix dimension" $ Fold.run2d "minimum-2d" n - , mkTest "foldseg-sum" "segmented vector reduction" $ FoldSeg.run "sum" n - , mkTest "scanseg-sum" "segmented vector prescanl (+) 0" $ ScanSeg.run "sum" n - , mkTest "stencil-1D" "3-element vector" $ Stencil.run "1D" n - , mkTest "stencil-2D" "3x3 pattern" $ Stencil.run2D "2D" n - , mkTest "stencil-3D" "3x3x3 pattern" $ Stencil.run3D "3D" n - , mkTest "stencil-3x3-cross" "3x3 cross pattern" $ Stencil.run2D "3x3-cross" n - , mkTest "stencil-3x3-pair" "3x3 non-symmetric pattern with pairs" $ Stencil.run2D "3x3-pair" n - , mkTest "stencil2-2D" "3x3 pattern" $ Stencil2.run2D "2D" n - , mkTest "permute-hist" "histogram" $ Permute.run "histogram" n - , mkTest "backpermute-reverse" "reverse a vector" $ Backpermute.run "reverse" n - , mkTest "backpermute-transpose" "transpose a matrix" $ Backpermute.run2d "transpose" n - , mkTest "init" "vector init" $ Vector.run "init" n - , mkTest "tail" "vector tail" $ Vector.run "tail" n - , mkTest "take" "vector take" $ Vector.run "take" n - , mkTest "drop" "vector drop" $ Vector.run "drop" n - , mkTest "slit" "vector slit" $ Vector.run "slit" n - , mkTest "gather" "backpermute via index mapping vector" $ Gather.run "gather" n - , mkTest "gather-if" "conditional backwards index mapping" $ Gather.run "gather-if" n - , mkTest "scatter" "permute via index mapping vector" $ Scatter.run "scatter" n - , mkTest "scatter-if" "conditional permutation via index mapping" $ Scatter.run "scatter-if" n - - -- simple examples - , mkTest "sasum" "sum of absolute values" $ SASUM.run n - , mkTest "saxpy" "scalar alpha*x + y" $ SAXPY.run n - , mkTest "dotp" "vector dot-product" $ DotP.run n - , mkTest "filter" "return elements that satisfy a predicate" $ Filter.run n - , mkTest "smvm" "sparse-matrix vector multiplication" $ SMVM.run (cfgMatrix cfg) - , mkTest "black-scholes" "Black-Scholes option pricing" $ BlackScholes.run n - , mkTest "radixsort" "radix sort" $ Radix.run n - - -- Array IO - , mkIO "io" "array ptr copy test" $ BlockCopy.run - , mkIO "io" "array vector copy test" $ VectorCopy.run - - -- image processing - , mkIO "canny" "canny edge detection" $ Canny.canny (backend cfg) img 50 100 - , mkNoRef "integral-image" "image integral (2D scan)" $ IntegralImage.run img - -- slices - , mkTest "slices" "replicate (Z:.2:.All:.All)" $ SliceExamples.run1 - , mkTest "slices" "replicate (Z:.All:.2:.All)" $ SliceExamples.run2 - , mkTest "slices" "replicate (Z:.All:.All:.2)" $ SliceExamples.run3 - , mkTest "slices" "replicate (Any:.2)" $ SliceExamples.run4 - , mkTest "slices" "replicate (Z:.2:.2:.2)" $ SliceExamples.run5 - -- - , mkIO "sharing-recovery" "simple" $ return (show SharingRecovery.simple) - , mkIO "sharing-recovery" "orderFail" $ return (show SharingRecovery.orderFail) - , mkIO "sharing-recovery" "testSort" $ return (show SharingRecovery.testSort) - , mkIO "sharing-recovery" "muchSharing" $ return (show $ SharingRecovery.muchSharing 20) - , mkIO "sharing-recovery" "bfsFail" $ return (show SharingRecovery.bfsFail) - , mkIO "sharing-recovery" "twoLetsSameLevel" $ return (show SharingRecovery.twoLetsSameLevel) - , mkIO "sharing-recovery" "twoLetsSameLevel2" $ return (show SharingRecovery.twoLetsSameLevel2) - , mkIO "sharing-recovery" "noLetAtTop" $ return (show SharingRecovery.noLetAtTop) - , mkIO "sharing-recovery" "noLetAtTop2" $ return (show SharingRecovery.noLetAtTop2) - , mkIO "sharing-recovery" "pipe" $ return (show SharingRecovery.pipe) - -- - , mkIO "bound-variables" "stencil2" $ return (show Stencil2.varUse) - ] - where - n = cfgElements cfg - img = fromMaybe (error "no image file specified") (cfgImage cfg) - -- - mkTest name desc builder = do - ~(ref,acc) <- unsafeInterleaveIO builder -- must be super lazy - return $ Test name desc ref acc Acc.toIArray - - mkNoRef name desc builder = do - acc <- unsafeInterleaveIO builder - return $ TestNoRef name desc acc - - mkIO name desc act = return $ TestIO name desc act - - --- Verify that the Accelerate and reference implementations yield the same --- result in the chosen backend --- -verifyTest :: Config -> Test -> IO Status -verifyTest cfg test = do - quiet <- (==Quiet) `fmap` getVerbosity - verify quiet `catch` \e -> let r = Failed (show (e :: SomeException)) - in putStrLn (show r) >> return r - where - run acc = backend cfg $ acc () - verify quiet = do - putStr (title test ++ ": ") >> hFlush stdout - result <- case test of - Test _ _ ref acc cvt -> - return $ case validate (ref ()) (cvt $ run acc) of - [] -> Ok - errs -> Failed $ - if quiet then ("(" ++ show (length errs) ++ " differences)") - else unlines . ("":) $ map (\(i,v) -> ">>> " ++ shows i " : " ++ show v) errs - TestNoRef _ _ acc -> return $ run acc `seq` Ok - TestIO _ _ act -> act >>= \v -> v `seq` return Ok - -- - putStrLn (show result) - return result - - --- Benchmark a test with Criterion --- -benchmarkTest :: Config -> Test -> Maybe Benchmark -benchmarkTest cfg (Test name _ _ acc _) = Just . bench name $ whnf (backend cfg . acc) () -benchmarkTest cfg (TestNoRef name _ acc) = Just . bench name $ whnf (backend cfg . acc) () -benchmarkTest _ (TestIO _ _ _) = Nothing - diff --git a/examples/tests/Util.hs b/examples/tests/Util.hs deleted file mode 100644 --- a/examples/tests/Util.hs +++ /dev/null @@ -1,20 +0,0 @@ - -module Util where - -import System.IO.Unsafe - --- Lazier version of 'Control.Monad.sequence' --- -sequence' :: [IO a] -> IO [a] -sequence' = foldr k (return []) - where k m ms = do { x <- m; xs <- unsafeInterleaveIO ms; return (x:xs) } - -mapM' :: (a -> IO b) -> [a] -> IO [b] -mapM' f xs = sequence' $ map f xs - -forM' :: [a] -> (a -> IO b) -> IO [b] -forM' = flip mapM' - -replicateM' :: Int -> IO a -> IO [a] -replicateM' n x = sequence' (replicate n x) - diff --git a/examples/tests/Validate.hs b/examples/tests/Validate.hs deleted file mode 100644 --- a/examples/tests/Validate.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE FlexibleContexts, ParallelListComp #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} - -module Validate (Similar(..), validate, validate') where - -import Data.Int -import Data.Word -import Data.Array.IArray -import Foreign.C.Types -import Foreign.Storable -import Control.Exception (assert) -import Unsafe.Coerce - -class Similar a where - sim :: a -> a -> Bool - -instance Similar Int where sim = (==) -instance Similar Int8 where sim = (==) -instance Similar Int16 where sim = (==) -instance Similar Int32 where sim = (==) -instance Similar Int64 where sim = (==) -instance Similar Word where sim = (==) -instance Similar Word8 where sim = (==) -instance Similar Word16 where sim = (==) -instance Similar Word32 where sim = (==) -instance Similar Word64 where sim = (==) -instance Similar CShort where sim = (==) -instance Similar CUShort where sim = (==) -instance Similar CInt where sim = (==) -instance Similar CUInt where sim = (==) -instance Similar CLong where sim = (==) -instance Similar CULong where sim = (==) -instance Similar CLLong where sim = (==) -instance Similar CULLong where sim = (==) - -instance Similar Bool where sim = (==) -instance Similar Char where sim = (==) -instance Similar CChar where sim = (==) -instance Similar CSChar where sim = (==) -instance Similar CUChar where sim = (==) - -instance Similar Float where sim = absoluteOrRelative -instance Similar CFloat where sim = absoluteOrRelative -instance Similar Double where sim = absoluteOrRelative -instance Similar CDouble where sim = absoluteOrRelative - -instance (Similar a, Similar b) => Similar (a,b) where - (x,y) `sim` (u,v) = x `sim` u && y `sim` v - --- --- http://www.cygnus-software.com/papers/comparingfloats/comparingfloats.htm --- - -absoluteOrRelative :: (Fractional a, Ord a) => a -> a -> Bool -absoluteOrRelative u v - | abs (u-v) < epsilonAbs = True - | abs u > abs v = abs ((u-v) / u) < epsilonRel - | otherwise = abs ((v-u) / v) < epsilonRel - where - epsilonRel = 0.001 - epsilonAbs = 0.00001 - - --- Comparisons using lexicographically ordered floating-point numbers --- reinterpreted as twos-complement integers. --- -lexicographic32 :: (Num a, Storable a) => Int -> a -> a -> Bool -lexicographic32 maxUlps a b - = assert (sizeOf a == 4 && maxUlps > 0 && maxUlps < 4 * 1024 * 1024) - $ intDiff < fromIntegral maxUlps - where - intDiff = abs (toInt a - toInt b) - toInt x | x' < 0 = 0x80000000 - x' - | otherwise = x' - where x' = unsafeCoerce x :: Int32 - - -lexicographic64 :: (Num a, Storable a) => Int -> a -> a -> Bool -lexicographic64 maxUlps a b - = assert (sizeOf a == 8 && maxUlps > 0 && maxUlps < 8 * 1024 * 1024) - $ intDiff < fromIntegral maxUlps - where - intDiff = abs (toInt a - toInt b) - toInt x | x' < 0 = 0x8000000000000000 - x' - | otherwise = x' - where x' = unsafeCoerce x :: Int64 - - --- Compare two vectors element-wise for equality, for a given measure of --- similarity. The index and values are returned for pairs that fail. --- -validate - :: (IArray array e, Ix ix, Similar e) - => array ix e - -> array ix e - -> [(ix,(e,e))] -validate ref arr = validate' (assocs ref) (elems arr) - -validate' :: (Ix ix, Similar e) => [(ix,e)] -> [e] -> [(ix,(e,e))] -validate' ref arr = - filter (not . uncurry sim . snd) [ (i,(x,y)) | (i,x) <- ref | y <- arr ] - diff --git a/examples/tests/image-processing/Canny.hs b/examples/tests/image-processing/Canny.hs deleted file mode 100644 --- a/examples/tests/image-processing/Canny.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeOperators #-} - -module Canny (canny) where - -import Prelude as P - -import Data.Array.Accelerate as A -import Data.Array.Accelerate.IO as A - -import Data.Array.Repa.Repr.Unboxed ( U ) -import qualified Data.Array.Repa as R -import qualified Data.Vector.Unboxed as V -import qualified Data.Vector.Unboxed.Mutable as VM --- import qualified Data.Array.Repa.IO.BMP as R --- import qualified Data.Array.Repa.Repr.Unboxed as R - - -canny :: (forall a. Arrays a => Acc a -> a) - -> FilePath - -> Float - -> Float - -> IO (R.Array U R.DIM2 Word8) -canny run fileIn threshLow threshHigh = do - - -- Read in the image BMP file - -- - img <- either (error . show) id `fmap` readImageFromBMP fileIn - - -- Setup and run the Accelerate kernel stages, which identify strong and weak - -- edges in the image. - -- - let low = unit (constant threshLow) - high = unit (constant threshHigh) - - grey = toGreyscale - blurred = gaussianY . gaussianX . grey - magdir = gradientMagDir low . blurred - suppress = nonMaximumSuppression low high . magdir - - (image,strong) = run $ stage1 (use img) - stage1 x = let img' = suppress x - in lift $ (img', selectStrong img') - - -- Now use Repa to trace out weak edges connected to strong edges - -- - edges <- wildfire (A.toRepa image) (A.toRepa strong) - --- R.writeImageToBMP "edges.bmp" (R.zip3 edges edges edges) - return edges - -{-- - -- Benchmark each (accelerate) stage. The "kernels" group is intended to be - -- run under nvvp, whereas the canny group is for end-to-end benchmarks. - -- - (args,rest) <- break (== "--") `fmap` getArgs - let opts = if null rest then [] else P.tail rest - force2 a = A.indexArray a (Z:.0:.0 :: DIM2) `seq` () - force1 a = A.indexArray a (Z:.0 :: DIM1) `seq` () - - -- Need to force partial results so that we benchmark individual stages - -- - grey' = run $ toGreyscale (use img) - blurX' = run $ gaussianX (use grey') - blurred' = run $ gaussianY (use blurX') - gradX' = run $ gradientX (use blurred') - gradY' = run $ gradientY (use blurred') - magdir' = run $ gradientMagDir low (use blurred') - suppress' = run $ nonMaximumSuppression low high (use magdir') - - withArgs opts $ defaultMain - [ bgroup "kernels" - [ bench "greyscale" $ whnf (force2 . run . grey) (use img) - , bench "blur-x" $ whnf (force2 . run . gaussianX) (use grey') - , bench "blur-y" $ whnf (force2 . run . gaussianY) (use blurX') - , bench "grad-x" $ whnf (force2 . run . gradientX) (use blurred') - , bench "grad-y" $ whnf (force2 . run . gradientY) (use blurred') - , bench "mag-orient" $ whnf (force2 . run . gradientMagDir low) (use blurred') - , bench "suppress" $ whnf (force2 . run . nonMaximumSuppression low high) (use magdir') - , bench "strong" $ whnf (force1 . run . selectStrong) (use suppress') - ] - - , bgroup "canny" - [ bench "run" $ whnf (force1 . P.snd . run . stage1) (use img) - , bench "run1" $ whnf (force1 . P.snd . run1 stage1) img - ] - ] ---} - --- Accelerate component -------------------------------------------------------- - -type RGBA = Word32 -type Image a = Array DIM2 a - -type Stencil5x1 a = (Stencil3 a, Stencil5 a, Stencil3 a) -type Stencil1x5 a = (Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a, Stencil3 a) - --- Classification of the output pixel -data Orient = Undef | PosD | Vert | NegD | Horiz -data Edge = None | Weak | Strong - -orient :: Orient -> Int -orient Undef = 0 -orient PosD = 64 -orient Vert = 128 -orient NegD = 192 -orient Horiz = 255 - -orient' :: Orient -> Exp Int -orient' = constant . orient - -edge :: Edge -> Float -edge None = 0 -edge Weak = 0.5 -edge Strong = 1.0 - -edge' :: Edge -> Exp Float -edge' = constant . edge - -convolve5x1 :: (Elt a, IsNum a) => [Exp a] -> Stencil5x1 a -> Exp a -convolve5x1 kernel (_, (a,b,c,d,e), _) - = P.foldl1 (+) - $ P.zipWith (*) kernel [a,b,c,d,e] - -convolve1x5 :: (Elt a, IsNum a) => [Exp a] -> Stencil1x5 a -> Exp a -convolve1x5 kernel ((_,a,_), (_,b,_), (_,c,_), (_,d,_), (_,e,_)) - = P.foldl1 (+) - $ P.zipWith (*) kernel [a,b,c,d,e] - - --- RGB to Greyscale conversion, in the range [0,255] --- -toGreyscale :: Acc (Image RGBA) -> Acc (Image Float) -toGreyscale = A.map (\rgba -> 255 * luminanceOfRGBA32 rgba) - - --- Separable Gaussian blur in the x- and y-directions --- -gaussianX :: Acc (Image Float) -> Acc (Image Float) -gaussianX = stencil (convolve5x1 gaussian) Clamp - where - gaussian = [ 1, 4, 6, 4, 1 ] - -gaussianY :: Acc (Image Float) -> Acc (Image Float) -gaussianY = stencil (convolve1x5 gaussian) Clamp - where - gaussian = P.map (/256) [ 1, 4, 6, 4, 1 ] - - --- Gradients in the x- and y- directions --- -gradientX :: Acc (Image Float) -> Acc (Image Float) -gradientX = stencil grad Clamp - where - grad :: Stencil3x3 Float -> Exp Float - grad ((u, _, x) - ,(v, _, y) - ,(w, _, z)) = x + (2*y) + z - u - (2*v) - w - -gradientY :: Acc (Image Float) -> Acc (Image Float) -gradientY = stencil grad Clamp - where - grad :: Stencil3x3 Float -> Exp Float - grad ((x, y, z) - ,(_, _, _) - ,(u, v, w)) = x + (2*y) + z - u - (2*v) - w - - --- Classify the magnitude and orientation of the image gradient. --- --- Because accelerate supports generalised stencil functions, not just --- convolutions, we can combine the x- and y- sobel operators and save some --- memory bandwidth. --- -gradientMagDir - :: Acc (Scalar Float) - -> Acc (Image Float) - -> Acc (Array DIM2 (Float,Int)) -gradientMagDir threshLow = stencil magdir Clamp - where - magdir :: Stencil3x3 Float -> Exp (Float,Int) - magdir ((v0, v1, v2) - ,(v3, _, v4) - ,(v5, v6, v7)) = - let - -- Image gradients - dx = v2 + (2*v4) + v7 - v0 - (2*v3) - v5 - dy = v0 + (2*v1) + v2 - v5 - (2*v6) - v7 - - -- Magnitude - mag = sqrt (dx * dx + dy + dy) - - -- Direction - -- - -- Determine the angle of the vector and rotate it around a bit to - -- make the segments easier to classify - theta = atan2 dy dx - alpha = (theta - (pi/8)) * (4/pi) - - -- Normalise the angle to between [0..8) - norm = alpha + 8 * A.fromIntegral (boolToInt (alpha <=* 0)) - - -- Try to avoid doing explicit tests, to avoid warp divergence - low = the threshLow - undef = abs dx <=* low &&* abs dy <=* low - dir = boolToInt (A.not undef) * ((64 * (1 + A.floor norm `mod` 4)) `A.min` 255) - in - lift (mag, dir) - - --- Non-maximum suppression classifies pixels that are the local maximum along --- the direction of the image gradient as either strong or weak edges. All other --- pixels are not considered edges at all. --- --- The image intensity is in the range [0,1] --- -nonMaximumSuppression - :: Acc (Scalar Float) - -> Acc (Scalar Float) - -> Acc (Image (Float,Int)) - -> Acc (Image Float) -nonMaximumSuppression threshLow threshHigh magdir = - generate (shape magdir) $ \ix -> - let -- The input parameters - -- - low = the threshLow - high = the threshHigh - (mag, dir) = unlift (magdir ! ix) - Z :. h :. w = unlift (shape magdir) - Z :. y :. x = unlift ix - - -- Determine the points that lie either side of this point along to the - -- direction of the image gradient. - -- - -- The direction coding: - -- - -- 192 128 64 - -- | - -- 255 --- --- - -- - offsetx = dir >* orient' Vert ? (-1, dir <* orient' Vert ? (1, 0)) - offsety = dir <* orient' Horiz ? (-1, 0) - - (fwd, _) = unlift $ magdir ! lift (clamp (Z :. y+offsety :. x+offsetx)) :: (Exp Float, Exp Int) - (rev, _) = unlift $ magdir ! lift (clamp (Z :. y-offsety :. x-offsetx)) :: (Exp Float, Exp Int) - - clamp (Z:.u:.v) = Z :. 0 `A.max` u `A.min` (h-1) :. 0 `A.max` v `A.min` (w-1) - - -- Try to avoid doing explicit tests to avoid warp divergence. - -- - none = dir ==* orient' Undef ||* mag <* low ||* mag <* fwd ||* mag <* rev - strong = mag >=* high - in - A.fromIntegral (boolToInt (A.not none) * (1 + boolToInt strong)) * 0.5 - - --- Extract the linear indices of the strong edges --- -selectStrong - :: Acc (Image Float) - -> Acc (Array DIM1 Int) -selectStrong img = - let strong = A.map (\x -> boolToInt (x ==* edge' Strong)) (flatten img) - (targetIdx, len) = A.scanl' (+) 0 strong - indices = A.enumFromN (index1 $ size img) 0 - zeros = A.fill (index1 $ the len) 0 - in - A.permute const zeros (\ix -> strong!ix ==* 0 ? (ignore, index1 $ targetIdx!ix)) indices - - --- Repa component -------------------------------------------------------------- - --- | Trace out strong edges in the final image. --- Also trace out weak edges that are connected to strong edges. --- -wildfire - :: R.Array A R.DIM2 Float -- ^ Image with strong and weak edges set. - -> R.Array A R.DIM1 Int -- ^ Array containing flat indices of strong edges. - -> IO (R.Array U R.DIM2 Word8) - -wildfire img arrStrong - = do (sh, vec) <- wildfireIO - return $ sh `seq` vec `seq` R.fromUnboxed sh vec - - where lenImg = R.size $ R.extent img - lenStrong = R.size $ R.extent arrStrong - shImg = R.extent img - - wildfireIO - = do -- Stack of image indices we still need to consider. - vStrong <- R.toUnboxed `fmap` R.computeUnboxedP (R.delay arrStrong) - vStrong' <- V.thaw vStrong - vStack <- VM.grow vStrong' (lenImg - lenStrong) - - -- Burn in new edges. - vImg <- VM.unsafeNew lenImg - VM.set vImg 0 - burn vImg vStack lenStrong - vImg' <- V.unsafeFreeze vImg - return (R.extent img, vImg') - - - burn :: VM.IOVector Word8 -> VM.IOVector Int -> Int -> IO () - burn !vImg !vStack !top - | top == 0 - = return () - - | otherwise - = do let !top' = top - 1 - n <- VM.unsafeRead vStack top' - let (R.Z R.:. y R.:. x) = R.fromIndex (R.extent img) n - - let {-# INLINE push #-} - push ix t = - if R.inShape shImg ix - then pushWeak vImg vStack ix t - else return t - - VM.write vImg n 255 - >> push (R.Z R.:. y - 1 R.:. x - 1) top' - >>= push (R.Z R.:. y - 1 R.:. x ) - >>= push (R.Z R.:. y - 1 R.:. x + 1) - - >>= push (R.Z R.:. y R.:. x - 1) - >>= push (R.Z R.:. y R.:. x + 1) - - >>= push (R.Z R.:. y + 1 R.:. x - 1) - >>= push (R.Z R.:. y + 1 R.:. x ) - >>= push (R.Z R.:. y + 1 R.:. x + 1) - - >>= burn vImg vStack - - -- If this ix is weak in the source then set it to strong in the - -- result and push the ix onto the stack. - {-# INLINE pushWeak #-} - pushWeak vImg vStack ix top - = do let n = R.toIndex (R.extent img) ix - xDst <- VM.unsafeRead vImg n - let xSrc = img `R.unsafeIndex` ix - - if xDst == 0 - && xSrc == edge Weak - then do - VM.unsafeWrite vStack top (R.toIndex (R.extent img) ix) - return (top + 1) - - else return top -{-# NOINLINE wildfire #-} - diff --git a/examples/tests/image-processing/IntegralImage.hs b/examples/tests/image-processing/IntegralImage.hs deleted file mode 100644 --- a/examples/tests/image-processing/IntegralImage.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, TypeOperators #-} - -module IntegralImage where - -import Data.Array.Accelerate as A -import Data.Array.Accelerate.IO as A - - --- |The value of each element in an integral image is the sum of all input elements --- above and to the left, inclusive. It is calculated by performing an inclusive/post --- scan from left-to-right then top-to-bottom. --- -integralImage :: (Elt a, IsFloating a) => Array DIM2 Word32 -> Acc (Array DIM2 a) -integralImage img = sumTable - where - -- scan rows - rowArr = reshape (index1 (w * h)) $ arr - rowSegs = A.replicate (index1 h) $ unit w - rowSum = reshape (index2 w h) $ scanl1Seg (+) rowArr rowSegs - - -- scan cols - colArr = reshape (index1 (h * w)) $ transpose rowSum - colSegs = A.replicate (index1 w) $ unit h - colSum = reshape (index2 h w) $ A.scanl1Seg (+) colArr colSegs - - -- transpose back - sumTable = transpose colSum - - -- - arr = A.map luminanceOfRGBA32 (use img) - Z:.w:.h = unlift $ shape arr - - --- Run integralImage over the input PGM --- -run :: FilePath -> IO (() -> Acc (Array DIM2 Float)) -run file = do - bmp <- either (error . show) id `fmap` readImageFromBMP file - return (\() -> integralImage bmp) - diff --git a/examples/tests/io/BlockCopy.hs b/examples/tests/io/BlockCopy.hs deleted file mode 100644 --- a/examples/tests/io/BlockCopy.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables, TypeOperators #-} - -module BlockCopy where - --- standard libraries -import Prelude as P -import Foreign.Ptr -import Foreign.C -import Control.Monad -import Control.Exception - --- friends -import Data.Array.Accelerate -import Data.Array.Accelerate.IO - -assertEqual :: (Eq a, Show a) => String -> a -> a -> IO () -assertEqual preface expected actual = - unless (actual == expected) (throw $ AssertionFailed msg) - where - msg = (if P.null preface then "" else preface ++ "\n") ++ - "expected: " ++ show expected ++ "\n but got: " ++ show actual - -run :: IO () -run = - mapM_ (\(msg,act) -> putStrLn ("test: " ++ msg) >> act) - [ ("fromPtr Int", testBlockCopyPrim) - , ("fromPtr (Int,Double)", testBlockCopyTuples) - , ("toPtr Int16", testBlockCopyFromArrayInt16) - , ("toPtr Int32", testBlockCopyFromArrayInt32) - , ("toPtr Int64", testBlockCopyFromArrayInt64) - , ("fromArray Int", testBlockCopyFromArrayWithFunctions) ] - - -testBlockCopyPrim :: IO () -testBlockCopyPrim = do - ptr <- oneToTen - (arr :: Vector Int32) <- fromPtr (Z :. 10) ((), ptr) - assertEqual "Not equal" [1..10] (toList arr) - -testBlockCopyTuples :: IO () -testBlockCopyTuples = do - intPtr <- oneToTen - doublePtr <- tenToOne - (arr :: Vector (Int32, Double)) <- fromPtr (Z :. 10) (((), intPtr), doublePtr) - assertEqual "Not equal" [ (x, P.fromIntegral (11 - x)) | x <- [1..10]] (toList arr) - -testBlockCopyFromArrayWithFunctions :: IO () -testBlockCopyFromArrayWithFunctions = do - let n = 5^(3::Int) - let (arr :: Array (Z:.Int:.Int:.Int) Int32) = fromList (Z:.5:.5:.5) [2*x | x <- [0..n-1]] - ohi <- nInt32s (P.fromIntegral n) - fromArray arr ((), memcpy ohi) - b <- isFilledWithEvens32 ohi (P.fromIntegral n) - assertEqual "Not equal" 1 b - -testBlockCopyFromArrayInt16 :: IO () -testBlockCopyFromArrayInt16 = do - let n = 50 - let (arr :: Vector Int16) = fromList (Z:.n) [2 * P.fromIntegral x | x <- [0..n-1]] - ohi <- nInt16s (P.fromIntegral n) - toPtr arr ((), ohi) - b <- isFilledWithEvens16 ohi (P.fromIntegral n) - assertEqual "Not equal" 1 b - -testBlockCopyFromArrayInt32 :: IO () -testBlockCopyFromArrayInt32 = do - let (arr :: Array (Z:.Int:.Int) Int32) = fromList (Z:.10:.10) [2*x | x <- [0..99]] - ohi <- nInt32s 100 - toPtr arr ((), ohi) - b <- isFilledWithEvens32 ohi 100 - assertEqual "Not equal" 1 b - -testBlockCopyFromArrayInt64 :: IO () -testBlockCopyFromArrayInt64 = do - let n = 73 - let (arr :: Vector Int64) = fromList (Z:.n) [2 * P.fromIntegral x | x <- [0..n-1]] - ohi <- nInt64s (P.fromIntegral n) - toPtr arr ((), ohi) - b <- isFilledWithEvens64 ohi (P.fromIntegral n) - assertEqual "Not equal" 1 b - -foreign import ccall "one_to_ten" oneToTen :: IO (Ptr Int32) -foreign import ccall "ten_to_one" tenToOne :: IO (Ptr Double) -foreign import ccall "n_int_16s" nInt16s :: CInt -> IO (Ptr Int16) -foreign import ccall "n_int_32s" nInt32s :: CInt -> IO (Ptr Int32) -foreign import ccall "n_int_64s" nInt64s :: CInt -> IO (Ptr Int64) -foreign import ccall "is_filled_with_evens_16" isFilledWithEvens16 :: Ptr Int16 -> CInt -> IO CInt -foreign import ccall "is_filled_with_evens_32" isFilledWithEvens32 :: Ptr Int32 -> CInt -> IO CInt -foreign import ccall "is_filled_with_evens_64" isFilledWithEvens64 :: Ptr Int64 -> CInt -> IO CInt -foreign import ccall memcpy :: Ptr a -> Ptr b -> Int -> IO () - diff --git a/examples/tests/io/VectorCopy.hs b/examples/tests/io/VectorCopy.hs deleted file mode 100644 --- a/examples/tests/io/VectorCopy.hs +++ /dev/null @@ -1,65 +0,0 @@ - -module VectorCopy (run) where - --- friends -import Data.Array.Accelerate -import Data.Array.Accelerate.IO ( toVectors, fromVectors ) - --- standard library -import Test.QuickCheck - - --- Print expected/received message on inequality --- -infix 4 .==. -(.==.) :: (Eq a, Show a) => a -> a -> Property -(.==.) ans ref = printTestCase message (ref == ans) - where - message = unlines ["*** Expected:", show ref - ,"*** Received:", show ans ] - - -roundtrip :: (Arbitrary a, Eq a, Elt a) - => [a] - -> Property -roundtrip xs = - let n = length xs - sh = Z:.n - arr = fromList sh xs - in - xs .==. toList (fromVectors sh (toVectors arr)) - - -prop_Int8_roundtrip :: [Int8] -> Property -prop_Int8_roundtrip = roundtrip - -prop_Int16_roundtrip :: [Int16] -> Property -prop_Int16_roundtrip = roundtrip - -prop_Int32_roundtrip :: [Int32] -> Property -prop_Int32_roundtrip = roundtrip - -prop_Int64_roundtrip :: [Int64] -> Property -prop_Int64_roundtrip = roundtrip - -prop_Int_roundtrip :: [Int] -> Property -prop_Int_roundtrip = roundtrip - -prop_Float_roundtrip :: [Float] -> Property -prop_Float_roundtrip = roundtrip - -prop_Double_roundtrip :: [Double] -> Property -prop_Double_roundtrip = roundtrip - - -run :: IO () -run = mapM_ quickCheck - [ property prop_Int8_roundtrip - , property prop_Int16_roundtrip - , property prop_Int32_roundtrip - , property prop_Int64_roundtrip - , property prop_Int_roundtrip - , property prop_Float_roundtrip - , property prop_Double_roundtrip - ] - diff --git a/examples/tests/io/fill_with_values.cpp b/examples/tests/io/fill_with_values.cpp deleted file mode 100644 --- a/examples/tests/io/fill_with_values.cpp +++ /dev/null @@ -1,81 +0,0 @@ -#include -#include -#include - -/* Returns one if it's filled with even values starting at 0 */ -template -int is_filled_with_evens(T *p, int size) { - T prev = 0; - int result = 1; // default to true - int i; - - if (p[0] != 0) { - result = 0; - } - - for (i=1; result && i < size; i++) { - if (p[i] != prev + 2) { - result = 0; - } - else { - prev = p[i]; - } - } - - return result; -} - - -#ifdef __cplusplus -extern "C" { -#endif - -int32_t *one_to_ten() { - int32_t *p = (int32_t*) malloc(sizeof(int32_t) * 10); - int i; - for (i=0; i<10; i++) { - p[i] = i+1; - } - return p; -} - -double *ten_to_one() { - double *p = (double*) malloc(sizeof(double) * 10); - int i; - for (i=0; i< 10; i++) { - p[i] = 10.0 - (double) i; - } - return p; -} - -int32_t *n_int_32s (int n) { - return (int32_t*) malloc(sizeof(int32_t) * n); -} - -int16_t *n_int_16s(int n) { - return (int16_t*) malloc(sizeof(int16_t) * n); -} - -int64_t *n_int_64s(int n) { - return (int64_t*) malloc(sizeof(int64_t) * n); -} - -int is_filled_with_evens_16(int16_t *p, int size) -{ - return is_filled_with_evens(p, size); -} - -int is_filled_with_evens_32(int32_t *p, int size) -{ - return is_filled_with_evens(p, size); -} - -int is_filled_with_evens_64(int64_t *p, int size) -{ - return is_filled_with_evens(p, size); -} - -#ifdef __cplusplus -} -#endif - diff --git a/examples/tests/primitives/Backpermute.hs b/examples/tests/primitives/Backpermute.hs deleted file mode 100644 --- a/examples/tests/primitives/Backpermute.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -module Backpermute where - -import Util -import Random - -import Control.Monad -import Control.Exception -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc -import Prelude as P - - --- Tests --- ----- - -reverseAcc :: Vector Float -> Acc (Vector Float) -reverseAcc xs = Acc.reverse (use xs) - -reverseRef :: UArray Int Float -> UArray Int Float -reverseRef xs = listArray (bounds xs) (P.reverse (elems xs)) - - -transposeAcc :: Acc.Array DIM2 Float -> Acc (Acc.Array DIM2 Float) -transposeAcc mat = Acc.transpose (use mat) - -transposeRef :: UArray (Int,Int) Float -> UArray (Int,Int) Float -transposeRef mat = - let swap (x,y) = (y,x) - (u,v) = bounds mat - in - array (swap u, swap v) [(swap ix, e) | (ix, e) <- assocs mat] - - --- Main --- ---- - -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run alg n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (-1,1) gen n - vec' <- convertUArray vec - -- - let go f g = return (\() -> f vec, \() -> g vec') - case alg of - "reverse" -> go reverseRef reverseAcc - _ -> error $ "unknown variant: " ++ alg - -run2d :: String -> Int -> IO (() -> UArray (Int,Int) Float, () -> Acc (Acc.Array DIM2 Float)) -run2d alg n = withSystemRandom $ \gen -> do - let n' = P.round $ sqrt (P.fromIntegral n :: Double) - (u,v) = (n'*2, n'`div`2) - mat <- listArray ((0,0), (u-1,v-1)) `fmap` replicateM' (u*v) (uniformR (-1,1) gen) - mat' <- let m = fromIArray mat :: Acc.Array DIM2 Float - in evaluate (m `Acc.indexArray` (Z:.0:.0)) >> return m - -- - let go f g = return (\() -> f mat, \() -> g mat') - case alg of - "transpose" -> go transposeRef transposeAcc - _ -> error $ "unknown variant: " ++ alg - diff --git a/examples/tests/primitives/Fold.hs b/examples/tests/primitives/Fold.hs deleted file mode 100644 --- a/examples/tests/primitives/Fold.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE FlexibleContexts, TypeOperators #-} - -module Fold where - -import Util -import Random - -import Control.Monad -import Control.Exception -import System.Random.MWC -import Data.List -import Data.Array.Unboxed hiding (Array) -import Data.Array.Accelerate as Acc -import Prelude as P - - --- one-dimension ah-ha-ha --- ---------------------- - -toUA :: (IArray UArray a, IArray UArray b) => ([a] -> b) -> UArray Int a -> UArray () b -toUA f = listArray ((),()) . return . f . elems - - -sumAcc, prodAcc, maxAcc, minAcc :: Shape ix => Array (ix:.Int) Float -> Acc (Array ix Float) -sumAcc = Acc.fold (+) 0 . Acc.use -prodAcc = Acc.fold (*) 1 . Acc.use -maxAcc = Acc.fold1 Acc.max . Acc.use -minAcc = Acc.fold1 Acc.min . Acc.use - -sumRef, prodRef, maxRef, minRef :: UArray Int Float -> UArray () Float -sumRef = toUA (foldl' (+) 0) -prodRef = toUA (foldl' (*) 1) -maxRef = toUA (foldl1' P.max) -minRef = toUA (foldl1' P.min) - - --- two-dimensions ah-ha-ha --- ----------------------- - -foldU2D :: IArray UArray a => (a -> a -> a) -> a -> UArray (Int,Int) a -> UArray Int a -foldU2D f z arr = - let (_,(m,_)) = bounds arr - in accumArray f z (0,m) [ (i,e) | ((i,_),e) <- assocs arr ] - -sum2DRef, prod2DRef, min2DRef, max2DRef :: UArray (Int,Int) Float -> UArray Int Float -sum2DRef = foldU2D (+) 0 -prod2DRef = foldU2D (*) 1 -min2DRef = foldU2D P.min ( 1/0) -max2DRef = foldU2D P.max (-1/0) - - --- Main --- ---- -run :: String -> Int -> IO (() -> UArray () Float, () -> Acc (Scalar Float)) -run alg n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (-1,1) gen n - vec' <- convertUArray vec - -- - let go f g = return (run_ref f vec, run_acc g vec') - case alg of - "sum" -> go sumRef sumAcc - "product" -> go prodRef prodAcc - "maximum" -> go maxRef maxAcc - "minimum" -> go minRef minAcc - x -> error $ "unknown variant: " ++ x - where - {-# NOINLINE run_ref #-} - run_ref f xs () = f xs - run_acc f xs () = f xs - -run2d :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run2d alg n = withSystemRandom $ \gen -> do - let u = P.floor . sqrt $ (P.fromIntegral n :: Double) - v = 2*u+1 :: Int - mat <- listArray ((0,0), (u-1,v-1)) `fmap` replicateM' (u*v) (uniformR (-1,1) gen) - mat' <- let m = fromIArray mat :: Array DIM2 Float - in evaluate (m `Acc.indexArray` (Z:.0:.0)) >> return m - -- - let go f g = return (run_ref f mat, run_acc g mat') - case alg of - "sum-2d" -> go sum2DRef sumAcc - "product-2d" -> go prod2DRef prodAcc - "maximum-2d" -> go max2DRef maxAcc - "minimum-2d" -> go min2DRef minAcc - x -> error $ "unknown variant: " ++ x - where - {-# NOINLINE run_ref #-} - run_ref f xs () = f xs - run_acc f xs () = f xs - diff --git a/examples/tests/primitives/FoldSeg.hs b/examples/tests/primitives/FoldSeg.hs deleted file mode 100644 --- a/examples/tests/primitives/FoldSeg.hs +++ /dev/null @@ -1,62 +0,0 @@ - -module FoldSeg where - -import Random - -import Data.List -import System.IO -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as A -import Prelude as P - - --- segmented reduction --- ------------------- - -sumSegAcc :: Vector Float -> Segments Int32 -> Acc (Vector Float) -sumSegAcc xs seg - = let xs' = use xs - seg' = use seg - in - A.foldSeg (+) 0 xs' seg' - -sumSegRef :: UArray Int Float -> UArray Int Int32 -> UArray Int Float -sumSegRef xs seg - = listArray (bounds seg) - $ list_foldSeg (+) 0 (elems xs) (elems seg) - -list_foldSeg :: (a -> a -> a) -> a -> [a] -> [Int32] -> [a] -list_foldSeg f s xs seg = P.map (foldl' f s) (split seg xs) - where - split [] _ = [] - split _ [] = [] - split (i:is) vs = - let (h,t) = splitAt (P.fromIntegral i) vs - in h : split is t - - --- main --- ---- - -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run alg m = withSystemRandom $ \gen -> do - -- generate segments - -- - let n = P.round $ sqrt (P.fromIntegral m :: Double) - seg <- randomUArrayR (0, 2*n) gen (P.fromIntegral n) - seg' <- convertUArray seg - - -- generate elements - -- - let x = P.fromIntegral $ P.sum (elems seg) - vec <- randomUArrayR (-1,1) gen x - vec' <- convertUArray vec - - -- super-happy-fun-times - -- - let go f g = return (\() -> f vec seg, \() -> g vec' seg') - case alg of - "sum" -> go sumSegRef sumSegAcc - unknown -> error $ "unknown variant: " ++ unknown - diff --git a/examples/tests/primitives/Gather.hs b/examples/tests/primitives/Gather.hs deleted file mode 100644 --- a/examples/tests/primitives/Gather.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Gather where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc hiding ((!)) -import Prelude as P - - --- Tests --- ----- - -gatherAcc :: Vector Int -> Vector Float -> Acc (Vector Float) -gatherAcc mapV inputV = Acc.gather (use mapV) (use inputV) - -gatherIfAcc :: Vector Int -> Vector Int -> Vector Float -> Vector Float -> Acc (Vector Float) -gatherIfAcc mapV maskV defaultV inputV - = Acc.gatherIf (use mapV) (use maskV) evenAcc (use defaultV) (use inputV) - -evenAcc :: Exp Int -> Exp Bool -evenAcc v = (v `mod` 2) ==* 0 - - -gatherRef :: UArray Int Int -> UArray Int Float -> UArray Int Float -gatherRef mapV inputV = amap (\ix -> inputV ! ix) mapV - -gatherIfRef :: UArray Int Int -> UArray Int Int -> UArray Int Float -> UArray Int Float -> UArray Int Float -gatherIfRef mapV maskV defaultV inputV - = listArray (bounds mapV) - $ P.map (\(mIx, mV, dV) -> if evenRef mV then (inputV ! mIx) else dV) - $ P.zip3 mapL maskL defaultL - where - mapL = elems mapV - maskL = elems maskV - defaultL = elems defaultV - -evenRef :: Int -> Bool -evenRef = even - - --- Main --- ---- -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run alg n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (-1, 1) gen n - vec' <- convertUArray vec - - mapV <- randomUArrayR (0, n - 1) gen n - mapV' <- convertUArray mapV - - maskV <- randomUArrayR (0, n) gen n - maskV' <- convertUArray maskV - - defaultV <- randomUArrayR (-1, 1) gen n - defaultV' <- convertUArray defaultV - - -- - let go f g = return (run_ref f vec, run_acc g vec') - - case alg of - "gather" -> go (gatherRef mapV) (gatherAcc mapV') - "gather-if" -> go (gatherIfRef mapV maskV defaultV) (gatherIfAcc mapV' maskV' defaultV') - x -> error $ "unknown variant: " ++ x - - where - {-# NOINLINE run_ref #-} - run_ref f xs () = f xs - run_acc f xs () = f xs - - diff --git a/examples/tests/primitives/Map.hs b/examples/tests/primitives/Map.hs deleted file mode 100644 --- a/examples/tests/primitives/Map.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Map where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc - - --- Tests --- ----- -sqAcc, absAcc :: Vector Float -> Acc (Vector Float) -absAcc = Acc.map abs . Acc.use -sqAcc = Acc.map (\x -> x * x) . Acc.use - -plusAcc :: Exp Float -> Vector Float -> Acc (Vector Float) -plusAcc alpha = Acc.map (+ alpha) . Acc.use - - -toUA :: (IArray UArray a, IArray UArray b) => ([a] -> [b]) -> UArray Int a -> UArray Int b -toUA f xs = listArray (bounds xs) $ f (elems xs) - -sqRef, absRef :: UArray Int Float -> UArray Int Float -absRef = toUA $ Prelude.map abs -sqRef = toUA $ Prelude.map (\x -> x*x) - -plusRef :: Float -> UArray Int Float -> UArray Int Float -plusRef alpha = toUA $ Prelude.map (+alpha) - - --- Main --- ---- -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run alg n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (-1,1) gen n - vec' <- convertUArray vec - alpha <- uniform gen - -- - let go f g = return (run_ref f vec, run_acc g vec') - case alg of - "abs" -> go absRef absAcc - "plus" -> go (plusRef alpha) (plusAcc $ constant alpha) - "square" -> go sqRef sqAcc - x -> error $ "unknown variant: " ++ x - - where - {-# NOINLINE run_ref #-} - run_ref f xs () = f xs - run_acc f xs () = f xs - diff --git a/examples/tests/primitives/Permute.hs b/examples/tests/primitives/Permute.hs deleted file mode 100644 --- a/examples/tests/primitives/Permute.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Permute where - -import Random - -import Data.Int -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc -import Prelude as P - - --- Tests --- ----- - -histogramAcc :: (Int,Int) -> Vector Float -> Acc (Vector Int32) -histogramAcc (m,n) vec = - let vec' = use vec - zeros = generate (constant (Z:. n-m)) (const 0) - ones = generate (shape vec') (const 1) - in - permute (+) zeros (\ix -> index1 (Acc.floor (vec' Acc.! ix) :: Exp Int)) ones - -histogramRef :: (Int,Int) -> UArray Int Float -> UArray Int Int32 -histogramRef (m,n) vec = - accumArray (+) 0 (0,n-m-1) [(P.floor e, 1) | e <- elems vec] - - --- Main --- ---- -run :: String -> Int -> IO (() -> UArray Int Int32, () -> Acc (Vector Int32)) -run alg n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (0,100::Float) gen n - vec' <- convertUArray vec - -- - let go f g = return (\() -> f vec, \() -> g vec') - case alg of - "histogram" -> go (histogramRef (0,100)) (histogramAcc (0,100)) - _ -> error $ "unknown variant: " ++ alg - - diff --git a/examples/tests/primitives/ScanSeg.hs b/examples/tests/primitives/ScanSeg.hs deleted file mode 100644 --- a/examples/tests/primitives/ScanSeg.hs +++ /dev/null @@ -1,63 +0,0 @@ - -module ScanSeg where - -import Random - -import System.IO -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc -import Prelude as P - - --- Segmented prefix-sum --- -------------------- -prefixSumSegAcc :: Vector Float -> Segments Int32 -> Acc (Vector Float) -prefixSumSegAcc xs seg - = let - xs' = use xs - seg' = use seg - in - prescanlSeg (+) 0 xs' seg' - - -prefixSumSegRef :: UArray Int Float -> UArray Int Int32 -> UArray Int Float -prefixSumSegRef xs seg - = listArray (bounds xs) - $ list_prescanlSeg (+) 0 (elems xs) (elems seg) - -list_prescanlSeg :: (a -> a -> a) -> a -> [a] -> [Int32] -> [a] -list_prescanlSeg f x xs seg = concatMap (P.init . P.scanl f x) (split seg xs) - where - split [] _ = [] - split _ [] = [] - split (i:is) vs = - let (h,t) = splitAt (P.fromIntegral i) vs - in h : split is t - - --- Main --- ---- -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run alg m = withSystemRandom $ \gen -> do - -- generate segments - -- - let n = P.round . sqrt $ (P.fromIntegral m :: Double) - seg <- randomUArrayR (0,n) gen (P.fromIntegral n) - seg' <- convertUArray seg - - -- generate elements - -- - let ne = P.fromIntegral $ P.sum (elems seg) - vec <- randomUArrayR (-1,1) gen ne - vec' <- convertUArray vec - -- - let go f g = return (run_ref f vec seg, run_acc g vec' seg') - case alg of - "sum" -> go prefixSumSegRef prefixSumSegAcc - x -> error $ "unknown variant: " ++ x - where - {-# NOINLINE run_ref #-} - run_ref f xs seg () = f xs seg - run_acc f xs seg () = f xs seg - diff --git a/examples/tests/primitives/Scatter.hs b/examples/tests/primitives/Scatter.hs deleted file mode 100644 --- a/examples/tests/primitives/Scatter.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} - -module Scatter where - -import Random - -import Data.List -import Data.Maybe -import Data.Array.ST -import Control.Monad -import Control.Applicative -import System.Random.MWC -import Data.Array.Unboxed - -import Prelude as P -import Data.Array.Accelerate as Acc hiding ((!)) -import qualified Data.Array.MArray as M -import qualified Data.HashTable.IO as Hash - - --- Tests --- ----- - -scatterAcc :: Vector Int -> Vector Float -> Vector Float -> Acc (Vector Float) -scatterAcc mapV defaultV inputV = Acc.scatter (use mapV) (use defaultV) (use inputV) - -scatterIfAcc :: Vector Int -> Vector Int -> Vector Float -> Vector Float -> Acc (Vector Float) -scatterIfAcc mapV maskV defaultV inputV - = Acc.scatterIf (use mapV) (use maskV) evenAcc (use defaultV) (use inputV) - -evenAcc :: Exp Int -> Exp Bool -evenAcc v = (v `mod` 2) ==* 0 - - -scatterRef :: UArray Int Int -> UArray Int Float -> UArray Int Float -> UArray Int Float -scatterRef mapV defaultV inputV = runSTUArray $ do - mu <- M.thaw defaultV - forM_ (P.zip [0..] $ elems mapV) $ \(inIx, outIx) -> do - writeArray mu outIx (inputV ! inIx) - return mu - -scatterIfRef :: UArray Int Int -> UArray Int Int -> UArray Int Float -> UArray Int Float -> UArray Int Float -scatterIfRef mapV maskV defaultV inputV = runSTUArray $ do - mu <- M.thaw defaultV - forM_ (P.zip [0..] $ elems mapV) $ \(inIx, outIx) -> do - when (evenRef (maskV ! inIx)) $ do - writeArray mu outIx (inputV ! inIx) - return mu - -evenRef :: Int -> Bool -evenRef = even - - --- Random --- ------ - -uniqueRandomUArrayR :: GenIO -> (Int,Int) -> Int -> IO (UArray Int Int) -uniqueRandomUArrayR gen lim n = do - set <- Hash.new :: IO (Hash.BasicHashTable Int ()) - - let go !i !m | i >= n = return m - | otherwise = do - v <- uniformR lim gen - exists <- isJust <$> Hash.lookup set v - if exists - then go (i+1) m - else Hash.insert set v () >> go (i+1) (m+1) - - n' <- go 0 0 - listArray (0, n'-1) . P.map P.fst <$> Hash.toList set - - --- Main --- ---- -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run alg n = withSystemRandom $ \gen -> do - let m = 2 * n - - mapV <- uniqueRandomUArrayR gen (0, m-1) n - mapV' <- convertUArray mapV - let n' = rangeSize (bounds mapV) - - vec <- randomUArrayR (-1, 1) gen n' - vec' <- convertUArray vec - - maskV <- randomUArrayR (0, n') gen n' - maskV' <- convertUArray maskV - - defaultV <- randomUArrayR (-1, 1) gen m - defaultV' <- convertUArray defaultV - - -- - let go f g = return (run_ref f vec, run_acc g vec') - - case alg of - "scatter" -> go (scatterRef mapV defaultV) (scatterAcc mapV' defaultV') - "scatter-if" -> go (scatterIfRef mapV maskV defaultV) (scatterIfAcc mapV' maskV' defaultV') - x -> error $ "unknown variant: " ++ x - - where - {-# NOINLINE run_ref #-} - run_ref f xs () = f xs - run_acc f xs () = f xs - - - diff --git a/examples/tests/primitives/Stencil.hs b/examples/tests/primitives/Stencil.hs deleted file mode 100644 --- a/examples/tests/primitives/Stencil.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Stencil where - -import Util -import Random - -import Control.Exception -import System.Random.MWC - -import Data.Array.Unboxed hiding (Array) -import qualified Data.Array.IArray as IArray - -import Data.Array.Accelerate hiding (min, max, round, fromIntegral) -import qualified Data.Array.Accelerate as Acc - - - --- Stencil Tests --- ------------- - --- 1D -------------------------------------------------------------------------- - -stencil1D :: Floating a - => (a, a, a) -> a -stencil1D (x, y, z) = (x + z - 2 * y) / 2 - -test_stencil1D :: Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -test_stencil1D n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (-1,1) gen n - vec' <- convertUArray vec - return (\() -> run_ref vec, \() -> run_acc vec') - where - run_acc = stencil stencil1D Clamp . use - run_ref v = - let (minx,maxx) = bounds v - clamp x = minx `max` x `min` maxx - - f ix = let x = v IArray.! clamp (ix-1) - y = v IArray.! ix - z = v IArray.! clamp (ix+1) - in - (x + z - 2 * y) / 2 - in - array (bounds v) [(ix, f ix) | ix <- indices v] - - --- 2D -------------------------------------------------------------------------- - -stencil2D :: Floating (Exp a) - => Stencil3x3 a -> Exp a -stencil2D ( (t1, t2, t3) - , (l , m, r ) - , (b1, b2, b3) - ) - = (t1/2 + t2 + t3/2 + l + r + b1/2 + b2 + b3/2 - 4 * m) / 4 - -test_stencil2D :: Int -> IO (() -> IArray.Array (Int,Int) Float, () -> Acc (Array DIM2 Float)) -test_stencil2D n2 = withSystemRandom $ \gen -> do - let n = round . (/3) . sqrt $ (fromIntegral n2 :: Double) - m = n * 4 - mat <- listArray ((0,0),(n-1,m-1)) `fmap` replicateM' (n*m) (uniformR (-1,1) gen) :: IO (IArray.Array (Int,Int) Float) - mat' <- let v = fromIArray mat :: Array DIM2 Float - in evaluate (v `indexArray` (Z:.0:.0)) >> return v - -- - return (\() -> run_ref mat, \() -> run_acc mat') - where - run_acc = stencil stencil2D (Constant 0) . use - run_ref arr = - let get ix - | inRange (bounds arr) ix = arr IArray.! ix - | otherwise = 0 - - f (x,y) = let t1 = get (x-1,y-1) - t2 = get (x, y-1) - t3 = get (x+1,y-1) - l = get (x-1,y) - m = get (x, y) - r = get (x+1,y) - b1 = get (x-1,y+1) - b2 = get (x, y+1) - b3 = get (x+1,y+1) - in - (t1/2 + t2 + t3/2 + l + r + b1/2 + b2 + b3/2 - 4 * m) / 4 - in - array (bounds arr) [(ix, f ix) | ix <- indices arr] - - - -stencil2D5 :: Floating (Exp a) - => Stencil3x3 a -> Exp a -stencil2D5 ( (_, t, _) - , (l, m, r) - , (_, b, _) - ) - = (t + l + r + b - 4 * m) / 4 - -test_stencil2D5 :: Int -> IO (() -> IArray.Array (Int,Int) Float, () -> Acc (Array DIM2 Float)) -test_stencil2D5 n2 = withSystemRandom $ \gen -> do - let n = round . sqrt $ (fromIntegral n2 :: Double) - mat <- listArray ((0,0),(n-1,n-1)) `fmap` replicateM' (n*n) (uniformR (-1,1) gen) :: IO (IArray.Array (Int,Int) Float) - mat' <- let m = fromIArray mat :: Array DIM2 Float - in evaluate (m `indexArray` (Z:.0:.0)) >> return m - -- - return (\() -> run_ref mat, \() -> run_acc mat') - where - run_acc = stencil stencil2D5 Clamp . use - run_ref arr = - let ((minx,miny),(maxx,maxy)) = bounds arr - clamp (x,y) = (minx `max` x `min` maxx - ,miny `max` y `min` maxy) - f (x,y) = let t = arr IArray.! clamp (x,y-1) - b = arr IArray.! clamp (x,y+1) - l = arr IArray.! clamp (x-1,y) - r = arr IArray.! clamp (x+1,y) - m = arr IArray.! (x,y) - in - (t + l + r + b - 4 * m) / 4 - in - array (bounds arr) [(ix, f ix) | ix <- indices arr] - - - -stencil2Dpair :: Stencil3x3 (Int,Float) -> Exp Float -stencil2Dpair ( (_, _, _) - , (x, _, _) - , (y, _, z) - ) - = let (x1,x2) = unlift x :: (Exp Int, Exp Float) - (y1,y2) = unlift y - (z1,z2) = unlift z - in - (x2 * Acc.fromIntegral x1 + y2 * Acc.fromIntegral z1 - z2 * Acc.fromIntegral y1) - -test_stencil2Dpair :: Int -> IO (() -> IArray.Array (Int,Int) Float, () -> Acc (Array DIM2 Float)) -test_stencil2Dpair n2 = withSystemRandom $ \gen -> do - let n = round (fromIntegral n2 ** 0.5 :: Double) - m = 2 * n - mat <- listArray ((0,0),(n-1,m-1)) `fmap` replicateM' (n*m) (uniformR ((-100,0), (100,0)) gen) :: IO (IArray.Array (Int,Int) (Int,Float)) - mat' <- let a = fromIArray mat - in evaluate (a `indexArray` (Z:.0:.0)) >> return a - -- - return (\() -> run_ref mat, \() -> run_acc mat') - where - run_acc = stencil stencil2Dpair Wrap . use - run_ref arr = - let ((minx,miny),(maxx,maxy)) = bounds arr - wrap (m,n) i - | i < m = n + (i-m) - | i > n = i - n + m - | otherwise = i - - get (x,y) = arr IArray.! ( wrap (minx,maxx) x, wrap (miny,maxy) y) - f (x,y) = let (a1,a2) = get (x-1,y) - (b1,b2) = get (x-1,y+1) - (c1,c2) = get (x+1,y+1) - in - (a2 * fromIntegral a1 + b2 * fromIntegral c1 - c2 * fromIntegral b1) - in - array (bounds arr) [(ix, f ix) | ix <- indices arr] - - --- 3D -------------------------------------------------------------------------- - -stencil3D :: Num (Exp a) - => Stencil3x3x3 a -> Exp a -stencil3D (front, back, _) = -- 'b4' is the focal point - let ((f1, f2, _), - (f3, f4, _), - _ ) = front - ((b1, b2, _), - (b3, b4, _), - _ ) = back - in - f1 + f2 + f3 + f4 + b1 + b2 + b3 + b4 - -test_stencil3D :: Int -> IO (() -> UArray (Int,Int,Int) Float, () -> Acc (Array DIM3 Float)) -test_stencil3D n3 = withSystemRandom $ \gen -> do - let u = round (fromIntegral n3 ** (1/3) :: Double) - v = u `div` 2 - w = u * 3 - arr <- listArray ((0,0,0), (u-1, v-1, w-1)) `fmap` replicateM' (u*v*w) (uniformR (-1,1) gen) :: IO (UArray (Int,Int,Int) Float) - arr' <- let a = fromIArray arr - in evaluate (a `indexArray` (Z:.0:.0:.0)) >> return a - -- - return (\() -> run_ref arr, \() -> run_acc arr') - where - run_acc = stencil stencil3D Mirror . use - run_ref arr = - let ((minx,miny,minz),(maxx,maxy,maxz)) = bounds arr - mirror (m,n) i - | i < m = -i + m - | i > n = n - (i-n+2) - | otherwise = i - - get (x,y,z) = arr IArray.! ( mirror (minx,maxx) x, mirror (miny,maxy) y, mirror (minz,maxz) z) - f (x,y,z) = let f1 = get (x-1,y-1,z-1) - f2 = get (x, y-1,z-1) - f3 = get (x-1,y, z-1) - f4 = get (x, y, z-1) - b1 = get (x-1,y-1,z ) - b2 = get (x, y-1,z ) - b3 = get (x-1,y, z ) - b4 = get (x, y, z ) - in - f1 + f2 + f3 + f4 + b1 + b2 + b3 + b4 - in - array (bounds arr) [(ix, f ix) | ix <- indices arr] - - --- Main --- ---- - -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run "1D" = test_stencil1D -run x = error $ "unknown variant: " ++ x - - -run2D :: String -> Int -> IO (() -> IArray.Array (Int,Int) Float, () -> Acc (Array DIM2 Float)) -run2D "2D" = test_stencil2D -run2D "3x3-cross" = test_stencil2D5 -run2D "3x3-pair" = test_stencil2Dpair -run2D x = error $ "unknown variant: " ++ x - - -run3D :: String -> Int -> IO (() -> UArray (Int,Int,Int) Float, () -> Acc (Array DIM3 Float)) -run3D "3D" = test_stencil3D -run3D x = error $ "unknown variant: " ++ x - diff --git a/examples/tests/primitives/Stencil2.hs b/examples/tests/primitives/Stencil2.hs deleted file mode 100644 --- a/examples/tests/primitives/Stencil2.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Stencil2 where - -import Util - -import Control.Exception -import System.Random.MWC -import Data.Array.Unboxed hiding (Array) -import Data.Array.Accelerate hiding (round, min, max, fromIntegral) -import qualified Data.Array.Accelerate as A -import qualified Data.Array.IArray as IArray - - - -stencil2D2 :: Floating (Exp a) => Stencil3x3 a -> Stencil3x3 a -> Exp a -stencil2D2 ((_,t,_), (_,x,_), (_,b,_)) - ((_,_,_), (l,y,r), (_,_,_)) = t + b + l + r - ((x+y) / 2) - - -stencil2D2Ref - :: (Floating a, IArray UArray a) - => UArray (Int,Int) a - -> UArray (Int,Int) a - -> UArray (Int,Int) a -stencil2D2Ref xs ys = array sh [(ix, f ix) | ix <- range sh] - where - (_,(n,m)) = bounds xs - (_,(u,v)) = bounds ys - sh = ((0,0), (n `min` u, m `min` v)) - - -- boundary conditions are placed on the *source* arrays - -- - get1 (x,y) = xs IArray.! (mirror n x, mirror m y) - get0 (x,y) = ys IArray.! (wrap u x, wrap v y) - - mirror sz i - | i < 0 = -i - | i > sz = sz - (i-sz) - | otherwise = i - - wrap sz i - | i < 0 = sz + i + 1 - | i > sz = i - sz - 1 - | otherwise = i - - f (ix,iy) = - let t = get1 (ix-1, iy ) - b = get1 (ix+1, iy ) - x = get1 (ix, iy ) - l = get0 (ix, iy-1) - r = get0 (ix, iy+1) - y = get0 (ix, iy ) - in - t + b + l + r - ((x+y) / 2) - - -test_stencil2_2D :: Int -> IO (() -> UArray (Int,Int) Float, () -> Acc (Array DIM2 Float)) -test_stencil2_2D n2 = withSystemRandom $ \gen -> do - let n = round $ sqrt (fromIntegral n2 :: Double) - m = n * 2 - u = m `div` 3 - v = n + m - m1 <- listArray ((0,0),(n-1,m-1)) `fmap` replicateM' (n*m) (uniformR (-1,1) gen) :: IO (UArray (Int,Int) Float) - m2 <- listArray ((0,0),(u-1,v-1)) `fmap` replicateM' (u*v) (uniformR (-1,1) gen) :: IO (UArray (Int,Int) Float) - m1' <- let m1' = fromIArray m1 in evaluate (m1' `indexArray` (Z:.0:.0)) >> return m1' - m2' <- let m2' = fromIArray m2 in evaluate (m2' `indexArray` (Z:.0:.0)) >> return m2' - -- - return (\() -> run_ref m1 m2, \() -> run_acc m1' m2') - where - run_acc xs ys = stencil2 stencil2D2 Mirror (use xs) Wrap (use ys) - run_ref xs ys = stencil2D2Ref xs ys - - -varUse :: (Acc (Array DIM2 Int), Acc (Array DIM2 Float), Acc (Array DIM2 Float)) -varUse = (first, both, second) - where - is :: Array DIM2 Int - is = fromList (Z:.10:.10) [0..] - - fs :: Array DIM2 Float - fs = fromList (Z:.10:.10) [0..] - - -- Ignoring the first parameter - first = stencil2 centre Clamp (use fs) Clamp (use is) - where - centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Int - centre _ (_,(_,y,_),_) = y - - -- Using both - both = stencil2 centre Clamp (use fs) Clamp (use is) - where - centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Float - centre (_,(_,x,_),_) (_,(_,y,_),_) = x + A.fromIntegral y - - -- Not using the second parameter - second = stencil2 centre Clamp (use fs) Clamp (use is) - where - centre :: Stencil3x3 Float -> Stencil3x3 Int -> Exp Float - centre (_,(_,x,_),_) _ = x - - --- Main --- ---- - -run2D :: String -> Int -> IO (() -> UArray (Int,Int) Float, () -> Acc (Array DIM2 Float)) -run2D "2D" = test_stencil2_2D -run2D x = error $ "unknown variant: " ++ x - diff --git a/examples/tests/primitives/Vector.hs b/examples/tests/primitives/Vector.hs deleted file mode 100644 --- a/examples/tests/primitives/Vector.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Vector where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc - - --- Tests --- ----- - -initAcc, tailAcc :: Vector Float -> Acc (Vector Float) -initAcc = Acc.init . Acc.use -tailAcc = Acc.tail . Acc.use - -takeAcc, dropAcc :: Int -> Vector Float -> Acc (Vector Float) -takeAcc n = (Acc.take $ constant n) . Acc.use -dropAcc n = (Acc.drop $ constant n) . Acc.use - -slitAcc :: Int -> Int -> Vector Float -> Acc (Vector Float) -slitAcc i n = (Acc.slit (constant i) (constant n)) . Acc.use - -toUA :: (IArray UArray a, IArray UArray b) => ([a] -> [b]) -> UArray Int a -> UArray Int b -toUA f xs = listArray (bounds xs) $ f (elems xs) - -initRef, tailRef :: UArray Int Float -> UArray Int Float -initRef = toUA $ Prelude.init -tailRef = toUA $ Prelude.tail - -takeRef, dropRef :: Int -> UArray Int Float -> UArray Int Float -takeRef n = toUA $ Prelude.take n -dropRef n = toUA $ Prelude.drop n - -slitRef :: Int -> Int -> UArray Int Float -> UArray Int Float -slitRef i n = toUA $ (Prelude.take n . Prelude.drop i) - - --- Main --- ---- -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run alg n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (-1,1) gen n - vec' <- convertUArray vec - ri0 <- uniform gen -- ri = random int - ri1 <- uniform gen - - -- - let go f g = return (run_ref f vec, run_acc g vec') - m = (abs ri0) `mod` n - len = (abs ri1) `mod` (n - m) - - case alg of - "init" -> go initRef initAcc - "tail" -> go tailRef tailAcc - "take" -> go (takeRef m) (takeAcc m) - "drop" -> go (dropRef m) (dropAcc m) - "slit" -> go (slitRef m len) (slitAcc m len) - x -> error $ "unknown variant: " ++ x - - where - {-# NOINLINE run_ref #-} - run_ref f xs () = f xs - run_acc f xs () = f xs - diff --git a/examples/tests/primitives/Zip.hs b/examples/tests/primitives/Zip.hs deleted file mode 100644 --- a/examples/tests/primitives/Zip.hs +++ /dev/null @@ -1,35 +0,0 @@ - -module Zip where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed as IArray -import Data.Array.Accelerate as Acc hiding (min) - - --- Tests --- ----- - -zipAcc :: Vector Float -> Vector Int -> Acc (Vector (Float,Int)) -zipAcc xs ys = Acc.zip (use xs) (use ys) - - -zipRef :: UArray Int Float -> UArray Int Int -> IArray.Array Int (Float,Int) -zipRef xs ys = - let mn = bounds xs - uv = bounds ys - newSize = (0, (rangeSize mn `min` rangeSize uv) - 1) - in - listArray newSize $ Prelude.zip (elems xs) (elems ys) - --- Main --- ---- -run :: Int -> IO (() -> IArray.Array Int (Float,Int), () -> Acc (Vector (Float,Int))) -run n = withSystemRandom $ \gen -> do - xs <- randomUArrayR (-1,1) gen n - ys <- randomUArrayR (-1,1) gen n - xs' <- convertUArray xs - ys' <- convertUArray ys - return $ (\() -> zipRef xs ys, \() -> zipAcc xs' ys') - diff --git a/examples/tests/primitives/ZipWith.hs b/examples/tests/primitives/ZipWith.hs deleted file mode 100644 --- a/examples/tests/primitives/ZipWith.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} - -module ZipWith where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc hiding (min) - - --- Tests --- ----- - -plusAcc :: Vector Float -> Vector Float -> Acc (Vector Float) -plusAcc xs ys = Acc.zipWith (+) (use xs) (use ys) - -plusRef :: UArray Int Float -> UArray Int Float -> UArray Int Float -plusRef = zipWithRef (+) - -zipWithRef :: (IArray array a, IArray array b, IArray array c) - => (a -> b -> c) -> array Int a -> array Int b -> array Int c -zipWithRef f xs ys = - let mn = bounds xs - uv = bounds ys - newSize = (0, (rangeSize mn `min` rangeSize uv) - 1) - in - listArray newSize [f x y | x <- elems xs | y <- elems ys] - --- Main --- ---- -run :: String -> Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run alg n = withSystemRandom $ \gen -> do - xs <- randomUArrayR (-1,1) gen n - ys <- randomUArrayR (-1,1) gen n - xs' <- convertUArray xs - ys' <- convertUArray ys - let go f g = return (\() -> f xs ys, \() -> g xs' ys') - case alg of - "plus" -> go plusRef plusAcc - _ -> error $ "unknown variant: " ++ alg - diff --git a/examples/tests/simple/BlackScholes.hs b/examples/tests/simple/BlackScholes.hs deleted file mode 100644 --- a/examples/tests/simple/BlackScholes.hs +++ /dev/null @@ -1,88 +0,0 @@ - -module BlackScholes where - -import Random - -import System.Random.MWC -import Data.Array.IArray as IArray -import Data.Array.Accelerate as Acc -import Prelude as P - - -riskfree, volatility :: Float -riskfree = 0.02 -volatility = 0.30 - --- Black-Scholes option pricing -------------------------------- - -horner :: Num a => [a] -> a -> a -horner coeff x = x * foldr1 madd coeff - where - madd a b = a + x*b - -cnd' :: Floating a => a -> a -cnd' d = - let poly = horner coeff - coeff = [0.31938153,-0.356563782,1.781477937,-1.821255978,1.330274429] - rsqrt2pi = 0.39894228040143267793994605993438 - k = 1.0 / (1.0 + 0.2316419 * abs d) - in - rsqrt2pi * exp (-0.5*d*d) * poly k - - -blackscholesAcc :: Vector (Float, Float, Float) -> Acc (Vector (Float, Float)) -blackscholesAcc xs = Acc.map go (Acc.use xs) - where - go x = - let (price, strike, years) = Acc.unlift x - r = Acc.constant riskfree - v = Acc.constant volatility - v_sqrtT = v * sqrt years - d1 = (log (price / strike) + (r + 0.5 * v * v) * years) / v_sqrtT - d2 = d1 - v_sqrtT - cnd d = let c = cnd' d in d >* 0 ? (1.0 - c, c) - cndD1 = cnd d1 - cndD2 = cnd d2 - x_expRT = strike * exp (-r * years) - in - Acc.lift ( price * cndD1 - x_expRT * cndD2 - , x_expRT * (1.0 - cndD2) - price * (1.0 - cndD1)) - - -blackscholesRef :: IArray.Array Int (Float,Float,Float) -> IArray.Array Int (Float,Float) -blackscholesRef xs = listArray (bounds xs) [ go x | x <- elems xs ] - where - go (price, strike, years) = - let r = riskfree - v = volatility - sqrtT = sqrt years - d1 = (log (price / strike) + (r + 0.5 * v * v) * years) / (v * sqrtT) - d2 = d1 - v * sqrtT - cnd d = if d > 0 then 1.0 - cnd' d else cnd' d - cndD1 = cnd d1 - cndD2 = cnd d2 - expRT = exp (-r * years) - in - ( price * cndD1 - strike * expRT * cndD2 - , strike * expRT * (1.0 - cndD2) - price * (1.0 - cndD1)) - - --- Main --- ---- - -run :: Int -> IO (() -> IArray.Array Int (Float,Float), () -> Acc (Vector (Float,Float))) -run n = withSystemRandom $ \gen -> do - v_sp <- randomUArrayR (5,30) gen n - v_os <- randomUArrayR (1,100) gen n - v_oy <- randomUArrayR (0.25,10) gen n - - let v_psy = listArray (0,n-1) $ P.zip3 (elems v_sp) (elems v_os) (elems v_oy) - a_psy = Acc.fromIArray v_psy - -- - return (run_ref v_psy, run_acc a_psy) - where - {-# NOINLINE run_ref #-} - run_ref psy () = blackscholesRef psy - run_acc psy () = blackscholesAcc psy - diff --git a/examples/tests/simple/DotP.hs b/examples/tests/simple/DotP.hs deleted file mode 100644 --- a/examples/tests/simple/DotP.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} - -module DotP where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc -import Prelude as P - - --- Dot product --- ----------- -dotpAcc :: Vector Float -> Vector Float -> Acc (Scalar Float) -dotpAcc xs ys - = let - xs' = use xs - ys' = use ys - in - Acc.fold (+) 0 (Acc.zipWith (*) xs' ys') - -dotpRef :: UArray Int Float - -> UArray Int Float - -> UArray () Float -dotpRef xs ys - = listArray ((), ()) [P.sum [x * y | x <- elems xs | y <- elems ys]] - - --- Main --- ---- - -run :: Int -> IO (() -> UArray () Float, () -> Acc (Scalar Float)) -run n = withSystemRandom $ \gen -> do - v1 <- randomUArrayR (-1,1) gen n - v2 <- randomUArrayR (-1,1) gen n - v1' <- convertUArray v1 - v2' <- convertUArray v2 - -- - return (run_ref v1 v2, run_acc v1' v2') - where - {-# NOINLINE run_ref #-} - run_ref xs ys () = dotpRef xs ys - run_acc xs ys () = dotpAcc xs ys - diff --git a/examples/tests/simple/Filter.hs b/examples/tests/simple/Filter.hs deleted file mode 100644 --- a/examples/tests/simple/Filter.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Filter where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed (IArray, UArray, elems, listArray) -import Data.Array.Accelerate as Acc - - --- Filter --- ------ -filterAcc :: Elt a => (Exp a -> Exp Bool) -> Vector a -> Acc (Vector a) -filterAcc p vec = Acc.filter p (use vec) - - -filterRef :: IArray UArray e => (e -> Bool) -> UArray Int e -> UArray Int e -filterRef p xs - = let xs' = Prelude.filter p (elems xs) - in - listArray (0, Prelude.length xs' - 1) xs' - - --- Main --- ---- - -run :: Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (-1,1) gen n - vec' <- convertUArray vec - -- - return (run_ref vec, run_acc vec') - where - {-# NOINLINE run_ref #-} - run_ref xs () = filterRef (> 0) xs - run_acc xs () = filterAcc (>*0) xs - diff --git a/examples/tests/simple/Radix.hs b/examples/tests/simple/Radix.hs deleted file mode 100644 --- a/examples/tests/simple/Radix.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} --- --- Radix sort for a subclass of element types --- - -module Radix where - -import Random - -import Prelude as P -import Data.Array.Accelerate as A - -import Data.Bits -import Data.List ( sort ) -import Data.Array.Unboxed ( IArray, UArray, listArray, bounds, elems ) -import System.Random.MWC - - --- Radix sort --- ---------- - -class Elt e => Radix e where - passes :: e {- dummy -} -> Int - radix :: Exp Int -> Exp e -> Exp Int - -instance Radix Int32 where - passes = bitSize - radix i e = i ==* (passes' - 1) ? (radix' (e `xor` minBound), radix' e) - where - radix' x = A.fromIntegral $ (x `A.shiftR` i) .&. 1 - passes' = constant (passes (undefined :: Int32)) - --- For IEEE-754 floating-point representation. Unsafe, but widely supported. --- TLM: unsafeCoerce does not work in the CUDA backend. --- --- instance Radix Float where --- passes _ = 32 --- radix i e = let x = (unsafeCoerce e :: Exp Int32) --- in i ==* 31 ? (radix' (x `xor` minBound), radix' (floatFlip x)) --- where --- floatFlip x = x `testBit` 31 ? (complement x, x) -- twos-complement negative numbers --- radix' x = x `testBit` i ? (1,0) - --- --- A simple (parallel) radix sort implementation [1]. --- --- [1] G. E. Blelloch. "Prefix sums and their applications." Technical Report --- CMU-CS-90-190. Carnegie Mellon University. 1990. --- -sortAcc :: Radix a => Acc (Vector a) -> Acc (Vector a) -sortAcc = sortAccBy id - -sortAccBy - :: forall a r. (Elt a, Radix r) - => (Exp a -> Exp r) - -> Acc (Vector a) - -> Acc (Vector a) -sortAccBy rdx arr = foldr1 (>->) (P.map radixPass [0..p-1]) arr - where - p = passes (undefined :: r) - -- - deal f x = let (a,b) = unlift x in (f ==* 0) ? (a,b) - radixPass k v = let k' = unit (constant k) - flags = A.map (radix (the k') . rdx) v - idown = prescanl (+) 0 . A.map (xor 1) $ flags - iup = A.map (size v - 1 -) . prescanr (+) 0 $ flags - index = A.zipWith deal flags (A.zip idown iup) - in - permute const v (\ix -> index1 (index!ix)) v - - -sortRef :: (Ord a, IArray UArray a) => UArray Int a -> UArray Int a -sortRef xs = listArray (bounds xs) $ sort (elems xs) - - --- Main --- ---- - -run :: Int -> IO (() -> UArray Int Int32, () -> Acc (Vector Int32)) -run n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (minBound,maxBound) gen n - vec' <- use `fmap` convertUArray vec - -- - return (run_ref vec, run_acc vec') - where - {-# NOINLINE run_ref #-} - run_ref xs () = sortRef xs - run_acc xs () = sortAcc xs - diff --git a/examples/tests/simple/SASUM.hs b/examples/tests/simple/SASUM.hs deleted file mode 100644 --- a/examples/tests/simple/SASUM.hs +++ /dev/null @@ -1,35 +0,0 @@ - -module SASUM where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc - - --- Sum of absolute values --- ---------------------- -sasumAcc :: Vector Float -> Acc (Scalar Float) -sasumAcc xs - = Acc.fold (+) 0 . Acc.map abs $ Acc.use xs - -sasumRef :: UArray Int Float -> UArray () Float -sasumRef xs - = listArray ((), ()) [Prelude.sum . Prelude.map abs $ elems xs] - - --- Main --- ---- - -run :: Int -> IO (() -> UArray () Float, () -> Acc (Scalar Float)) -run n = withSystemRandom $ \gen -> do - vec <- randomUArrayR (-1,1) gen n - vec' <- convertUArray vec - -- - return (run_ref vec, run_acc vec') - where - {-# NOINLINE run_ref #-} - run_ref xs () = sasumRef xs - run_acc xs () = sasumAcc xs - diff --git a/examples/tests/simple/SAXPY.hs b/examples/tests/simple/SAXPY.hs deleted file mode 100644 --- a/examples/tests/simple/SAXPY.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} - -module SAXPY where - -import Random - -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate as Acc - --- SAXPY --- ----- -saxpyAcc :: Float -> Vector Float -> Vector Float -> Acc (Vector Float) -saxpyAcc alpha xs ys - = let - xs' = use xs - ys' = use ys - in - Acc.zipWith (\x y -> constant alpha * x + y) xs' ys' - -saxpyRef :: Float -> UArray Int Float -> UArray Int Float -> UArray Int Float -saxpyRef alpha xs ys - = listArray (bounds xs) [alpha * x + y | x <- elems xs | y <- elems ys] - - --- Main --- ---- - -run :: Int -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run nelements = withSystemRandom $ \gen -> do - v1 <- randomUArrayR (-1,1) gen nelements - v2 <- randomUArrayR (-1,1) gen nelements - v1' <- convertUArray v1 - v2' <- convertUArray v2 - alpha <- uniform gen - -- - return (run_ref alpha v1 v2, run_acc alpha v1' v2') - where - {-# NOINLINE run_ref #-} - run_ref alpha xs ys () = saxpyRef alpha xs ys - run_acc alpha xs ys () = saxpyAcc alpha xs ys - diff --git a/examples/tests/simple/SMVM.hs b/examples/tests/simple/SMVM.hs deleted file mode 100644 --- a/examples/tests/simple/SMVM.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module SMVM where - -import Random -import SMVM.Matrix - -import System.Random.MWC -import Data.Array.Unboxed -import Data.Array.Accelerate (Vector, Segments, Acc) -import qualified Data.Array.Accelerate as Acc -import qualified Data.Vector.Unboxed as V - - --- Sparse-matrix vector multiplication --- ----------------------------------- - -type SparseVector a = (Vector Int, Vector a) -type SparseMatrix a = (Segments Int, SparseVector a) - -smvmAcc :: SparseMatrix Float -> Vector Float -> Acc (Vector Float) -smvmAcc (segd', (inds', vals')) vec' - = let - segd = Acc.use segd' - inds = Acc.use inds' - vals = Acc.use vals' - vec = Acc.use vec' - --- - vecVals = Acc.backpermute (Acc.shape inds) (\i -> Acc.index1 $ inds Acc.! i) vec - products = Acc.zipWith (*) vecVals vals - in - Acc.foldSeg (+) 0 products segd - - --- The reference version will be slow, with many conversions between --- array/vector/list representations. This will likely skew heap usage --- calculations, but oh well... --- -type USparseMatrix a = (UArray Int Int, (UArray Int Int, UArray Int a)) - -smvmRef :: USparseMatrix Float -> UArray Int Float -> UArray Int Float -smvmRef (segd, (inds, values)) vec - = listArray (0, rangeSize (bounds segd) - 1) - [sum [ values!i * vec!(inds!i) | i <- range seg] | seg <- segd' ] - where - segbegin = scanl (+) 0 $ elems segd - segend = scanl1 (+) $ elems segd - segd' = zipWith (\x y -> (x,y-1)) segbegin segend - - --- Main --- ---- - -run :: Maybe FilePath -> IO (() -> UArray Int Float, () -> Acc (Vector Float)) -run f = withSystemRandom $ \gen -> do - -- sparse-matrix - (segd', smat') <- maybe (randomCSRMatrix gen 512 512) (readCSRMatrix gen) f - let (ind',val') = V.unzip smat' - - segd <- convertVector segd' - ind <- convertVector ind' - val <- convertVector val' - let smat = (segd, (ind,val)) - - -- vector - vec' <- uniformVector gen (V.length segd') - vec <- convertVector vec' - - -- multiply! - return (run_ref (v2a segd', (v2a ind',v2a val')) (v2a vec'), run_acc smat vec) - where - {-# NOINLINE run_ref #-} - run_ref smat vec () = smvmRef smat vec - run_acc smat vec () = smvmAcc smat vec - -- - v2a :: (V.Unbox a, IArray UArray a) => V.Vector a -> UArray Int a - v2a vec = listArray (0, V.length vec - 1) $ V.toList vec - diff --git a/examples/tests/simple/SMVM/Matrix.hs b/examples/tests/simple/SMVM/Matrix.hs deleted file mode 100644 --- a/examples/tests/simple/SMVM/Matrix.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE BangPatterns, TupleSections #-} - -module SMVM.Matrix (readCSRMatrix, randomCSRMatrix) where - -import Random -import SMVM.MatrixMarket -import System.Random.MWC -import System.IO.Unsafe - -import Data.Vector.Unboxed (Vector) -import qualified Data.Vector.Unboxed as V -import qualified Data.Vector.Unboxed.Mutable as M -import qualified Data.Vector.Algorithms.Intro as V - -type CSRMatrix a = (Vector Int, Vector (Int,a)) - - --- Read a sparse matrix from a MatrixMarket file. Pattern matrices are filled --- with random numbers in the range (-1,1). --- -{-# INLINE readCSRMatrix #-} -readCSRMatrix :: GenIO -> FilePath -> IO (CSRMatrix Float) -readCSRMatrix gen file = do - mtx <- readMatrix file - case mtx of - (RealMatrix dim l vals) -> csr dim l vals - (PatternMatrix dim l ix) -> csr dim l =<< mapM' (\(a,b) -> (a,b,) `fmap` uniformR (-1,1) gen) ix - (IntMatrix _ _ _) -> error "IntMatrix type not supported" - (ComplexMatrix _ _ _) -> error "ComplexMatrix type not supported" - - --- A randomly generated matrix of given size --- -{-# INLINE randomCSRMatrix #-} -randomCSRMatrix :: GenIO -> Int -> Int -> IO (CSRMatrix Float) -randomCSRMatrix gen rows cols = do - segd <- randomVectorR ( 0,cols`div`3) gen rows - let nnz = V.sum segd - inds <- randomVectorR ( 0,cols-1) gen nnz - vals <- randomVectorR (-1,1) gen nnz - return (segd, V.zip inds vals) - - --- Read elements into unboxed arrays, convert to zero-indexed compress sparse --- row format. --- -{-# INLINE csr #-} -csr :: (Int,Int) -> Int -> [(Int,Int,Float)] -> IO (Vector Int, Vector (Int,Float)) -csr (m,_) l elems = do - mu <- M.new l - let goe _ [] = return () - goe !n (x:xs) = let (i,j,v) = x in M.unsafeWrite mu n (i-1,j-1,v) >> goe (n+1) xs - goe 0 elems - - let cmp (x1,y1,_) (x2,y2,_) | x1 == x2 = compare y1 y2 - | otherwise = compare x1 x2 - V.sortBy cmp mu - - (i,j,v) <- V.unzip3 `fmap` V.unsafeFreeze mu - mseg <- M.new m - let gos !n rows | n < m = let (s,ss) = V.span (==n) rows in M.unsafeWrite mseg n (V.length s) >> gos (n+1) ss - | otherwise = V.unsafeFreeze mseg - seg <- gos 0 i - return (seg , V.zip j v) - - --- Lazier versions of things in Control.Monad --- -sequence' :: [IO a] -> IO [a] -sequence' ms = foldr k (return []) ms - where k m m' = do { x <- m; xs <- unsafeInterleaveIO m'; return (x:xs) } - -mapM' :: (a -> IO b) -> [a] -> IO [b] -mapM' f as = sequence' (map f as) - diff --git a/examples/tests/simple/SMVM/MatrixMarket.hs b/examples/tests/simple/SMVM/MatrixMarket.hs deleted file mode 100644 --- a/examples/tests/simple/SMVM/MatrixMarket.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE OverloadedStrings, GADTs, StandaloneDeriving #-} - -module SMVM.MatrixMarket (Matrix(..), readMatrix) where - -import Control.Applicative hiding ( many ) - -import Data.Complex -import Data.Attoparsec.Char8 -import Data.ByteString.Lex.Double -import qualified Data.Attoparsec.Lazy as L -import qualified Data.ByteString.Lazy as L - - --- | Specifies the element type. Pattern matrices do not have any elements, --- only indices, and only make sense for coordinate matrices and vectors. --- -data Field = Real | Complex | Integer | Pattern - deriving (Eq, Show) - --- | Specifies either sparse or dense storage. In sparse (\"coordinate\") --- storage, elements are given in (i,j,x) triplets for matrices (or (i,x) for --- vectors). Indices are 1-based, so that A(1,1) is the first element of a --- matrix, and x(1) is the first element of a vector. --- --- In dense (\"array\") storage, elements are given in column-major order. --- --- In both cases, each element is given on a separate line. --- -data Format = Coordinate | Array - deriving (Eq, Show) - --- | Specifies any special structure in the matrix. For symmetric and hermition --- matrices, only the lower-triangular part of the matrix is given. For skew --- matrices, only the entries below the diagonal are stored. --- -data Structure = General | Symmetric | Hermitian | Skew - deriving (Eq, Show) - - --- We really want a type parameter to Matrix, but I think that requires some --- kind of dynamic typing so that we can determine (a ~ Integral) or (a ~ --- RealFloat), and so forth, depending on the file being read. This will do for --- our purposes... --- --- Format is: (rows,columns) nnz [(row,column,value)] --- -data Matrix where - PatternMatrix :: (Int,Int) -> Int -> [(Int,Int)] -> Matrix - IntMatrix :: (Int,Int) -> Int -> [(Int,Int,Int)] -> Matrix - RealMatrix :: (Int,Int) -> Int -> [(Int,Int,Float)] -> Matrix - ComplexMatrix :: (Int,Int) -> Int -> [(Int,Int,Complex Float)] -> Matrix - -deriving instance Show Matrix - - --------------------------------------------------------------------------------- --- Combinators --------------------------------------------------------------------------------- - -comment :: Parser () -comment = char '%' *> skipWhile (not . eol) *> endOfLine - where eol w = w `elem` "\n\r" - -floating :: Fractional a => Parser a -floating = do - mv <- readDouble <$> (skipSpace *> takeTill isSpace) -- readDouble does the fancy stuff - case mv of - Just (v,_) -> return . realToFrac $ v - Nothing -> fail "floating-point number" - -integral :: Integral a => Parser a -integral = skipSpace *> decimal - -format :: Parser Format -format = string "coordinate" *> pure Coordinate - <|> string "array" *> pure Array - "matrix format" - -field :: Parser Field -field = string "real" *> pure Real - <|> string "complex" *> pure Complex - <|> string "integer" *> pure Integer - <|> string "pattern" *> pure Pattern - "matrix field" - -structure :: Parser Structure -structure = string "general" *> pure General - <|> string "symmetric" *> pure Symmetric - <|> string "hermitian" *> pure Hermitian - <|> string "skew-symmetric" *> pure Skew - "matrix structure" - -header :: Parser (Format,Field,Structure) -header = string "%%MatrixMarket matrix" - >> (,,) <$> (skipSpace *> format) - <*> (skipSpace *> field) - <*> (skipSpace *> structure) - <* endOfLine - "MatrixMarket header" - -extent :: Parser (Int,Int,Int) -extent = do - [m,n,l] <- skipWhile isSpace *> count 3 integral <* endOfLine - return (m,n,l) - -line :: Parser a -> Parser (Int,Int,a) -line f = (,,) <$> integral - <*> integral - <*> f - <* endOfLine - --------------------------------------------------------------------------------- --- Matrix Market --------------------------------------------------------------------------------- - -matrix :: Parser Matrix -matrix = do - (_,t,_) <- header - (m,n,l) <- skipMany comment *> extent - case t of - Real -> RealMatrix (m,n) l `fmap` many1 (line floating) - Complex -> ComplexMatrix (m,n) l `fmap` many1 (line ((:+) <$> floating <*> floating)) - Integer -> IntMatrix (m,n) l `fmap` many1 (line integral) - Pattern -> PatternMatrix (m,n) l `fmap` many1 ((,) <$> integral <*> integral) - - -readMatrix :: FilePath -> IO Matrix -readMatrix file = do - chunks <- L.readFile file - case L.parse matrix chunks of - L.Fail _ _ msg -> error $ file ++ ": " ++ msg - L.Done _ mtx -> return mtx - diff --git a/examples/tests/simple/SharingRecovery.hs b/examples/tests/simple/SharingRecovery.hs deleted file mode 100644 --- a/examples/tests/simple/SharingRecovery.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE TypeOperators, ScopedTypeVariables #-} - - --- --- Some tests to make sure that sharing recovery is working. --- -module SharingRecovery where - -import Prelude hiding (zip3) - -import Data.Array.Accelerate as Acc - - -mkArray :: Int -> Acc (Array DIM1 Int) -mkArray n = use $ fromList (Z:.1) [n] - -muchSharing :: Int -> Acc (Array DIM1 Int) -muchSharing 0 = (mkArray 0) -muchSharing n = Acc.map (\_ -> newArr ! (lift (Z:.(0::Int))) + - newArr ! (lift (Z:.(1::Int)))) (mkArray n) - where - newArr = muchSharing (n-1) - -idx :: Int -> Exp DIM1 -idx i = lift (Z:.i) - -bfsFail :: Acc (Array DIM1 Int) -bfsFail = Acc.map (\x -> (map2 ! (idx 1)) + (map1 ! (idx 2)) + x) arr - where - map1 :: Acc (Array DIM1 Int) - map1 = Acc.map (\y -> (map2 ! (idx 3)) + y) arr - map2 :: Acc (Array DIM1 Int) - map2 = Acc.map (\z -> z + 1) arr - arr :: Acc (Array DIM1 Int) - arr = mkArray 666 - -twoLetsSameLevel :: Acc (Array DIM1 Int) -twoLetsSameLevel = - let arr1 = mkArray 1 - in let arr2 = mkArray 2 - in Acc.map (\_ -> arr1!(idx 1) + arr1!(idx 2) + arr2!(idx 3) + arr2!(idx 4)) (mkArray 3) - -twoLetsSameLevel2 :: Acc (Array DIM1 Int) -twoLetsSameLevel2 = - let arr2 = mkArray 2 - in let arr1 = mkArray 1 - in Acc.map (\_ -> arr1!(idx 1) + arr1!(idx 2) + arr2!(idx 3) + arr2!(idx 4)) (mkArray 3) - --- --- These two programs test that lets can be introduced not just at the top of a AST --- but in intermediate nodes. --- -noLetAtTop :: Acc (Array DIM1 Int) -noLetAtTop = Acc.map (\x -> x + 1) bfsFail - -noLetAtTop2 :: Acc (Array DIM1 Int) -noLetAtTop2 = Acc.map (\x -> x + 2) $ Acc.map (\x -> x + 1) bfsFail - --- --- --- -simple :: Acc (Array DIM1 (Int,Int)) -simple = Acc.map (\_ -> a ! (idx 1)) d - where - c = use $ Acc.fromList (Z :. 3) [1..] - d = Acc.map (+1) c - a = Acc.zip d c - --------------------------------------------------------------------------------- --- --- sortKey is a real program that Ben Lever wrote. It has some pretty interesting --- sharing going on. --- -sortKey :: (Elt e) - => (Exp e -> Exp Int) -- ^mapping function to produce key array from input array - -> Acc (Vector e) - -> Acc (Vector e) -sortKey keyFun arr = foldl sortOneBit arr (Prelude.map lift ([0..31] :: [Int])) - where - sortOneBit inArr bitNum = outArr - where - keys = Acc.map keyFun inArr - - bits = Acc.map (\a -> (Acc.testBit a bitNum) ? (1, 0)) keys - bitsInv = Acc.map (\b -> (b ==* 0) ? (1, 0)) bits - - (falses, numZeroes) = Acc.scanl' (+) 0 bitsInv - trues = Acc.map (\x -> (Acc.the numZeroes) + (Acc.fst x) - (Acc.snd x)) $ - Acc.zip ixs falses - - dstIxs = Acc.map (\x -> let (b, t, f) = unlift x in (b ==* (constant (0::Int))) ? (f, t)) $ - zip3 bits trues falses - outArr = scatter dstIxs inArr inArr -- just use input as default array - --(we're writing over everything anyway) - -- - ixs = enumeratedArray (shape arr) - --- | Create an array where each element is the value of its corresponding row-major --- index. --- ---enumeratedArray :: (Shape sh) => Exp sh -> Acc (Array sh Int) ---enumeratedArray sh = Acc.reshape sh --- $ Acc.generate (index1 $ shapeSize sh) unindex1 - -enumeratedArray :: Exp DIM1 -> Acc (Array DIM1 Int) -enumeratedArray sh = Acc.generate sh unindex1 - -testSort :: Acc (Vector Int) -testSort = sortKey id $ use $ fromList (Z:.10) [9,8,7,6,5,4,3,2,1,0] - ----------------------------------------------------------------------- - --- --- map1 has children map3 and map2. --- map2 has child map3. --- Back when we still used a list for the NodeCounts data structure this mean that --- you would be merging [1,3,2] with [2,3] which violated precondition of (+++). --- This tests that the new algorithm works just fine on this. --- -orderFail :: Acc (Array DIM1 Int) -orderFail = Acc.map (\_ -> map1 ! (idx 1) + map2 ! (idx 1)) arr - where - map1 = Acc.map (\_ -> map3 ! (idx 1) + map2 ! (idx 2)) arr - map2 = Acc.map (\_ -> map3 ! (idx 3)) arr - map3 = Acc.map (+1) arr - arr = mkArray 42 - ----------------------------------------------------------------------- - --- Tests array-valued lambdas in conjunction with sharing recovery. --- -pipe :: Acc (Vector Int) -pipe = (acc1 >-> acc2) xs - where - z :: Acc (Scalar Int) - z = unit 0 - - xs :: Acc (Vector Int) - xs = use $ fromList (Z:.10) [0..] - - acc1 :: Acc (Vector Int) -> Acc (Vector Int) - acc1 = Acc.map (\_ -> the z) - - acc2 :: Acc (Vector Int) -> Acc (Vector Int) - acc2 arr = let arr2 = use $ fromList (Z:.10) [10..] in Acc.map (\_ -> arr2!constant (Z:.(0::Int))) (Acc.zip arr arr2) diff --git a/examples/tests/simple/SliceExamples.hs b/examples/tests/simple/SliceExamples.hs deleted file mode 100644 --- a/examples/tests/simple/SliceExamples.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE TypeOperators, ScopedTypeVariables #-} -module SliceExamples where - -import Data.Array.Accelerate as Acc -import qualified Data.Array.Unboxed as UA - --- y --- ^ --- | 3 4 --- | 1 2 --- -------> x --- -arr :: Acc (Array DIM2 Int) -arr = use $ fromList (Z:.2:.2) [1,2,3,4] - -slice1 :: Exp (Z:.Int:.All:.All) -slice1 = lift $ Z:.(2::Int):.All:.All - -slice2 :: Exp (Z:.All:.Int:.All) -slice2 = lift $ Z:.All:.(2::Int):.All - -slice3 :: Exp (Z:.All:.All:.Int) -slice3 = lift $ Z:.All:.All:.(2::Int) - --- Replicate into z-axis --- should produce [1,2,3,4,1,2,3,4] -test1 :: Acc (Array DIM3 Int) -test1 = Acc.replicate slice1 arr - --- Replicate into y-axis --- should produce [1,2,1,2,3,4,3,4] -test2 :: Acc (Array DIM3 Int) -test2 = Acc.replicate slice2 arr - --- Replicate into x-axis --- should produce [1,1,2,2,3,3,4,4] -test3 :: Acc (Array DIM3 Int) -test3 = Acc.replicate slice3 arr - --- --- repN. Replicates an array into the rightmost dimension of --- the result array. --- -repN :: forall sh e. (Shape sh, Elt e) - => Int - -> Acc (Array sh e) - -> Acc (Array (sh:.Int) e) -repN n a = Acc.replicate (lift (Any:.n :: Any sh:.Int)) a - -repExample :: Acc (Array DIM2 Int) -> Acc (Array DIM3 Int) -repExample = repN 2 - -repExample' :: Acc (Array DIM2 Int) -> Acc (Array DIM3 Int) -repExample' = Acc.replicate (lift (Z:.All:.All:.(2::Int))) - -slice1' :: Any (Z:.Int:.Int) :. Int -slice1' = Any:.2 - -slice2' :: Z:.All:.All:.Int -slice2' = Z:.All:.All:.2 - -run1 :: IO (() -> UA.UArray (Int,Int,Int) Int, () -> Acc (Array DIM3 Int)) -run1 = return (\() -> UA.array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) - , ((0,0,1), 2) - , ((0,1,0), 3) - , ((0,1,1), 4) - , ((1,0,0), 1) - , ((1,0,1), 2) - , ((1,1,0), 3) - , ((1,1,1), 4) ] - ,\() -> test1) - - -run2 :: IO (() -> UA.UArray (Int,Int,Int) Int, () -> Acc (Array DIM3 Int)) -run2 = return (\() -> UA.array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) - , ((0,0,1), 2) - , ((0,1,0), 1) - , ((0,1,1), 2) - , ((1,0,0), 3) - , ((1,0,1), 4) - , ((1,1,0), 3) - , ((1,1,1), 4) ] - ,\() -> test2) - -run3 :: IO (() -> UA.UArray (Int,Int,Int) Int, () -> Acc (Array DIM3 Int)) -run3 = return (\() -> UA.array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) - , ((0,0,1), 1) - , ((0,1,0), 2) - , ((0,1,1), 2) - , ((1,0,0), 3) - , ((1,0,1), 3) - , ((1,1,0), 4) - , ((1,1,1), 4) ] - ,\() -> test3) -run4 :: IO (() -> UA.UArray (Int,Int,Int) Int, () -> Acc (Array DIM3 Int)) -run4 = return (\() -> UA.array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) - , ((0,0,1), 1) - , ((0,1,0), 2) - , ((0,1,1), 2) - , ((1,0,0), 3) - , ((1,0,1), 3) - , ((1,1,0), 4) - , ((1,1,1), 4) ] - ,\() -> repExample arr) - -run5 :: IO (() -> UA.UArray (Int,Int,Int) Int, () -> Acc (Array DIM3 Int)) -run5 = return (\() -> UA.array ((0,0,0),(1,1,1)) [ ((0,0,0), 1) - , ((0,0,1), 1) - , ((0,1,0), 2) - , ((0,1,1), 2) - , ((1,0,0), 3) - , ((1,0,1), 3) - , ((1,1,0), 4) - , ((1,1,1), 4) ] - ,\() -> repExample' arr) diff --git a/lib/Monitoring.hs b/lib/Monitoring.hs new file mode 100644 --- /dev/null +++ b/lib/Monitoring.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Monitoring where + +#ifdef ACCELERATE_ENABLE_EKG +import Control.Monad +import System.Remote.Monitoring +#endif + + +beginMonitoring :: IO () +#ifdef ACCELERATE_ENABLE_EKG +beginMonitoring = do + putStrLn "EKG monitor started at: http://localhost:8000\n" + void $ forkServer "localhost" 8000 +#else +beginMonitoring = return () +#endif + diff --git a/lib/ParseArgs.hs b/lib/ParseArgs.hs --- a/lib/ParseArgs.hs +++ b/lib/ParseArgs.hs @@ -5,7 +5,7 @@ module ParseArgs ( - Backend(..), parseArgs, run, run1, + module ParseArgs, module System.Console.GetOpt, ) where @@ -19,6 +19,7 @@ import qualified Criterion.Config as Criterion import Data.Array.Accelerate ( Arrays, Acc ) +import qualified Data.Array.Accelerate as A import qualified Data.Array.Accelerate.Interpreter as Interp #ifdef ACCELERATE_CUDA_BACKEND import qualified Data.Array.Accelerate.CUDA as CUDA @@ -40,8 +41,13 @@ run1 CUDA f = CUDA.run1 f #endif +run2 :: (Arrays a, Arrays b, Arrays c) => Backend -> (Acc a -> Acc b -> Acc c) -> a -> b -> c +run2 backend f x y = run1 backend (A.uncurry f) (x,y) --- | The set of backends available to execute the program + +-- | The set of backends available to execute the program. The example programs +-- all choose 'maxBound' as the default, so there should be some honesty in +-- how this list is sorted. -- data Backend = Interpreter #ifdef ACCELERATE_CUDA_BACKEND @@ -92,6 +98,18 @@ body = "Available backends:" : table +-- | Strip the short option arguments that have a required or optional argument. +-- Because we use several different options groups, the flag and its argument +-- get separated. The user is required to instead use a --flag=value format. +-- +stripShortOpts :: [OptDescr a] -> [OptDescr a] +stripShortOpts = map strip + where + strip (Option _ long arg@(ReqArg _ _) desc) = Option [] long arg desc + strip (Option _ long arg@(OptArg _ _) desc) = Option [] long arg desc + strip x = x + + -- | Process the command line arguments and return a tuple consisting of the -- options structure, options for Criterion, and a list of unrecognised and -- non-options. @@ -108,20 +126,31 @@ -> IO (config, Criterion.Config, [String]) parseArgs help backend (withBackends backend -> options) config header footer (takeWhile (/= "--") -> argv) = let + criterionOptions = stripShortOpts Criterion.defaultOptions + helpMsg err = concat err ++ usageInfo (unlines header) options - ++ usageInfo "\nGeneric criterion options:" Criterion.defaultOptions + ++ usageInfo "\nGeneric criterion options:" criterionOptions - in case getOpt' Permute options argv of - (o,n,u,[]) -> do + in do - -- pass unrecognised options to criterion - (cconf, n') <- Criterion.parseArgs Criterion.defaultConfig Criterion.defaultOptions u + -- Process options for the main program. Any non-options will be split out + -- here. Unrecognised options get passed to criterion. + -- + (conf,non,u) <- case getOpt' Permute options argv of + (opts,n,u,[]) -> case foldr id config opts of + conf | False <- get help conf + -> putStrLn (fancyHeader backend conf header footer) >> return (conf,n,u) + _ -> putStrLn (helpMsg []) >> exitSuccess + -- + (_,_,_,err) -> error (helpMsg err) - case foldr id config o of - conf | False <- get help conf - -> putStrLn (fancyHeader backend conf header footer) >> return (conf, cconf, n ++ n') - _ -> putStrLn (helpMsg []) >> exitSuccess + -- Criterion + -- + -- TODO: don't bail on unrecognised options. Print to screen, or return for + -- further processing (e.g. test-framework). + -- + (cconf, _) <- Criterion.parseArgs Criterion.defaultConfig criterionOptions u - (_,_,_,err) -> error (helpMsg err) + return (conf, cconf, non)