diff --git a/accelerate-examples.cabal b/accelerate-examples.cabal --- a/accelerate-examples.cabal +++ b/accelerate-examples.cabal @@ -1,7 +1,7 @@ Name: accelerate-examples -Version: 0.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 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 --- diff --git a/examples/canny/src-acc/Canny.hs b/examples/canny/src-acc/Canny.hs --- a/examples/canny/src-acc/Canny.hs +++ b/examples/canny/src-acc/Canny.hs @@ -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 diff --git a/examples/canny/src-acc/Config.hs b/examples/canny/src-acc/Config.hs --- a/examples/canny/src-acc/Config.hs +++ b/examples/canny/src-acc/Config.hs @@ -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 = [ "" ] diff --git a/examples/canny/src-acc/Main.hs b/examples/canny/src-acc/Main.hs --- a/examples/canny/src-acc/Main.hs +++ b/examples/canny/src-acc/Main.hs @@ -2,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' diff --git a/examples/canny/src-acc/Wildfire.hs b/examples/canny/src-acc/Wildfire.hs --- a/examples/canny/src-acc/Wildfire.hs +++ b/examples/canny/src-acc/Wildfire.hs @@ -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. diff --git a/examples/crystal/Config.hs b/examples/crystal/Config.hs --- a/examples/crystal/Config.hs +++ b/examples/crystal/Config.hs @@ -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 = [ "" ] diff --git a/examples/crystal/Main.hs b/examples/crystal/Main.hs --- a/examples/crystal/Main.hs +++ b/examples/crystal/Main.hs @@ -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) diff --git a/examples/fft/src-acc/Config.hs b/examples/fft/src-acc/Config.hs --- a/examples/fft/src-acc/Config.hs +++ b/examples/fft/src-acc/Config.hs @@ -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 = [ "" ] diff --git a/examples/fft/src-acc/HighPass.hs b/examples/fft/src-acc/HighPass.hs --- a/examples/fft/src-acc/HighPass.hs +++ b/examples/fft/src-acc/HighPass.hs @@ -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) diff --git a/examples/fft/src-acc/Main.hs b/examples/fft/src-acc/Main.hs --- a/examples/fft/src-acc/Main.hs +++ b/examples/fft/src-acc/Main.hs @@ -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 + ] + diff --git a/examples/fluid/src-acc/Config.hs b/examples/fluid/src-acc/Config.hs --- a/examples/fluid/src-acc/Config.hs +++ b/examples/fluid/src-acc/Config.hs @@ -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 diff --git a/examples/fluid/src-acc/Fluid.hs b/examples/fluid/src-acc/Fluid.hs --- a/examples/fluid/src-acc/Fluid.hs +++ b/examples/fluid/src-acc/Fluid.hs @@ -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) diff --git a/examples/fluid/src-acc/Main.hs b/examples/fluid/src-acc/Main.hs --- a/examples/fluid/src-acc/Main.hs +++ b/examples/fluid/src-acc/Main.hs @@ -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 diff --git a/examples/fluid/src-acc/World.hs b/examples/fluid/src-acc/World.hs --- a/examples/fluid/src-acc/World.hs +++ b/examples/fluid/src-acc/World.hs @@ -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 diff --git a/examples/hashcat/Config.hs b/examples/hashcat/Config.hs --- a/examples/hashcat/Config.hs +++ b/examples/hashcat/Config.hs @@ -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 = [ "" ] diff --git a/examples/hashcat/Digest.hs b/examples/hashcat/Digest.hs --- a/examples/hashcat/Digest.hs +++ b/examples/hashcat/Digest.hs @@ -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 diff --git a/examples/hashcat/MD5.hs b/examples/hashcat/MD5.hs --- a/examples/hashcat/MD5.hs +++ b/examples/hashcat/MD5.hs @@ -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 diff --git a/examples/hashcat/Main.hs b/examples/hashcat/Main.hs --- a/examples/hashcat/Main.hs +++ b/examples/hashcat/Main.hs @@ -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) diff --git a/examples/kmeans/Config.hs b/examples/kmeans/Config.hs --- a/examples/kmeans/Config.hs +++ b/examples/kmeans/Config.hs @@ -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 = [ "" ] diff --git a/examples/kmeans/GenSamples.hs b/examples/kmeans/GenSamples.hs new file mode 100644 --- /dev/null +++ b/examples/kmeans/GenSamples.hs @@ -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) + diff --git a/examples/kmeans/Kmeans.hs b/examples/kmeans/Kmeans.hs --- a/examples/kmeans/Kmeans.hs +++ b/examples/kmeans/Kmeans.hs @@ -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 diff --git a/examples/kmeans/Main.hs b/examples/kmeans/Main.hs --- a/examples/kmeans/Main.hs +++ b/examples/kmeans/Main.hs @@ -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 ] diff --git a/examples/mandelbrot/Config.hs b/examples/mandelbrot/Config.hs --- a/examples/mandelbrot/Config.hs +++ b/examples/mandelbrot/Config.hs @@ -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)" + , "" ] diff --git a/examples/mandelbrot/Main.hs b/examples/mandelbrot/Main.hs --- a/examples/mandelbrot/Main.hs +++ b/examples/mandelbrot/Main.hs @@ -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) diff --git a/examples/mandelbrot/Mandel.hs b/examples/mandelbrot/Mandel.hs --- a/examples/mandelbrot/Mandel.hs +++ b/examples/mandelbrot/Mandel.hs @@ -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 {-- diff --git a/examples/mandelbrot/World.hs b/examples/mandelbrot/World.hs --- a/examples/mandelbrot/World.hs +++ b/examples/mandelbrot/World.hs @@ -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]) diff --git a/examples/n-body/Config.hs b/examples/n-body/Config.hs --- a/examples/n-body/Config.hs +++ b/examples/n-body/Config.hs @@ -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 = [ "" ] diff --git a/examples/n-body/Main.hs b/examples/n-body/Main.hs --- a/examples/n-body/Main.hs +++ b/examples/n-body/Main.hs @@ -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 diff --git a/examples/n-body/Random/Position.hs b/examples/n-body/Random/Position.hs --- a/examples/n-body/Random/Position.hs +++ b/examples/n-body/Random/Position.hs @@ -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 diff --git a/examples/n-body/Test.hs b/examples/n-body/Test.hs new file mode 100644 --- /dev/null +++ b/examples/n-body/Test.hs @@ -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))] + diff --git a/examples/nofib/Config.hs b/examples/nofib/Config.hs --- a/examples/nofib/Config.hs +++ b/examples/nofib/Config.hs @@ -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 = [ "" ] diff --git a/examples/nofib/Main.hs b/examples/nofib/Main.hs --- a/examples/nofib/Main.hs +++ b/examples/nofib/Main.hs @@ -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. -- diff --git a/examples/nofib/QuickCheck/Arbitrary/Shape.hs b/examples/nofib/QuickCheck/Arbitrary/Shape.hs --- a/examples/nofib/QuickCheck/Arbitrary/Shape.hs +++ b/examples/nofib/QuickCheck/Arbitrary/Shape.hs @@ -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 diff --git a/examples/nofib/Test/Base.hs b/examples/nofib/Test/Base.hs --- a/examples/nofib/Test/Base.hs +++ b/examples/nofib/Test/Base.hs @@ -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 diff --git a/examples/nofib/Test/FFT.hs b/examples/nofib/Test/FFT.hs --- a/examples/nofib/Test/FFT.hs +++ b/examples/nofib/Test/FFT.hs @@ -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 diff --git a/examples/nofib/Test/Foreign.hs b/examples/nofib/Test/Foreign.hs --- a/examples/nofib/Test/Foreign.hs +++ b/examples/nofib/Test/Foreign.hs @@ -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 diff --git a/examples/nofib/Test/Foreign/CUDA.hs b/examples/nofib/Test/Foreign/CUDA.hs new file mode 100644 --- /dev/null +++ b/examples/nofib/Test/Foreign/CUDA.hs @@ -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 + diff --git a/examples/nofib/Test/IO/Vector.hs b/examples/nofib/Test/IO/Vector.hs --- a/examples/nofib/Test/IO/Vector.hs +++ b/examples/nofib/Test/IO/Vector.hs @@ -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 diff --git a/examples/nofib/Test/Imaginary.hs b/examples/nofib/Test/Imaginary.hs --- a/examples/nofib/Test/Imaginary.hs +++ b/examples/nofib/Test/Imaginary.hs @@ -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 ] diff --git a/examples/nofib/Test/Imaginary/DotP.hs b/examples/nofib/Test/Imaginary/DotP.hs --- a/examples/nofib/Test/Imaginary/DotP.hs +++ b/examples/nofib/Test/Imaginary/DotP.hs @@ -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 diff --git a/examples/nofib/Test/Imaginary/SASUM.hs b/examples/nofib/Test/Imaginary/SASUM.hs --- a/examples/nofib/Test/Imaginary/SASUM.hs +++ b/examples/nofib/Test/Imaginary/SASUM.hs @@ -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 diff --git a/examples/nofib/Test/Imaginary/SAXPY.hs b/examples/nofib/Test/Imaginary/SAXPY.hs --- a/examples/nofib/Test/Imaginary/SAXPY.hs +++ b/examples/nofib/Test/Imaginary/SAXPY.hs @@ -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 diff --git a/examples/nofib/Test/Issues.hs b/examples/nofib/Test/Issues.hs --- a/examples/nofib/Test/Issues.hs +++ b/examples/nofib/Test/Issues.hs @@ -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 ] diff --git a/examples/nofib/Test/Issues/Issue102.hs b/examples/nofib/Test/Issues/Issue102.hs --- a/examples/nofib/Test/Issues/Issue102.hs +++ b/examples/nofib/Test/Issues/Issue102.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue114.hs b/examples/nofib/Test/Issues/Issue114.hs --- a/examples/nofib/Test/Issues/Issue114.hs +++ b/examples/nofib/Test/Issues/Issue114.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue119.hs b/examples/nofib/Test/Issues/Issue119.hs --- a/examples/nofib/Test/Issues/Issue119.hs +++ b/examples/nofib/Test/Issues/Issue119.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue123.hs b/examples/nofib/Test/Issues/Issue123.hs --- a/examples/nofib/Test/Issues/Issue123.hs +++ b/examples/nofib/Test/Issues/Issue123.hs @@ -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] diff --git a/examples/nofib/Test/Issues/Issue137.hs b/examples/nofib/Test/Issues/Issue137.hs --- a/examples/nofib/Test/Issues/Issue137.hs +++ b/examples/nofib/Test/Issues/Issue137.hs @@ -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)] diff --git a/examples/nofib/Test/Issues/Issue168.hs b/examples/nofib/Test/Issues/Issue168.hs --- a/examples/nofib/Test/Issues/Issue168.hs +++ b/examples/nofib/Test/Issues/Issue168.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue184.hs b/examples/nofib/Test/Issues/Issue184.hs --- a/examples/nofib/Test/Issues/Issue184.hs +++ b/examples/nofib/Test/Issues/Issue184.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue185.hs b/examples/nofib/Test/Issues/Issue185.hs --- a/examples/nofib/Test/Issues/Issue185.hs +++ b/examples/nofib/Test/Issues/Issue185.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue187.hs b/examples/nofib/Test/Issues/Issue187.hs --- a/examples/nofib/Test/Issues/Issue187.hs +++ b/examples/nofib/Test/Issues/Issue187.hs @@ -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 diff --git a/examples/nofib/Test/Issues/Issue93.hs b/examples/nofib/Test/Issues/Issue93.hs --- a/examples/nofib/Test/Issues/Issue93.hs +++ b/examples/nofib/Test/Issues/Issue93.hs @@ -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 diff --git a/examples/nofib/Test/Prelude.hs b/examples/nofib/Test/Prelude.hs --- a/examples/nofib/Test/Prelude.hs +++ b/examples/nofib/Test/Prelude.hs @@ -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 ] diff --git a/examples/nofib/Test/Prelude/Filter.hs b/examples/nofib/Test/Prelude/Filter.hs --- a/examples/nofib/Test/Prelude/Filter.hs +++ b/examples/nofib/Test/Prelude/Filter.hs @@ -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 diff --git a/examples/nofib/Test/Prelude/IndexSpace.hs b/examples/nofib/Test/Prelude/IndexSpace.hs --- a/examples/nofib/Test/Prelude/IndexSpace.hs +++ b/examples/nofib/Test/Prelude/IndexSpace.hs @@ -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 diff --git a/examples/nofib/Test/Prelude/Mapping.hs b/examples/nofib/Test/Prelude/Mapping.hs --- a/examples/nofib/Test/Prelude/Mapping.hs +++ b/examples/nofib/Test/Prelude/Mapping.hs @@ -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 diff --git a/examples/nofib/Test/Prelude/PrefixSum.hs b/examples/nofib/Test/Prelude/PrefixSum.hs --- a/examples/nofib/Test/Prelude/PrefixSum.hs +++ b/examples/nofib/Test/Prelude/PrefixSum.hs @@ -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 -- diff --git a/examples/nofib/Test/Prelude/Reduction.hs b/examples/nofib/Test/Prelude/Reduction.hs --- a/examples/nofib/Test/Prelude/Reduction.hs +++ b/examples/nofib/Test/Prelude/Reduction.hs @@ -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 diff --git a/examples/nofib/Test/Prelude/Replicate.hs b/examples/nofib/Test/Prelude/Replicate.hs --- a/examples/nofib/Test/Prelude/Replicate.hs +++ b/examples/nofib/Test/Prelude/Replicate.hs @@ -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 diff --git a/examples/nofib/Test/Prelude/Stencil.hs b/examples/nofib/Test/Prelude/Stencil.hs --- a/examples/nofib/Test/Prelude/Stencil.hs +++ b/examples/nofib/Test/Prelude/Stencil.hs @@ -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 diff --git a/examples/nofib/Test/Sharing.hs b/examples/nofib/Test/Sharing.hs --- a/examples/nofib/Test/Sharing.hs +++ b/examples/nofib/Test/Sharing.hs @@ -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 diff --git a/examples/nofib/Test/Spectral.hs b/examples/nofib/Test/Spectral.hs --- a/examples/nofib/Test/Spectral.hs +++ b/examples/nofib/Test/Spectral.hs @@ -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 ] diff --git a/examples/nofib/Test/Spectral/BlackScholes.hs b/examples/nofib/Test/Spectral/BlackScholes.hs --- a/examples/nofib/Test/Spectral/BlackScholes.hs +++ b/examples/nofib/Test/Spectral/BlackScholes.hs @@ -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) diff --git a/examples/nofib/Test/Spectral/RadixSort.hs b/examples/nofib/Test/Spectral/RadixSort.hs --- a/examples/nofib/Test/Spectral/RadixSort.hs +++ b/examples/nofib/Test/Spectral/RadixSort.hs @@ -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 diff --git a/examples/nofib/Test/Spectral/SMVM.hs b/examples/nofib/Test/Spectral/SMVM.hs --- a/examples/nofib/Test/Spectral/SMVM.hs +++ b/examples/nofib/Test/Spectral/SMVM.hs @@ -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 ~?= diff --git a/examples/pagerank/Config.hs b/examples/pagerank/Config.hs --- a/examples/pagerank/Config.hs +++ b/examples/pagerank/Config.hs @@ -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 = [ "" ] diff --git a/examples/pagerank/Main.hs b/examples/pagerank/Main.hs --- a/examples/pagerank/Main.hs +++ b/examples/pagerank/Main.hs @@ -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 diff --git a/examples/pagerank/Page.hs b/examples/pagerank/Page.hs --- a/examples/pagerank/Page.hs +++ b/examples/pagerank/Page.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} + module Page ( PageId , Rank diff --git a/examples/pagerank/Rank.hs b/examples/pagerank/Rank.hs --- a/examples/pagerank/Rank.hs +++ b/examples/pagerank/Rank.hs @@ -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 diff --git a/examples/ray/Config.hs b/examples/ray/Config.hs --- a/examples/ray/Config.hs +++ b/examples/ray/Config.hs @@ -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" + , "" ] diff --git a/examples/ray/Main.hs b/examples/ray/Main.hs --- a/examples/ray/Main.hs +++ b/examples/ray/Main.hs @@ -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 diff --git a/examples/ray/Ray/Intersect.hs b/examples/ray/Ray/Intersect.hs --- a/examples/ray/Ray/Intersect.hs +++ b/examples/ray/Ray/Intersect.hs @@ -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)) diff --git a/examples/ray/Ray/Trace.hs b/examples/ray/Ray/Trace.hs --- a/examples/ray/Ray/Trace.hs +++ b/examples/ray/Ray/Trace.hs @@ -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 diff --git a/examples/ray/Scene/Object.hs b/examples/ray/Scene/Object.hs --- a/examples/ray/Scene/Object.hs +++ b/examples/ray/Scene/Object.hs @@ -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 diff --git a/examples/smoothlife/Config.hs b/examples/smoothlife/Config.hs --- a/examples/smoothlife/Config.hs +++ b/examples/smoothlife/Config.hs @@ -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]) + , "" ] diff --git a/examples/smoothlife/Gloss/Draw.hs b/examples/smoothlife/Gloss/Draw.hs --- a/examples/smoothlife/Gloss/Draw.hs +++ b/examples/smoothlife/Gloss/Draw.hs @@ -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 diff --git a/examples/smoothlife/Main.hs b/examples/smoothlife/Main.hs --- a/examples/smoothlife/Main.hs +++ b/examples/smoothlife/Main.hs @@ -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) diff --git a/examples/smoothlife/Random/Splat.hs b/examples/smoothlife/Random/Splat.hs --- a/examples/smoothlife/Random/Splat.hs +++ b/examples/smoothlife/Random/Splat.hs @@ -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. diff --git a/examples/smoothlife/SmoothLife.hs b/examples/smoothlife/SmoothLife.hs --- a/examples/smoothlife/SmoothLife.hs +++ b/examples/smoothlife/SmoothLife.hs @@ -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' )) diff --git a/examples/smvm/Config.hs b/examples/smvm/Config.hs --- a/examples/smvm/Config.hs +++ b/examples/smvm/Config.hs @@ -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 = [ "" ] diff --git a/examples/smvm/Main.hs b/examples/smvm/Main.hs --- a/examples/smvm/Main.hs +++ b/examples/smvm/Main.hs @@ -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 ] diff --git a/examples/smvm/MatrixMarket.hs b/examples/smvm/MatrixMarket.hs --- a/examples/smvm/MatrixMarket.hs +++ b/examples/smvm/MatrixMarket.hs @@ -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 diff --git a/lib/Data/Array/Accelerate/Examples/Internal.hs b/lib/Data/Array/Accelerate/Examples/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal.hs @@ -0,0 +1,35 @@ +-- | +-- Module: : Data.Array.Accelerate.Examples.Internal +-- Copyright : [2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Backend.hs b/lib/Data/Array/Accelerate/Examples/Internal/Backend.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Backend.hs @@ -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 +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Codespeed.hs b/lib/Data/Array/Accelerate/Examples/Internal/Codespeed.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Codespeed.hs @@ -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 +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs b/lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Criterion.hs @@ -0,0 +1,76 @@ +-- | +-- Module: : Data.Array.Accelerate.Examples.Internal.Criterion +-- Copyright : [2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Criterion/Config.hs b/lib/Data/Array/Accelerate/Examples/Internal/Criterion/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Criterion/Config.hs @@ -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 +-- 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 ] + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Interactive.hs b/lib/Data/Array/Accelerate/Examples/Internal/Interactive.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Interactive.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module: : Data.Array.Accelerate.Examples.Internal.Interactive +-- Copyright : [2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs b/lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Monitoring.hs @@ -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 +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs b/lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/ParseArgs.hs @@ -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 +-- 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) + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs b/lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Random/Array.hs @@ -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 +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Report.hs b/lib/Data/Array/Accelerate/Examples/Internal/Report.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Report.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +-- | +-- Module: : Data.Array.Accelerate.Examples.Internal.Report +-- Copyright : [2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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 () + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Similar.hs b/lib/Data/Array/Accelerate/Examples/Internal/Similar.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Similar.hs @@ -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 +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/TH.hs b/lib/Data/Array/Accelerate/Examples/Internal/TH.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/TH.hs @@ -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 +-- 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 + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/TestFramework.hs b/lib/Data/Array/Accelerate/Examples/Internal/TestFramework.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/TestFramework.hs @@ -0,0 +1,92 @@ +-- | +-- Module: : Data.Array.Accelerate.Examples.Internal.TestFramework +-- Copyright : [2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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 (~=?) + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs b/lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/TestFramework/Config.hs @@ -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 +-- 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 + + diff --git a/lib/Data/Array/Accelerate/Examples/Internal/Util.hs b/lib/Data/Array/Accelerate/Examples/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Array/Accelerate/Examples/Internal/Util.hs @@ -0,0 +1,33 @@ +-- | +-- Module: : Data.Array.Accelerate.Examples.Internal.Util +-- Copyright : [2014] Trevor L. McDonell +-- License : BSD3 +-- +-- Maintainer : Trevor L. McDonell +-- 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 + diff --git a/lib/Monitoring.hs b/lib/Monitoring.hs deleted file mode 100644 --- a/lib/Monitoring.hs +++ /dev/null @@ -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 - diff --git a/lib/ParseArgs.hs b/lib/ParseArgs.hs deleted file mode 100644 --- a/lib/ParseArgs.hs +++ /dev/null @@ -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) - diff --git a/lib/Random/Array.hs b/lib/Random/Array.hs deleted file mode 100644 --- a/lib/Random/Array.hs +++ /dev/null @@ -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 - diff --git a/lib/Util.hs b/lib/Util.hs deleted file mode 100644 --- a/lib/Util.hs +++ /dev/null @@ -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 -