accelerate-examples 0.13.0.0 → 0.14.0.0
raw patch · 111 files changed
+4382/−4857 lines, 111 filesdep +HUnitdep +containersdep +ekgdep −cmdargsdep −cudadep −deepseqdep ~QuickCheckdep ~acceleratedep ~accelerate-cudanew-component:exe:accelerate-fftnew-component:exe:accelerate-nofibnew-component:exe:accelerate-smvm
Dependencies added: HUnit, containers, ekg, gloss-accelerate, gloss-raster-accelerate, primitive, test-framework-hunit
Dependencies removed: cmdargs, cuda, deepseq, directory, hashtables, mtl, pgm, pretty
Dependency ranges changed: QuickCheck, accelerate, accelerate-cuda, accelerate-fft, accelerate-io, array, base, bmp, cereal, fclabels, filepath, gloss, mwc-random
Files
- accelerate-examples.cabal +283/−133
- data/hashcat/README.md +30/−0
- data/matrices/README.md +21/−0
- examples/canny/src-acc/Canny.hs +3/−3
- examples/canny/src-acc/Main.hs +5/−2
- examples/crystal/Main.hs +54/−129
- examples/fft/src-acc/Config.hs +78/−0
- examples/fft/src-acc/FFT.hs +36/−0
- examples/fft/src-acc/HighPass.hs +51/−0
- examples/fft/src-acc/Main.hs +62/−0
- examples/fluid/src-acc/Config.hs +3/−3
- examples/fluid/src-acc/Fluid.hs +1/−1
- examples/fluid/src-acc/Main.hs +2/−0
- examples/hashcat/Main.hs +5/−3
- examples/mandelbrot/Main.hs +5/−18
- examples/mandelbrot/Mandel.hs +32/−69
- examples/mandelbrot/World.hs +5/−4
- examples/n-body/Common/Body.hs +3/−5
- examples/n-body/Common/World.hs +3/−2
- examples/n-body/Config.hs +4/−3
- examples/n-body/Main.hs +7/−3
- examples/n-body/Solver/BarnsHut.hs +1/−1
- examples/n-body/Solver/Naive.hs +0/−23
- examples/n-body/Solver/Naive1.hs +30/−0
- examples/n-body/Solver/Naive2.hs +25/−0
- examples/nofib/Config.hs +187/−0
- examples/nofib/Main.hs +59/−0
- examples/nofib/QuickCheck/Arbitrary/Array.hs +139/−0
- examples/nofib/QuickCheck/Arbitrary/Shape.hs +58/−0
- examples/nofib/Test/Base.hs +147/−0
- examples/nofib/Test/Foreign.hs +45/−0
- examples/nofib/Test/IO.hs +17/−0
- examples/nofib/Test/IO/Ptr.hs +114/−0
- examples/nofib/Test/IO/Vector.hs +53/−0
- examples/nofib/Test/IO/fill_with_values.cpp +81/−0
- examples/nofib/Test/Imaginary.hs +23/−0
- examples/nofib/Test/Imaginary/DotP.hs +66/−0
- examples/nofib/Test/Imaginary/SASUM.hs +60/−0
- examples/nofib/Test/Imaginary/SAXPY.hs +68/−0
- examples/nofib/Test/Prelude.hs +31/−0
- examples/nofib/Test/Prelude/Filter.hs +58/−0
- examples/nofib/Test/Prelude/IndexSpace.hs +279/−0
- examples/nofib/Test/Prelude/Mapping.hs +131/−0
- examples/nofib/Test/Prelude/PrefixSum.hs +211/−0
- examples/nofib/Test/Prelude/Reduction.hs +232/−0
- examples/nofib/Test/Prelude/Replicate.hs +136/−0
- examples/nofib/Test/Prelude/Stencil.hs +212/−0
- examples/nofib/Test/Sharing.hs +298/−0
- examples/nofib/Test/Spectral.hs +23/−0
- examples/nofib/Test/Spectral/BlackScholes.cpp +116/−0
- examples/nofib/Test/Spectral/BlackScholes.hs +134/−0
- examples/nofib/Test/Spectral/RadixSort.hs +132/−0
- examples/nofib/Test/Spectral/SMVM.hs +74/−0
- examples/quickcheck/Arbitrary/Array.hs +0/−78
- examples/quickcheck/Arbitrary/Shape.hs +0/−51
- examples/quickcheck/Config.hs +0/−151
- examples/quickcheck/Main.hs +0/−34
- examples/quickcheck/Test/Base.hs +0/−118
- examples/quickcheck/Test/IndexSpace.hs +0/−112
- examples/quickcheck/Test/Mapping.hs +0/−121
- examples/quickcheck/Test/PrefixSum.hs +0/−192
- examples/quickcheck/Test/Reduction.hs +0/−219
- examples/smoothlife/Config.hs +2/−2
- examples/smoothlife/Gloss/Draw.hs +4/−18
- examples/smoothlife/Main.hs +3/−1
- examples/smoothlife/Random/Splat.hs +1/−1
- examples/smoothlife/SmoothLife.hs +11/−3
- examples/smvm/Config.hs +47/−0
- examples/smvm/Main.hs +51/−0
- examples/smvm/Matrix.hs +110/−0
- examples/smvm/MatrixMarket.hs +134/−0
- examples/smvm/SMVM.hs +25/−0
- examples/tests/Benchmark.hs +0/−64
- examples/tests/Config.hs +0/−197
- examples/tests/Main.hs +0/−79
- examples/tests/PGM.hs +0/−32
- examples/tests/Random.hs +0/−73
- examples/tests/Test.hs +0/−233
- examples/tests/Util.hs +0/−20
- examples/tests/Validate.hs +0/−102
- examples/tests/image-processing/Canny.hs +0/−350
- examples/tests/image-processing/IntegralImage.hs +0/−40
- examples/tests/io/BlockCopy.hs +0/−91
- examples/tests/io/VectorCopy.hs +0/−65
- examples/tests/io/fill_with_values.cpp +0/−81
- examples/tests/primitives/Backpermute.hs +0/−62
- examples/tests/primitives/Fold.hs +0/−90
- examples/tests/primitives/FoldSeg.hs +0/−62
- examples/tests/primitives/Gather.hs +0/−73
- examples/tests/primitives/Map.hs +0/−52
- examples/tests/primitives/Permute.hs +0/−40
- examples/tests/primitives/ScanSeg.hs +0/−63
- examples/tests/primitives/Scatter.hs +0/−107
- examples/tests/primitives/Stencil.hs +0/−229
- examples/tests/primitives/Stencil2.hs +0/−109
- examples/tests/primitives/Vector.hs +0/−67
- examples/tests/primitives/Zip.hs +0/−35
- examples/tests/primitives/ZipWith.hs +0/−42
- examples/tests/simple/BlackScholes.hs +0/−88
- examples/tests/simple/DotP.hs +0/−45
- examples/tests/simple/Filter.hs +0/−38
- examples/tests/simple/Radix.hs +0/−90
- examples/tests/simple/SASUM.hs +0/−35
- examples/tests/simple/SAXPY.hs +0/−42
- examples/tests/simple/SMVM.hs +0/−78
- examples/tests/simple/SMVM/Matrix.hs +0/−75
- examples/tests/simple/SMVM/MatrixMarket.hs +0/−133
- examples/tests/simple/SharingRecovery.hs +0/−145
- examples/tests/simple/SliceExamples.hs +0/−115
- lib/Monitoring.hs +20/−0
- lib/ParseArgs.hs +41/−12
accelerate-examples.cabal view
@@ -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 <http://localhost:8000>+ 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
+ data/hashcat/README.md view
@@ -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+
+ data/matrices/README.md view
@@ -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+
examples/canny/src-acc/Canny.hs view
@@ -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. --
examples/canny/src-acc/Main.hs view
@@ -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)
examples/crystal/Main.hs view
@@ -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)
+ examples/fft/src-acc/Config.hs view
@@ -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 = []+
+ examples/fft/src-acc/FFT.hs view
@@ -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+
+ examples/fft/src-acc/HighPass.hs view
@@ -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+
+ examples/fft/src-acc/Main.hs view
@@ -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+ ]+
examples/fluid/src-acc/Config.hs view
@@ -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
examples/fluid/src-acc/Fluid.hs view
@@ -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)
examples/fluid/src-acc/Main.hs view
@@ -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
examples/hashcat/Main.hs view
@@ -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")
examples/mandelbrot/Main.hs view
@@ -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
examples/mandelbrot/Mandel.hs view
@@ -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
examples/mandelbrot/World.hs view
@@ -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')
examples/n-body/Common/Body.hs view
@@ -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
examples/n-body/Common/World.hs view
@@ -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)
examples/n-body/Config.hs view
@@ -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
examples/n-body/Main.hs view
@@ -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
examples/n-body/Solver/BarnsHut.hs view
@@ -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!"
− examples/n-body/Solver/Naive.hs
@@ -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-
+ examples/n-body/Solver/Naive1.hs view
@@ -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+
+ examples/n-body/Solver/Naive2.hs view
@@ -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+
+ examples/nofib/Config.hs view
@@ -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)+
+ examples/nofib/Main.hs view
@@ -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.+ --+
+ examples/nofib/QuickCheck/Arbitrary/Array.hs view
@@ -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)+
+ examples/nofib/QuickCheck/Arbitrary/Shape.hs view
@@ -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+
+ examples/nofib/Test/Base.hs view
@@ -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+
+ examples/nofib/Test/Foreign.hs view
@@ -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
+ examples/nofib/Test/IO.hs view
@@ -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+ ]+
+ examples/nofib/Test/IO/Ptr.hs view
@@ -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 ()+
+ examples/nofib/Test/IO/Vector.hs view
@@ -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+
+ examples/nofib/Test/IO/fill_with_values.cpp view
@@ -0,0 +1,81 @@+#include <stdio.h>+#include <stdlib.h>+#include <stdint.h>++/* Returns one if it's filled with even values starting at 0 */+template <typename T>+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+
+ examples/nofib/Test/Imaginary.hs view
@@ -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+ ]+
+ examples/nofib/Test/Imaginary/DotP.hs view
@@ -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+
+ examples/nofib/Test/Imaginary/SASUM.hs view
@@ -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+
+ examples/nofib/Test/Imaginary/SAXPY.hs view
@@ -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+
+ examples/nofib/Test/Prelude.hs view
@@ -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+ ]+
+ examples/nofib/Test/Prelude/Filter.hs view
@@ -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)+
+ examples/nofib/Test/Prelude/IndexSpace.hs view
@@ -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+
+ examples/nofib/Test/Prelude/Mapping.hs view
@@ -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))+
+ examples/nofib/Test/Prelude/PrefixSum.hs view
@@ -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 )+
+ examples/nofib/Test/Prelude/Reduction.hs view
@@ -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)+
+ examples/nofib/Test/Prelude/Replicate.hs view
@@ -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) ]+
+ examples/nofib/Test/Prelude/Stencil.hs view
@@ -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]+
+ examples/nofib/Test/Sharing.hs view
@@ -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))+++
+ examples/nofib/Test/Spectral.hs view
@@ -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+ ]+
+ examples/nofib/Test/Spectral/BlackScholes.cpp view
@@ -0,0 +1,116 @@++#include <math.h>+++/*+ * Polynomial approximation of cumulative normal distribution function+ */+template <typename T>+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 <typename T>+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<float>+ (+ 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<double>+ (+ CallResult[opt],+ PutResult[opt],+ StockPrice[opt],+ OptionStrike[opt],+ OptionYears[opt],+ Riskfree,+ Volatility+ );+ }+}+
+ examples/nofib/Test/Spectral/BlackScholes.hs view
@@ -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 ()+
+ examples/nofib/Test/Spectral/RadixSort.hs view
@@ -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++
+ examples/nofib/Test/Spectral/SMVM.hs view
@@ -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) ]+
− examples/quickcheck/Arbitrary/Array.hs
@@ -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-
− examples/quickcheck/Arbitrary/Shape.hs
@@ -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)-
− examples/quickcheck/Config.hs
@@ -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-
− examples/quickcheck/Main.hs
@@ -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-
− examples/quickcheck/Test/Base.hs
@@ -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-
− examples/quickcheck/Test/IndexSpace.hs
@@ -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))-
− examples/quickcheck/Test/Mapping.hs
@@ -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))-
− examples/quickcheck/Test/PrefixSum.hs
@@ -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 )-
− examples/quickcheck/Test/Reduction.hs
@@ -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)-
examples/smoothlife/Config.hs view
@@ -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 =
examples/smoothlife/Gloss/Draw.hs view
@@ -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
examples/smoothlife/Main.hs view
@@ -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
examples/smoothlife/Random/Splat.hs view
@@ -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
examples/smoothlife/SmoothLife.hs view
@@ -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)
+ examples/smvm/Config.hs view
@@ -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 = []++
+ examples/smvm/Main.hs view
@@ -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 ]+
+ examples/smvm/Matrix.hs view
@@ -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)+
+ examples/smvm/MatrixMarket.hs view
@@ -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+
+ examples/smvm/SMVM.hs view
@@ -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+
− examples/tests/Benchmark.hs
@@ -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-
− examples/tests/Config.hs
@@ -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:"- , " <default> 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-
− examples/tests/Main.hs
@@ -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
− examples/tests/PGM.hs
@@ -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-
− examples/tests/Random.hs
@@ -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--
− examples/tests/Test.hs
@@ -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-
− examples/tests/Util.hs
@@ -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)-
− examples/tests/Validate.hs
@@ -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 ]-
− examples/tests/image-processing/Canny.hs
@@ -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 #-}-
− examples/tests/image-processing/IntegralImage.hs
@@ -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)-
− examples/tests/io/BlockCopy.hs
@@ -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 ()-
− examples/tests/io/VectorCopy.hs
@@ -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- ]-
− examples/tests/io/fill_with_values.cpp
@@ -1,81 +0,0 @@-#include <stdio.h>-#include <stdlib.h>-#include <stdint.h>--/* Returns one if it's filled with even values starting at 0 */-template <typename T>-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-
− examples/tests/primitives/Backpermute.hs
@@ -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-
− examples/tests/primitives/Fold.hs
@@ -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-
− examples/tests/primitives/FoldSeg.hs
@@ -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-
− examples/tests/primitives/Gather.hs
@@ -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--
− examples/tests/primitives/Map.hs
@@ -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-
− examples/tests/primitives/Permute.hs
@@ -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--
− examples/tests/primitives/ScanSeg.hs
@@ -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-
− examples/tests/primitives/Scatter.hs
@@ -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---
− examples/tests/primitives/Stencil.hs
@@ -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-
− examples/tests/primitives/Stencil2.hs
@@ -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-
− examples/tests/primitives/Vector.hs
@@ -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-
− examples/tests/primitives/Zip.hs
@@ -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')-
− examples/tests/primitives/ZipWith.hs
@@ -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-
− examples/tests/simple/BlackScholes.hs
@@ -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-
− examples/tests/simple/DotP.hs
@@ -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-
− examples/tests/simple/Filter.hs
@@ -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-
− examples/tests/simple/Radix.hs
@@ -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-
− examples/tests/simple/SASUM.hs
@@ -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-
− examples/tests/simple/SAXPY.hs
@@ -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-
− examples/tests/simple/SMVM.hs
@@ -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-
− examples/tests/simple/SMVM/Matrix.hs
@@ -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)-
− examples/tests/simple/SMVM/MatrixMarket.hs
@@ -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-
− examples/tests/simple/SharingRecovery.hs
@@ -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)
− examples/tests/simple/SliceExamples.hs
@@ -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)
+ lib/Monitoring.hs view
@@ -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+
lib/ParseArgs.hs view
@@ -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)