accelerate-examples 0.15.0.0 → 0.15.1.0
raw patch · 102 files changed
+2941/−2010 lines, 102 filesdep +HTTPdep +accelerate-examplesdep +accelerate-icc-opencldep −accelerate-llvmdep −accelerate-llvm-multidevdep ~accelerate-cudadep ~basedep ~bytestring
Dependencies added: HTTP, accelerate-examples, accelerate-icc-opencl, aeson, ansi-wl-pprint, gloss-rendering, http-types, network, process, statistics, template-haskell, text, time
Dependencies removed: accelerate-llvm, accelerate-llvm-multidev
Dependency ranges changed: accelerate-cuda, base, bytestring, bytestring-lexing, containers, criterion, fclabels, gloss, gloss-accelerate, gloss-raster-accelerate
Files
- accelerate-examples.cabal +236/−346
- examples/canny/src-acc/Canny.hs +3/−3
- examples/canny/src-acc/Config.hs +5/−24
- examples/canny/src-acc/Main.hs +7/−9
- examples/canny/src-acc/Wildfire.hs +1/−0
- examples/crystal/Config.hs +20/−33
- examples/crystal/Main.hs +16/−20
- examples/fft/src-acc/Config.hs +5/−21
- examples/fft/src-acc/HighPass.hs +2/−2
- examples/fft/src-acc/Main.hs +21/−23
- examples/fluid/src-acc/Config.hs +13/−28
- examples/fluid/src-acc/Fluid.hs +2/−1
- examples/fluid/src-acc/Main.hs +25/−34
- examples/fluid/src-acc/World.hs +1/−0
- examples/hashcat/Config.hs +4/−15
- examples/hashcat/Digest.hs +1/−1
- examples/hashcat/MD5.hs +4/−3
- examples/hashcat/Main.hs +18/−8
- examples/kmeans/Config.hs +4/−17
- examples/kmeans/GenSamples.hs +114/−0
- examples/kmeans/Kmeans.hs +1/−1
- examples/kmeans/Main.hs +31/−32
- examples/mandelbrot/Config.hs +22/−33
- examples/mandelbrot/Main.hs +31/−47
- examples/mandelbrot/Mandel.hs +9/−6
- examples/mandelbrot/World.hs +13/−13
- examples/n-body/Config.hs +4/−19
- examples/n-body/Main.hs +25/−24
- examples/n-body/Random/Position.hs +3/−3
- examples/n-body/Test.hs +49/−0
- examples/nofib/Config.hs +27/−89
- examples/nofib/Main.hs +14/−23
- examples/nofib/QuickCheck/Arbitrary/Shape.hs +20/−1
- examples/nofib/Test/Base.hs +3/−133
- examples/nofib/Test/FFT.hs +8/−10
- examples/nofib/Test/Foreign.hs +14/−34
- examples/nofib/Test/Foreign/CUDA.hs +36/−0
- examples/nofib/Test/IO/Vector.hs +1/−0
- examples/nofib/Test/Imaginary.hs +7/−5
- examples/nofib/Test/Imaginary/DotP.hs +7/−11
- examples/nofib/Test/Imaginary/SASUM.hs +7/−11
- examples/nofib/Test/Imaginary/SAXPY.hs +7/−11
- examples/nofib/Test/Issues.hs +14/−12
- examples/nofib/Test/Issues/Issue102.hs +5/−9
- examples/nofib/Test/Issues/Issue114.hs +5/−9
- examples/nofib/Test/Issues/Issue119.hs +5/−9
- examples/nofib/Test/Issues/Issue123.hs +5/−8
- examples/nofib/Test/Issues/Issue137.hs +6/−9
- examples/nofib/Test/Issues/Issue168.hs +5/−8
- examples/nofib/Test/Issues/Issue184.hs +5/−9
- examples/nofib/Test/Issues/Issue185.hs +3/−7
- examples/nofib/Test/Issues/Issue187.hs +5/−9
- examples/nofib/Test/Issues/Issue93.hs +5/−9
- examples/nofib/Test/Prelude.hs +15/−13
- examples/nofib/Test/Prelude/Filter.hs +3/−6
- examples/nofib/Test/Prelude/IndexSpace.hs +91/−78
- examples/nofib/Test/Prelude/Mapping.hs +185/−53
- examples/nofib/Test/Prelude/PrefixSum.hs +5/−7
- examples/nofib/Test/Prelude/Reduction.hs +10/−15
- examples/nofib/Test/Prelude/Replicate.hs +10/−13
- examples/nofib/Test/Prelude/Stencil.hs +9/−12
- examples/nofib/Test/Sharing.hs +4/−4
- examples/nofib/Test/Spectral.hs +7/−5
- examples/nofib/Test/Spectral/BlackScholes.hs +12/−14
- examples/nofib/Test/Spectral/RadixSort.hs +5/−7
- examples/nofib/Test/Spectral/SMVM.hs +4/−8
- examples/pagerank/Config.hs +18/−22
- examples/pagerank/Main.hs +18/−10
- examples/pagerank/Page.hs +3/−1
- examples/pagerank/Rank.hs +12/−9
- examples/ray/Config.hs +26/−38
- examples/ray/Main.hs +32/−37
- examples/ray/Ray/Intersect.hs +5/−5
- examples/ray/Ray/Trace.hs +1/−1
- examples/ray/Scene/Object.hs +2/−2
- examples/smoothlife/Config.hs +4/−20
- examples/smoothlife/Gloss/Draw.hs +8/−7
- examples/smoothlife/Main.hs +17/−25
- examples/smoothlife/Random/Splat.hs +2/−3
- examples/smoothlife/SmoothLife.hs +12/−10
- examples/smvm/Config.hs +4/−18
- examples/smvm/Main.hs +10/−12
- examples/smvm/MatrixMarket.hs +6/−5
- lib/Data/Array/Accelerate/Examples/Internal.hs +35/−0
- lib/Data/Array/Accelerate/Examples/Internal/Backend.hs +196/−0
- lib/Data/Array/Accelerate/Examples/Internal/Codespeed.hs +139/−0
- lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs +76/−0
- lib/Data/Array/Accelerate/Examples/Internal/Criterion/Config.hs +160/−0
- lib/Data/Array/Accelerate/Examples/Internal/Interactive.hs +43/−0
- lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs +38/−0
- lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs +300/−0
- lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs +105/−0
- lib/Data/Array/Accelerate/Examples/Internal/Report.hs +35/−0
- lib/Data/Array/Accelerate/Examples/Internal/Similar.hs +138/−0
- lib/Data/Array/Accelerate/Examples/Internal/TH.hs +68/−0
- lib/Data/Array/Accelerate/Examples/Internal/TestFramework.hs +92/−0
- lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs +39/−0
- lib/Data/Array/Accelerate/Examples/Internal/Util.hs +33/−0
- lib/Monitoring.hs +0/−20
- lib/ParseArgs.hs +0/−223
- lib/Random/Array.hs +0/−96
- lib/Util.hs +0/−19
accelerate-examples.cabal view
@@ -1,7 +1,7 @@ Name: accelerate-examples-Version: 0.15.0.0-Cabal-version: >=1.6-Tested-with: GHC == 7.8.*+Version: 0.15.1.0+Cabal-version: >=1.8+Tested-with: GHC >= 7.8 Build-type: Simple Synopsis: Examples using the Accelerate library@@ -27,6 +27,8 @@ Extra-source-files: data/hashcat/README.md data/matrices/README.md +-- Flags that control features of the benchmark programs+-- Flag gui Description: Enable gloss-based GUIs, where applicable. If not enabled, the application always runs in benchmark mode.@@ -36,26 +38,27 @@ Description: Enable EKG remote monitoring server at <http://localhost:8000> Default: True +Flag codespeed+ Description: Enable upload of results to benchmark server+ Default: False++-- Flags that control which Accelerate backends that are linked against+-- Flag cuda Description: Enable the CUDA parallel backend for NVIDIA GPUs Default: True -Flag opencl- Description: Enable the OpenCL parallel backend- Default: False- Flag llvm-cpu Description: Enable the LLVM backend for multicore CPUs- Default: True+ Default: False Flag llvm-gpu Description: Enable the LLVM backend for NVIDIA CPUs- Default: True--Flag llvm-multi- Description: Enable the multi-device LLVM backend- Default: True+ Default: False +Flag cilk+ Description: Enable the Cilk backend for multicore CPUs+ Default: False -- Flags to specify which programs to build --@@ -112,6 +115,83 @@ Default: True +-- Test harness+-- ------------++Library+ hs-source-dirs: lib+ Build-depends: accelerate == 0.15.*,+ ansi-wl-pprint >= 0.6,+ base >= 4.7 && < 4.9,+ containers >= 0.5,+ criterion >= 1.0,+ directory >= 1.1,+ fclabels >= 2.0,+ HUnit >= 1.2,+ mwc-random >= 0.8,+ QuickCheck >= 2.7,+ test-framework >= 0.5,+ test-framework-hunit >= 0.3,+ test-framework-quickcheck2 >= 0.2++ Exposed-modules: Data.Array.Accelerate.Examples.Internal++ Other-modules: Data.Array.Accelerate.Examples.Internal.Backend+ Data.Array.Accelerate.Examples.Internal.Criterion+ Data.Array.Accelerate.Examples.Internal.Criterion.Config+ Data.Array.Accelerate.Examples.Internal.Interactive+ Data.Array.Accelerate.Examples.Internal.Monitoring+ Data.Array.Accelerate.Examples.Internal.ParseArgs+ Data.Array.Accelerate.Examples.Internal.Random.Array+ Data.Array.Accelerate.Examples.Internal.Report+ Data.Array.Accelerate.Examples.Internal.Similar+ Data.Array.Accelerate.Examples.Internal.TestFramework+ Data.Array.Accelerate.Examples.Internal.TestFramework.Config+ Data.Array.Accelerate.Examples.Internal.Util++ ghc-options: -O2 -Wall+ ghc-prof-options: -caf-all -auto-all++ if flag(gui)+ CPP-options: -DACCELERATE_ENABLE_GUI++ if flag(cuda)+ CPP-options: -DACCELERATE_CUDA_BACKEND+ build-depends: accelerate-cuda == 0.15.*++ if flag(llvm-cpu)+ CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND+ build-depends: accelerate-llvm-native == 0.15.*++ if flag(llvm-gpu)+ CPP-options: -DACCELERATE_LLVM_PTX_BACKEND+ build-depends: accelerate-llvm-ptx == 0.15.*++ if flag(cilk)+ CPP-options: -DACCELERATE_CILK_BACKEND+ build-depends: accelerate-icc-opencl == 0.15.*++ if flag(ekg)+ CPP-options: -DACCELERATE_ENABLE_EKG+ build-depends: ekg >= 0.3++ if flag(codespeed)+ CPP-options: -DACCELERATE_ENABLE_CODESPEED+ build-depends: aeson >= 0.8,+ bytestring >= 0.10,+ HTTP >= 4000.2,+ http-types >= 0.8,+ network >= 2.5,+ process >= 1.0,+ statistics >= 0.13,+ template-haskell >= 2.2,+ text >= 0.11,+ time >= 1.4++ other-modules: Data.Array.Accelerate.Examples.Internal.Codespeed+ Data.Array.Accelerate.Examples.Internal.TH++ -- The main test program. This includes randomised quickcheck testing for array -- primitives, unit tests, imaginary/spectral/real programs, and benchmarks. --@@ -119,15 +199,15 @@ -- Executable accelerate-nofib Main-is: Main.hs- hs-source-dirs: lib- examples/nofib+ hs-source-dirs: examples/nofib examples/smvm - other-modules: Config ParseArgs Monitoring+ other-modules: Config QuickCheck.Arbitrary.Array QuickCheck.Arbitrary.Shape Test.Base Test.FFT+ Test.Foreign Test.IO Test.IO.Ptr Test.IO.Vector@@ -157,8 +237,8 @@ Test.Sharing Test.Spectral Test.Spectral.BlackScholes- Test.Spectral.SMVM Test.Spectral.RadixSort+ Test.Spectral.SMVM ghc-options: -Wall -O2 -threaded@@ -177,31 +257,21 @@ if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND build-depends: accelerate-cuda == 0.15.*- other-modules: Test.Foreign-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*+ other-modules: Test.Foreign.CUDA if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(nofib) buildable: False else build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*, accelerate-fft == 0.15.*, accelerate-io == 0.15.*,- base == 4.7.*,+ base >= 4.7 && < 4.9, array >= 0.3, containers >= 0.5,- criterion >= 0.5 && < 1.0, fclabels >= 2.0, HUnit >= 1.2, QuickCheck >= 2.7,@@ -215,10 +285,9 @@ -- ----------------------------------- Executable accelerate-smvm- hs-source-dirs: examples/smvm lib Main-is: Main.hs- other-modules: ParseArgs Monitoring- Config+ hs-source-dirs: examples/smvm+ other-modules: Config Matrix MatrixMarket SMVM@@ -229,87 +298,58 @@ if impl(ghc >= 7.6) ghc-options: -fsimpl-tick-factor=130 - if flag(cuda)- CPP-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*- if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(smvm) buildable: False else- build-depends: accelerate == 0.15.*,- base == 4.7.*,- attoparsec >= 0.10,- bytestring >= 0.9,- bytestring-lexing >= 0.2,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- primitive >= 0.5,- mwc-random >= 0.8,- vector >= 0.7,- vector-algorithms >= 0.4+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ base >= 4.7 && < 4.9,+ attoparsec >= 0.10,+ bytestring >= 0.9,+ bytestring-lexing >= 0.5,+ fclabels >= 2.0,+ primitive >= 0.5,+ mwc-random >= 0.8,+ vector >= 0.7,+ vector-algorithms >= 0.4 -- A quasicrystal demo as the sum of waves in a plane -- -------------------------------------------------- Executable accelerate-crystal- hs-source-dirs: examples/crystal lib+ hs-source-dirs: examples/crystal Main-is: Main.hs- other-modules: Config ParseArgs Monitoring+ other-modules: Config ghc-options: -O2 -Wall -threaded -rtsopts -eventlog ghc-prof-options: -auto-all - if flag(gui)- CPP-options: -DACCELERATE_ENABLE_GUI-- if flag(cuda)- CPP-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*- if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(crystal) buildable: False else- build-depends: accelerate == 0.15.*,- base == 4.7.*,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- gloss-raster-accelerate >= 1.7+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ base >= 4.7 && < 4.9,+ fclabels >= 2.0,+ gloss-raster-accelerate >= 1.7 -- Image edge detection -- -------------------- Executable accelerate-canny- hs-source-dirs: examples/canny/src-acc lib+ hs-source-dirs: examples/canny/src-acc Main-is: Main.hs- other-modules: Config ParseArgs Canny Wildfire Monitoring+ other-modules: Config+ Canny+ Wildfire ghc-options: -Wall -threaded@@ -321,82 +361,48 @@ ghc-prof-options: -auto-all - if flag(cuda)- CPP-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*- if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(canny) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-io == 0.15.*,- base == 4.7.*,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- repa >= 3.1,- repa-io >= 3.1,- vector >= 0.7+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ accelerate-io == 0.15.*,+ base >= 4.7 && < 4.9,+ fclabels >= 2.0,+ repa >= 3.1,+ repa-io >= 3.1,+ vector >= 0.7 -- A simple mandelbrot generator -- ----------------------------- Executable accelerate-mandelbrot- hs-source-dirs: examples/mandelbrot lib+ hs-source-dirs: examples/mandelbrot Main-is: Main.hs- other-modules: Config World Mandel ParseArgs Monitoring+ other-modules: Config+ Mandel+ World ghc-options: -O2 -Wall -threaded -eventlog -rtsopts ghc-prof-options: -auto-all - if flag(gui)- CPP-options: -DACCELERATE_ENABLE_GUI-- if flag(cuda)- CPP-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*,- accelerate-llvm-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*-- if flag(llvm-cpu) && flag(llvm-gpu) && flag(llvm-multi)- CPP-options: -DACCELERATE_LLVM_MULTIDEV_BACKEND- build-depends: accelerate-llvm-multidev== 0.15.*- if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(mandelbrot) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-io == 0.15.*,- base == 4.7.*,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- gloss >= 1.7,- gloss-accelerate >= 1.7+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ accelerate-io == 0.15.*,+ base >= 4.7 && < 4.9,+ fclabels >= 2.0,+ gloss >= 1.7,+ gloss-accelerate >= 1.7 -- A stable fluid simulation@@ -404,8 +410,8 @@ Executable accelerate-fluid Main-is: Main.hs- hs-source-dirs: examples/fluid/src-acc lib- other-modules: Config ParseArgs Monitoring+ hs-source-dirs: examples/fluid/src-acc+ other-modules: Config Event Fluid Type@@ -414,36 +420,20 @@ ghc-options: -O2 -Wall -threaded -eventlog -rtsopts ghc-prof-options: -auto-all - if flag(gui)- CPP-options: -DACCELERATE_ENABLE_GUI-- if flag(cuda)- cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*- if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(fluid) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-io == 0.15.*,- base == 4.7.*,- bmp >= 1.2,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- gloss >= 1.7+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ accelerate-io == 0.15.*,+ base >= 4.7 && < 4.9,+ bmp >= 1.2,+ fclabels >= 2.0,+ gloss >= 1.9,+ gloss-rendering >= 1.9 -- Simulation of gravitational attraction between solid particles@@ -451,55 +441,38 @@ Executable accelerate-nbody Main-is: Main.hs- hs-source-dirs: examples/n-body lib- other-modules: Config ParseArgs Monitoring- Common.Body+ hs-source-dirs: examples/n-body+ other-modules: Common.Body Common.Dump Common.Tree Common.Type Common.Util Common.World+ Config Gloss.Draw Gloss.Event Gloss.Simulate- Random.Array Random.Position Solver.BarnsHut Solver.Naive1 Solver.Naive2+ Test ghc-options: -O2 -Wall -threaded -eventlog -rtsopts ghc-prof-options: -auto-all - if flag(gui)- cpp-options: -DACCELERATE_ENABLE_GUI-- if flag(cuda)- cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*- if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(nbody) buildable: False else- build-depends: accelerate == 0.15.*,- base == 4.7.*,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- gloss >= 1.7,- mwc-random >= 0.8+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ base >= 4.7 && < 4.9,+ fclabels >= 2.0,+ gloss >= 1.7,+ mwc-random >= 0.8 -- A celular automata@@ -507,50 +480,36 @@ Executable accelerate-smoothlife Main-is: Main.hs- hs-source-dirs: examples/smoothlife lib- other-modules: Config ParseArgs Monitoring- SmoothLife+ hs-source-dirs: examples/smoothlife+ other-modules: Config Gloss.Draw Gloss.Event Gloss.Simulate- Random.Array Random.Splat+ SmoothLife ghc-options: -O2 -Wall -threaded -threaded -rtsopts ghc-prof-options: -auto-all - if flag(gui)- cpp-options: -DACCELERATE_ENABLE_GUI- if flag(cuda) cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*+ build-depends: accelerate-cuda == 0.15.* if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(smoothlife) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-fft == 0.15.*,- accelerate-io == 0.15.*,- base == 4.7.*,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- gloss >= 1.7,- gloss-accelerate >= 1.7,- mwc-random >= 0.8+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ accelerate-fft == 0.15.*,+ accelerate-io == 0.15.*,+ base >= 4.7 && < 4.9,+ fclabels >= 2.0,+ gloss >= 1.7,+ gloss-accelerate >= 1.7,+ mwc-random >= 0.8 -- A password recovery tool@@ -558,123 +517,89 @@ Executable accelerate-hashcat Main-is: Main.hs- hs-source-dirs: examples/hashcat lib- other-modules: Config ParseArgs Monitoring+ hs-source-dirs: examples/hashcat+ other-modules: Config Digest MD5- Util ghc-options: -O2 -Wall -threaded -threaded -rtsopts ghc-prof-options: -auto-all - if flag(cuda)- cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*- if flag(ekg)- CPP-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T if !flag(hashcat) buildable: False else- build-depends: accelerate == 0.15.*,- base == 4.7.*,- bytestring >= 0.9,- bytestring-lexing >= 0.2,- cereal >= 0.3,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- mwc-random >= 0.8+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ base >= 4.7 && < 4.9,+ bytestring >= 0.9,+ bytestring-lexing >= 0.5,+ cereal >= 0.3,+ criterion >= 1.0,+ fclabels >= 2.0,+ mwc-random >= 0.8 -- FFT examples -- ------------ Executable accelerate-fft Main-is: Main.hs- hs-source-dirs: examples/fft/src-acc lib+ hs-source-dirs: examples/fft/src-acc other-modules: Config- ParseArgs HighPass FFT ghc-options: -O2 -Wall -threaded -threaded -rtsopts ghc-prof-options: -auto-all - if flag(cuda)- cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*+ if flag(ekg)+ ghc-options: -with-rtsopts=-T if !flag(fft) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-io == 0.15.*,- accelerate-fft == 0.15.*,- base == 4.7.*,- criterion >= 0.5 && < 1.0,- fclabels >= 2.0,- filepath >= 1.0+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ accelerate-fft == 0.15.*,+ accelerate-io == 0.15.*,+ base >= 4.7 && < 4.9,+ fclabels >= 2.0,+ filepath >= 1.0 -- PageRank -- -------- Executable accelerate-pagerank Main-is: Main.hs- hs-source-dirs: examples/pagerank lib+ hs-source-dirs: examples/pagerank other-modules: Config+ Count+ Load Page Progress Rank Step- Count- Rank- Step- Load- ghc-options: -rtsopts -threaded -O2 - if flag(cuda)- cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda == 0.15.*-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*+ ghc-options: -rtsopts -threaded -O2 - if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*+ if flag(ekg)+ ghc-options: -with-rtsopts=-T if !flag(pagerank) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-io == 0.15.*,- base == 4.7.*,- bytestring >= 0.9.2,- containers >= 0.4.2,- criterion >= 0.5 && < 1.0,- directory >= 1.1,- fclabels >= 1.0,- vector >= 0.9,- vector-algorithms >= 0.5.4+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ accelerate-io == 0.15.*,+ base >= 4.7 && < 4.9,+ bytestring >= 0.9.2,+ containers >= 0.4.2,+ directory >= 1.1,+ fclabels >= 1.0,+ vector >= 0.9,+ vector-algorithms >= 0.5.4 -- Ray tracer@@ -682,9 +607,8 @@ Executable accelerate-ray Main-is: Main.hs- hs-source-dirs: examples/ray lib- other-modules: ParseArgs Monitoring- Config+ hs-source-dirs: examples/ray+ other-modules: Config Vec3 Gloss.Draw Gloss.Event@@ -698,88 +622,54 @@ if !flag(ray) buildable: False else- build-depends: accelerate == 0.15.*,- accelerate-io == 0.15.*,- base == 4.7.*,- criterion >= 0.5 && < 1.0,- fclabels >= 1.0,- gloss == 1.8.*,- gloss-accelerate == 1.8.*,- gloss-raster-accelerate == 1.8.*-- if flag(cuda)- cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda >= 0.15-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ base >= 4.7 && < 4.9,+ fclabels >= 1.0,+ gloss >= 1.8,+ gloss-accelerate >= 1.8,+ gloss-raster-accelerate >= 1.8 - if flag(llvm-cpu) && flag(llvm-gpu) && flag(llvm-multi)- CPP-options: -DACCELERATE_LLVM_MULTIDEV_BACKEND- build-depends: accelerate-llvm-multidev== 0.15.*+ ghc-options: -Wall -O2 -threaded -threaded -rtsopts+ ghc-prof-options: -auto-all if flag(ekg)- cpp-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T - if flag(gui)- CPP-options: -DACCELERATE_ENABLE_GUI - ghc-options: -Wall -O2 -threaded -threaded -rtsopts- ghc-prof-options: -auto-all-- -- K-means -- ------- Executable accelerate-kmeans Main-is: Main.hs- hs-source-dirs: examples/kmeans lib- other-modules: ParseArgs Monitoring- Config+ hs-source-dirs: examples/kmeans+ other-modules: Config Main Kmeans+ GenSamples if !flag(kmeans) buildable: False else- build-depends: accelerate == 0.15.*,- base == 4.7.*,- binary >= 0.7,- criterion >= 0.5 && < 1.0,+ build-depends: accelerate == 0.15.*,+ accelerate-examples == 0.15.*,+ base >= 4.7 && < 4.9,+ binary >= 0.7,+ directory >= 1.1,+ fclabels >= 1.0, normaldistribution, random - if flag(cuda)- cpp-options: -DACCELERATE_CUDA_BACKEND- build-depends: accelerate-cuda >= 0.15-- if flag(llvm-cpu)- CPP-options: -DACCELERATE_LLVM_NATIVE_BACKEND- build-depends: accelerate-llvm-native == 0.15.*-- if flag(llvm-gpu)- CPP-options: -DACCELERATE_LLVM_PTX_BACKEND- build-depends: accelerate-llvm-ptx == 0.15.*- if flag(ekg)- cpp-options: -DACCELERATE_ENABLE_EKG- build-depends: ekg >= 0.3 ghc-options: -with-rtsopts=-T ghc-options: -Wall -O2 -threaded -threaded -rtsopts ghc-prof-options: -auto-all -source-repository head+source-repository this type: git location: https://github.com/AccelerateHS/accelerate-examples+ branch: release/0.15+ tag: 0.15.1.0 --- vim: nospell---
examples/canny/src-acc/Canny.hs view
@@ -178,8 +178,8 @@ -- | -- 255 --- --- --- offsetx = dir >* orient' Vert ? (-1, dir <* orient' Vert ? (1, 0))- offsety = dir <* orient' Horiz ? (-1, 0)+ offsetx = dir A.>* orient' Vert ? (-1, dir A.<* orient' Vert ? (1, 0))+ offsety = dir A.<* 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)@@ -188,7 +188,7 @@ -- Try to avoid doing explicit tests to avoid warp divergence. --- none = dir ==* orient' Undef ||* mag <* low ||* mag <* fwd ||* mag <* rev+ none = dir ==* orient' Undef ||* mag A.<* low ||* mag A.<* fwd ||* mag A.<* rev strong = mag >=* high in A.fromIntegral (boolToInt (A.not none) * (1 + boolToInt strong)) * 0.5
examples/canny/src-acc/Config.hs view
@@ -2,33 +2,22 @@ module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt + data Config = Config {- -- Standard options- _configBackend :: Backend- , _configHelp :: Bool- , _configBenchmark :: Bool-- -- How to execute the program- , _configThreshLow :: Float+ _configThreshLow :: Float , _configThreshHigh :: Float- } $(mkLabels [''Config]) defaults :: Config defaults = Config- {- _configBackend = maxBound- , _configHelp = False- , _configBenchmark = False-- , _configThreshLow = 50+ { _configThreshLow = 50 , _configThreshHigh = 100 } @@ -42,14 +31,6 @@ , Option ['s'] ["threshold-high"] (ReqArg (set configThreshHigh . read) "FLOAT") (describe configThreshHigh "threshold value for strong edges")-- , Option [] ["benchmark"]- (NoArg (set configBenchmark True))- (describe configBenchmark "benchmark instead of displaying animation")-- , Option ['h', '?'] ["help"]- (NoArg (set configHelp True))- "show this help message" ] where describe f msg@@ -68,5 +49,5 @@ ] footer :: [String]-footer = []+footer = [ "" ]
examples/canny/src-acc/Main.hs view
@@ -2,17 +2,15 @@ import Canny import Config-import Monitoring-import ParseArgs import Wildfire import Prelude as P import Data.Label-import Criterion.Main ( defaultMainWith, bgroup, bench, whnf ) import System.Exit import System.Environment import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A import qualified Data.Array.Accelerate.IO as A import qualified Data.Array.Repa.IO.BMP as R import qualified Data.Array.Repa.Repr.Unboxed as R@@ -25,10 +23,10 @@ = do beginMonitoring argv <- getArgs- (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv- (fileIn, fileOut) <- case nops of+ (conf, opts, rest) <- parseArgs options defaults header footer argv+ (fileIn, fileOut) <- case rest of (i:o:_) -> return (i,o)- _ -> parseArgs configHelp configBackend options defaults header footer ("--help":argv)+ _ -> parseArgs options defaults header footer ("--help":argv) >> exitSuccess -- Read in the image file@@ -37,7 +35,7 @@ -- Set up the algorithm parameters let threshLow = get configThreshLow conf threshHigh = get configThreshHigh conf- backend = get configBackend conf+ backend = get optBackend opts -- Set up the partial results so that we can benchmark individual -- kernel stages.@@ -50,7 +48,7 @@ magdir' = run backend $ gradientMagDir low (use blurred') suppress' = run backend $ nonMaximumSuppression low high (use magdir') - if P.not (get configBenchmark conf)+ if P.not (get optBenchmark opts) then do -- Connect the strong and weak edges of the image using Repa, and -- write the final image to file@@ -63,7 +61,7 @@ -- Run each of the individual kernel stages through criterion, as -- well as the end-to-end step process. --- withArgs (P.drop 2 nops) $ defaultMainWith cconf (return ())+ runBenchmarks opts (P.drop 2 rest) [ bgroup "kernels" [ bench "greyscale" $ whnf (run1 backend toGreyscale) img , bench "blur-x" $ whnf (run1 backend gaussianX) grey'
examples/canny/src-acc/Wildfire.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- This module defines the final phase of the Canny algorithm, a recursive -- algorithm to "connect" pixels of the output image.
examples/crystal/Config.hs view
@@ -1,60 +1,47 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt -data Options = Options+data Config = Config {- _optBackend :: Backend- , _optSize :: Int- , _optZoom :: Int- , _optScale :: Float- , _optDegree :: Int- , _optBench :: Bool- , _optHelp :: Bool+ _configSize :: Int+ , _configZoom :: Int+ , _configScale :: Float+ , _configDegree :: Int } deriving Show -$(mkLabels [''Options])+$(mkLabels [''Config]) -defaults :: Options-defaults = Options- { _optBackend = maxBound- , _optSize = 200- , _optZoom = 3- , _optScale = 30- , _optDegree = 5-#ifdef ACCELERATE_ENABLE_GUI- , _optBench = False-#else- , _optBench = True-#endif- , _optHelp = False+defaults :: Config+defaults = Config+ { _configSize = 200+ , _configZoom = 3+ , _configScale = 30+ , _configDegree = 5 } -options :: [OptDescr (Options -> Options)]+options :: [OptDescr (Config -> Config)] options =- [ Option [] ["size"] (ReqArg (set optSize . read) "INT") "visualisation size (200)"- , Option [] ["zoom"] (ReqArg (set optZoom . read) "INT") "pixel replication factor (3)"- , Option [] ["scale"] (ReqArg (set optScale . read) "FLOAT") "feature size of visualisation (30)"- , Option [] ["degree"] (ReqArg (set optDegree . read) "INT") "number of waves to sum for each point (5)"- , Option [] ["benchmark"] (NoArg (set optBench True)) "benchmark instead of displaying animation (False)"- , Option "h?" ["help"] (NoArg (set optHelp True)) "show help message"+ [ Option [] ["size"] (ReqArg (set configSize . read) "INT") "visualisation size (200)"+ , Option [] ["zoom"] (ReqArg (set configZoom . read) "INT") "pixel replication factor (3)"+ , Option [] ["scale"] (ReqArg (set configScale . read) "FLOAT") "feature size of visualisation (30)"+ , Option [] ["degree"] (ReqArg (set configDegree . read) "INT") "number of waves to sum for each point (5)" ] header :: [String] header =- [ "accelerate-crystal (c) [2011..2013] The Accelerate Team"+ [ "accelerate-crystal (c) [2011..2014] The Accelerate Team" , "" , "Usage: accelerate-crystal [OPTIONS]" , "" ] footer :: [String]-footer = []+footer = [ "" ]
examples/crystal/Main.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} -- Quasicrystals demo. -- -- Based on code from:@@ -10,14 +10,12 @@ import Prelude as P import Config-import Monitoring-import ParseArgs import Data.Label ( get )-import Criterion.Main ( defaultMainWith, bench, whnf ) import System.Environment import Data.Array.Accelerate as A hiding ( size )+import Data.Array.Accelerate.Examples.Internal as A import Graphics.Gloss.Accelerate.Raster.Field as G @@ -95,26 +93,24 @@ beginMonitoring argv <- getArgs- (config, crit, nops) <- parseArgs optHelp optBackend options defaults header footer argv+ (conf, opts, rest) <- parseArgs 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+ let size = get configSize conf+ zoom = get configZoom conf+ scale = get configScale conf+ degree = get configDegree conf+ backend = get optBackend opts - -- 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]) ]+ runBenchmarks opts rest+ [ bench "crystal" $ whnf frame (A.fromList Z [1.0]) ] - else G.animateFieldWith- (run1 backend)- (InWindow "Quasicrystals" (size * zoom, size * zoom) (10, 10))- (zoom, zoom)- (quasicrystal scale degree)+ runInteractive opts rest+ $ G.animateFieldWith+ (run1 backend)+ (InWindow "Quasicrystals" (size * zoom, size * zoom) (10, 10))+ (zoom, zoom)+ (quasicrystal scale degree)
examples/fft/src-acc/Config.hs view
@@ -2,19 +2,15 @@ module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt + data Config = Config {- -- Standard options- _configBackend :: Backend- , _configHelp :: Bool- , _configBenchmark :: Bool- -- How to execute the program- , _configCutoff :: Int+ _configCutoff :: Int , _configClip :: Int }@@ -24,11 +20,7 @@ defaults :: Config defaults = Config {- _configBackend = maxBound- , _configHelp = False- , _configBenchmark = False-- , _configCutoff = 100+ _configCutoff = 10 , _configClip = 128 } @@ -42,14 +34,6 @@ , 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@@ -74,5 +58,5 @@ ] footer :: [String]-footer = []+footer = [ "" ]
examples/fft/src-acc/HighPass.hs view
@@ -36,8 +36,8 @@ 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+ inx = x >* centreX - cutoff &&* x A.<* centreX + cutoff+ iny = y >* centreY - cutoff &&* y A.<* centreY + cutoff in inx &&* iny ? (constant (0 :+ 0), arrFreq A.! ix)
examples/fft/src-acc/Main.hs view
@@ -4,27 +4,29 @@ 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+import Data.Array.Accelerate.Examples.Internal 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+ = do+ beginMonitoring+ argv <- getArgs+ (conf, opts, rest) <- parseArgs options defaults header footer argv+ (fileIn, fileOut) <- case rest of (i:o:_) -> return (i,o)- _ -> parseArgs configHelp configBackend options defaults header footer ("--help":argv)+ _ -> parseArgs options defaults header footer ("--help":argv) >> exitSuccess -- Read in the image file@@ -39,24 +41,20 @@ cutoff = get configCutoff conf clip = get configClip conf- backend = get configBackend conf+ backend = get optBackend opts - 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)+ -- Write out the images to file+ --+ 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+ 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- ]+ runBenchmarks opts (P.drop 2 rest)+ [ 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
@@ -1,6 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-} -- -- Configuration parameters --@@ -8,13 +8,13 @@ module Config where import Type-import ParseArgs import Data.Label import Control.Monad import Prelude as P import Data.Array.Accelerate as A import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Examples.Internal as A data Initial a@@ -40,11 +40,6 @@ , _initialDensity :: DensityField , _initialVelocity :: VelocityField - -- misc- , _optBackend :: !Backend- , _optBench :: !Bool- , _optHelp :: !Bool- -- extra options to specify initial conditions for command parsing , _setupDensity :: Initial DensityField , _setupVelocity :: Initial VelocityField@@ -69,10 +64,6 @@ , _initialDensity = error "initial density??" , _initialVelocity = error "initial velocity??" - , _optBackend = maxBound- , _optBench = False- , _optHelp = False- , _setupDensity = FromFunction makeField_empty , _setupVelocity = FromFunction makeField_empty }@@ -144,15 +135,6 @@ , Option [] ["init-elk"] (NoArg init_elk) "initial density field with swirling velocity"-- -- Miscellaneous- , Option [] ["benchmark"]- (NoArg (set optBench True))- (describe optBench "benchmark instead of displaying animation")-- , Option ['h','?'] ["help"]- (NoArg (set optHelp True))- (describe optHelp "show help message") ] where parse f x = set f (read x)@@ -185,15 +167,16 @@ , " r reset the image" , " d toggle display of density field" , " v toggle display of velocity field lines"+ , "" ] -- Initial conditions -- ------------------ -initialiseConfig :: Config -> IO Config-initialiseConfig conf = do- let backend = get optBackend conf+initialiseConfig :: (Config, Options, [String]) -> IO (Config, Options, [String])+initialiseConfig (conf, opts, rest) = do+ let backend = get optBackend opts width = get simulationWidth conf height = get simulationHeight conf @@ -205,9 +188,11 @@ FromFile fn -> loadVelocity_bmp backend fn width height FromFunction f -> return (f backend width height) - return . set initialDensity dens- . set initialVelocity velo- $ conf+ let conf' = set initialDensity dens+ . set initialVelocity velo+ $ conf++ return (conf', opts, rest) makeField_empty :: FieldElt e => Backend -> Int -> Int -> Field e
examples/fluid/src-acc/Fluid.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} -- -- Fluid simulation --@@ -167,7 +168,7 @@ -- read the density values surrounding the calculated advection point get ix'@(Z :. j' :. i')- = (j' <* 0 ||* i' <* 0 ||* j' >=* h ||* i' >=* w)+ = (j' A.<* 0 ||* i' A.<* 0 ||* j' >=* h ||* i' >=* w) ? (A.constant zero, df A.! A.lift ix') d00 = get (Z :. j0 :. i0)
examples/fluid/src-acc/Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- -- A stable fluid simulation --@@ -8,38 +7,35 @@ module Main where import Config-import Monitoring-import ParseArgs import World import Fluid import Event import Data.Label-import Criterion.Main ( defaultMainWith, bench, whnf ) import Control.Exception import System.Environment import Graphics.Gloss.Interface.IO.Game -import Prelude as P-import Data.Array.Accelerate as A+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A main :: IO () main = do beginMonitoring argv <- getArgs- (c,crit,noms) <- parseArgs optHelp optBackend options defaults header footer argv- opt <- initialiseConfig c+ (conf, opts, rest) <- initialiseConfig =<< parseArgs options defaults header footer argv let -- configuration parameters --- width = get simulationWidth opt * get displayScale opt- height = get simulationHeight opt * get displayScale opt- steps = get simulationSteps opt- fps = get displayFramerate opt- dp = get viscosity opt- dn = get diffusion opt- dt = get timestep opt- backend = get optBackend opt+ width = get simulationWidth conf * get displayScale conf+ height = get simulationHeight conf * get displayScale conf+ steps = get simulationSteps conf+ fps = get displayFramerate conf+ dp = get viscosity conf+ dn = get diffusion conf+ dt = get timestep conf+ backend = get optBackend opts -- Prepare user-input density and velocity sources --@@ -69,25 +65,20 @@ -- warming up... --- initialWorld <- evaluate (initialise opt)+ initialWorld <- evaluate (initialise conf) _ <- evaluate (simulate initialWorld) -#ifndef ACCELERATE_ENABLE_GUI- if True-#else- if get optBench opt-#endif- -- benchmark- then withArgs noms $ defaultMainWith crit (return ())- [ bench "fluid" $ whnf simulate initialWorld ] - -- simulate- else playIO- (InWindow "accelerate-fluid" (width, height) (10, 20))- black -- background colour- fps -- display framerate- initialWorld -- initial state of the simulation- (render opt) -- render world state into a picture- (\e -> return . react opt e) -- handle user events- (\_ -> return . simulate) -- one step of the simulation+ runBenchmarks opts rest+ [ bench "fluid" $ whnf simulate initialWorld ]++ runInteractive opts rest+ $ playIO+ (InWindow "accelerate-fluid" (width, height) (10, 20))+ black -- background colour+ fps -- display framerate+ initialWorld -- initial state of the simulation+ (render conf) -- render world state into a picture+ (\e -> return . react conf e) -- handle user events+ (\_ -> return . simulate) -- one step of the simulation
examples/fluid/src-acc/World.hs view
@@ -11,6 +11,7 @@ import Data.Word import Data.Label+import Graphics.Gloss.Rendering import Graphics.Gloss.Interface.IO.Game import Foreign.Ptr import Foreign.ForeignPtr
examples/hashcat/Config.hs view
@@ -4,23 +4,18 @@ module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt data Config = Config {- -- How to execute the search- _configBackend :: Backend- -- Input data- , _configStrings :: [String]+ _configStrings :: [String] , _configDict :: FilePath , _configMaxWords :: Maybe Int , _configSkipWords :: Int-- , _configHelp :: Bool } deriving Show @@ -29,12 +24,10 @@ defaults :: Config defaults = Config {- _configBackend = maxBound- , _configStrings = []+ _configStrings = [] , _configDict = [] , _configMaxWords = Nothing , _configSkipWords = 0- , _configHelp = False } @@ -57,10 +50,6 @@ , Option ['n'] ["max-words"] (ReqArg (set configMaxWords . Just . read) "INT") "Use at most this many words from the list"-- , Option ['h', '?'] ["help"]- (NoArg (set configHelp True))- "show this help message" ] @@ -75,5 +64,5 @@ ] footer :: [String]-footer = []+footer = [ "" ]
examples/hashcat/Digest.hs view
@@ -6,7 +6,6 @@ import MD5 import Config -import Prelude import Data.Label import Control.Monad import Control.Applicative@@ -14,6 +13,7 @@ import qualified Data.Serialize as S import qualified Data.ByteString as S import qualified Data.ByteString.Lazy.Char8 as L+import Prelude import Data.Array.Accelerate.Array.Data as A import Data.Array.Accelerate.Array.Sugar as A
examples/hashcat/MD5.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-} module MD5 ( @@ -8,17 +9,17 @@ ) where -import Prelude as P import Numeric import Control.Monad import Control.Applicative import Data.Maybe import Data.List ( foldl' ) import Data.Bits hiding ( rotateL )+import Data.ByteString.Lex.Integral ( readHexadecimal ) import qualified Data.Serialize as S import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.ByteString.Lex.Integral ( readHexadecimal )+import Prelude as P import Data.Array.Accelerate as A
examples/hashcat/Main.hs view
@@ -1,12 +1,11 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-} module Main where import Config import Digest import MD5-import Monitoring-import ParseArgs-import Util import Data.Label import Text.Printf@@ -15,16 +14,19 @@ import Criterion.Measurement import System.IO import System.Environment-import Data.Array.Accelerate ( Z(..), (:.)(..) )-import qualified Data.Array.Accelerate as A-import qualified Data.ByteString.Lazy.Char8 as L+import Data.Array.Accelerate ( Z(..), (:.)(..) )+import Data.Array.Accelerate.Examples.Internal+import qualified Data.Array.Accelerate as A+import qualified Data.ByteString.Lazy.Char8 as L+import Prelude main :: IO () main = do+ initializeTime beginMonitoring argv <- getArgs- (conf, _cconf, files) <- parseArgs configHelp configBackend options defaults header footer argv+ (conf, opts, files) <- parseArgs options defaults header footer argv -- Read the plain text word lists. This creates a vector of MD5 chunks ready -- for hashing.@@ -42,7 +44,7 @@ -- function are applied, but is defeated by salting passwords. This is true -- even if the salt is known, so long as it is unique for each password. --- let backend = get configBackend conf+ let backend = get optBackend opts recover hash = let abcd = readMD5 hash@@ -79,4 +81,12 @@ (showFFloatSIBase (Just 2) 1000 persec "Hash/sec") when (r == t) $ putStrLn "All hashes recovered (:"++time :: IO a -> IO (Double, a)+time action = do+ start <- getTime+ result <- action+ end <- getTime+ let !delta = end - start+ return (delta, result)
examples/kmeans/Config.hs view
@@ -2,38 +2,25 @@ module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt -- Configuration options ---data Config- = Config- {- _configBackend :: Backend- , _configHelp :: Bool- }+data Config = Config deriving Show $(mkLabels [''Config]) defaults :: Config defaults = Config- {- _configBackend = maxBound- , _configHelp = False- } -- The set of available command line options -- options :: [OptDescr (Config -> Config)]-options =- [ Option ['h', '?'] ["help"]- (NoArg (set configHelp True))- "show this help message"- ]+options = [] -- Command line decoration@@ -50,5 +37,5 @@ ] footer :: [String]-footer = []+footer = [ "" ]
+ examples/kmeans/GenSamples.hs view
@@ -0,0 +1,114 @@+--+-- Adapted from K-Means sample from "Parallel and Concurrent Programming in+-- Haskell", (c) Simon Marlow, 2013.+--+-- ./generate-samples 5 50000 100000 1010+--++import Control.Monad+import Data.Array+import Data.Binary+import Data.List+import Data.Word+import Data.Random.Normal+import System.Environment+import System.IO+import System.Random+++-- Points+-- ------++type Point = (Float, Float)++zeroPoint :: Point+zeroPoint = (0,0)+++-- Clusters+-----------++type Cluster = (Word32, Point)++makeCluster :: Int -> [Point] -> Cluster+makeCluster clid points+ = ( fromIntegral clid+ , (a / fromIntegral count, b / fromIntegral count))+ where+ (a,b) = foldl' addPoint zeroPoint points+ count = length points++ addPoint :: Point -> Point -> Point+ addPoint (x,y) (u,v) = (x+u,y+v)+++-- Generate random points+-- ----------------------++minX, maxX, minY, maxY, minSD, maxSD :: Float+minX = -10+maxX = 10+minY = -10+maxY = 10+minSD = 1.5+maxSD = 2.0++main :: IO ()+main = do+ n: minp: maxp: rest <- fmap (fmap read) getArgs++ case rest of+ [seed] -> setStdGen (mkStdGen seed)+ _ -> return ()++ nps <- replicateM n (randomRIO (minp, maxp))+ xs <- replicateM n (randomRIO (minX, maxX))+ ys <- replicateM n (randomRIO (minY, maxY))+ sds <- replicateM n (randomRIO (minSD, maxSD))++ let params = zip5 nps xs ys sds sds++ -- first generate a set of points for each set of sample parameters+ ss <- mapM (\(a,b,c,d,e) -> generate2DSamples a b c d e) params+ let points = concat ss++ -- dump all the points into the file "points"+ hsamp <- openFile "points" WriteMode+ mapM_ (printPoint hsamp) points+ hClose hsamp++ encodeFile "points.bin" points++ -- generate the initial clusters by assigning each point to random+ -- cluster.+ gen <- newStdGen+ let+ rand_clusters = randomRs (0,n-1) gen :: [Int]+ arr = accumArray (flip (:)) [] (0,n-1) $+ zip rand_clusters points+ clusters = map (uncurry makeCluster) (assocs arr)+ writeFile "clusters" (show clusters)++ -- so we can tell what the answer should be:+ writeFile "params" (show params)+++printPoint :: Handle -> Point -> IO ()+printPoint h (x,y) = do+ hPutStr h (show x)+ hPutChar h ' '+ hPutStr h (show y)+ hPutChar h '\n'++generate2DSamples+ :: Int -- number of samples to generate+ -> Float -> Float -- X and Y of the mean+ -> Float -> Float -- X and Y standard deviations+ -> IO [Point]+generate2DSamples n mx my sdx sdy = do+ gen <- newStdGen+ let (genx, geny) = split gen+ xsamples = normals' (mx,sdx) genx+ ysamples = normals' (my,sdy) geny+ return (zipWith (,) (take n xsamples) ysamples)+
examples/kmeans/Kmeans.hs view
@@ -86,7 +86,7 @@ let d = A.snd st d' = distance p (centroidOfCluster c) in- d' <* d ? ( lift (idOfCluster c, d') , st )+ d' A.<* d ? ( lift (idOfCluster c, d') , st ) -- Given a vector of points and a vector of clusters we, we first locate the
examples/kmeans/Main.hs view
@@ -7,55 +7,54 @@ import Kmeans import Config-import Monitoring-import ParseArgs -import Prelude as P import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -import Control.Applicative ( (<$>), (<*>) )+import Control.Applicative import Control.Monad ( unless )-import Criterion.Main ( defaultMainWith, bench, whnf ) import Data.Binary ( decodeFile ) import Data.Label ( get ) import System.Directory import System.Environment+import Prelude as P main :: IO ()-main- = do beginMonitoring- argv <- getArgs- (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv+main = do - inputs <- (&&) <$> doesFileExist "points.bin"- <*> doesFileExist "clusters"- unless inputs $ do- error "Run the GenSamples program first to generate random data"+ beginMonitoring+ argv <- getArgs+ (_, opts, rest) <- parseArgs options defaults header footer argv - points' <- decodeFile "points.bin"- initial' <- read `fmap` readFile "clusters"+ inputs <- (&&) <$> doesFileExist "points.bin"+ <*> doesFileExist "clusters"+ unless inputs $ do+ error "Run the GenSamples program first to generate random data" - let nclusters = P.length initial'- npoints = P.length points'+ points' <- decodeFile "points.bin"+ initial' <- read `fmap` readFile "clusters" - solve = run1 backend (kmeans (use points))- backend = get configBackend conf+ let nclusters = P.length initial'+ npoints = P.length points' - initial :: Vector (Cluster Float)- initial = A.fromList (Z:.nclusters) initial'+ solve = run1 backend (kmeans (use points))+ backend = get optBackend opts - points :: Vector (Point Float)- points = A.fromList (Z:.npoints) points'+ initial :: Vector (Cluster Float)+ initial = A.fromList (Z:.nclusters) initial' - -- Warm up first by printing the expected results- --- putStrLn $ "number of points: " P.++ show npoints- putStrLn $ "final clusters:\n" P.++- unlines (P.map show . A.toList $ solve initial)+ points :: Vector (Point Float)+ points = A.fromList (Z:.npoints) points' - -- Now benchmark- --- withArgs nops $ defaultMainWith cconf (return ())- [ bench "k-means" $ whnf solve initial ]+ -- Warm up first by printing the expected results+ --+ putStrLn $ "number of points: " P.++ show npoints+ putStrLn $ "final clusters:\n" P.+++ unlines (P.map show . A.toList $ solve initial)++ -- Now benchmark+ --+ runBenchmarks opts rest+ [ bench "k-means" $ whnf solve initial ]
examples/mandelbrot/Config.hs view
@@ -1,55 +1,43 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt -data Options = Options++data Config = Config {- _optBackend :: Backend- , _optWidth :: Int- , _optHeight :: Int- , _optLimit :: Int- , _optFramerate :: Int- , _optBench :: Bool- , _optHelp :: Bool+ _configWidth :: Int+ , _configHeight :: Int+ , _configLimit :: Int+ , _configFramerate :: Int } deriving Show -$(mkLabels [''Options])+$(mkLabels [''Config]) -defaults :: Options-defaults = Options- { _optBackend = maxBound- , _optWidth = 800- , _optHeight = 600- , _optLimit = 255- , _optFramerate = 25-#ifdef ACCELERATE_ENABLE_GUI- , _optBench = False-#else- , _optBench = True-#endif- , _optHelp = False+defaults :: Config+defaults = Config+ { _configWidth = 800+ , _configHeight = 600+ , _configLimit = 255+ , _configFramerate = 25 } -options :: [OptDescr (Options -> Options)]+options :: [OptDescr (Config -> Config)] options =- [ Option [] ["width"] (ReqArg (set optWidth . read) "INT") "visualisation width (800)"- , Option [] ["height"] (ReqArg (set optHeight . read) "INT") "visualisation height (600)"- , Option [] ["limit"] (ReqArg (set optLimit . read) "INT") "iteration limit for escape (255)"- , Option [] ["framerate"] (ReqArg (set optFramerate . read) "INT")"visualisation framerate (10)"- , Option [] ["static"] (NoArg (set optFramerate 0)) "do not animate the image"- , Option [] ["benchmark"] (NoArg (set optBench True)) "benchmark instead of displaying animation (False)"- , Option "h?" ["help"] (NoArg (set optHelp True)) "show help message"+ [ Option [] ["width"] (ReqArg (set configWidth . read) "INT") "visualisation width (800)"+ , Option [] ["height"] (ReqArg (set configHeight . read) "INT") "visualisation height (600)"+ , Option [] ["limit"] (ReqArg (set configLimit . read) "INT") "iteration limit for escape (255)"+ , Option [] ["framerate"] (ReqArg (set configFramerate . read) "INT") "visualisation framerate (10)"+ , Option [] ["static"] (NoArg (set configFramerate 0)) "do not animate the image" ] header :: [String] header =- [ "accelerate-mandelbrot (c) [2011..2013] The Accelerate Team"+ [ "accelerate-mandelbrot (c) [2011..2014] The Accelerate Team" , "" , "Usage: accelerate-mandelbrot [OPTIONS]" , ""@@ -64,5 +52,6 @@ , " x q zoom out" , " f single precision calculations" , " d double precision calculations (if supported)"+ , "" ]
examples/mandelbrot/Main.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} -- -- A Mandelbrot set generator. -- Originally submitted by Simon Marlow as part of Issue #49.@@ -6,16 +5,13 @@ import World import Config-import Monitoring-import ParseArgs import Data.Label-import Control.Monad-import System.Environment ( getArgs, withArgs )-import Criterion.Main ( defaultMainWith, bench, whnf )+import System.Environment ( getArgs ) import Prelude as P import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A import Graphics.Gloss.Accelerate.Data.Picture as G import qualified Graphics.Gloss as G @@ -27,51 +23,39 @@ main :: IO ()-main- = do- beginMonitoring- argv <- getArgs- (conf, cconf, rest) <- parseArgs optHelp optBackend options defaults header footer argv-- let world = initialWorld conf view- fps = get optFramerate conf- width = get optWidth conf- height = get optHeight conf-- -- Centre coordinates: Re(c) = -0.7; Im(c) = 0- -- View width: 3.067- --- view = (-2.23, -1.15, 0.83, 1.15)+main = do+ beginMonitoring+ argv <- getArgs+ (conf, opts, rest) <- parseArgs options defaults header footer argv - force arr = indexArray arr (Z:.0:.0) `seq` arr+ let world = initialWorld conf opts view+ fps = get configFramerate conf+ width = get configWidth conf+ height = get configHeight conf - mandel- | get optBench conf- = withArgs rest $ defaultMainWith cconf (return ())- [ bench "mandelbrot" $ whnf (force . renderWorld) world ]-#ifdef ACCELERATE_ENABLE_GUI- | fps == 0- = G.display- (G.InWindow "Mandelbrot" (width, height) (10, 10))- G.black- (makePicture world)+ -- Centre coordinates: Re(c) = -0.7; Im(c) = 0+ -- View width: 3.067+ --+ view = (-2.23, -1.15, 0.83, 1.15) - | fps > 0- = G.play- (G.InWindow "Mandelbrot" (width, height) (10, 10))- G.black- fps- world- makePicture- (react conf)- (const refocus)-#endif- | otherwise- = return ()+ force arr = indexArray arr (Z:.0:.0) `seq` arr + runBenchmarks opts rest+ [ bench "mandelbrot" $ whnf (force . renderWorld) world ] - unless (P.null rest) $- putStrLn $ "Warning: unrecognized options: " P.++ show rest+ runInteractive opts rest+ $ if fps == 0+ then G.display+ (G.InWindow "Mandelbrot" (width, height) (10, 10))+ G.black+ (makePicture world) - mandel+ else G.play+ (G.InWindow "Mandelbrot" (width, height) (10, 10))+ G.black+ fps+ world+ makePicture+ (react conf opts)+ (const refocus)
examples/mandelbrot/Mandel.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -- -- A Mandelbrot set generator.@@ -48,7 +49,7 @@ 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)+ in A.snd $ A.while (\zi -> A.snd zi A.<* lIMIT &&* dot (A.fst zi) A.<* 4) (\zi -> lift1 (next c) zi) (lift (c, constant 0))) where@@ -87,13 +88,15 @@ -- Directly convert the iteration count on escape to a colour. The base set -- (x,y,z) yields a dark background with light highlights. --+-- Note that OpenGL reads pixel data in AGBR format, rather than RGBA.+-- escapeToColour :: Exp Int32 -> Exp RGBA32-escapeToColour m = constant 0xFFFFFFFF - (packRGBA32 $ lift (x,y,z,w))+escapeToColour m = constant 0xFFFFFFFF - (packRGBA32 $ lift (a,b,g,r)) where- x = constant 0- w = A.fromIntegral (3 * m)- z = A.fromIntegral (5 * m)- y = A.fromIntegral (7 * m)+ r = A.fromIntegral (3 * m)+ g = A.fromIntegral (5 * m)+ b = A.fromIntegral (7 * m)+ a = constant 0 {--
examples/mandelbrot/World.hs view
@@ -14,12 +14,12 @@ import Mandel import Config-import ParseArgs import Prelude as P import Data.Char import Data.Label import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A import Graphics.Gloss.Interface.Pure.Game hiding ( translate, scale ) @@ -49,21 +49,21 @@ -- Initialise the World state ---initialWorld :: Options -> View Float -> World-initialWorld config view- = setPrecisionOfWorld Float config+initialWorld :: Config -> Options -> View Float -> World+initialWorld conf opts view+ = setPrecisionOfWorld Float conf opts $ World view undefined Nothing Nothing Nothing -- Reset the rendering routines to compute with the specified precision ---setPrecisionOfWorld :: Precision -> Options -> World -> World-setPrecisionOfWorld f config (World p _ z h v)+setPrecisionOfWorld :: Precision -> Config -> Options -> World -> World+setPrecisionOfWorld f conf opts (World p _ z h v) = let- width = get optWidth config- height = get optHeight config- limit = get optLimit config- backend = get optBackend config+ width = get configWidth conf+ height = get configHeight conf+ limit = get configLimit conf+ backend = get optBackend opts render :: (Elt a, IsFloating a) => Render a render = run1 backend@@ -131,8 +131,8 @@ -- size is (100,100) with scale factor of 4, then the event coordinates are -- returned in the range [-200,200]. ---react :: Options -> Event -> World -> World-react opt event world+react :: Config -> Options -> Event -> World -> World+react conf opts event world = case event of EventKey (Char c) s _ _ -> char (toLower c) s world EventKey (SpecialKey c) s _ _ -> special c s world@@ -156,7 +156,7 @@ toggle f x Down = set f (Just x) toggle f _ Up = set f Nothing - precision f Down = setPrecisionOfWorld f opt+ precision f Down = setPrecisionOfWorld f conf opts precision _ _ = id preset n Down = loadPreset (read [n])
examples/n-body/Config.hs view
@@ -2,12 +2,12 @@ module Config where -import ParseArgs import Common.Type import Data.Char import Data.List import Data.Label+import System.Console.GetOpt data Solver = Naive1 | Naive2 | BarnsHut@@ -18,8 +18,7 @@ = Config { -- How to execute the simulation- _configBackend :: Backend- , _configSolver :: Solver+ _configSolver :: Solver -- How to present the output , _configWindowSize :: Int@@ -38,8 +37,6 @@ -- Terminating conditions , _configMaxSteps :: Maybe Int- , _configBenchmark :: Bool- , _configHelp :: Bool -- Dump final particle locations to file , _configDumpFinal :: Maybe FilePath@@ -52,8 +49,7 @@ defaults :: Config defaults = Config {- _configBackend = maxBound- , _configSolver = Naive2 -- no barns-hut yet!+ _configSolver = Naive2 -- no barns-hut yet! , _configWindowSize = 1000 , _configShouldDrawTree = False -- no barns-hut yet!@@ -68,9 +64,6 @@ , _configStartSpeed = 1 , _configMaxSteps = Nothing- , _configBenchmark = False- , _configHelp = False- , _configDumpFinal = Nothing } @@ -123,17 +116,9 @@ (ReqArg (set configMaxSteps . read) "INT") (describe configMaxSteps "exit simulation after this many steps") - , Option [] ["benchmark"]- (NoArg (set configBenchmark True))- (describe configBenchmark "benchmark instead of displaying animation")- , Option [] ["dump-final"] (ReqArg (set configDumpFinal . Just) "FILE") "dump final body positions to file"-- , Option ['h', '?'] ["help"]- (NoArg (set configHelp True))- "show this help message" ] where solver algorithm@@ -160,5 +145,5 @@ ] footer :: [String]-footer = []+footer = [ "" ]
examples/n-body/Main.hs view
@@ -3,27 +3,25 @@ -- -- friends+import Test import Config-import Monitoring-import ParseArgs import Common.Body import Common.World import Gloss.Draw import Gloss.Event import Gloss.Simulate-import Random.Array import Random.Position-import qualified Solver.Naive1 as Naive1-import qualified Solver.Naive2 as Naive2-import qualified Solver.BarnsHut as BarnsHut+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 )+import Data.Array.Accelerate as A hiding ( size )+import Data.Array.Accelerate.Examples.Internal as A -- system-import Prelude as P+import Prelude as P import Data.Label import System.Environment-import Criterion.Main ( defaultMainWith, bench, whnf ) import Graphics.Gloss.Interface.Pure.Game @@ -31,7 +29,7 @@ main = do beginMonitoring argv <- getArgs- (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer argv let solver = case get configSolver conf of Naive1 -> Naive1.calcAccels@@ -44,7 +42,7 @@ epsilon = get configEpsilon conf mass = get configBodyMass conf radius = get configStartDiscSize conf- backend = get configBackend conf+ backend = get optBackend opts -- Generate random particle positions in a disc layout centred at -- the origin. Start the system rotating with particle speed@@ -56,8 +54,7 @@ bodies = run backend $ A.map (setStartVelOfBody . constant $ get configStartSpeed conf) $ A.zipWith setMassOfBody (A.use masses)- $ A.map unitBody- $ A.use positions+ $ A.map unitBody (A.use positions) -- The initial simulation state --@@ -74,18 +71,22 @@ $ A.uncurry $ advanceBodies (solver $ constant epsilon) + -- Forward unto dawn --- if get configBenchmark conf- then withArgs nops $ defaultMainWith cconf (return ())- [ bench "n-body" $ whnf (advance 0.1) world ]+ runTests opts rest+ $ makeTests step - else play- (InWindow "N-Body" (size, size) (10, 10)) -- window size & position- black -- background colour- fps -- number of simulation steps per second- universe -- initial world- (draw conf) -- fn to convert a world into a picture- react -- fn to handle input events- (simulate advance) -- fn to advance the world+ runBenchmarks opts rest+ [ bench "n-body" $ whnf (advance 0.1) world ]++ runInteractive opts rest+ $ play+ (InWindow "N-Body" (size, size) (10, 10)) -- window size & position+ black -- background colour+ fps -- number of simulation steps per second+ universe -- initial world+ (draw conf) -- fn to convert a world into a picture+ react -- fn to handle input events+ (simulate advance) -- fn to advance the world
examples/n-body/Random/Position.hs view
@@ -9,9 +9,9 @@ import Common.Type -import Random.Array ( (:~>) )-import System.Random.MWC ( uniformR )-import Data.Array.Accelerate.Array.Sugar as A+import System.Random.MWC ( uniformR )+import Data.Array.Accelerate.Examples.Internal ( (:~>) )+import Data.Array.Accelerate.Array.Sugar as A -- | Points distributed as a disc
+ examples/n-body/Test.hs view
@@ -0,0 +1,49 @@++module Test (makeTests)+ where++import Common.Type++import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal++-- Generate the tests+--+makeTests :: (Scalar Time -> Vector Body -> Vector Body) -> [Test]+makeTests step =+ [ testCase "t=0" $ assertEqual t0 t0'+ , testCase "t=10" $ assertEqual t10 t10'+ , testCase "t=20" $ assertEqual t20 t20'+ , testCase "t=30" $ assertEqual t30 t30'+ , testCase "t=40" $ assertEqual t40 t40'+ , testCase "t=50" $ assertEqual t50 t50'+ ]+ where+ advance = foldl1 (.) (P.replicate 10 (step dt))+ t0' = step (fromList Z [0]) bodies+ t10' = advance t0'+ t20' = advance t10'+ t30' = advance t20'+ t40' = advance t30'+ t50' = advance t40'+++-- Input data+--+bodies :: Vector Body+bodies = fromList (Z :. 32) [(((49.934765,48.864784,49.504097),3.456227),(10.561408,-10.792668,10.699586),(0.0,0.0,0.0)),(((-19.72055,21.0447,21.976465),63.459526),(6.989762,6.5499606,7.2992377),(0.0,0.0,0.0)),(((-8.485103,70.43111,-66.07767),74.34554),(14.306272,1.7235309,-13.421982),(0.0,0.0,0.0)),(((-40.529545,-23.411388,-23.874193),8.434827),(-6.4595428,11.182692,-6.5872374),(0.0,0.0,0.0)),(((36.915504,-13.378705,22.885813),16.776989),(-3.9690585,-10.951718,6.7895308),(0.0,0.0,0.0)),(((58.12199,47.11681,49.27831),21.63172),(9.955754,-12.281143,10.4124775),(0.0,0.0,0.0)),(((-18.56515,19.121122,19.856537),69.831604),(6.6335444,6.440665,6.8886757),(0.0,0.0,0.0)),(((-16.319696,68.65275,-70.91549),66.98223),(13.727621,3.263243,-14.180073),(0.0,0.0,0.0)),(((-35.320797,-9.581309,-15.5530615),23.477612),(-3.0388143,11.202367,-4.932819),(0.0,0.0,0.0)),(((35.467846,-31.458008,57.63878),4.5274367),(-7.2828484,-8.211167,13.343963),(0.0,0.0,0.0)),(((22.741138,16.762173,47.443493),45.534313),(4.5114946,-6.1207175,12.769291),(0.0,0.0,0.0)),(((-19.066488,32.53443,19.284454),37.293446),(9.998227,5.859364,5.926348),(0.0,0.0,0.0)),(((-4.6187997,54.83043,-69.1615),52.771004),(11.664729,0.9826122,-14.713549),(0.0,0.0,0.0)),(((-37.741123,-23.498236,-29.302645),83.92678),(-6.4404936,10.344243,-8.03139),(0.0,0.0,0.0)),(((36.013374,-17.063395,32.41684),13.032608),(-4.7614217,-10.049282,9.045693),(0.0,0.0,0.0)),(((49.562435,83.03267,83.920395),18.12446),(14.676114,-8.760214,14.83302),(0.0,0.0,0.0)),(((-9.462863,25.536043,36.41799),53.132633),(7.573575,2.8065314,10.800983),(0.0,0.0,0.0)),(((-10.790539,66.63314,-67.998985),94.62536),(13.614646,2.204749,-13.893719),(0.0,0.0,0.0)),(((-40.558056,-29.971233,-24.474981),6.5728045),(-8.00616,10.834197,-6.5379558),(0.0,0.0,0.0)),(((29.8883,-20.165321,45.04451),53.180336),(-5.309554,-7.869626,11.860275),(0.0,0.0,0.0)),(((32.482105,30.910307,49.05143),91.3407),(7.583363,-7.9689794,12.034005),(0.0,0.0,0.0)),(((-20.018032,19.918154,27.472118),87.52959),(6.346644,6.378469,8.753611),(0.0,0.0,0.0)),(((-12.006343,50.781525,-48.374542),75.542244),(12.0401945,2.8466792,-11.469504),(0.0,0.0,0.0)),(((-36.06932,-13.634953,-28.24347),35.689384),(-3.9444003,10.434348,-8.17044),(0.0,0.0,0.0)),(((36.564384,-22.889074,41.142605),77.35545),(-5.9291406,-9.471566,10.6575),(0.0,0.0,0.0)),(((72.98635,36.489113,44.127728),34.4798),(7.5769863,-15.15566,9.163149),(0.0,0.0,0.0)),(((-6.637457,11.754714,14.4537),20.805649),(5.286392,2.9850323,6.5001945),(0.0,0.0,0.0)),(((-5.4672456,71.23518,-59.5781),58.3743),(14.7713995,1.1336936,-12.354176),(0.0,0.0,0.0)),(((-43.633926,-22.012821,-7.0467205),20.659788),(-6.265288,12.4190855,-2.0056372),(0.0,0.0,0.0)),(((54.48485,-44.066643,29.847332),82.26547),(-10.098527,-12.486015,6.8399606),(0.0,0.0,0.0)),(((50.216465,50.00622,49.413647),86.262726),(10.759963,-10.805201,10.632457),(0.0,0.0,0.0)),(((-24.18221,1.1176014,18.39111),52.37195),(0.40538555,8.771569,6.670974),(0.0,0.0,0.0))]++dt :: Scalar Time+dt = fromList Z [0.1]++-- Take a number of steps in 0.1 second increments+--+t0, t10, t20, t30, t40, t50 :: Vector Body+t0 = fromList (Z :. 32) [(((49.934765,48.864784,49.504097),3.456227),(10.561408,-10.792668,10.699586),(-0.2020692,-0.18428235,-0.13120669)),(((-19.72055,21.0447,21.976465),63.459526),(6.989762,6.5499606,7.2992377),(3.0261776,-0.7999116,-1.3126944)),(((-8.485103,70.43111,-66.07767),74.34554),(14.306272,1.7235309,-13.421982),(-0.1371406,-3.710925,3.796874)),(((-40.529545,-23.411388,-23.874193),8.434827),(-6.4595428,11.182692,-6.5872374),(0.42419815,0.5393226,0.31401542)),(((36.915504,-13.378705,22.885813),16.776989),(-3.9690585,-10.951718,6.7895308),(-0.9118709,0.8006712,0.2444)),(((58.12199,47.11681,49.27831),21.63172),(9.955754,-12.281143,10.4124775),(-1.5379857,-0.9758822,-0.7344652)),(((-18.56515,19.121122,19.856537),69.831604),(6.6335444,6.440665,6.8886757),(2.988307,-0.41186926,-0.9475892)),(((-16.319696,68.65275,-70.91549),66.98223),(13.727621,3.263243,-14.180073),(1.625271,-2.7936146,4.267117)),(((-35.320797,-9.581309,-15.5530615),23.477612),(-3.0388143,11.202367,-4.932819),(1.208595,1.1207385,0.7841558)),(((35.467846,-31.458008,57.63878),4.5274367),(-7.2828484,-8.211167,13.343963),(-0.12642522,0.3105037,-0.2921983)),(((22.741138,16.762173,47.443493),45.534313),(4.5114946,-6.1207175,12.769291),(-1.232773,2.6571987e-2,-2.692973)),(((-19.066488,32.53443,19.284454),37.293446),(9.998227,5.859364,5.926348),(1.6313204,-1.8151838,-0.52129644)),(((-4.6187997,54.83043,-69.1615),52.771004),(11.664729,0.9826122,-14.713549),(-0.81280035,-0.112044565,3.5451076)),(((-37.741123,-23.498236,-29.302645),83.92678),(-6.4404936,10.344243,-8.03139),(3.5243607,5.315734,3.9011729)),(((36.013374,-17.063395,32.41684),13.032608),(-4.7614217,-10.049282,9.045693),(-0.61353976,0.70832497,-0.11806177)),(((49.562435,83.03267,83.920395),18.12446),(14.676114,-8.760214,14.83302),(-0.4695076,-1.0319139,-1.0167954)),(((-9.462863,25.536043,36.41799),53.132633),(7.573575,2.8065314,10.800983),(1.3853245,-1.4187478,-3.0760522)),(((-10.790539,66.63314,-67.998985),94.62536),(13.614646,2.204749,-13.893719),(0.56374645,-3.55292,5.51218)),(((-40.558056,-29.971233,-24.474981),6.5728045),(-8.00616,10.834197,-6.5379558),(0.30523086,0.47446692,0.23335022)),(((29.8883,-20.165321,45.04451),53.180336),(-5.309554,-7.869626,11.860275),(-1.4631323,3.3048942,-2.3880641)),(((32.482105,30.910307,49.05143),91.3407),(7.583363,-7.9689794,12.034005),(-3.6304643,-2.5821278,-4.8232713)),(((-20.018032,19.918154,27.472118),87.52959),(6.346644,6.378469,8.753611),(4.4817963,-0.7540304,-3.3089616)),(((-12.006343,50.781525,-48.374542),75.542244),(12.0401945,2.8466792,-11.469504),(0.74818593,-0.64892244,1.946604)),(((-36.06932,-13.634953,-28.24347),35.689384),(-3.9444003,10.434348,-8.17044),(1.5595063,1.77316,1.7561425)),(((36.564384,-22.889074,41.142605),77.35545),(-5.9291406,-9.471566,10.6575),(-3.1575167,4.8282127,-2.4603796)),(((72.98635,36.489113,44.127728),34.4798),(7.5769863,-15.15566,9.163149),(-3.1058714,-0.73178864,-0.6773815)),(((-6.637457,11.754714,14.4537),20.805649),(5.286392,2.9850323,6.5001945),(6.1454386e-2,0.3914103,0.19268043)),(((-5.4672456,71.23518,-59.5781),58.3743),(14.7713995,1.1336936,-12.354176),(-0.6793159,-3.241285,1.9731628)),(((-43.633926,-22.012821,-7.0467205),20.659788),(-6.265288,12.4190855,-2.0056372),(1.3458371,1.3664191,0.22117926)),(((54.48485,-44.066643,29.847332),82.26547),(-10.098527,-12.486015,6.8399606),(-4.644851,6.0297318,-0.19813985)),(((50.216465,50.00622,49.413647),86.262726),(10.759963,-10.805201,10.632457),(-5.0198126,-4.7489667,-3.2173421)),(((-24.18221,1.1176014,18.39111),52.37195),(0.40538555,8.771569,6.670974),(2.865766,2.5242555,-0.771268))]+t10 = fromList (Z :. 32) [(((60.402256,37.99447,60.14521),3.456227),(10.347675,-10.957504,10.569622),(-0.22668193,-0.14637746,-0.13127826)),(((-11.430504,27.125307,28.753597),63.459526),(9.780841,5.350463,6.240201),(2.5433345,-1.5698189,-0.8167556)),(((5.672099,70.57071,-77.842896),74.34554),(13.856287,-1.666952,-9.809946),(-0.7218549,-3.07428,3.454369)),(((-46.79211,-12.007825,-30.323624),8.434827),(-6.012946,11.642888,-6.2869954),(0.46778414,0.38886592,0.2849534)),(((32.574455,-23.946268,29.79417),16.776989),(-4.7382054,-10.062807,7.0655513),(-0.6296934,0.97357625,0.30322555)),(((67.3728,34.43472,59.36437),21.63172),(8.367946,-13.115515,9.689009),(-1.6421701,-0.6976927,-0.72507)),(((-10.644274,25.257013,26.39887),69.831604),(9.401735,5.590103,6.2358103),(2.5346236,-1.2643027,-0.3754633)),(((-1.9366095,70.68937,-83.21151),66.98223),(15.068537,0.5764816,-10.042387),(1.0556761,-2.6000845,4.0255356)),(((-37.81175,2.0563722,-20.14278),23.477612),(-1.817153,12.071388,-4.190213),(1.2293873,0.63759214,0.687956)),(((28.138607,-39.52876,70.849945),4.5274367),(-7.370752,-7.898251,13.046776),(-5.1867843e-2,0.31481925,-0.30228883)),(((26.732052,10.697684,58.990242),45.534313),(3.4046803,-5.9327974,10.0338125),(-0.98696345,0.33534586,-2.785121)),(((-8.415286,37.529408,25.032337),37.293446),(11.330664,3.876094,5.60827),(1.0490761,-2.1232,-0.13574754)),(((6.675616,55.826862,-82.31381),52.771004),(10.847925,1.0917499,-11.286869),(-0.7843886,0.27396658,3.3349295)),(((-42.53744,-10.963094,-35.619644),83.92678),(-2.7064044,14.917309,-4.294997),(3.9198356,3.8610702,3.5435603)),(((31.007177,-26.778881,41.412075),13.032608),(-5.2589273,-9.285036,8.936092),(-0.38566536,0.8186842,-0.10571819)),(((64.01576,73.82858,98.300285),18.12446),(14.1636095,-9.714817,13.833233),(-0.55458456,-0.8758056,-0.98143333)),(((-1.29756,27.675724,45.853508),53.132633),(8.84061,1.2858781,7.796603),(1.1496811,-1.6105593,-2.9288754)),(((2.984476,67.32786,-79.47979),94.62536),(13.839526,-1.0205598,-8.638148),(-8.429852e-2,-2.9109285,4.988788)),(((-48.420025,-18.939562,-30.91017),6.5728045),(-7.6758323,11.250289,-6.3134418),(0.35382912,0.36280265,0.21467017)),(((24.05571,-26.526985,55.817623),53.180336),(-6.2717843,-4.4937367,9.426997),(-0.48020265,3.4272532,-2.4739354)),(((38.412075,21.907555,58.91943),91.3407),(3.8768096,-10.066701,7.232523),(-3.7875612,-1.6009333,-4.7642846)),(((-11.713844,25.808075,34.806118),87.52959),(10.581014,5.0761976,5.7207565),(3.913912,-1.8188158,-2.7121327)),(((0.29591668,53.392735,-59.070557),75.542244),(12.523133,2.3962336,-9.897869),(0.258676,-0.2904919,1.2244126)),(((-39.304882,-2.4880366,-35.646812),35.689384),(-2.3586354,11.898649,-6.5040054),(1.6116967,1.186789,1.5703841)),(((29.410185,-30.127684,50.689945),77.35545),(-8.353604,-4.429852,8.189255),(-1.6932052,5.2191257,-2.4670205)),(((79.16618,21.078148,52.9975),34.4798),(4.4726243,-15.612979,8.523445),(-3.1038995,-0.19130452,-0.6173794)),(((-1.3194776,14.902553,21.06105),20.805649),(5.366333,3.3273313,6.76692),(0.10942383,0.29500887,0.33297652)),(((8.919601,70.99377,-71.09529),58.3743),(13.811482,-1.798587,-10.556653),(-1.1980586,-2.6337848,1.6664244)),(((-49.27589,-9.043354,-8.953376),20.659788),(-4.8574266,13.547301,-1.7893666),(1.4573994,0.90100104,0.20331861)),(((42.495594,-53.756332,36.63188),82.26547),(-13.994319,-6.1497493,6.7633076),(-3.1410325,6.6301613,3.0234138e-2)),(((58.644115,37.20186,58.620056),86.262726),(5.4610834,-15.029127,7.486924),(-5.588184,-3.6724644,-3.101759)),(((-22.410553,10.888989,24.760492),52.37195),(3.5517094,10.775686,6.068233),(3.405976,1.4547812,-0.44147408))]+t20 = fromList (Z :. 32) [(((70.64258,26.97726,70.65352),3.456227),(10.103177,-11.083501,10.430128),(-0.25878596,-0.1096651,-0.14805585)),(((-0.60530925,31.649681,34.703568),63.459526),(11.983897,3.3875232,5.6731596),(1.9059213,-2.2702324,-0.38499674)),(((19.129223,67.63949,-86.13814),74.34554),(12.898823,-4.338295,-6.4802012),(-1.11779,-2.3244681,3.2478783)),(((-52.587482,-0.21061647,-36.487682),8.434827),(-5.521948,11.965574,-6.018765),(0.5088869,0.27565396,0.25721252)),(((27.600586,-33.542427,37.002804),16.776989),(-5.2118816,-8.994746,7.3886538),(-0.35461906,1.1443055,0.33297035)),(((74.98001,21.052492,68.71739),21.63172),(6.6536603,-13.656725,8.92714),(-1.7712361,-0.41551957,-0.8035278)),(((-0.1968162,30.138866,32.549713),69.831604),(11.614001,3.864655,6.1276393),(1.9305562,-2.0955043,7.4945375e-2)),(((13.495451,70.11945,-91.47385),66.98223),(15.745442,-1.9447142,-6.1191072),(0.34707648,-2.4542372,3.844818)),(((-39.07626,14.344181,-24.048937),23.477612),(-0.5911909,12.481703,-3.5879762),(1.2193754,0.2451571,0.5313611)),(((20.755718,-47.285156,83.758934),4.5274367),(-7.3864875,-7.5831957,12.738908),(1.0477281e-2,0.3141431,-0.31150085)),(((29.731346,4.957616,67.74644),45.534313),(2.542373,-5.4659686,7.1639175),(-0.773719,0.55258787,-2.949255)),(((3.2952871,40.414585,30.630938),37.293446),(12.0785885,1.6407151,5.635318),(0.5175421,-2.311788,0.13688904)),(((17.204876,57.061028,-92.11485),52.771004),(10.187838,1.4056993,-7.992482),(-0.5327076,0.28180283,3.2848911)),(((-43.428978,5.4403176,-38.405262),83.92678),(1.3721125,17.93844,-1.0416794),(4.1768746,2.3258047,2.9994802)),(((25.61177,-35.67625,50.29802),13.032608),(-5.5239754,-8.40189,8.819078),(-0.17469631,0.9371397,-0.13386086)),(((77.91648,63.749935,111.700096),18.12446),(13.566664,-10.48896,12.8802395),(-0.6257403,-0.68909454,-0.9268724)),(((8.015066,28.20771,52.363438),53.132633),(9.834624,-0.42201662,4.975245),(0.8522565,-1.7886617,-2.724254)),(((16.687307,65.11167,-85.9828),94.62536),(13.431137,-3.5456862,-4.025685),(-0.6603307,-2.1941738,4.275058)),(((-55.929226,-7.5420556,-37.130413),6.5728045),(-7.2981763,11.561206,-6.1095667),(0.39473253,0.27254176,0.196624)),(((17.732718,-29.473835,64.11756),53.180336),(-6.2080007,-1.0590713,6.9066863),(0.49391943,3.4189227,-2.5597522)),(((40.55933,11.31991,64.03876),91.3407),(1.478368e-2,-10.987337,2.5858128),(-3.8935337,-0.3199196,-4.506024)),(((0.45339978,29.896873,39.454823),87.52959),(13.876055,2.7052927,3.5193348),(2.690946,-2.7923274,-1.7411938)),(((12.880193,55.68854,-68.52059),75.542244),(12.610873,2.1888132,-9.000532),(-1.7048633e-2,-0.18977338,0.6773345)),(((-40.928196,9.86234,-41.4781),35.689384),(-0.7128805,12.819815,-5.0434055),(1.6750612,0.72688335,1.3807626)),(((20.569416,-32.173176,57.774376),77.35545),(-9.122361,0.8884996,5.742017),(1.2530923e-2,5.3429766,-2.4258206)),(((82.24203,5.4715424,61.2392),34.4798),(1.3694282,-15.498303,7.885867),(-3.0998273,0.35917798,-0.67349565)),(((4.1159596,18.343342,27.995344),20.805649),(5.547433,3.5543864,7.153706),(0.2545224,0.16027838,0.41772422)),(((22.132597,68.11572,-80.91648),58.3743),(12.430078,-4.07933,-8.919203),(-1.4921408,-1.9892223,1.665496)),(((-53.46823,4.8355,-10.660793),20.659788),(-3.3736873,14.207917,-1.6194743),(1.4933307,0.48024258,0.13877386)),(((27.381256,-56.825172,43.436813),82.26547),(-16.138443,0.79542387,6.8798237),(-1.272959,7.1740904,0.16700138)),(((61.48199,20.758127,64.70831),86.262726),(-0.48431414,-17.875822,4.367215),(-6.221025,-2.0769675,-3.1554008)),(((-17.251387,22.09256,30.678736),52.37195),(7.1905856,11.458972,5.7806373),(3.7821503,9.846892e-3,-0.18520965))]+t30 = fromList (Z :. 32) [(((80.62529,15.850722,81.01362),3.456227),(9.832466,-11.171636,10.271142),(-0.27626523,-6.907271e-2,-0.16648479)),(((12.109674,33.908443,40.254055),63.459526),(13.452332,0.7633101,5.4452367),(1.0651537,-2.9039454,-0.13198845)),(((31.485191,62.397385,-91.180084),74.34554),(11.659424,-6.17881,-3.3099105),(-1.3080394,-1.4175643,3.1050818)),(((-57.875084,11.86496,-42.392822),8.434827),(-4.9964967,12.19545,-5.7677174),(0.53527856,0.19483553,0.24825694)),(((22.266294,-41.991844,44.539543),16.776989),(-5.4461217,-7.745878,7.7115583),(-0.14457354,1.3438723,0.30253243)),(((80.82082,7.255052,77.26334),21.63172),(4.8354826,-13.9168,8.057859),(-1.8398229,-0.1291134,-0.92295176)),(((12.16488,32.92552,38.752),69.831604),(13.12455,1.3194892,6.3205833),(1.1184452,-2.9104452,0.23775212)),(((29.262188,67.1042,-95.894775),66.98223),(15.635218,-4.276028,-2.3869843),(-0.5043809,-2.201609,3.6215343)),(((-39.12235,26.887955,-27.421051),23.477612),(0.6162337,12.572925,-3.130873),(1.1982962,-1.6151225e-2,0.4058443)),(((13.381501,-54.72822,96.35743),4.5274367),(-7.351956,-7.273869,12.427602),(5.11916e-2,0.3034085,-0.3084455)),(((31.944645,-0.24181631,73.54906),45.534313),(1.8208045,-4.8607187,4.099617),(-0.7120765,0.6306646,-3.160519)),(((15.529402,40.993393,36.353447),37.293446),(12.340105,-0.740232,5.8483925),(5.584805e-2,-2.4297142,0.2502288)),(((27.210176,58.54192,-98.62292),52.771004),(9.847976,1.4936708,-4.6850176),(-0.17808737,-0.12827606,3.3288074)),(((-40.165707,24.159132,-38.19885),83.92678),(5.569859,19.36941,1.6151043),(4.1652684,0.6796782,2.36701)),(((20.0366,-43.634075,59.045513),13.032608),(-5.610209,-7.3880525,8.644443),(-2.1231862e-2,1.0824242,-0.2157843)),(((91.1954,52.98254,124.174416),18.12446),(12.923086,-11.0728035,11.991299),(-0.65076464,-0.49877062,-0.85619026)),(((18.163801,26.950344,56.156433),53.132633),(10.439416,-2.310497,2.4027362),(0.35562944,-1.9632834,-2.4307075)),(((29.736702,60.715374,-88.231476),94.62536),(12.49499,-5.2733855,-0.25494644),(-1.143601,-1.3175715,3.3169105)),(((-63.04561,4.129257,-43.15318),6.5728045),(-6.891207,11.792309,-5.9181933),(0.41236284,0.19797336,0.18787487)),(((11.896064,-29.014198,69.856224),53.180336),(-5.2224894,2.284795,4.2921305),(1.3726617,3.257218,-2.6621897)),(((38.84494,0.44165504,64.68979),91.3407),(-3.7706373,-10.44458,-1.5761747),(-3.6047552,1.2989374,-3.7820122)),(((15.253961,31.213158,42.37834),87.52959),(15.57238,-0.5108675,2.4073062),(0.77382207,-3.5107894,-0.5931102)),(((25.462185,57.7606,-77.258286),75.542244),(12.529613,1.8682239,-8.432913),(-0.11828619,-0.50076365,0.56394)),(((-40.875896,22.949284,-45.92175),35.689384),(1.0001571,13.351651,-3.730043),(1.7436737,0.38464665,1.2702756)),(((11.7580805,-28.916342,62.435238),77.35545),(-8.081674,6.077168,3.352129),(1.9076473,4.964432,-2.3579834)),(((82.2225,-9.7786255,68.797226),34.4798),(-1.7052021,-14.852521,7.1237183),(-3.0383008,0.8755246,-0.85059637)),(((9.812528,21.933826,35.338314),20.805649),(5.919625,3.5853083,7.5684195),(0.47318155,-0.10099702,0.39165217)),(((33.87477,63.25305,-89.045364),58.3743),(10.897609,-5.691883,-7.101499),(-1.5258808,-1.2934843,1.9847765)),(((-56.17241,19.20363,-12.229358),20.659788),(-1.8913364,14.507622,-1.5179769),(1.4663916,0.16752706,7.473919e-2)),(((11.038544,-52.75113,50.393963),82.26547),(-16.147457,8.103466,7.0406375),(1.1229347,7.317746,0.116557844)),(((58.12866,2.3073416,67.638176),86.262726),(-6.899946,-18.700304,1.1591533),(-6.4619718,0.34747308,-3.231288)),(((-8.346832,33.286644,36.39714),52.37195),(10.981637,10.563141,5.655627),(3.7102525,-1.6548095,-0.10352421))]+t40 = fromList (Z :. 32) [(((90.3346,4.655861,91.20859),3.456227),(9.561887,-11.214318,10.101466),(-0.26128083,-2.0770896e-2,-0.16977718)),(((25.855879,33.27752,45.650112),63.459526),(13.874311,-2.4134786,5.3301144),(-0.17173003,-3.3428502,-0.14888263)),(((42.55104,55.74881,-93.12408),74.34554),(10.346969,-7.033272,-0.31666315),(-1.2832952,-0.39005303,2.8811932)),(((-62.630367,24.135597,-48.04935),8.434827),(-4.4623313,12.3485365,-5.5214076),(0.5272145,0.11860251,0.24403755)),(((16.786787,-49.09336,52.37048),16.776989),(-5.482549,-6.270866,7.9521694),(6.0247123e-2,1.5767819,0.17346881)),(((84.83455,-6.668477,84.889885),21.63172),(3.0254977,-13.872956,7.0852513),(-1.7604394,0.1894979,-1.002964)),(((25.607107,32.814,45.158234),69.831604),(13.595416,-1.9758472,6.462585),(-0.13727047,-3.549432,-3.7056354e-3)),(((44.518757,61.90863,-96.71034),66.98223),(14.625989,-6.22489,1.0272641),(-1.417286,-1.7000344,3.2084227)),(((-37.96874,39.424587,-30.38036),23.477612),(1.8094404,12.464852,-2.7568665),(1.1918833,-0.17094232,0.36163473)),(((6.057052,-61.869263,108.64919),4.5274367),(-7.286687,-6.983825,12.130093),(7.459494e-2,0.27627227,-0.28570133)),(((33.423145,-4.8133616,76.19642),45.534313),(1.0209748,-4.2072473,0.8476473),(-0.9101132,0.69006634,-3.3002555)),(((27.816963,39.14842,42.311176),37.293446),(12.133267,-3.2016866,6.077291),(-0.43277112,-2.4690394,0.1829573)),(((37.032055,59.871284,-101.80806),52.771004),(9.842458,1.0014532,-1.3576142),(0.113305725,-0.80959976,3.3034868)),(((-32.768158,43.553585,-35.62678),83.92678),(9.558228,19.116442,3.6231754),(3.785976,-1.0030328,1.7205341)),(((14.439234,-50.508904,67.57433),13.032608),(-5.5554476,-6.2216606,8.366025),(0.12124021,1.2241457,-0.33175266)),(((103.82722,41.714848,135.79294),18.12446),(12.279673,-11.474536,11.176818),(-0.631969,-0.3265566,-0.78048927)),(((28.635696,23.74509,57.530754),53.132633),(10.348517,-4.291683,0.19939163),(-0.5118455,-1.936669,-1.9911488)),(((41.658382,55.011665,-87.18198),94.62536),(11.169736,-6.0489197,2.4283314),(-1.4343514,-0.3365628,2.1519272)),(((-69.752426,15.998649,-48.988125),6.5728045),(-6.48451,11.950421,-5.7348514),(0.39747268,0.12604822,0.17903966)),(((7.421006,-25.314278,72.93206),53.180336),(-3.4275875,5.3594904,1.5695516),(2.1104321,2.8862293,-2.7693553)),(((33.593594,-9.123072,61.628304),91.3407),(-6.853316,-8.163884,-4.585922),(-2.5169895,3.068793,-2.2420175)),(((30.775204,29.06608,44.69013),87.52959),(14.991441,-4.1634536,2.3604884),(-1.743295,-3.6350572,0.3263754)),(((37.925953,59.291317,-85.37278),75.542244),(12.364148,0.97157943,-7.610811),(-0.22051588,-1.2753534,1.148759)),(((-39.081818,36.42463,-49.090176),35.689384),(2.7722025,13.572521,-2.4910996),(1.7876816,8.852193e-2,1.2181025)),(((4.854909,-20.765474,64.73786),77.35545),(-5.121062,10.451305,1.0317328),(3.773904,3.7349844,-2.2926235)),(((79.178535,-24.155758,75.49906),34.4798),(-4.636625,-13.707212,6.141575),(-2.8098998,1.3618014,-1.0914961)),(((15.977711,25.408234,43.059597),20.805649),(6.4937973,3.2579877,7.8726983),(0.63328594,-0.5327105,0.20720817)),(((44.112415,57.10134,-95.17267),58.3743),(9.473635,-6.577284,-4.840429),(-1.3064284,-0.55162036,2.500792)),(((-57.413094,33.74672,-13.71971),20.659788),(-0.45732188,14.546219,-1.4605455),(1.4030969,-5.6085628e-2,5.0729703e-2)),(((-4.132298,-41.444485,57.4354),82.26547),(-13.4335,15.047902,6.9562955),(4.059167,6.4290543,-0.3307359)),(((48.41738,-15.724357,67.36842),86.262726),(-12.948876,-16.616163,-1.95434),(-5.4540496,3.5695972,-2.9190702)),(((4.210882,42.83211,41.997192),52.37195),(14.340451,8.013545,5.5130305),(2.9640288,-3.234027,-0.19869432))]+t50 = fromList (Z :. 32) [(((99.78429,-6.5603447,101.23478),3.456227),(9.319103,-11.210923,9.935835),(-0.22626747,2.1161372e-2,-0.1612093)),(((39.403965,29.356451,50.871735),63.459526),(12.86763,-5.723307,5.028878),(-1.6957306,-3.1606607,-0.4616191)),(((52.3492,48.69863,-92.19782),74.34554),(9.166924,-6.910074,2.3809798),(-1.0765165,0.49746767,2.5362353)),(((-66.8613,36.525005,-53.462444),8.434827),(-3.9560394,12.425948,-5.2827253),(0.48558196,4.514877e-2,0.23342745)),(((11.3726,-54.63127,60.366547),16.776989),(-5.284395,-4.62866,8.007034),(0.309564,1.6607597,-5.4514244e-2)),(((87.09958,-20.402815,91.51911),21.63172),(1.3766433,-13.507609,6.0697675),(-1.5429239,0.502993,-1.0176795)),(((38.87964,29.213264,51.52705),69.831604),(12.579766,-5.5654917,6.13499),(-1.747105,-3.477748,-0.63458973)),(((58.371513,55.032394,-94.33609),66.98223),(12.771849,-7.537657,3.9042752),(-2.1691554,-0.976144,2.5849755)),(((-35.62298,51.793858,-32.97171),23.477612),(3.000215,12.232307,-2.3830836),(1.1863849,-0.2821353,0.39073357)),(((-1.1938903,-68.73547,120.656364),4.5274367),(-7.2055235,-6.73064,11.863677),(8.4682934e-2,0.2324943,-0.24955781)),(((33.98479,-8.668965,75.568375),45.534313),(-4.586573e-2,-3.3565376,-2.4003098),(-1.161805,1.0472943,-3.1469493)),(((39.66494,34.850323,48.43695),37.293446),(11.395371,-5.6083426,6.138593),(-0.99539036,-2.3176267,-6.147321e-2)),(((46.950523,60.39374,-101.70575),52.771004),(10.027083,-0.18237326,1.846281),(0.21004155,-1.4657336,3.093771)),(((-21.612383,61.96557,-31.32596),83.92678),(12.976039,17.290213,5.0295744),(3.0800977,-2.4412982,1.1717454)),(((8.96526,-56.172928,75.77116),13.032608),(-5.345359,-4.985807,7.967873),(0.27868465,1.2160217,-0.45238936)),(((115.829254,30.117777,146.63062),18.12446),(11.671261,-11.721733,10.436247),(-0.5865162,-0.18780562,-0.70882756)),(((38.582184,18.651218,56.93042),53.132633),(9.270124,-5.9622445,-1.4593434),(-1.5178046,-1.3589051,-1.3558631)),(((52.169697,48.95184,-83.96839),94.62536),(9.706987,-5.938324,3.989206),(-1.4470835,0.41542193,1.1349429)),(((-76.06361,27.99487,-54.644337),6.5728045),(-6.106245,12.040813,-5.5623775),(0.36062056,6.338345e-2,0.1667967)),(((5.031253,-18.753942,73.24428),53.180336),(-1.0452096,7.9019423,-1.2293646),(2.5434313,2.215863,-2.8002636)),(((25.895203,-15.654797,56.379826),91.3407),(-8.374308,-4.2960773,-5.6613545),(-0.61054236,4.410234,-0.105147086)),(((44.56931,23.377563,47.275223),87.52959),(11.912463,-7.3660054,2.9104905),(-4.0473733,-2.6802368,0.6384738)),(((50.153812,59.54019,-92.28699),75.542244),(12.008861,-0.7881906,-5.8424706),(-0.4955644,-2.1168833,2.3230572)),(((-35.506397,49.987667,-51.03989),35.689384),(4.5507164,13.495833,-1.2958468),(1.7571652,-0.21390966,1.1755395)),(((1.6586281,-8.966029,64.74854),77.35545),(-0.6585472,13.033994,-1.2206159),(4.837213,1.534798,-2.2026932)),(((73.34591,-37.17399,81.11334),34.4798),(-7.204541,-12.09446,4.9343133),(-2.3330922,1.8091398,-1.2886307)),(((22.757414,28.347914,50.975887),20.805649),(7.116842,2.4678946,7.908502),(0.5789135,-0.98542297,-0.11901239)),(((53.056896,50.391014,-98.801895),58.3743),(8.367776,-6.7536325,-2.0602012),(-0.93099135,0.10514579,2.9887574)),(((-57.253033,48.23814,-15.15559),20.659788),(0.8975221,14.393842,-1.4017532),(1.3112133,-0.22530983,7.0312925e-2)),(((-15.272543,-23.845793,64.09268),82.26547),(-7.877729,20.243881,6.091751),(6.59736,3.9433155,-1.3863378)),(((33.405663,-30.212833,64.24376),86.262726),(-17.00329,-11.36592,-4.358442),(-2.6607215,6.4482036,-1.8884766)),(((19.681992,49.188995,47.388447),52.37195),(16.6021,4.146414,5.202059),(1.6236293,-4.2790256,-0.41353542))]+
examples/nofib/Config.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-}@@ -6,28 +7,16 @@ 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+import System.Console.GetOpt data Config = Config {- -- Standard options- _configBackend :: Backend- , _configHelp :: Bool- , _configBenchmark :: Bool- , _configQuickCheck :: Bool- -- Which QuickCheck test types to enable?- , _configDouble :: Bool+ _configDouble :: Bool , _configFloat :: Bool , _configInt64 :: Bool , _configInt32 :: Bool@@ -38,22 +27,16 @@ , _configWord16 :: Bool , _configWord8 :: Bool }- deriving Show -$(mkLabels [''Config])+$(mkLabel ''Config) defaults :: Config defaults = Config {- _configBackend = maxBound- , _configHelp = False- , _configBenchmark = True- , _configQuickCheck = True-- , _configDouble = False+ _configDouble = True , _configFloat = False- , _configInt64 = True+ , _configInt64 = False , _configInt32 = True , _configInt16 = False , _configInt8 = False@@ -63,15 +46,27 @@ , _configWord8 = False } +extensive :: Config+extensive = Config+ {+ _configDouble = True+ , _configFloat = True+ , _configInt64 = True+ , _configInt32 = True+ , _configInt16 = True+ , _configInt8 = True+ , _configWord64 = True+ , _configWord32 = True+ , _configWord16 = True+ , _configWord8 = True+ }++ 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 [] ["all"]+ (NoArg (const extensive))+ "enable tests on all primitive types" , Option [] ["double"] (OptArg (set configDouble . read . fromMaybe "True") "BOOL")@@ -79,7 +74,7 @@ , Option [] ["float"] (OptArg (set configFloat . read . fromMaybe "True") "BOOL")- (describe configDouble "enable single-precision tests")+ (describe configFloat "enable single-precision tests") , Option [] ["int64"] (OptArg (set configInt64 . read . fromMaybe "True") "BOOL")@@ -112,10 +107,6 @@ , 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@@ -130,58 +121,5 @@ ] 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)+footer = [ "" ]
examples/nofib/Main.hs view
@@ -1,13 +1,10 @@-{-# LANGUAGE CPP #-}+ module Main where -import Test.Framework-import Control.Exception-import System.Exit+import Data.Label import System.Environment import Config-import Monitoring import Test.FFT import Test.IO import Test.Prelude@@ -15,11 +12,11 @@ import Test.Imaginary import Test.Spectral import Test.Issues-#ifdef ACCELERATE_CUDA_BACKEND import Test.Foreign-#endif +import Data.Array.Accelerate.Examples.Internal + main :: IO () main = do @@ -30,30 +27,24 @@ -- process command line args, and print a brief usage message --- argv <- getArgs- (conf, cconf, tfconf, nops) <- parseArgs' configHelp configBackend options defaults header footer argv+ argv <- getArgs+ (conf, opts, rest) <- parseArgs options defaults header footer argv+ let backend = get optBackend opts -- 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+ runTests opts rest+ [ test_prelude backend conf , test_sharing conf- , test_fft conf , test_io conf- , test_imaginary conf- , test_spectral conf-#ifdef ACCELERATE_CUDA_BACKEND- , test_foreign conf-#endif- , test_issues conf+ , test_imaginary backend conf+ , test_spectral backend conf+ , test_fft backend conf+ , test_foreign backend conf+ , test_issues backend conf ]- 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. --
examples/nofib/QuickCheck/Arbitrary/Shape.hs view
@@ -6,7 +6,7 @@ module QuickCheck.Arbitrary.Shape where import Test.QuickCheck-import Data.Array.Accelerate ( Shape, Z(..), (:.)(..), DIM0, DIM1, DIM2 )+import Data.Array.Accelerate ( Shape, Z(..), (:.)(..), DIM0, DIM1, DIM2, DIM3, DIM4 ) import qualified Data.Array.Accelerate.Array.Sugar as Sugar @@ -28,6 +28,25 @@ return (Z :. h :. w) shrink (Z :. h :. w) = [ Z :. h' :. w' | h' <- shrink h, w' <- shrink w ]++instance Arbitrary DIM3 where+ arbitrary = sized $ \n -> do+ w <- choose (0, n)+ h <- choose (0, n)+ d <- choose (0, n)+ return (Z :. h :. w :. d)++ shrink (Z :. h :. w :. d) = [ Z :. h' :. w' :. d' | h' <- shrink h, w' <- shrink w, d' <- shrink d ]++instance Arbitrary DIM4 where+ arbitrary = sized $ \n -> do+ w <- choose (0, n)+ h <- choose (0, n)+ d <- choose (0, n)+ t <- choose (0, n)+ return (Z :. h :. w :. d :. t)++ shrink (Z :. h :. w :. d :. t) = [ Z :. h' :. w' :. d' :. t' | h' <- shrink h, w' <- shrink w, d' <- shrink d, t' <- shrink t ] -- Generate an arbitrary shape with approximately this many elements in each
examples/nofib/Test/Base.hs view
@@ -1,144 +1,14 @@-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeOperators #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeOperators #-} module Test.Base where import Prelude as P-import Data.Complex-import Control.Monad ( unless )-import Test.HUnit ( Assertion, assertFailure )-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, x2) ~= (y1, y2) = x1 ~= y1 && x2 ~= y2--instance (Similar a, Similar b, Similar c) => Similar (a, b, c) where- (x1, x2, x3) ~= (y1, y2, y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3--instance (Similar a, Similar b, Similar c, Similar d) => Similar (a, b, c, d) where- (x1, x2, x3, x4) ~= (y1, y2, y3, y4) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4--instance (Similar a, Similar b, Similar c, Similar d, Similar e)- => Similar (a, b, c, d, e) where- (x1, x2, x3, x4, x5) ~= (y1, y2, y3, y4, y5) =- x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5--instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f)- => Similar (a, b, c, d, e, f) where- (x1, x2, x3, x4, x5, x6) ~= (y1, y2, y3, y4, y5, y6) =- x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6---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 Char-instance Similar Bool--instance Similar DIM1-instance Similar DIM2-instance Similar DIM3--instance Similar Float where (~=) = absRelTol 0.00005 0.005-instance Similar Double where (~=) = absRelTol 0.00005 0.005--instance (Similar e, RealFloat e) => Similar (Complex e) where- -- CUFFT can actually give quite large errors, so we have to- -- increase the epsilon for the absolute relative value difference.- (r1 :+ i1) ~= (r2 :+ i2) = r1 ~= r2 && i1 ~= i2---{-# 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 -> a -> a -> Bool-absRelTol epsilonAbs epsilonRel 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--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)- => a -- ^ The expected value- -> a -- ^ The actual value- -> Assertion-assertEqual expected actual =- unless (expected ~= actual)- (assertFailure (failure expected actual))--failure :: Show a => a -> a -> String-failure expected actual =- 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-expected ~=? actual = counterexample (failure expected actual) (expected ~= actual)---- 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 (~=?)+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Array.Sugar -- Miscellaneous --- indexHead :: Shape sh => (sh:.Int) -> Int indexHead (_ :. sz) = sz
examples/nofib/Test/FFT.hs view
@@ -9,7 +9,6 @@ ) where import Config-import ParseArgs import Control.Applicative import Data.Label@@ -18,17 +17,18 @@ import Prelude as P -import Test.Base-import Test.QuickCheck hiding ( (.&.) )+import Test.QuickCheck hiding ( (.&.) ) import Test.Framework import Test.Framework.Providers.QuickCheck2 import QuickCheck.Arbitrary.Array -import Data.Array.Accelerate.Math.FFT as FFT-import Data.Array.Accelerate as A hiding ( (!) )-import Data.Array.Accelerate.Array.Sugar ( (!) )+import Data.Array.Accelerate.Math.FFT as FFT+import Data.Array.Accelerate as A hiding ( (!) )+import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Accelerate.Array.Sugar ( (!) ) import Data.Array.Accelerate.Data.Complex + newtype PowerOf2Array a = PowerOf2Array (Array DIM2 a) deriving Show instance (Arbitrary a, Elt a) => Arbitrary (PowerOf2Array a) where@@ -46,14 +46,12 @@ , PowerOf2Array . fromList (Z:.h:.(w `div` 2)) $ [a ! (Z:.y:.x) | y <- [0..h - 1], x <- [0..w `div` 2]] ] else [] -test_fft :: Config -> Test-test_fft opt = testGroup "fft" $ catMaybes+test_fft :: Backend -> Config -> Test+test_fft backend opt = testGroup "fft" $ catMaybes [ testElt configFloat (undefined::Float) , testElt configDouble (undefined::Double) ] where- backend = get configBackend opt- testElt :: forall a. (Elt a, Similar a, Arbitrary a, IsFloating a, RealFloat a) => (Config :-> Bool) -> a
examples/nofib/Test/Foreign.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+ module Test.Foreign ( test_foreign@@ -6,40 +7,19 @@ ) where import Config+#ifdef ACCELERATE_CUDA_BACKEND+import Test.Foreign.CUDA+#endif -import Data.Label+import Data.Array.Accelerate.Examples.Internal -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+test_foreign :: Backend -> Config -> Test+test_foreign be conf =+ testGroup "foreign"+ [+#ifdef ACCELERATE_CUDA_BACKEND+ test_cuda be conf+#endif+ ] - 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/Foreign/CUDA.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE FlexibleContexts #-}++module Test.Foreign.CUDA+ where++import Config+import Test.Prelude.Mapping++import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Accelerate.CUDA.Foreign as A+++test_cuda :: Backend -> Config -> Test+test_cuda backend _conf = testGroup "CUDA"+ $ if backend == CUDA+ then [ testExpf, testFmaf ]+ else [ ]+ where+ 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/Vector.hs view
@@ -19,6 +19,7 @@ import Data.Array.Accelerate import Data.Array.Accelerate.IO ( toVectors, fromVectors ) import Data.Array.Accelerate.Array.Sugar as Sugar+import Data.Array.Accelerate.Examples.Internal test_vector :: Config -> Test
examples/nofib/Test/Imaginary.hs view
@@ -12,12 +12,14 @@ import Test.Imaginary.SASUM import Test.Imaginary.SAXPY +import Data.Array.Accelerate.Examples.Internal -test_imaginary :: Config -> Test-test_imaginary conf =++test_imaginary :: Backend -> Config -> Test+test_imaginary be conf = testGroup "imaginary"- [ test_sasum conf- , test_saxpy conf- , test_dotp conf+ [ test_sasum be conf+ , test_saxpy be conf+ , test_dotp be conf ]
examples/nofib/Test/Imaginary/DotP.hs view
@@ -8,23 +8,21 @@ ) where +import Config+import QuickCheck.Arbitrary.Array ()+ import Prelude as P import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal 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+test_dotp :: Backend -> Config -> Test+test_dotp backend opt = testGroup "dot-product" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -37,8 +35,6 @@ , testElt configDouble (undefined :: Double) ] where- backend = get configBackend opt- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) => (Config :-> Bool) -> a
examples/nofib/Test/Imaginary/SASUM.hs view
@@ -7,23 +7,21 @@ ) where +import Config+import QuickCheck.Arbitrary.Array ()+ import Prelude as P import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal 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+test_sasum :: Backend -> Config -> Test+test_sasum backend opt = testGroup "sasum" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -36,8 +34,6 @@ , testElt configDouble (undefined :: Double) ] where- backend = get configBackend opt- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) => (Config :-> Bool) -> a
examples/nofib/Test/Imaginary/SAXPY.hs view
@@ -8,23 +8,21 @@ ) where +import Config+import QuickCheck.Arbitrary.Array ()+ import Prelude as P import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal 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+test_saxpy :: Backend -> Config -> Test+test_saxpy backend opt = testGroup "saxpy" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -37,8 +35,6 @@ , testElt configDouble (undefined :: Double) ] where- backend = get configBackend opt- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) => (Config :-> Bool) -> a
examples/nofib/Test/Issues.hs view
@@ -19,20 +19,22 @@ import Test.Issues.Issue185 import Test.Issues.Issue187 +import Data.Array.Accelerate.Examples.Internal -test_issues :: Config -> Test-test_issues conf =++test_issues :: Backend -> Config -> Test+test_issues be conf = testGroup "issues" [- test_issue93 conf- , test_issue102 conf- , test_issue114 conf- , test_issue119 conf- , test_issue123 conf- , test_issue137 conf- , test_issue168 conf- , test_issue184 conf- , test_issue185 conf- , test_issue187 conf+ test_issue93 be conf+ , test_issue102 be conf+ , test_issue114 be conf+ , test_issue119 be conf+ , test_issue123 be conf+ , test_issue137 be conf+ , test_issue168 be conf+ , test_issue184 be conf+ , test_issue185 be conf+ , test_issue187 be conf ]
examples/nofib/Test/Issues/Issue102.hs view
@@ -4,21 +4,17 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue102 :: Config -> Test-test_issue102 conf =+test_issue102 :: Backend -> Config -> Test+test_issue102 backend _conf = testCase "102" (assertEqual ref1 $ run backend test1)- where- backend = get configBackend conf ref1 :: Array DIM3 Int
examples/nofib/Test/Issues/Issue114.hs view
@@ -3,23 +3,19 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue114 :: Config -> Test-test_issue114 conf = testGroup "114"+test_issue114 :: Backend -> Config -> Test+test_issue114 backend _conf = testGroup "114" [ testCase "A" (assertEqual ref1 $ run backend test1) , testCase "B" (assertEqual ref2 $ run backend test2) ]- where- backend = get configBackend conf type EFloat = (Float, Float) -- Represents a real number with a value and error
examples/nofib/Test/Issues/Issue119.hs view
@@ -3,18 +3,16 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue119 :: Config -> Test-test_issue119 conf = testGroup "119"+test_issue119 :: Backend -> Config -> Test+test_issue119 backend _conf = testGroup "119" [ testCase "A" (assertEqual ref1 (run backend test1)) , testCase "B" (assertEqual ref2 (run backend test2)) , testCase "C" (assertEqual ref3 (run backend test3))@@ -27,8 +25,6 @@ , testCase "J" (assertEqual ref10 (run backend test10)) , testCase "K" (assertEqual ref11 (run backend test11)) ]- where- backend = get configBackend conf -- Fold tests
examples/nofib/Test/Issues/Issue123.hs view
@@ -3,21 +3,18 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue123 :: Config -> Test-test_issue123 conf =+test_issue123 :: Backend -> Config -> Test+test_issue123 backend _conf = testCase "123" (assertEqual ref1 $ run backend (test1 n)) where- backend = get configBackend conf n = 100 ref1 = fromList Z [n]
examples/nofib/Test/Issues/Issue137.hs view
@@ -5,21 +5,18 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue137 :: Config -> Test-test_issue137 conf =+test_issue137 :: Backend -> Config -> Test+test_issue137 backend _conf = testCase "137" (assertEqual ref1 $ run backend test1)- where- backend = get configBackend conf+ ref1 :: Vector (Int,Int) ref1 = fromList (Z:.384) [(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,1),(2,3),(0,1),(3,4),(0,1),(4,5),(0,1),(5,5),(0,1),(4,5),(0,1),(3,4),(0,1),(2,3),(0,1),(1,2),(1,2),(0,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000),(10000,10000)]
examples/nofib/Test/Issues/Issue168.hs view
@@ -3,24 +3,21 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue168 :: Config -> Test-test_issue168 conf = testGroup "168"+test_issue168 :: Backend -> Config -> Test+test_issue168 backend _conf = testGroup "168" [ testCase "A" (assertEqual ref1 $ run backend (A.fill sh test1)) , testCase "B" (assertEqual ref2 $ run backend (A.fill sh test2)) , testCase "C" (assertEqual ref3 $ run backend (A.fill sh test3)) ] where- backend = get configBackend conf sh = index1 (constant 1) :: Exp DIM1 -- Test 1
examples/nofib/Test/Issues/Issue184.hs view
@@ -3,24 +3,20 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue184 :: Config -> Test-test_issue184 conf = testGroup "184"+test_issue184 :: Backend -> Config -> Test+test_issue184 backend _conf = testGroup "184" [ testCase "A" (assertEqual ref1 $ run backend test1) , testCase "B" (assertEqual ref2 $ run backend test2) , testCase "C" (assertEqual ref3 $ run backend test3) ]- where- backend = get configBackend conf ref1 :: Vector Int
examples/nofib/Test/Issues/Issue185.hs view
@@ -6,18 +6,16 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit import Prelude as P import Data.Array.Accelerate as A-import Data.Label+import Data.Array.Accelerate.Examples.Internal as A -test_issue185 :: Config -> Test-test_issue185 conf = testGroup "185"+test_issue185 :: Backend -> Config -> Test+test_issue185 backend _conf = testGroup "185" [ testCase "A" (assertEqual ref1 (run backend acc1 :: Vector Int)) , testCase "B" (assertEqual ref2 (run backend acc2 :: Vector Int)) , testCase "C" (assertEqual ref3 (run backend acc3 :: Vector Int))@@ -25,8 +23,6 @@ , testCase "E" (assertEqual ref5 (run backend acc5 :: Vector Int)) , testCase "F" (assertEqual ref6 (run backend acc6 :: Vector Int)) ]- where- backend = get configBackend conf ref1 :: (Elt a, Num a) => Vector a
examples/nofib/Test/Issues/Issue187.hs view
@@ -3,23 +3,19 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue187 :: Config -> Test-test_issue187 conf = testGroup "187"+test_issue187 :: Backend -> Config -> Test+test_issue187 backend _conf = testGroup "187" [ testCase "A" (assertEqual ref1 $ run backend test1) , testCase "B" (assertEqual ref2 $ run backend test2) ]- where- backend = get configBackend conf ref1 :: Scalar Bool
examples/nofib/Test/Issues/Issue93.hs view
@@ -3,21 +3,17 @@ where import Config-import ParseArgs-import Test.Base import Test.Framework import Test.Framework.Providers.HUnit -import Prelude as P-import Data.Array.Accelerate as A-import Data.Label+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A -test_issue93 :: Config -> Test-test_issue93 conf =+test_issue93 :: Backend -> Config -> Test+test_issue93 backend _conf = testCase "93" (assertEqual xs $ run backend test1)- where- backend = get configBackend conf xs :: Array DIM2 Int
examples/nofib/Test/Prelude.hs view
@@ -12,20 +12,22 @@ import Test.Prelude.Replicate import Test.Prelude.Stencil +import Data.Array.Accelerate.Examples.Internal -test_prelude :: Config -> Test-test_prelude conf =++test_prelude :: Backend -> Config -> Test+test_prelude be 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+ [ test_map be conf+ , test_zipWith be conf+ , test_foldAll be conf+ , test_fold be conf+ , test_backpermute be conf+ , test_permute be conf+ , test_prefixsum be conf -- requires fold+ , test_foldSeg be conf -- requires scan+ , test_stencil be conf+ , test_replicate be conf+ , test_filter be conf ]
examples/nofib/Test/Prelude/Filter.hs view
@@ -16,17 +16,16 @@ 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.Examples.Internal as A -- -- Filter ---------------------------------------------------------------------- -- -test_filter :: Config -> Test-test_filter opt = testGroup "filter" $ catMaybes+test_filter :: Backend -> Config -> Test+test_filter backend opt = testGroup "filter" $ catMaybes [ testIntegralElt configInt8 (undefined :: Int8) , testIntegralElt configInt16 (undefined :: Int16) , testIntegralElt configInt32 (undefined :: Int32)@@ -39,8 +38,6 @@ , 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
examples/nofib/Test/Prelude/IndexSpace.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Test.Prelude.IndexSpace (@@ -9,7 +10,7 @@ ) where -import Prelude as P+import Prelude as P import Data.Label import Data.Maybe import Data.Typeable@@ -19,24 +20,25 @@ 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.Accelerate as A+import Data.Array.Accelerate.Array.Sugar ( newArray, dim )+import Data.Array.Accelerate.Examples.Internal as A -import Data.Array.ST ( runSTArray )-import qualified Data.Array.Unboxed as IArray-import qualified Data.Array.MArray as M+import Data.Array.ST ( runSTArray )+import Data.Array.Unboxed ( IArray, UArray )+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+test_permute :: Backend -> Config -> Test+test_permute backend opt = testGroup "permute" $ catMaybes [ testIntegralElt configInt8 (undefined :: Int8) , testIntegralElt configInt16 (undefined :: Int16) , testIntegralElt configInt32 (undefined :: Int32)@@ -49,9 +51,7 @@ , 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 :: forall e. (Elt e, Integral e, IsIntegral e, Arbitrary e, Similar e, IArray UArray e) => (Config :-> Bool) -> e -> Maybe Test testIntegralElt ok _ | P.not (get ok opt) = Nothing | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))@@ -62,7 +62,7 @@ , 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 :: forall e. (Elt e, RealFrac e, IsFloating e, Arbitrary e, Similar e, IArray UArray e) => (Config :-> Bool) -> e -> Maybe Test testFloatingElt ok _ | P.not (get ok opt) = Nothing | otherwise = Just $ testGroup (show (typeOf (undefined :: e)))@@ -86,20 +86,23 @@ 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+ where+ 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 :: (Elt e, IsNum e, Similar e, Arbitrary e, IArray UArray e) => (Exp e -> Exp Int) -> (e -> Int) -> Vector e -> Property test_histogram f g xs = forAll (sized return) $ \n -> run backend (histogramAcc n f xs) ~?= histogramRef n g xs + histogramAcc :: (Elt e, IsNum e) => Int -> (Exp e -> Exp Int) -> Vector e -> Acc (Vector e) histogramAcc n f xs = let n' = unit (constant n) xs' = use xs@@ -108,8 +111,9 @@ in permute (+) zeros (\ix -> index1 $ f (xs' A.! ix) `mod` the n') ones + histogramRef :: forall e. (Elt e, Num e, IArray UArray e) => Int -> (e -> Int) -> Vector e -> Vector e histogramRef n f xs =- let arr :: IArray.UArray Int Int32+ let arr :: IArray.UArray Int e arr = IArray.accumArray (+) 0 (0, n-1) [ (f e `mod` n, 1) | e <- toList xs ] in fromIArray arr@@ -142,8 +146,8 @@ -- Backward permutation -------------------------------------------------------- -- -test_backpermute :: Config -> Test-test_backpermute opt = testGroup "backpermute" $ catMaybes+test_backpermute :: Backend -> Config -> Test+test_backpermute backend opt = testGroup "backpermute" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -170,72 +174,81 @@ , testProperty "gather" (test_gather :: Array DIM1 e -> Property) , testProperty "gatherIf" (test_gatherIf :: Array DIM1 e -> Property) ]+ where+ test_reverse :: Vector e -> Property+ test_reverse xs = run backend (reverseAcc xs) ~?= reverseRef xs - backend = get configBackend opt- test_reverse xs = run backend (reverseAcc xs) ~?= reverseRef xs- test_transpose xs = run backend (transposeAcc xs) ~?= transposeRef xs+ test_transpose :: Array DIM2 e -> Property+ 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)+ -- 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))+ -- 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)+ -- Extracting sub-vectors+ --+ test_init :: Vector e -> Property+ 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_tail :: Vector e -> Property+ 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_drop :: Vector e -> Property+ 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_take :: Vector e -> Property+ 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))+ test_slit :: Vector e -> Property+ 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 ]+ -- Gathering+ --+ test_gather :: Vector e -> Property+ 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+ test_gatherIf :: Vector e -> Property+ 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
examples/nofib/Test/Prelude/Mapping.hs view
@@ -13,18 +13,20 @@ ) where import Prelude as P+import Data.Bits as P import Data.Label import Data.Maybe import Data.Typeable-import Test.QuickCheck+import Test.QuickCheck hiding ( (.&.) ) import Test.Framework import Test.Framework.Providers.QuickCheck2 import Config-import ParseArgs import Test.Base-import QuickCheck.Arbitrary.Array ()+import QuickCheck.Arbitrary.Array+import QuickCheck.Arbitrary.Shape import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A import Data.Array.Accelerate.Array.Sugar as Sugar import qualified Data.Array.Accelerate.Array.Representation as R @@ -32,32 +34,48 @@ -- 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)+test_map :: Backend -> Config -> Test+test_map backend opt = testGroup "map" $ 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- 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+ testIntegralElt :: forall a. (Elt a, Integral a, Bits a, IsNum a, IsIntegral a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test+ testIntegralElt ok a+ | 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))+ [ -- operators on Num+ testProperty "neg" (test negate negate)+ , testProperty "abs" (test abs abs)+ , testProperty "sig" (test signum signum) - testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a)- => (Config :-> Bool)- -> a- -> Maybe Test- testElt ok _+ -- operators on Integral & Bits+ , testProperty "complement" (test complement complement)++ -- conversions+ , testProperty "fromIntegral" (testF A.fromIntegral P.fromIntegral)+ ]+ where+ test = mkTest a a sh+ testF = mkTest a (undefined::Float) sh++ testFloatingElt :: forall a. (Elt a, RealFrac a, IsFloating a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test+ testFloatingElt ok a | P.not (get ok opt) = Nothing | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) [ testDim dim0@@ -67,36 +85,110 @@ 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)+ [ -- operators on Num+ testProperty "neg" (test negate negate)+ , testProperty "abs" (test abs abs)+ , testProperty "sig" (test signum signum)++ -- operators on Fractional, Floating, RealFrac & RealFloat+ , testProperty "recip" (test recip recip)+ , testProperty "sin" (test sin sin)+ , testProperty "cos" (test cos cos)+ , testProperty "tan" (requiring (\x -> P.not (sin x ~= 1)) $ test tan tan)+ , testProperty "asin" (requiring (\x -> -1 <= x && x <= 1) $ test asin asin)+ , testProperty "acos" (requiring (\x -> -1 <= x && x <= 1) $ test acos acos)+ , testProperty "atan" (test atan atan)+ , testProperty "asinh" (test asinh asinh)+ , testProperty "acosh" (requiring (>= 1) $ test acosh acosh)+ , testProperty "atanh" (requiring (\x -> -1 < x && x < 1) $ test atanh atanh)+ , testProperty "exp" (test exp exp)+ , testProperty "sqrt" (requiring (>= 0) $ test sqrt sqrt)+ , testProperty "log" (requiring (> 0) $ test log log)+ , testProperty "truncate" (testI A.truncate P.truncate)+ , testProperty "round" (testI A.round P.round)+ , testProperty "floor" (testI A.floor P.floor)+ , testProperty "ceiling" (testI A.ceiling P.ceiling) ]+ where+ test = mkTest a a sh+ testI = mkTest a (undefined::Int) sh + -- The test generator. The first three arguments are dummies that are used+ -- to fix the types. The next two are the Accelerate and Prelude functions+ -- respectively that are arguments to the Map operation, and the final is+ -- the (randomly generated) input data.+ --+ mkTest :: (Elt a, Elt b, Shape sh, Eq sh, Similar b)+ => a -> b -> sh -> (Exp a -> Exp b) -> (a -> b) -> Array sh a -> Property+ mkTest _ _ _ f g xs = run1 backend (A.map f) xs ~?= mapRef g xs -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)++test_zipWith :: Backend -> Config -> Test+test_zipWith backend opt = testGroup "zipWith" $ 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- 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+ testIntegralElt :: forall a. (Elt a, Integral a, Bits a, IsNum a, IsIntegral a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test+ testIntegralElt ok a+ | 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), Arbitrary (Array sh Int)) => sh -> Test+ testDim sh = testGroup ("DIM" P.++ show (dim sh))+ [ -- operators on Num+ testProperty "(+)" (test (+) (+))+ , testProperty "(-)" (test (-) (-))+ , testProperty "(*)" (test (*) (*)) - testElt :: forall a. (Elt a, IsNum a, Ord a, Similar a, Arbitrary a)- => (Config :-> Bool)- -> a- -> Maybe Test- testElt ok _+ -- operators on Integral & Bits+ , testProperty "quot" (denom $ test quot quot)+ , testProperty "rem" (denom $ test rem rem)+ , testProperty "quotRem" (denom $ test' (\x y -> lift (quotRem x y)) quotRem)+ , testProperty "div" (denom $ test div div)+ , testProperty "mod" (denom $ test mod mod)+ , testProperty "divMod" (denom $ test' (\x y -> lift (divMod x y)) divMod)+ , testProperty "(.&.)" (test (.&.) (.&.))+ , testProperty "(.|.)" (test (.|.) (.|.))+ , testProperty "xor" (test xor xor)+ , testProperty "shiftL" (testSR A.shiftL P.shiftL)+ , testProperty "shiftR" (testSR A.shiftR P.shiftR)+ , testProperty "rotateL" (testSR A.rotateL P.rotateL)+ , testProperty "rotateR" (testSR A.rotateR P.rotateR)++ -- relational and equality operators+ , testProperty "(<)" (testAB (A.<*) (<))+ , testProperty "(>)" (testAB (A.>*) (>))+ , testProperty "(<=)" (testAB (<=*) (<=))+ , testProperty "(>=)" (testAB (>=*) (>=))+ , testProperty "(==)" (testAB (==*) (==))+ , testProperty "(/=)" (testAB (/=*) (/=))+ , testProperty "min" (test min min)+ , testProperty "max" (test max max)+ ]+ where+ test = mkTest a a a sh+ test' = mkTest a a (undefined::(a,a)) sh+ testAB = mkTest a a (undefined::Bool) sh++ testSR f g = forAll arbitrary $ \xs ->+ requiring (>= 0) $ \ys ->+ mkTest a (undefined::Int) a sh f g xs ys++ testFloatingElt :: forall a. (Elt a, RealFrac a, RealFloat a, IsFloating a, Arbitrary a, Similar a) => (Config :-> Bool) -> a -> Maybe Test+ testFloatingElt ok a | P.not (get ok opt) = Nothing | otherwise = Just $ testGroup (show (typeOf (undefined :: a))) [ testDim dim0@@ -106,10 +198,50 @@ 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)+ [ -- operators on Num+ testProperty "(+)" (test (+) (+))+ , testProperty "(-)" (test (-) (-))+ , testProperty "(*)" (test (*) (*))++ -- operators on Fractional, Floating, RealFrac & RealFloat+ , testProperty "(/)" (denom $ test (/) (/))+ , testProperty "(**)" (test (**) (**))+ , testProperty "atan2" (test atan2 atan2)+ , testProperty "logBase" (requiring (> 0) $ \xs ->+ requiring (> 0) $ \ys -> test logBase logBase xs ys)++ -- relational and equality operators+ , testProperty "(<)" (testAB (A.<*) (<))+ , testProperty "(>)" (testAB (A.>*) (>))+ , testProperty "(<=)" (testAB (<=*) (<=))+ , testProperty "(>=)" (testAB (>=*) (>=))+ , testProperty "(==)" (testAB (==*) (==))+ , testProperty "(/=)" (testAB (/=*) (/=))+ , testProperty "min" (test min min)+ , testProperty "max" (test max max) ]+ where+ test = mkTest a a a sh+ testAB = mkTest a a (undefined::Bool) sh++ -- The test generator. See comments in test_map above.+ --+ mkTest :: (Elt a, Elt b, Elt c, Shape sh, Eq sh, Similar c)+ => a -> b -> c -> sh -> (Exp a -> Exp b -> Exp c) -> (a -> b -> c) -> Array sh a -> Array sh b -> Property+ mkTest _ _ _ _ f g xs ys = run2 backend (A.zipWith f) xs ys ~?= zipWithRef g xs ys++ denom f = forAll arbitrary $ \xs ->+ requiring (/= 0) $ \ys -> f xs ys+++requiring+ :: (Elt e, Shape sh, Arbitrary e, Arbitrary sh, Testable prop)+ => (e -> Bool)+ -> (Array sh e -> prop)+ -> Property+requiring f go =+ forAll (do sh <- sized arbitraryShape+ arbitraryArrayOf sh (arbitrary `suchThat` f)) go -- Reference Implementation
examples/nofib/Test/Prelude/PrefixSum.hs view
@@ -8,7 +8,7 @@ ) where -import Prelude as P+import Prelude as P import Test.QuickCheck import Data.Label import Data.Maybe@@ -17,18 +17,18 @@ 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 as A+import Data.Array.Accelerate.Examples.Internal as A -- -- prefix sum ------------------------------------------------------------------ -- -test_prefixsum :: Config -> Test-test_prefixsum opt = testGroup "prefix sum" $ catMaybes+test_prefixsum :: Backend -> Config -> Test+test_prefixsum backend opt = testGroup "prefix sum" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -59,8 +59,6 @@ , testProperty "scanl'Seg" (test_scanl'seg :: Vector e -> Property) , testProperty "scanr'Seg" (test_scanr'seg :: Vector e -> Property) ]-- backend = get configBackend opt -- left scan --
examples/nofib/Test/Prelude/Reduction.hs view
@@ -10,7 +10,7 @@ ) where -import Prelude as P+import Prelude as P import Data.List import Data.Label import Data.Maybe@@ -18,11 +18,11 @@ 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 Data.Array.Accelerate as A hiding (indexHead, indexTail)+import Data.Array.Accelerate.Array.Sugar as Sugar+import Data.Array.Accelerate.Examples.Internal as A import Config-import ParseArgs import Test.Base import QuickCheck.Arbitrary.Array @@ -35,8 +35,8 @@ -- foldAll -- ------- -test_foldAll :: Config -> Test-test_foldAll opt = testGroup "foldAll" $ catMaybes+test_foldAll :: Backend -> Config -> Test+test_foldAll backend opt = testGroup "foldAll" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -82,14 +82,13 @@ 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+test_fold :: Backend -> Config -> Test+test_fold backend opt = testGroup "fold" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -134,14 +133,12 @@ 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+test_foldSeg :: Backend -> Config -> Test+test_foldSeg backend opt = testGroup "foldSeg" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -182,8 +179,6 @@ 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
examples/nofib/Test/Prelude/Replicate.hs view
@@ -8,26 +8,25 @@ ) where -import Prelude as P-import Data.Array.Accelerate as A-import Data.Array.Unboxed as IArray hiding ( Array )+import Config+import Test.Framework++import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal 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+import Test.HUnit hiding ( Test ) -- -- Slice ----------------------------------------------------------------------- -- -test_replicate :: Config -> Test-test_replicate opt = testGroup "replicate" $ catMaybes+test_replicate :: Backend -> Config -> Test+test_replicate backend opt = testGroup "replicate" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -40,8 +39,6 @@ , 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
examples/nofib/Test/Prelude/Stencil.hs view
@@ -9,24 +9,23 @@ ) where -import Prelude as P+import Prelude as P import Data.Label import Data.Maybe import Data.Typeable import Test.QuickCheck-import Test.HUnit ((@?=))+import Test.HUnit ((@?=)) import Test.Framework import Test.Framework.Providers.QuickCheck2 import Test.Framework.Providers.HUnit import Config-import ParseArgs-import Test.Base-import QuickCheck.Arbitrary.Array ()+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+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A+import Data.Array.Unboxed as IArray hiding ( Array )+import qualified Data.Array.IArray as IArray -- TODO:@@ -39,8 +38,8 @@ -- Stencil --------------------------------------------------------------------- -- -test_stencil :: Config -> Test-test_stencil opt = testGroup "stencil" $ catMaybes+test_stencil :: Backend -> Config -> Test+test_stencil backend opt = testGroup "stencil" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -54,8 +53,6 @@ , testBoundary ] where- backend = get configBackend opt- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a, IArray UArray a) => (Config :-> Bool) -> a
examples/nofib/Test/Sharing.hs view
@@ -236,19 +236,19 @@ test1 :: Acc (Vector Float) test1 = flip A.map vec- $ \x -> A.while (<* x) (+1) 0+ $ \x -> A.while (A.<* x) (+1) 0 test2 :: Acc (Vector Float) test2 = flip A.map vec $ \x -> let y = 2*pi- in y + A.while (<* 10) (+y) x+ in y + A.while (A.<* 10) (+y) x test3 :: Acc (Vector Float) test3 = flip A.map vec- $ \x -> A.while (<* x) (+x) 0+ $ \x -> A.while (A.<* x) (+x) 0 awhile_test :: Acc (Vector Float)- awhile_test = A.awhile (\a -> A.unit (the (A.sum a) <* 200)) (A.map (+1)) vec+ awhile_test = A.awhile (\a -> A.unit (the (A.sum a) A.<* 200)) (A.map (+1)) vec iterate_test :: Acc (Vector Float) iterate_test = flip A.map vec
examples/nofib/Test/Spectral.hs view
@@ -12,12 +12,14 @@ import Test.Spectral.SMVM import Test.Spectral.RadixSort +import Data.Array.Accelerate.Examples.Internal -test_spectral :: Config -> Test-test_spectral conf =++test_spectral :: Backend -> Config -> Test+test_spectral be conf = testGroup "spectral"- [ test_blackscholes conf- , test_smvm conf- , test_radixsort conf+ [ test_blackscholes be conf+ , test_smvm be conf+ , test_radixsort be conf ]
examples/nofib/Test/Spectral/BlackScholes.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Test.Spectral.BlackScholes ( @@ -9,36 +10,33 @@ ) where -import Prelude as P import Control.Applicative import Data.Label import Data.Maybe import Data.Typeable-import Test.QuickCheck-import Test.Framework-import Test.Framework.Providers.QuickCheck2-import Foreign.Ptr import Foreign.Marshal+import Foreign.Ptr import Foreign.Storable import System.Random+import Test.Framework+import Test.Framework.Providers.QuickCheck2+import Test.QuickCheck+import Prelude as P 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.Examples.Internal as A import Data.Array.Accelerate.IO as A -test_blackscholes :: Config -> Test-test_blackscholes opt = testGroup "black-scholes" $ catMaybes+test_blackscholes :: Backend -> Config -> Test+test_blackscholes backend 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)
examples/nofib/Test/Spectral/RadixSort.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} --@@ -18,15 +19,14 @@ import Data.Maybe import Data.Function import Data.Typeable-import Test.QuickCheck ( Arbitrary, Property )+import Test.QuickCheck ( Arbitrary ) 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.Examples.Internal as A --@@ -37,8 +37,8 @@ -- to the simple list-based representation for the time being. -- -test_radixsort :: Config -> Test-test_radixsort opt = testGroup "radix sort" $ catMaybes+test_radixsort :: Backend -> Config -> Test+test_radixsort backend opt = testGroup "radix sort" $ catMaybes [ testElt configInt8 (undefined :: Int8) , testElt configInt16 (undefined :: Int16) , testElt configInt32 (undefined :: Int32)@@ -49,8 +49,6 @@ , 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
examples/nofib/Test/Spectral/SMVM.hs view
@@ -12,21 +12,19 @@ import Prelude as P import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal 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+test_smvm :: Backend -> Config -> Test+test_smvm backend opt = testGroup "smvm" $ catMaybes -- [ testElt configInt8 (undefined :: Int8) -- , testElt configInt16 (undefined :: Int16) -- , testElt configInt32 (undefined :: Int32)@@ -39,8 +37,6 @@ , testElt configDouble (undefined :: Double) ] where- backend = get configBackend opt- testElt :: forall a. (Elt a, IsNum a, Similar a, Arbitrary a) => (Config :-> Bool) -> a@@ -52,7 +48,7 @@ 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 arbitraryCSRMatrix $ \(segd, svec :: Vector (Int32,a), cols) -> forAll (arbitraryArray (Z :. cols)) $ \vec -> run2 backend smvm (segd, svec) vec ~?=
examples/pagerank/Config.hs view
@@ -1,39 +1,34 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt -data Options = Options++data Config = Config {- _optBackend :: Backend- , _optSteps :: Int- , _optChunkSize :: Int- , _optCount :: Bool- , _optHelp :: Bool+ _configSteps :: Int+ , _configChunkSize :: Int+ , _configCount :: Bool } deriving Show -$(mkLabels [''Options])+$(mkLabels [''Config]) -defaults :: Options-defaults = Options- { _optBackend = maxBound- , _optSteps = 10- , _optChunkSize = 12000000- , _optCount = False- , _optHelp = False+defaults :: Config+defaults = Config+ { _configSteps = 10+ , _configChunkSize = 12000000+ , _configCount = False } -options :: [OptDescr (Options -> Options)]+options :: [OptDescr (Config -> Config)] options =- [ Option [] ["steps"] (ReqArg (set optSteps . read) "INT") "number of steps to perform"- , Option [] ["chunk-size"] (ReqArg (set optChunkSize . read) "INT") "size of chunks to be processed"- , Option [] ["count"] (NoArg (set optCount True)) "count number of pages in the links file"- , Option "h?" ["help"] (NoArg (set optHelp True)) "show help message"+ [ Option [] ["steps"] (ReqArg (set configSteps . read) "INT") "number of steps to perform"+ , Option [] ["chunk-size"] (ReqArg (set configChunkSize . read) "INT") "size of chunks to be processed"+ , Option [] ["count"] (NoArg (set configCount True)) "count number of pages in the links file" ] @@ -49,8 +44,9 @@ , " running out of device memory. With experimentation, you can arrive" , " at a heap size that will force garbage collection before device" , " memory runs out."+ , "" ] footer :: [String]-footer = []+footer = [ "" ]
examples/pagerank/Main.hs view
@@ -1,25 +1,33 @@ {-# LANGUAGE PatternGuards #-} --- An implementation of PageRank based off of Ben Lippmeier's Repa implementation (http://repa.ouroborus.net/).+-- An implementation of PageRank based off of Ben Lippmeier's Repa+-- implementation (http://repa.ouroborus.net/). -- import Config-import ParseArgs import Count import Rank++import Control.Monad+import Data.Char import Data.Label ( get ) import System.Environment import System.Exit-import Data.Char-import Control.Monad +import Data.Array.Accelerate.Examples.Internal + main :: IO ()-main- = do argv <- getArgs- (config, _, linksPath : titlesPath : _) <- parseArgs optHelp optBackend options defaults header footer argv+main = do+ beginMonitoring+ argv <- getArgs+ (conf, opts, linksPath : titlesPath : _) <- parseArgs options defaults header footer argv - if get optCount config- then void (countPages linksPath)- else rank (get optBackend config) (get optSteps config) (get optChunkSize config) linksPath titlesPath+ let backend = get optBackend opts+ steps = get configSteps conf+ chunk = get configChunkSize conf++ if get configCount conf+ then void (countPages linksPath)+ else rank backend steps chunk linksPath titlesPath
examples/pagerank/Page.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ module Page ( PageId , Rank
examples/pagerank/Rank.hs view
@@ -1,19 +1,22 @@ {-# LANGUAGE BangPatterns #-}-module Rank- (rank)-where+{-# LANGUAGE TypeFamilies #-}++module Rank (rank)+ where++ import Load import Step import Count import Page-import ParseArgs import System.Directory import Control.Monad-import Prelude as P-import Data.Array.Accelerate as A-import Data.Array.Accelerate.IO as A-import qualified Data.Vector as V-import qualified Data.Vector.Storable as S+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.IO as A+import Data.Array.Accelerate.Examples.Internal as A+import qualified Data.Vector as V+import qualified Data.Vector.Storable as S import System.CPUTime
examples/ray/Config.hs view
@@ -1,62 +1,49 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt -data Options = Options+data Config = Config {- _optBackend :: Backend- , _optWidth :: Int- , _optHeight :: Int- , _optZoom :: Int- , _optFieldOfView :: Int- , _optBounces :: Int- , _optFramerate :: Int- , _optBench :: Bool- , _optHelp :: Bool+ _configWidth :: Int+ , _configHeight :: Int+ , _configZoom :: Int+ , _configFieldOfView :: Int+ , _configBounces :: Int+ , _configFramerate :: Int } deriving Show -$(mkLabels [''Options])+$(mkLabels [''Config]) -defaults :: Options-defaults = Options- { _optBackend = maxBound- , _optWidth = 800- , _optHeight = 600- , _optFieldOfView = 100- , _optZoom = 1- , _optBounces = 4- , _optFramerate = 30-#ifdef ACCELERATE_ENABLE_GUI- , _optBench = False-#else- , _optBench = True-#endif- , _optHelp = False+defaults :: Config+defaults = Config+ { _configWidth = 800+ , _configHeight = 600+ , _configFieldOfView = 100+ , _configZoom = 1+ , _configBounces = 4+ , _configFramerate = 30 } -options :: [OptDescr (Options -> Options)]+options :: [OptDescr (Config -> Config)] options =- [ Option [] ["width"] (ReqArg (set optWidth . read) "INT") (describe optWidth "visualisation width")- , Option [] ["height"] (ReqArg (set optHeight . read) "INT") (describe optHeight "visualisation height")- , Option [] ["zoom"] (ReqArg (set optZoom . read) "INT") (describe optZoom "pixel replication factor")- , Option [] ["fov"] (ReqArg (set optFieldOfView . read) "INT") (describe optFieldOfView "field of view")- , Option [] ["bounces"] (ReqArg (set optBounces . read) "INT") (describe optBounces "ray bounce limit")- , Option [] ["fps"] (ReqArg (set optFramerate . read) "INT") (describe optFramerate "frames per second")- , Option [] ["benchmark"] (NoArg (set optBench True)) "benchmark instead of displaying animation"- , Option "h?" ["help"] (NoArg (set optHelp True)) "show help message"+ [ Option [] ["width"] (ReqArg (set configWidth . read) "INT") (describe configWidth "visualisation width")+ , Option [] ["height"] (ReqArg (set configHeight . read) "INT") (describe configHeight "visualisation height")+ , Option [] ["zoom"] (ReqArg (set configZoom . read) "INT") (describe configZoom "pixel replication factor")+ , Option [] ["fov"] (ReqArg (set configFieldOfView . read) "INT") (describe configFieldOfView "field of view")+ , Option [] ["bounces"] (ReqArg (set configBounces . read) "INT") (describe configBounces "ray bounce limit")+ , Option [] ["fps"] (ReqArg (set configFramerate . read) "INT") (describe configFramerate "frames per second") ] where describe f msg = msg ++ " (" ++ show (get f defaults) ++ ")" header :: [String] header =- [ "accelerate-ray (c) [2013] The Accelerate Team"+ [ "accelerate-ray (c) [2013..2014] The Accelerate Team" , "" , "Usage: accelerate-ray [OPTIONS]" , ""@@ -68,5 +55,6 @@ , "Runtime usage:" , " WASD move the eye position" , " arrows move the light source"+ , "" ]
examples/ray/Main.hs view
@@ -1,43 +1,43 @@-{-# LANGUAGE CPP #-} module Main where --- friends+-- Ray import Config-import ParseArgs-import Monitoring+import Scene.Object ( Objects )+import Scene.Light ( Lights ) import Scene.State import Gloss.Draw import Gloss.Event import Ray.Trace --- frenemies-import Data.Label+-- Friends import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal import Graphics.Gloss.Accelerate.Data.Color.RGB import qualified Graphics.Gloss.Accelerate.Raster.Field as G --- library-import Criterion.Main ( defaultMainWith, bench, whnf )-import System.Environment ( getArgs, withArgs )+-- Enemies+import Data.Label+import System.Environment ( getArgs ) main :: IO () main = do beginMonitoring argv <- getArgs- (conf, cconf, rest) <- parseArgs optHelp optBackend options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer argv - let width = get optWidth conf- height = get optHeight conf- zoom = get optZoom conf- fov = get optFieldOfView conf- bounces = get optBounces conf- backend = get optBackend conf- fps = get optFramerate conf+ let width = get configWidth conf+ height = get configHeight conf+ zoom = get configZoom conf+ fov = get configFieldOfView conf+ bounces = get configBounces conf+ fps = get configFramerate conf+ backend = get optBackend opts state = initState 0 ambient = rawColor 0.3 0.3 0.3 + scene :: Acc (Objects,Lights) -> Acc (Array DIM2 Color) scene st = let eye = constant (get stateEyePos state) eyeDir = castViewRays width height fov eye@@ -46,25 +46,20 @@ in A.zipWith (traceRay bounces objects lights ambient) eyePos eyeDir - if get optBench conf- then withArgs rest- $ defaultMainWith cconf (return ())- [ bench "ray" $ whnf (run1 backend scene)- (get stateObjects state, get stateLights state)- ]+ runBenchmarks opts rest+ [ bench "ray"+ $ whnf (run1 backend scene)+ (get stateObjects state, get stateLights state) ] -#ifndef ACCELERATE_ENABLE_GUI- else return ()-#else- else G.playFieldWith- (run1 backend)- (G.InWindow "Ray" (width, height) (10, 10))- (zoom, zoom)- fps- state- prepareState- (tracePixel width height fov bounces ambient)- handleEvent- advanceState-#endif+ runInteractive opts rest+ $ G.playFieldWith+ (run1 backend)+ (G.InWindow "Ray" (width, height) (10, 10))+ (zoom, zoom)+ fps+ state+ prepareState+ (tracePixel width height fov bounces ambient)+ handleEvent+ advanceState
examples/ray/Ray/Intersect.hs view
@@ -26,8 +26,8 @@ (h1, d1, _ :: Exp a) = unlift x (h2, d2, _ :: Exp a) = unlift y in- h1 &&* h2 ? ( d1 <* d2 ? (x, y) -- both objects intersect; take the nearest- , h1 ? (x, y) ) -- only one object intersects+ h1 &&* h2 ? ( d1 A.<* d2 ? (x, y) -- both objects intersect; take the nearest+ , h1 ? (x, y) ) -- only one object intersects -- | Find the nearest point of intersection for a ray. If there is a hit, then@@ -54,7 +54,7 @@ = sfoldl (\s o -> let (_, dist, _) = unlift s :: (Exp Bool, Exp Float, Exp object) (hit, dist') = unlift $ distanceTo o orig dir in- hit &&* dist' <* dist ? (lift (hit, dist', o), s))+ hit &&* dist' A.<* dist ? (lift (hit, dist', o), s)) (lift (False, infinity, dummy)) (constant Z) objects@@ -72,9 +72,9 @@ -> Exp Float -- minimum distance -> Exp Bool checkRay distanceTo objs orig dir dist- = A.fst $ A.while (\s -> let (hit, i) = unlift s in A.not hit &&* i <* unindex1 (shape objs))+ = A.fst $ A.while (\s -> let (hit, i) = unlift s in A.not hit &&* i A.<* unindex1 (shape objs)) (\s -> let i = A.snd s (hit, dist') = unlift $ distanceTo (objs ! index1 i) orig dir- in hit &&* dist' <* dist ? (lift (True, i), lift (False, i+1)))+ in hit &&* dist' A.<* dist ? (lift (True, i), lift (False, i+1))) (constant (False, 0))
examples/ray/Ray/Trace.hs view
@@ -85,7 +85,7 @@ next_p = hitPlaneCheck p dist_p orig dir (point, normal, color, shine)- = unlift (dist_s <* dist_p ? ( next_s, next_p ))+ = unlift (dist_s A.<* dist_p ? ( next_s, next_p )) -- result angle of ray after reflection newdir = dir - (2.0 * (normal `dot` dir)) .* normal
examples/ray/Scene/Object.hs view
@@ -126,8 +126,8 @@ v1 = (A.truncate (x / 100) :: Exp Int32) `mod` 2 v2 = (A.truncate (z / 100) :: Exp Int32) `mod` 2- v3 = A.fromIntegral . boolToInt $ x <* 0.0- v4 = A.fromIntegral . boolToInt $ z <* 0.0+ v3 = A.fromIntegral . boolToInt $ x A.<* 0.0+ v4 = A.fromIntegral . boolToInt $ z A.<* 0.0 in v1 `xor` v2 `xor` v3 `xor` v4 ==* 1 {- True -} ? ( rawColor 1.0 1.0 1.0
examples/smoothlife/Config.hs view
@@ -6,9 +6,9 @@ import Prelude as P hiding ((.), id, fst, snd) import qualified Prelude as P -import ParseArgs import Data.Label import Control.Category+import System.Console.GetOpt import Data.Array.Accelerate ( Array, DIM2 ) import Data.Array.Accelerate.Data.Complex ( Complex )@@ -46,11 +46,8 @@ data Config = Config {- -- How to execute the simulation- _configBackend :: Backend- -- How to present the output- , _configWindowSize :: Int+ _configWindowSize :: Int , _configWindowZoom :: Int , _configFramerate :: Int , _configTimestep :: Float@@ -71,8 +68,6 @@ -- Terminating conditions , _configMaxSteps :: Maybe Int- , _configBenchmark :: Bool- , _configHelp :: Bool } $(mkLabels [''Config])@@ -81,9 +76,7 @@ defaults :: Config defaults = Config {- _configBackend = maxBound-- , _configWindowSize = 256+ _configWindowSize = 256 , _configWindowZoom = 3 , _configFramerate = 30 , _configTimestep = 0.1@@ -114,8 +107,6 @@ , _configMixtype = Smooth , _configMaxSteps = Nothing- , _configBenchmark = False- , _configHelp = False } @@ -196,14 +187,6 @@ , Option [] ["max-steps"] (ReqArg (set configMaxSteps . read) "INT") (describe configMaxSteps "exit simulation after this many steps")-- , Option [] ["benchmark"]- (NoArg (set configBenchmark True))- (describe configBenchmark "benchmark instead of displaying animation")-- , Option "h?" ["help"]- (NoArg (set configHelp True))- "show this help message" ] where describe f msg@@ -228,5 +211,6 @@ , "" , "Available colour schemes:" , " " ++ unwords (map show [minBound .. maxBound :: ColourScheme])+ , "" ]
examples/smoothlife/Gloss/Draw.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleContexts #-} module Gloss.Draw where@@ -36,13 +37,13 @@ colour Rainbow3 f = rainbow' (sqrt (sqrt (1-f))) (sqrt (sqrt f)) rainbow p x- = p >* 0 &&* p <* 1- ? (lift (x, x*p, constant 0, alpha)- , p <* 2 ? (lift (x*(2-p), x, constant 0, alpha)- , p <* 3 ? (lift (constant 0, x, x*(p-2), alpha)- , p <* 4 ? (lift (constant 0, x*(4-p), x, alpha)- , p <* 5 ? (lift (x*(p-4), constant 0, x, alpha)- , p <* 6 ? (lift (x, constant 0, x*(6-p), alpha)+ = p >* 0 &&* p A.<* 1+ ? (lift (x, x*p, constant 0, alpha)+ , p A.<* 2 ? (lift (x*(2-p), x, constant 0, alpha)+ , p A.<* 3 ? (lift (constant 0, x, x*(p-2), alpha)+ , p A.<* 4 ? (lift (constant 0, x*(4-p), x, alpha)+ , p A.<* 5 ? (lift (x*(p-4), constant 0, x, alpha)+ , p A.<* 6 ? (lift (x, constant 0, x*(6-p), alpha) , {-else-} (constant (0,0,0,0)))))))) rainbow' p x
examples/smoothlife/Main.hs view
@@ -1,32 +1,28 @@-{-# LANGUAGE CPP #-} -- -- A cellular automata simulation -- -- friends import Config-import Monitoring-import ParseArgs import SmoothLife import Gloss.Draw-import Random.Array import Random.Splat -- system-import Prelude as P-import Data.Array.Accelerate as A+import Prelude as P+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A import Data.Label import Control.Exception import System.Environment import Graphics.Gloss-import Criterion.Main ( defaultMainWith, bench, whnf ) main :: IO () main = do beginMonitoring argv <- getArgs- (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv+ (conf, opts, rest) <- parseArgs options defaults header footer argv let -- visualisation configuration n = get configWindowSize conf@@ -38,12 +34,12 @@ width = n * zoom height = n * zoom - backend = get configBackend conf+ backend = get optBackend opts scheme = get configColourScheme conf render = draw conf . run1 backend (colourise scheme)- advance = run1 backend (smoothlife conf)+ advance = run1 backend (smoothlife conf opts) -- initialise with patches of random data dots <- randomCircles dish ra rb@@ -52,20 +48,16 @@ world <- evaluate (advance agar) -- Rise minions!- if get configBenchmark conf- then withArgs nops $ defaultMainWith cconf (return ())- [ bench "smoothlife" $ whnf advance world ]+ runBenchmarks opts rest+ [ bench "smoothlife" $ whnf advance world ] -#ifndef ACCELERATE_ENABLE_GUI- else return ()-#else- else play- (InWindow "Smooth Life" (width, height) (10, 20))- black- fps- world- render- (\_ -> id)- (\_ -> advance)-#endif+ runInteractive opts rest+ $ play+ (InWindow "Smooth Life" (width, height) (10, 20))+ black+ fps+ world+ render+ (\_ -> id)+ (\_ -> advance)
examples/smoothlife/Random/Splat.hs view
@@ -7,9 +7,8 @@ import Control.Monad import System.Random.MWC-import Random.Array ( (:~>) )-import Data.Array.Accelerate ( DIM2, Z(..), (:.)(..) )-+import Data.Array.Accelerate ( DIM2, Z(..), (:.)(..) )+import Data.Array.Accelerate.Examples.Internal ( (:~>) ) -- Generate a random point on the grid by checking which circles it overlaps.
examples/smoothlife/SmoothLife.hs view
@@ -1,6 +1,7 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE CPP #-} -- -- A cellular automata simulation over a smooth domain. --@@ -12,11 +13,11 @@ where import Config-import ParseArgs -import Prelude as P+import Prelude as P import Data.Label-import Data.Array.Accelerate as A hiding ( size )+import Data.Array.Accelerate as A hiding ( size )+import Data.Array.Accelerate.Examples.Internal as A hiding ( nf ) import Data.Array.Accelerate.Math.FFT import Data.Array.Accelerate.Math.DFT.Centre import Data.Array.Accelerate.Data.Complex@@ -30,9 +31,10 @@ smoothlife :: Config+ -> Options -> Acc (Matrix R) -> Acc (Matrix R)-smoothlife conf aa+smoothlife conf opts aa = aa'' where -- A simulation step@@ -73,7 +75,7 @@ kflr'' = constant (kflr' `A.indexArray` Z) kfld'' = constant (kfld' `A.indexArray` Z) (kflr', kfld', krf', kdf')- = run (get configBackend conf) $ lift (kflr, kfld, krf, kdf)+ = run (get optBackend opts) $ lift (kflr, kfld, krf, kdf) -- Auxiliary --@@ -90,8 +92,8 @@ sqrt (x*x + y*y) linear x l u- = x <* l-u/2 ? ( 0.0- , x >* l+u/2 ? ( 1.0+ = x A.<* l-u/2 ? ( 0.0+ , x A.>* l+u/2 ? ( 1.0 , (x - l + u / 2) / u )) clamp = A.map@@ -163,6 +165,6 @@ where bounded :: (Exp R -> Exp R -> Exp R -> Exp R) -> Exp R -> Exp R -> Exp R -> Exp R bounded f' x' a' ea'- = x' <* a'-ea'/2.0 ? ( 0.0- , x' >* a'+ea'/2.0 ? ( 1.0+ = x' A.<* a'-ea'/2.0 ? ( 0.0+ , x' A.>* a'+ea'/2.0 ? ( 1.0 , f' x' a' ea' ))
examples/smvm/Config.hs view
@@ -2,35 +2,22 @@ module Config where -import ParseArgs import Data.Label+import System.Console.GetOpt + 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) ++ ")"+options = [] header :: [String]@@ -42,6 +29,5 @@ ] footer :: [String]-footer = []-+footer = [ "" ]
examples/smvm/Main.hs view
@@ -2,17 +2,15 @@ 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 Prelude as P+import Data.Label ( get ) import System.Random.MWC import System.Exit import System.Environment-import Data.Array.Accelerate as A-import qualified Data.Vector.Unboxed as V+import Data.Array.Accelerate as A+import Data.Array.Accelerate.Examples.Internal as A+import qualified Data.Vector.Unboxed as V main :: IO ()@@ -20,10 +18,10 @@ beginMonitoring argv <- getArgs- (conf, cconf, nops) <- parseArgs configHelp configBackend options defaults header footer argv- fileIn <- case nops of+ (_, opts, rest) <- parseArgs options defaults header footer argv+ fileIn <- case rest of (i:_) -> return i- _ -> parseArgs configHelp configBackend options defaults [] [] ("--help":argv)+ _ -> parseArgs options defaults [] [] ("--help":argv) >> exitSuccess -- Read in the matrix file, and generate a random vector to multiply against@@ -38,7 +36,7 @@ svec = fromFunction (Z :. V.length svec') (\(Z:.i) -> svec' V.! i) smat = lift (use segd, svec) - backend = get configBackend conf+ backend = get optBackend opts putStrLn $ "Reading matrix: " P.++ fileIn putStrLn $ " with shape: " P.++ shows (V.length segd') " x " P.++ shows cols " and "@@ -46,6 +44,6 @@ -- Benchmark --- withArgs (P.tail nops) $ defaultMainWith cconf (return ())+ runBenchmarks opts (P.tail rest) [ bench "smvm" $ whnf (run1 backend (smvm smat)) vec ]
examples/smvm/MatrixMarket.hs view
@@ -7,8 +7,8 @@ import Data.Int import Data.Complex-import Data.Attoparsec.Char8-import Data.ByteString.Lex.Double+import Data.Attoparsec.ByteString.Char8+import Data.ByteString.Lex.Fractional import qualified Data.Attoparsec.Lazy as L import qualified Data.ByteString.Lazy as L @@ -60,13 +60,14 @@ comment :: Parser () comment = char '%' *> skipWhile (not . eol) *> endOfLine- where eol w = w `elem` "\n\r"+ where+ eol w = w `elem` ("\n\r" :: String) floating :: Fractional a => Parser a floating = do- mv <- readDouble <$> (skipSpace *> takeTill isSpace) -- readDouble does the fancy stuff+ mv <- readDecimal <$> (skipSpace *> takeTill isSpace) -- readDecimal does the fancy stuff case mv of- Just (v,_) -> return . realToFrac $ v+ Just (v,_) -> return v Nothing -> fail "floating-point number" integral :: Integral a => Parser a
+ lib/Data/Array/Accelerate/Examples/Internal.hs view
@@ -0,0 +1,35 @@+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module exposes some internal infrastructure that is useful and common to+-- the accelerate-examples test and benchmark program suite. This is not+-- intended for general consumption.+--++module Data.Array.Accelerate.Examples.Internal (++ module Data.Array.Accelerate.Examples.Internal.ParseArgs,+ module Data.Array.Accelerate.Examples.Internal.Criterion,+ module Data.Array.Accelerate.Examples.Internal.Interactive,+ module Data.Array.Accelerate.Examples.Internal.TestFramework,+ module Data.Array.Accelerate.Examples.Internal.Monitoring,+ module Data.Array.Accelerate.Examples.Internal.Random.Array,+ module Data.Array.Accelerate.Examples.Internal.Util,++) where++import Data.Array.Accelerate.Examples.Internal.Criterion+import Data.Array.Accelerate.Examples.Internal.Interactive+import Data.Array.Accelerate.Examples.Internal.Monitoring+import Data.Array.Accelerate.Examples.Internal.ParseArgs+import Data.Array.Accelerate.Examples.Internal.Random.Array+import Data.Array.Accelerate.Examples.Internal.Similar+import Data.Array.Accelerate.Examples.Internal.TestFramework+import Data.Array.Accelerate.Examples.Internal.Util+
+ lib/Data/Array/Accelerate/Examples/Internal/Backend.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Backend+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This file is all that should need editing in order to add support for new+-- backends to the accelerate-examples package.+--++module Data.Array.Accelerate.Examples.Internal.Backend+ where++import Data.Label+import System.Console.GetOpt++import Data.Array.Accelerate+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+#endif+#ifdef ACCELERATE_LLVM_NATIVE_BACKEND+import qualified Data.Array.Accelerate.LLVM.Native as CPU+#endif+#ifdef ACCELERATE_LLVM_PTX_BACKEND+import qualified Data.Array.Accelerate.LLVM.PTX as PTX+#endif+#ifdef ACCELERATE_CILK_BACKEND+import qualified Data.Array.Accelerate.Cilk as Cilk+#endif+++-- | Execute Accelerate expressions+--+run :: Arrays a => Backend -> Acc a -> a+run Interpreter = Interp.run+#ifdef ACCELERATE_CUDA_BACKEND+run CUDA = CUDA.run+#endif+#ifdef ACCELERATE_LLVM_NATIVE_BACKEND+run CPU = CPU.run+#endif+#ifdef ACCELERATE_LLVM_PTX_BACKEND+run PTX = PTX.run+#endif+#ifdef ACCELERATE_CILK_BACKEND+run Cilk = Cilk.run+#endif+++run1 :: (Arrays a, Arrays b) => Backend -> (Acc a -> Acc b) -> a -> b+run1 Interpreter f = Interp.run1 f+#ifdef ACCELERATE_CUDA_BACKEND+run1 CUDA f = CUDA.run1 f+#endif+#ifdef ACCELERATE_LLVM_NATIVE_BACKEND+run1 CPU f = CPU.run1 f+#endif+#ifdef ACCELERATE_LLVM_PTX_BACKEND+run1 PTX f = PTX.run1 f+#endif+#ifdef ACCELERATE_CILK_BACKEND+run1 Cilk f = Cilk.run . f . use+#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.+--+data Backend = Interpreter+#ifdef ACCELERATE_CUDA_BACKEND+ | CUDA+#endif+#ifdef ACCELERATE_LLVM_NATIVE_BACKEND+ | CPU+#endif+#ifdef ACCELERATE_LLVM_PTX_BACKEND+ | PTX+#endif+#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND+ | Multi+#endif+#ifdef ACCELERATE_CILK_BACKEND+ | Cilk+#endif+ deriving (Eq, Bounded)+++-- The choice of show instance is important because this will be used to+-- generate the command line flag.+--+instance Show Backend where+ show Interpreter = "interpreter"+#ifdef ACCELERATE_CUDA_BACKEND+ show CUDA = "cuda"+#endif+#ifdef ACCELERATE_LLVM_NATIVE_BACKEND+ show CPU = "llvm-cpu"+#endif+#ifdef ACCELERATE_LLVM_PTX_BACKEND+ show PTX = "llvm-gpu"+#endif+#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND+ show Multi = "llvm-multi"+#endif+#ifdef ACCELERATE_CILK_BACKEND+ show Cilk = "cilk"+#endif+++-- The default backend to use. Currently the only complete accelerated backend+-- is CUDA, so default to that if it is available.+--+defaultBackend :: Backend+#ifdef ACCELERATE_CUDA_BACKEND+defaultBackend = CUDA+#else+defaultBackend = maxBound+#endif+++-- The set of available backnds. This will be used for both the command line+-- options as well as the fancy header generation.+--+availableBackends :: (options :-> Backend) -> [OptDescr (options -> options)]+availableBackends optBackend =+ [ Option [] [show Interpreter]+ (NoArg (set optBackend Interpreter))+ "reference implementation (sequential)"++#ifdef ACCELERATE_CUDA_BACKEND+ , Option [] [show CUDA]+ (NoArg (set optBackend CUDA))+ "implementation for NVIDIA GPUs (parallel)"+#endif+#ifdef ACCELERATE_LLVM_NATIVE_BACKEND+ , Option [] [show CPU]+ (NoArg (set optBackend CPU))+ "LLVM based implementation for multicore CPUs (parallel)"+#endif+#ifdef ACCELERATE_LLVM_PTX_BACKEND+ , Option [] [show PTX]+ (NoArg (set optBackend PTX))+ "LLVM based implementation for NVIDIA GPUs (parallel)"+#endif+#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND+ , Option [] [show Multi]+ (NoArg (set optBackend Multi))+ "LLVM based multi-device implementation using CPUs and GPUs (parallel)"+#endif+#ifdef ACCELERATE_CILK_BACKEND+ , Option [] [show Cilk]+ (NoArg (set optBackend Cilk))+ "Cilk based implementation for multicore CPUs (parallel)"+#endif+ ]+++-- By default, how many instances of the backend can be run concurrently?+--+-- If this returns `Nothing` then we make no changes to the configuration and+-- inherit the RTS options. If this is `Just n`, then by default only `n`+-- threads will be used to run tests at once. This option can still be+-- overridden via the command line flags, it just sets a default.+--+-- e.g.+-- * A multicore CPU backend may specify `Just 1`, so that only one instance+-- runs at once, and it inherits all threads specified via `+RTS -Nn`+--+-- * A thread-safe accelerator backend can specify `Nothing`, while a+-- non-thread-safe backend (perhaps it requires exclusive access to the+-- accelerator board) should specify `Just 1`.+--+concurrentBackends :: Backend -> Maybe Int+concurrentBackends Interpreter = Nothing+#ifdef ACCELERATE_CUDA_BACKEND+concurrentBackends CUDA = Nothing -- not quite true! D:+#endif+#ifdef ACCELERATE_LLVM_NATIVE_BACKEND+concurrentBackends CPU = Just 1+#endif+#ifdef ACCELERATE_LLVM_PTX_BACKEND+concurrentBackends PTX = Nothing -- ???+#endif+#ifdef ACCELERATE_CILK_BACKEND+concurrentBackends Cilk = Just 1+#endif+
+ lib/Data/Array/Accelerate/Examples/Internal/Codespeed.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Codespeed+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.Codespeed+ where++import Data.Array.Accelerate.Error+import Data.Array.Accelerate.Examples.Internal.TH+import Data.Array.Accelerate.Examples.Internal.ParseArgs++import Data.Aeson+import Data.Char+import Data.Text ( Text )+import Data.Label+import Data.Monoid+import Control.Monad+import Criterion.Types ( Report(..), SampleAnalysis(..), Regression(..) )+import Statistics.Resampling.Bootstrap ( Estimate(..), scale )+import Network.HTTP ( simpleHTTP, postRequestWithBody, Response(..) )+import Network.HTTP.Types ( urlEncode )+import System.IO+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Map as Map+import qualified Data.Text+++data Sample = Sample+ {+ sampleName :: String -- benchmark name+ , sampleTime :: Estimate -- sample result (via OLS regression)+ , sampleRSquare :: Estimate -- R^2 goodness-of-fit estimate of regression+ , sampleMean :: Estimate -- result mean+ , sampleStdDev :: Estimate -- standard deviation+ , sampleUnits :: Unit+ }++data Unit = Unit+ {+ unitName :: String -- e.g. seconds+ , unitType :: String -- description of the unit, e.g. Time+ , lessIsMore :: Bool -- so python, much philosophical+ }+++-- Treat a sample as being in milliseconds+--+ms :: Sample -> Sample+ms Sample{..} =+ Sample { sampleTime = scale 1000 sampleTime+ , sampleRSquare = scale 1000 sampleRSquare+ , sampleMean = scale 1000 sampleMean+ , sampleStdDev = scale 1000 sampleStdDev+ , sampleUnits = Unit { unitName = "ms"+ , unitType = "Time"+ , lessIsMore = True }+ , ..+ }+++-- Extract benchmark information from the Criterion report+--+-- TODO: Extract any other regressions present in the report into separate+-- samples, e.g. GC statistics+--+sample :: Report -> Sample+sample Report{..} = ms $ Sample+ { sampleName = reportName+ , sampleTime = regIters+ , sampleRSquare = regRSquare+ , sampleMean = anMean+ , sampleStdDev = anStdDev+ , sampleUnits = error "sample has no unit assigned"+ }+ where+ SampleAnalysis{..} = reportAnalysis+ Regression{..} = head anRegress+ regIters = case Map.lookup "iters" regCoeffs of+ Nothing -> $internalError "sample" "no benchmark result found"+ Just t -> t++-- Encode a sample to a JSON value suitable for upload to codespeed+--+toValue :: Options -> Sample -> Value+toValue opt Sample{..} = object+ [ "commitid" .= $(_HEAD)+ , "branch" .= $(_BRANCH)+ , "project" .= ("accelerate-examples" :: Text)+ , "executable" .= get optVariant opt+ , "environment" .= get optHostname opt+ , "benchmark" .= sampleName+ , "result_value" .= estPoint sampleTime+ , "min" .= estLowerBound sampleTime+ , "max" .= estUpperBound sampleTime+ , "std_dev" .= estPoint sampleStdDev+ , "units" .= unitName sampleUnits+ , "units_title" .= unitType sampleUnits+ , "lessismore" .= lessIsMore sampleUnits+ ]+++-- Upload a set of criterion reports to the codespeed server+--+uploadReports :: Options -> [Report] -> IO ()+uploadReports opt reports =+ when upload $ do+ putStr ("Uploading results to " ++ server ++ " ... ") >> hFlush stdout+ rsp <- simpleHTTP $ postRequestWithBody url contentType content+ case rsp of+ Left err -> do+ putStrLn "failed"+ hPutStrLn stderr (show err)++ Right Response{..} ->+ case rspCode of+ (2,0,2) -> putStrLn "Ok"+ (a,b,c) -> do putStrLn $ map intToDigit [a,b,c] ++ ' ' : rspReason+ hPutStrLn stderr rspBody+ where+ (upload, server) = maybe (False, undefined) (True,) (get optCodespeed opt)++ contentType = "application/x-www-form-urlencoded"+ url = server <> "/result/add/json/"+ payload = "json=" <> encode (map (toValue opt . sample) reports)+ content = BS.unpack . urlEncode False $ BL.toStrict payload+
+ lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs view
@@ -0,0 +1,76 @@+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Criterion+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.Criterion (++ -- * Criterion benchmarking+ runBenchmarks,+ nf, whnf, nfIO, whnfIO,+ Benchmark, env, bench, bgroup,++) where++import Data.Array.Accelerate.Examples.Internal.Report+import Data.Array.Accelerate.Examples.Internal.ParseArgs+import Data.Array.Accelerate.Examples.Internal.Criterion.Config++import Data.Label+import Control.Monad+import System.IO+import System.Directory+import System.Environment++import Criterion.IO+import Criterion.Main+++-- | Run the given benchmarks, if we have enabled benchmark mode.+--+runBenchmarks :: Options -> [String] -> [Benchmark] -> IO ()+runBenchmarks opt argv benchmarks+ = when (get optBenchmark opt)+ $ withArgs argv+ $ do+ let crit = get optCriterion opt++ -- In order to get the reports, we read them from the raw data file.+ -- This is actually the way that Criterion does it as well, and I+ -- believe is so that gathering the reports does not affect the+ -- measurements when there is a large number of benchmarks.+ --+ rawFile <- case get rawDataFile crit of+ Just f -> return f+ Nothing -> do+ tmp <- getTemporaryDirectory+ (f,h) <- openBinaryTempFile tmp "accelerate-examples.dat"+ hClose h+ removeFile f+ return f++ -- Run the standard benchmark loop+ --+ defaultMainWith (set rawDataFile (Just rawFile) crit) benchmarks++ -- Retrieve the reports. Delete the temporary file if necessary.+ --+ reports <- do+ exists <- doesFileExist rawFile+ if exists+ then either fail return =<< do+ rs <- readReports rawFile+ case get rawDataFile crit of+ Nothing -> removeFile rawFile >> return rs+ Just _ -> return rs+ else return []++ -- Analyse the reports, upload to the benchmark server, etc.+ --+ processReports opt reports+
+ lib/Data/Array/Accelerate/Examples/Internal/Criterion/Config.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Criterion.Config+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.Criterion.Config (++ -- ** Criterion options+ Config, defaultConfig,+ module Data.Array.Accelerate.Examples.Internal.Criterion.Config++) where++import Prelude hiding ( (.), (<$>), id )+import Data.Char+import Data.Label+import Data.Label.Derive+import Control.Category ( (.), id )+import System.Console.GetOpt+import Text.Printf+import Text.PrettyPrint.ANSI.Leijen+import qualified Data.Map as M++import Criterion.Analysis ( validateAccessors )+import Criterion.Types ( Config, measureKeys, measureAccessors )+import Criterion.Main.Options ( defaultConfig )++$(mkLabelsNamed id [''Config])+++-- A GetOpt version of Criterion's command line options parser. It is+-- unfortunate that we need to do this to integrate with the other frameworks.+--+defaultOptions :: [OptDescr (Config -> Config)]+defaultOptions =+ [ Option [] ["ci"]+ (ReqArg (set confInterval . read) "CI")+ (describe confInterval "confidence interval")++ , Option [] ["no-gc"]+ (NoArg (set forceGC False))+ "do not collect garbage between iterations"++ , Option [] ["time-limit"]+ (ReqArg (set timeLimit . read) "SECS")+ (describe timeLimit "time limit to run a benchmark")++ , Option [] ["resamples"]+ (ReqArg (set resamples . read) "INT")+ (describe resamples "number of bootstrap resamples to perform")++ , Option [] ["regress"]+ (ReqArg (\v -> modify regressions (regressParams v :)) "RESP:PRED..")+ "regressions to perform"++ , Option [] ["raw"]+ (OptArg (set rawDataFile) "FILE")+ (describe rawDataFile "file to write raw data to")++ , Option [] ["output"]+ (OptArg (set reportFile) "FILE")+ (describe reportFile "file to write report to")++ , Option [] ["csv"]+ (OptArg (set csvFile) "FILE")+ (describe csvFile "file to write CSV summary to")++ , Option [] ["junit"]+ (OptArg (set junitFile) "FILE")+ (describe junitFile "file to write JUnit summary to")++ , Option [] ["verbosity"]+ (ReqArg (set verbosity . toEnum . range (0,2) . read) "LEVEL")+ (describe' fromEnum verbosity "verbosity level")++ , Option [] ["template"]+ (ReqArg (set template) "FILE")+ (describe template "template to use for report")+ ]+ where+ describe :: Show a => (Config :-> a) -> String -> String+ describe = describe' id++ describe' :: Show a => (b -> a) -> (Config :-> b) -> String -> String+ describe' p f msg+ = msg ++ " (" ++ show (p (get f defaultConfig)) ++ ")"++ range (n,m) x+ | n <= x && x <= m = x+ | otherwise = error $ printf "%d is outside range (%d,%d)" x n m++-- The following options are not part of the configuration structure, but will+-- be intercepted when calling 'defaultMainWith', and control the execution+-- mode. We include these extra options when generating the help text, but don't+-- include them when processing the 'Config' structure.+--+extraOptions :: [OptDescr (a -> a)]+extraOptions =+ [ Option [] ["match"]+ (ReqArg (flip const) "MATCH")+ "how to match benchmark names"++ , Option [] ["only-run"]+ (ReqArg (flip const) "ITERS")+ "run benchmarks, don't analyse"++ , Option [] ["list"]+ (NoArg id)+ "list benchmarks"++ , Option [] ["help"]+ (NoArg id)+ "Shows this help text"+ ]+++-- Check and parse the arguments to '--regress'. Copied from+-- Criterion.Main.Options+--+regressParams :: String -> ([String], String)+regressParams m+ | null r = error "regression parameters: no responder specified"+ | null ps = error "regression parameters: no predictors specified"+ | otherwise = validate `seq` ret+ where+ repl ',' = ' '+ repl c = c++ tidy = reverse . dropWhile isSpace . reverse . dropWhile isSpace+ (r,ps) = break (==':') m++ ret = (words . map repl . drop 1 $ ps, tidy r)+ validate = either error id $ uncurry validateAccessors ret++-- Generate the help string to describe the possible arguments to '--regress'.+-- Copied from Criterion.Main.Options.+--+regressHelp :: String+regressHelp+ = show+ $ text "Criterion regression metrics for use with --regress:"+ <$> tabulate [(text n, text d) | (n,(_,d)) <- map f measureKeys]+ where+ f k = (k, measureAccessors M.! k)+++tabulate :: [(Doc,Doc)] -> Doc+tabulate = tabulate' 24+ where+ tabulate' _ [] = empty+ tabulate' size table = vcat+ [ indent 2 (fillBreak size key <+> value) | (key, value) <- table ]+
+ lib/Data/Array/Accelerate/Examples/Internal/Interactive.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Interactive+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--+-- This module exposes some internal infrastructure that is useful and common to+-- the accelerate-examples test and benchmark program suite. This is not+-- intended for general consumption.+--++module Data.Array.Accelerate.Examples.Internal.Interactive (++ -- * Interactive/GUI+ runInteractive,++) where++import Data.Array.Accelerate.Examples.Internal.ParseArgs++#ifdef ACCELERATE_ENABLE_GUI+import Data.Label+import Control.Monad+import System.Environment+#endif++-- | If accelerate-examples is configured to enable GUI programs, and we are+-- not in benchmarking mode, then execute the given action.+--+runInteractive :: Options -> [String] -> IO () -> IO ()+#ifndef ACCELERATE_ENABLE_GUI+runInteractive _ _ _+ = return ()+#else+runInteractive opt argv gui+ = unless (get optBenchmark opt)+ $ withArgs argv gui+#endif+
+ lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Monitoring+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.Monitoring (++ -- * Resource monitoring+ beginMonitoring,++) where++#ifdef ACCELERATE_ENABLE_EKG+import Control.Monad+import System.Remote.Monitoring+#endif+++-- | Launch a monitoring server that will collect statistics on the running+-- application. This should be called as soon as the application starts. The+-- program will need to be run with the RTS option -T.+--+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/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.ParseArgs+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.ParseArgs (++ -- * Options processing+ parseArgs,+ Options, optBackend, optTest, optBenchmark, optCodespeed, optHostname,+ optVariant, optHelp, optCriterion, optTestFramework,++ module System.Console.GetOpt,++ -- * Executing programs+ module Data.Array.Accelerate.Examples.Internal.Backend,++) where++import Data.Array.Accelerate.Examples.Internal.Backend+import qualified Data.Array.Accelerate.Examples.Internal.Criterion.Config as Criterion+import qualified Data.Array.Accelerate.Examples.Internal.TestFramework.Config as TestFramework++import Data.List+import Data.Label+import Data.Monoid+import Control.Monad+import System.Exit+import System.Console.GetOpt+import Text.PrettyPrint.ANSI.Leijen+import Prelude++#ifdef ACCELERATE_ENABLE_CODESPEED+import Data.Char+import Network.BSD+import System.IO.Unsafe+#endif++-- Generic program options+-- -----------------------++data Options = Options+ {+ _optBackend :: Backend -- ^ Accelerate backend to execute programs with+ , _optTest :: Bool -- ^ Should tests be run?+ , _optBenchmark :: Bool -- ^ Should benchmarks be run?+ , _optCodespeed :: Maybe String -- ^ URL of codespeed server to upload results to+ , _optHostname :: String -- ^ Machine name to use for reported results+ , _optVariant :: String -- ^ Variant to use for reported results+ , _optHelp :: Bool -- ^ Display help message (and exit)?+ --+ , _optTestFramework :: TestFramework.Config -- ^ Options for test-framework+ , _optCriterion :: Criterion.Config -- ^ Options for criterion benchmarks+ }++$(mkLabels [''Options])+++-- Options parsing infrastructure+-- ------------------------------++defaultOptions :: Options+defaultOptions = Options+ {+ _optBackend = backend+ , _optTest = True+#ifndef ACCELERATE_ENABLE_GUI+ , _optBenchmark = True+#else+ , _optBenchmark = False+#endif+ , _optCodespeed = Nothing+ , _optVariant = variant+ , _optHostname = hostname+ , _optHelp = False+ , _optCriterion = Criterion.defaultConfig+ , _optTestFramework = TestFramework.defaultConfig backend+ }+ where+ backend = defaultBackend+#ifdef ACCELERATE_ENABLE_CODESPEED+ variant = "accelerate-" ++ show (_optBackend defaultOptions)+ hostname = unsafePerformIO $ do+ h <- getHostName+ return $ map toLower $ takeWhile (/= '.') h+#else+ variant = []+ hostname = []+#endif+++options :: [OptDescr (Options -> Options)]+options = availableBackends optBackend +++ [+ Option [] ["benchmark"]+ (OptArg (set optBenchmark . maybe True read) "BOOL")+ (describe optBenchmark "enable benchmark mode")++ , Option [] ["test"]+ (OptArg (set optTest . maybe True read) "BOOL")+ (describe optTest "enable test mode")++#ifdef ACCELERATE_ENABLE_CODESPEED+ , Option [] ["upload"]+ (ReqArg (set optCodespeed . Just) "URL")+ "address of codespeed server to upload benchmark results"++ , Option [] ["hostname"]+ (ReqArg (set optHostname) "HOSTNAME")+ (describe optHostname "hostname to use for reported results")++ , Option [] ["variant"]+ (ReqArg (set optVariant) "STRING")+ (describe optVariant "variant to use for reported results")+#endif++ , Option "h?" ["help"]+ (NoArg (set optHelp True))+ "show help message"+ ]+ where+ describe f msg+ = msg ++ " (" ++ show (get f defaultOptions) ++ ")"+++-- | Format a (console) string as bold text. Assume the user has configured+-- their terminal colours to something that looks good (and avoids the light vs.+-- dark background debate).+--+sectionHeader :: String -> String+sectionHeader = show . bold . text++-- | Generate the list of available (and the selected) Accelerate backends.+--+fancyHeader :: Options -> [String] -> [String] -> String+fancyHeader opts header footer = intercalate "\n" (header ++ body ++ footer)+ where+ active this = if this == show (get optBackend opts) then "*" else ""+ (ss,bs,ds) = unzip3 $ map (\(b,d) -> (active b, b, d)) $ concatMap extract (availableBackends optBackend)+ 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 ]+ --+ 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+++-- | Strip the operational part of the options description structure, so that+-- the option lists can be combined for the purposes of displaying the usage+-- information.+--+_stripArgDescr :: [OptDescr a] -> [OptDescr b]+_stripArgDescr = map strip+ where+ strip (Option s l (NoArg _) d) = Option s l (NoArg undefined) d+ strip (Option s l (ReqArg _ a) d) = Option s l (ReqArg undefined a) d+ strip (Option s l (OptArg _ a) d) = Option s l (OptArg undefined a) d+++-- | Extract the option flags+--+extractOptFlags :: [OptDescr a] -> [String]+extractOptFlags = concatMap extract+ where+ extract (Option short long _ _) = map (\s -> '-':s:[]) short ++ map ("--"++) long+++-- | Process the command line arguments and return a tuple consisting of the+-- user options structure, accelerate-examples options (including options for+-- criterion and test-framework), and a list of unrecognised command line+-- arguments.+--+-- Since criterion and test-framework both bail if they encounter unrecognised+-- options, we run getOpt' ourselves. This means that the error messages might+-- be slightly different.+--+-- Any command line arguments following a "--" are not processed, but are+-- included as part of the unprocessed arguments returned on output.+--+parseArgs :: [OptDescr (config -> config)] -- ^ the user option descriptions+ -> config -- ^ user default option set+ -> [String] -- ^ header text+ -> [String] -- ^ footer text+ -> [String] -- ^ command line arguments+ -> IO (config, Options, [String])+parseArgs programOptions programConfig header footer args =+ let+ -- The option "--list" is ambiguous. It is handled by criterion only when+ -- benchmarks are being run, but if passed to test framework during option+ -- processing it will be consumed and treated as the "--list-tests" flag.+ --+ (argv, rest) =+ let (x, y) = span (/= "--") args+ (ls, x') = partition (== "--list") x+ in+ (x', ls ++ y)++ criterionOptions = stripShortOpts $ Criterion.defaultOptions ++ Criterion.extraOptions+ testframeworkOptions = stripShortOpts $ TestFramework.defaultOptions++ helpMsg [] = helpMsg'+ helpMsg err = unlines [ concat err, helpMsg' ]++ section (sectionHeader -> str) opts = usageInfo str opts++ helpMsg' = unlines+ [ fancyHeader defaultOptions header []+ , ""+ , section "Options:" options+ , section "Program options:" programOptions+ , section "Criterion options:" criterionOptions+ , Criterion.regressHelp+ , ""+ , section "Test-Framework options:" testframeworkOptions+ ]++ in do+ -- In the first round process options for the user program. Processing the+ -- user options first means that we can still handle any short or long options+ -- that take arguments but which were not joined with an equals sign; e.g.+ --+ -- "-f blah" or "--foo blah".+ --+ -- Following this phase we must disallow short options with arguments, and+ -- only long options in the form "--foo=blah" will work correctly. This is+ -- because getOpt is splitting the unrecognised options ("--foo") from the+ -- non-option arguments ("blah").+ --+ (c1,non,u1) <- case getOpt' Permute programOptions argv of+ (opts,n,u,[]) -> case foldr id programConfig opts of+ conf -> return (conf,n,u)+ (_,_,_,err) -> error (helpMsg err)++ -- The standard accelerate-examples options+ --+ (c2,u2) <- case getOpt' Permute options u1 of+ (opts,_,u,[]) -> return (foldr id defaultOptions opts, u)+ (_,_,_,err) -> error (helpMsg err)++ -- Criterion options+ --+ (c3,u3) <- case getOpt' Permute Criterion.defaultOptions u2 of+ (opts,_,u,[]) -> return (foldr id Criterion.defaultConfig opts, u)+ (_,_,_,err) -> error (helpMsg err)++ -- Test framework options+ --+ (c4,u4) <- case getOpt' Permute testframeworkOptions u3 of+ (opts,_,u,[]) | Just os <- sequence opts+ -> return (mconcat os, u)+ (_,_,_,err) -> error (helpMsg err)++ -- Show the help message if that was requested. This is done last so that the+ -- header is not shown twice in the case of a subsequent options parse error.+ --+ if get optHelp c2+ then putStr (helpMsg []) >> exitSuccess+ else putStrLn (fancyHeader c2 header footer)++ -- Issue a warning if there are any unrecognised options. Criterion will error+ -- if we are in benchmark mode and there is anything it doesn't understand,+ -- and the error message is somewhat confusing.+ --+ let eco = extractOptFlags Criterion.extraOptions+ (yes,no) = partition (\x -> takeWhile (/= '=') x `elem` eco) u4++ unless (null no) $ do+ putStrLn "Warning: unrecognised options"+ putStrLn $ unlines $ map (" "++) no++ return (c1, c2 { _optCriterion = c3, _optTestFramework = c4 }, yes ++ non ++ rest)+
+ lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeOperators #-}+-- Module: : Data.Array.Accelerate.Examples.Internal.Random.Array+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.Random.Array (++ -- * Generating random arrays+ (:~>),+ uniform, uniformR,+ randomArray, randomArrayWithSeed, randomArrayWithSystemRandom,++) where++import System.Random.MWC hiding ( uniform, uniformR )+import qualified System.Random.MWC as R++import Data.Array.Accelerate as A+import Data.Array.Accelerate.Array.Data as A+import Data.Array.Accelerate.Array.Sugar as Sugar+++-- | A PNRG from indices to variates+--+type sh :~> e = sh -> GenIO -> IO e+++-- | Uniformly distributed random variates.+--+uniform :: (Shape sh, Elt e, Variate e) => sh :~> e+uniform _ = R.uniform++-- | Uniformly distributed random variates in a given range.+--+uniformR :: (Shape sh, Elt e, Variate e) => (e, e) -> sh :~> e+uniformR bounds _ = R.uniformR bounds+++-- | Generate an array of random values using the supplied generator function.+-- The generator for variates is initialised with a fixed seed.+--+randomArray :: (Shape sh, Elt e) => sh :~> e -> sh -> Array sh e+randomArray f sh+ = let+ (adata, _) = runArrayData $ do+ gen <- create+ arr <- runRandomArray f sh gen+ return (arr, undefined)+ in+ adata `seq` Array (fromElt sh) adata+++-- | Generate an array of random values using a supplied generator function and+-- seed value.+--+randomArrayWithSeed :: (Shape sh, Elt e) => Seed -> sh :~> e -> sh -> Array sh e+randomArrayWithSeed seed f sh+ = let+ (adata, _) = runArrayData $ do+ gen <- restore seed+ arr <- runRandomArray f sh gen+ return (arr, undefined)+ in+ adata `seq` Array (fromElt sh) adata+++-- | Generate an array of random values using a supplied generator function,+-- initialised with the system's source of pseudo-random numbers.+--+-- TODO: find a way to do this directly, without going via save/restore.+--+randomArrayWithSystemRandom+ :: forall sh e. (Shape sh, Elt e)+ => sh :~> e+ -> sh+ -> IO (Array sh e)+randomArrayWithSystemRandom f sh+ = do+ seed <- withSystemRandom (asGenIO save)+ return $! randomArrayWithSeed seed f sh+++-- Common function to create a mutable array and fill it with random values+--+runRandomArray+ :: (Shape sh, Elt e)+ => sh :~> e+ -> sh+ -> GenIO+ -> IO (MutableArrayData (EltRepr e))+runRandomArray f sh gen+ = do+ arr <- newArrayData $! Sugar.size sh+ let write ix = unsafeWriteArrayData arr (Sugar.toIndex sh ix)+ . fromElt =<< f ix gen++ iter sh write (>>) (return ())+ return arr+
+ lib/Data/Array/Accelerate/Examples/Internal/Report.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Report+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.Report (++ processReports,++) where++import Criterion.Types+import Data.Array.Accelerate.Examples.Internal.ParseArgs++#ifdef ACCELERATE_ENABLE_CODESPEED+import Data.Array.Accelerate.Examples.Internal.Codespeed+#endif+++-- | Post-process the benchmark reports.+--+processReports :: Options -> [Report] -> IO ()+processReports _opt _reports = do+#ifdef ACCELERATE_ENABLE_CODESPEED+ uploadReports _opt _reports+#endif++ return ()+
+ lib/Data/Array/Accelerate/Examples/Internal/Similar.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Similar+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.Similar (++ Similar(..)++) where++import Prelude as P+import Data.Complex+import Foreign.C.Types+import Data.Array.Accelerate+++-- 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, x2) ~= (y1, y2) = x1 ~= y1 && x2 ~= y2++instance (Similar a, Similar b, Similar c) => Similar (a, b, c) where+ (x1, x2, x3) ~= (y1, y2, y3) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3++instance (Similar a, Similar b, Similar c, Similar d) => Similar (a, b, c, d) where+ (x1, x2, x3, x4) ~= (y1, y2, y3, y4) = x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4++instance (Similar a, Similar b, Similar c, Similar d, Similar e)+ => Similar (a, b, c, d, e) where+ (x1, x2, x3, x4, x5) ~= (y1, y2, y3, y4, y5) =+ x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f)+ => Similar (a, b, c, d, e, f) where+ (x1, x2, x3, x4, x5, x6) ~= (y1, y2, y3, y4, y5, y6) =+ x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g)+ => Similar (a, b, c, d, e, f, g) where+ (x1, x2, x3, x4, x5, x6, x7) ~= (y1, y2, y3, y4, y5, y6, y7) =+ x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h)+ => Similar (a, b, c, d, e, f, g, h) where+ (x1, x2, x3, x4, x5, x6, x7, x8) ~= (y1, y2, y3, y4, y5, y6, y7, y8) =+ x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8++instance (Similar a, Similar b, Similar c, Similar d, Similar e, Similar f, Similar g, Similar h, Similar i)+ => Similar (a, b, c, d, e, f, g, h, i) where+ (x1, x2, x3, x4, x5, x6, x7, x8, x9) ~= (y1, y2, y3, y4, y5, y6, y7, y8, y9) =+ x1 ~= y1 && x2 ~= y2 && x3 ~= y3 && x4 ~= y4 && x5 ~= y5 && x6 ~= y6 && x7 ~= y7 && x8 ~= y8 && x9 ~= y9++instance Similar Z+instance (Eq sh, Eq sz) => Similar (sh:.sz)++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 Char+instance Similar Bool+instance Similar CShort+instance Similar CUShort+instance Similar CInt+instance Similar CUInt+instance Similar CLong+instance Similar CULong+instance Similar CLLong+instance Similar CULLong+instance Similar CChar+instance Similar CSChar+instance Similar CUChar++instance Similar Float where (~=) = absRelTol 0.00005 0.005+instance Similar Double where (~=) = absRelTol 0.00005 0.005+instance Similar CFloat where (~=) = absRelTol 0.00005 0.005+instance Similar CDouble where (~=) = absRelTol 0.00005 0.005++instance (Similar e, RealFloat e) => Similar (Complex e) where+ (r1 :+ i1) ~= (r2 :+ i2) = r1 ~= r2 && i1 ~= i2+++-- {-# 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 -> a -> a -> Bool+absRelTol epsilonAbs epsilonRel u v+ | isInfinite u+ && isInfinite v = True+ | P.isNaN u+ && P.isNaN v = True+ | abs (u-v) < epsilonAbs = True+ | abs u > abs v = abs ((u-v) / u) < epsilonRel+ | otherwise = abs ((v-u) / v) < epsilonRel++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+
+ lib/Data/Array/Accelerate/Examples/Internal/TH.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.TH+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.TH (++ _HEAD, _BRANCH,++) where++import Data.Version+import Control.Exception+import Language.Haskell.TH+import System.Process++import Paths_accelerate_examples+++-- Try to determine the git version of the repository. If this fails, then we+-- aren't in a git (development) repository, so assume that we are a released+-- version and report the cabal version instead.+--+_HEAD :: ExpQ+_HEAD = packQ =<< runIO (gitVersion `orElse` cabalVersion)+ where+ gitVersion :: IO String+ gitVersion = init `fmap` readProcess "git" ["rev-parse", "HEAD"] []++ -- Based on the cabal version, we can look up the SHA of that version. Of+ -- course, there is a circular dependency here...+ --+ cabalVersion :: String+ cabalVersion =+ case versionBranch version of+ [0,16,0,0] -> "TODO: release/0.16 SHA"+ _ -> "(no commit)"+++-- Try to determine the git branch of the repository. If this fails, then we+-- aren't in a git (development) repository, so assume a release branch.+--+_BRANCH :: ExpQ+_BRANCH = packQ =<< runIO (gitBranch `orElse` releaseBranch)+ where+ gitBranch :: IO String+ gitBranch = init `fmap` readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] []++ releaseBranch :: String+ releaseBranch =+ case versionBranch version of+ (m:n:_) -> "release/" ++ show m ++ "." ++ show n+ _ -> "(no branch)"+++orElse :: IO a -> a -> IO a+orElse x y = x `catch` \ (_ :: IOError) -> return y++packQ :: String -> ExpQ+packQ x = varE (mkName "Data.Text.pack") `appE` stringE x+
+ lib/Data/Array/Accelerate/Examples/Internal/TestFramework.hs view
@@ -0,0 +1,92 @@+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.TestFramework+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.TestFramework (++ -- * Test-framework runner+ Test, runTests,++ -- ** QuickCheck+ Property, testProperty, testGroup, (~=?), (~?=),++ -- ** HUnit+ Assertion, testCase, assertEqual,++ -- ** Similarity+ module Data.Array.Accelerate.Examples.Internal.Similar,++) where++import Data.Array.Accelerate.Examples.Internal.ParseArgs+import Data.Array.Accelerate.Examples.Internal.Similar++import Data.Label+import Control.Monad+import Control.Exception+import System.Exit+import System.Environment++import Test.Framework+import Test.HUnit ( Assertion, assertFailure )+import Test.QuickCheck ( Property, counterexample, ioProperty )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+++-- | Run the given tests, if enabled.+--+runTests :: Options -> [String] -> [Test] -> IO ()+runTests opts argv tests+ = when (get optTest opts)+ $ withArgs argv+ $ do+ putStrLn "running tests..."+ defaultMainWithOpts tests (get optTestFramework opts)+ -- test-framework wants to have a nap on success; don't let it.+ `catch` \e -> case e of+ ExitSuccess -> putStrLn ""+ _ -> throwIO e+++failure :: Show a => a -> a -> String+failure expected actual =+ unlines [ "*** Expected:", show expected+ , "*** Received:", show actual ]++-- | 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)+ => a -- ^ The expected value+ -> a -- ^ The actual value+ -> Assertion+assertEqual expected actual =+ unless (expected ~= actual)+ (assertFailure (failure expected 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+expected ~=? actual =+ ioProperty $ do+ actual' <- evaluate actual+ return $! counterexample (failure expected actual') (expected ~= actual')++-- | 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 (~=?)+
+ lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.TestFramework.Config+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.TestFramework.Config (++ -- ** Test framework options+ module Data.Array.Accelerate.Examples.Internal.TestFramework.Config++) where++import Data.Monoid+import Data.Label+import Data.Label.Derive+import Test.Framework ( RunnerOptions, RunnerOptions', optionsDescription, SuppliedRunnerOptions )+import System.Console.GetOpt+import Prelude++import Data.Array.Accelerate.Examples.Internal.Backend++$(mkLabelsNamed id [''RunnerOptions'])++type Config = RunnerOptions++defaultConfig :: Backend -> Config+defaultConfig b = set ropt_threads (concurrentBackends b) mempty++defaultOptions :: [OptDescr SuppliedRunnerOptions]+defaultOptions = optionsDescription++
+ lib/Data/Array/Accelerate/Examples/Internal/Util.hs view
@@ -0,0 +1,33 @@+-- |+-- Module: : Data.Array.Accelerate.Examples.Internal.Util+-- Copyright : [2014] Trevor L. McDonell+-- License : BSD3+--+-- Maintainer : Trevor L. McDonell <tmcdonell@cse.unsw.edu.au>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)+--++module Data.Array.Accelerate.Examples.Internal.Util (++ -- * Miscellaneous+ showFFloatSIBase,++) where++import Numeric+import Data.List+++-- | Show a floating point number in scientific notation with a specific base.+--+showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS+showFFloatSIBase p b n+ = showString+ . nubBy (\x y -> x == ' ' && y == ' ')+ $ showFFloat p n' [ ' ', si_unit ]+ where+ n' = n / (b ^^ (pow-4))+ pow = max 0 . min 8 . (+) 4 . floor $ logBase b n+ si_unit = "pnµm kMGT" !! pow+
− lib/Monitoring.hs
@@ -1,20 +0,0 @@-{-# 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
@@ -1,223 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternGuards #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ViewPatterns #-}--module ParseArgs (-- module ParseArgs,- module System.Console.GetOpt,--) where--import Data.List-import Data.Label-import System.Exit-import System.Console.GetOpt-import qualified Criterion.Main as Criterion-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-#endif-#ifdef ACCELERATE_LLVM_NATIVE_BACKEND-import qualified Data.Array.Accelerate.LLVM.Native as CPU-#endif-#ifdef ACCELERATE_LLVM_PTX_BACKEND-import qualified Data.Array.Accelerate.LLVM.PTX as PTX-#endif-#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND-import qualified Data.Array.Accelerate.LLVM.Multi as Multi-#endif----- | Execute Accelerate expressions----run :: Arrays a => Backend -> Acc a -> a-run Interpreter = Interp.run-#ifdef ACCELERATE_CUDA_BACKEND-run CUDA = CUDA.run-#endif-#ifdef ACCELERATE_LLVM_NATIVE_BACKEND-run CPU = CPU.run-#endif-#ifdef ACCELERATE_LLVM_PTX_BACKEND-run PTX = PTX.run-#endif-#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND-run Multi = Multi.run-#endif---run1 :: (Arrays a, Arrays b) => Backend -> (Acc a -> Acc b) -> a -> b-run1 Interpreter f = Interp.run1 f-#ifdef ACCELERATE_CUDA_BACKEND-run1 CUDA f = CUDA.run1 f-#endif-#ifdef ACCELERATE_LLVM_NATIVE_BACKEND-run1 CPU f = CPU.run1 f-#endif-#ifdef ACCELERATE_LLVM_PTX_BACKEND-run1 PTX f = PTX.run1 f-#endif-#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND-run1 Multi f = Multi.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 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- | CUDA-#endif-#ifdef ACCELERATE_LLVM_NATIVE_BACKEND- | CPU-#endif-#ifdef ACCELERATE_LLVM_PTX_BACKEND- | PTX-#endif-#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND- | Multi-#endif- deriving (Eq, Bounded)---instance Show Backend where- show Interpreter = "interpreter"-#ifdef ACCELERATE_CUDA_BACKEND- show CUDA = "cuda"-#endif-#ifdef ACCELERATE_LLVM_NATIVE_BACKEND- show CPU = "llvm-cpu"-#endif-#ifdef ACCELERATE_LLVM_PTX_BACKEND- show PTX = "llvm-gpu"-#endif-#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND- show Multi = "llvm-multi"-#endif---availableBackends :: (f :-> Backend) -> [OptDescr (f -> f)]-availableBackends backend =- [ Option [] [show Interpreter]- (NoArg (set backend Interpreter))- "reference implementation (sequential)"--#ifdef ACCELERATE_CUDA_BACKEND- , Option [] [show CUDA]- (NoArg (set backend CUDA))- "implementation for NVIDIA GPUs (parallel)"-#endif-#ifdef ACCELERATE_LLVM_NATIVE_BACKEND- , Option [] [show CPU]- (NoArg (set backend CPU))- "LLVM based implementation for multicore CPUs (parallel)"-#endif-#ifdef ACCELERATE_LLVM_PTX_BACKEND- , Option [] [show PTX]- (NoArg (set backend PTX))- "LLVM based implementation for NVIDIA GPUs (parallel)"-#endif-#ifdef ACCELERATE_LLVM_MULTIDEV_BACKEND- , Option [] [show Multi]- (NoArg (set backend Multi))- "LLVM based multi-device implementation using CPUs and GPUs (parallel)"-#endif- ]----- | Complete the options set by appending a description of the available--- execution backends.----withBackends :: (f :-> Backend) -> [OptDescr (f -> f)] -> [OptDescr (f -> f)]-withBackends backend xs = availableBackends backend ++ xs----- | Create the help text including a list of the available (and selected)--- Accelerate backends.----fancyHeader :: (config :-> Backend) -> config -> [String] -> [String] -> String-fancyHeader backend opts header footer = unlines (header ++ body ++ footer)- where- active this = if this == show (get backend opts) then "*" else ""- (ss,bs,ds) = unzip3 $ map (\(b,d) -> (active b, b, d)) $ concatMap extract (availableBackends backend)- 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 ]- --- 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.------ We drop any command line arguments following a "--".----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, [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:" criterionOptions-- in do-- -- 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)-- -- 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-- return (conf, cconf, non)-
− lib/Random/Array.hs
@@ -1,96 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}--module Random.Array (-- (:~>),- uniform, uniformR,- randomArray, randomArrayWithSeed, randomArrayWithSystemRandom,--) where--import System.Random.MWC hiding ( uniform, uniformR )-import qualified System.Random.MWC as R--import Data.Array.Accelerate as A-import Data.Array.Accelerate.Array.Data as A-import Data.Array.Accelerate.Array.Sugar as Sugar----- | A PNRG from indices to variates----type sh :~> e = sh -> GenIO -> IO e----- | Uniformly distributed random variates.----uniform :: (Shape sh, Elt e, Variate e) => sh :~> e-uniform _ = R.uniform---- | Uniformly distributed random variates in a given range.----uniformR :: (Shape sh, Elt e, Variate e) => (e, e) -> sh :~> e-uniformR bounds _ = R.uniformR bounds----- | Generate an array of random values using the supplied generator function.--- The generator for variates is initialised with a fixed seed.----randomArray :: (Shape sh, Elt e) => sh :~> e -> sh -> Array sh e-randomArray f sh- = let- (adata, _) = runArrayData $ do- gen <- create- arr <- runRandomArray f sh gen- return (arr, undefined)- in- adata `seq` Array (fromElt sh) adata----- | Generate an array of random values using a supplied generator function and--- seed value.----randomArrayWithSeed :: (Shape sh, Elt e) => Seed -> sh :~> e -> sh -> Array sh e-randomArrayWithSeed seed f sh- = let- (adata, _) = runArrayData $ do- gen <- restore seed- arr <- runRandomArray f sh gen- return (arr, undefined)- in- adata `seq` Array (fromElt sh) adata----- | Generate an array of random values using a supplied generator function,--- initialised with the system's source of pseudo-random numbers.------ TODO: find a way to do this directly, without going via save/restore.----randomArrayWithSystemRandom- :: forall sh e. (Shape sh, Elt e)- => sh :~> e- -> sh- -> IO (Array sh e)-randomArrayWithSystemRandom f sh- = do- seed <- withSystemRandom (asGenIO save)- return $! randomArrayWithSeed seed f sh----- Common function to create a mutable array and fill it with random values----runRandomArray- :: (Shape sh, Elt e)- => sh :~> e- -> sh- -> GenIO- -> IO (MutableArrayData (EltRepr e))-runRandomArray f sh gen- = do- arr <- newArrayData $! Sugar.size sh- let write ix = unsafeWriteArrayData arr (Sugar.toIndex sh ix)- . fromElt =<< f ix gen-- iter sh write (>>) (return ())- return arr-
− lib/Util.hs
@@ -1,19 +0,0 @@--module Util where--import Numeric-import Data.List----- Utilities----showFFloatSIBase :: RealFloat a => Maybe Int -> a -> a -> ShowS-showFFloatSIBase p b n- = showString- . nubBy (\x y -> x == ' ' && y == ' ')- $ showFFloat p n' [ ' ', si_unit ]- where- n' = n / (b ^^ (pow-4))- pow = max 0 . min 8 . (+) 4 . floor $ logBase b n- si_unit = "pnµm kMGT" !! pow-