diff --git a/accelerate-examples.cabal b/accelerate-examples.cabal --- a/accelerate-examples.cabal +++ b/accelerate-examples.cabal @@ -1,5 +1,5 @@ Name: accelerate-examples -Version: 0.12.0.0 +Version: 0.12.1.0 License: BSD3 License-file: LICENSE Author: The Accelerate Team @@ -29,6 +29,11 @@ * io: Extra tests for reading and writing arrays in various formats . +Flag gui + Description: Enable gloss-based GUIs, where applicable. If not + enabled, the application always runs in benchmark mode. + Default: True + Flag cuda Description: Enable the CUDA parallel backend for NVIDIA GPUs Default: True @@ -161,6 +166,9 @@ if impl(ghc >= 7.0) ghc-options: -rtsopts + if flag(gui) + CPP-options: -DACCELERATE_ENABLE_GUI + if flag(cuda) CPP-options: -DACCELERATE_CUDA_BACKEND build-depends: accelerate-cuda >= 0.12 @@ -175,7 +183,34 @@ fclabels >= 1.0, gloss >= 1.5 +-- A simple mandelbrot generator +Executable accelerate-mandelbrot + hs-source-dirs: examples/mandelbrot + Main-is: Main.hs + other-modules: Config + ghc-options: -O2 -Wall + if impl(ghc >= 7.0) + ghc-options: -rtsopts + + if flag(gui) + CPP-options: -DACCELERATE_ENABLE_GUI + + if flag(cuda) + CPP-options: -DACCELERATE_CUDA_BACKEND + build-depends: accelerate-cuda >= 0.12 + + if flag(opencl) + CPP-options: -DACCELERATE_OPENCL_BACKEND + build-depends: accelerate-opencl == 0.1.* + + build-depends: accelerate >= 0.12, + base == 4.*, + criterion >= 0.5, + fclabels >= 1.0, + gloss >= 1.5 + + -- A stable fluid simulation -- Executable accelerate-fluid @@ -188,6 +223,9 @@ World ghc-options: -O2 -Wall + + if flag(gui) + CPP-options: -DACCELERATE_ENABLE_GUI if flag(cuda) cpp-options: -DACCELERATE_CUDA_BACKEND diff --git a/examples/crystal/Config.hs b/examples/crystal/Config.hs --- a/examples/crystal/Config.hs +++ b/examples/crystal/Config.hs @@ -43,7 +43,11 @@ , _optZoom = 3 , _optScale = 30 , _optDegree = 5 +#ifdef ACCELERATE_ENABLE_GUI , _optBench = False +#else + , _optBench = True +#endif , _optHelp = False } diff --git a/examples/crystal/Main.hs b/examples/crystal/Main.hs --- a/examples/crystal/Main.hs +++ b/examples/crystal/Main.hs @@ -173,14 +173,18 @@ scale = get optScale config degree = get optDegree config render = run config $ makeImage size scale degree + force arr = A.indexArray arr (Z:.0:.0) `seq` arr void . evaluate $ render (A.fromList Z [0]) if get optBench config then withArgs nops $ defaultMain - [ bench "crystal" $ whnf render (A.fromList Z [1.0]) ] + [ bench "crystal" $ whnf (force . render) (A.fromList Z [1.0]) ] -#if MIN_VERSION_gloss(1,6,0) +#ifndef ACCELERATE_ENABLE_GUI + else return () + +#elif MIN_VERSION_gloss(1,6,0) else G.animate (G.InWindow "Quasicrystals" (size * zoom, size * zoom) (10, 10)) (G.black) diff --git a/examples/fluid/src/Config.hs b/examples/fluid/src/Config.hs --- a/examples/fluid/src/Config.hs +++ b/examples/fluid/src/Config.hs @@ -66,7 +66,11 @@ , _displayFramerate = 20 , _optBackend = maxBound +#ifdef ACCELERATE_ENABLE_GUI , _optBench = False +#else + , _optBench = True +#endif , _optHelp = False } diff --git a/examples/fluid/src/Main.hs b/examples/fluid/src/Main.hs --- a/examples/fluid/src/Main.hs +++ b/examples/fluid/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} -- -- A stable fluid simulation -- @@ -36,6 +37,12 @@ sh = Z :. length ix in ( A.fromList sh ix, A.fromList sh ss ) + -- for benchmarking + -- + force world = + indexArray (densityField world) (Z:.0:.0) `seq` + indexArray (velocityField world) (Z:.0:.0) `seq` () + -- Prepare to execute the next step of the simulation. -- -- Critically, we use the run1 execution form to ensure we bypass all @@ -58,8 +65,12 @@ if get optBench opt -- benchmark then withArgs noms $ defaultMain - [ bench "fluid" $ whnfIO (simulate 1.0 initialWorld) ] + [ bench "fluid" $ whnfIO (force `fmap` simulate 1.0 initialWorld) ] +#ifndef ACCELERATE_ENABLE_GUI + else return () + +#else -- simulate else playIO (InWindow "accelerate-fluid" (width, height) (10, 20)) @@ -69,4 +80,5 @@ (render opt) -- render world state into a picture (react opt) -- handle user events simulate -- one step of the simulation +#endif diff --git a/examples/mandelbrot/Config.hs b/examples/mandelbrot/Config.hs new file mode 100644 --- /dev/null +++ b/examples/mandelbrot/Config.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Config ( + + Options, optBackend, optSize, optLimit, optBench, + processArgs, run, run1 + +) where + +import Data.Label +import System.Exit +import System.Console.GetOpt +import Data.Array.Accelerate ( Arrays, Acc ) +import qualified Data.Array.Accelerate.Interpreter as Interp +#ifdef ACCELERATE_CUDA_BACKEND +import qualified Data.Array.Accelerate.CUDA as CUDA +#endif + +data Backend = Interpreter +#ifdef ACCELERATE_CUDA_BACKEND + | CUDA +#endif + deriving (Bounded, Show) + +data Options = Options + { + _optBackend :: Backend + , _optSize :: Int + , _optLimit :: Int + , _optBench :: Bool + , _optHelp :: Bool + } + deriving Show + +$(mkLabels [''Options]) + +defaultOptions :: Options +defaultOptions = Options + { _optBackend = maxBound + , _optSize = 512 + , _optLimit = 255 +#ifdef ACCELERATE_ENABLE_GUI + , _optBench = False +#else + , _optBench = True +#endif + , _optHelp = False + } + + +run :: Arrays a => Options -> Acc a -> a +run opts = case _optBackend opts of + Interpreter -> Interp.run +#ifdef ACCELERATE_CUDA_BACKEND + CUDA -> CUDA.run +#endif + +run1 :: (Arrays a, Arrays b) => Options -> (Acc a -> Acc b) -> a -> b +run1 opts f = case _optBackend opts of + Interpreter -> head . Interp.stream f . return +#ifdef ACCELERATE_CUDA_BACKEND + CUDA -> CUDA.run1 f +#endif + + +options :: [OptDescr (Options -> Options)] +options = + [ Option [] ["interpreter"] (NoArg (set optBackend Interpreter)) "reference implementation (sequential)" +#ifdef ACCELERATE_CUDA_BACKEND + , Option [] ["cuda"] (NoArg (set optBackend CUDA)) "implementation for NVIDIA GPUs (parallel)" +#endif + , Option [] ["size"] (ReqArg (set optSize . read) "INT") "visualisation size (512)" + , Option [] ["limit"] (ReqArg (set optLimit . read) "INT") "iteration limit for escape (255)" + , Option [] ["benchmark"] (NoArg (set optBench True)) "benchmark instead of displaying animation (False)" + , Option "h?" ["help"] (NoArg (set optHelp True)) "show help message" + ] + + +processArgs :: [String] -> IO (Options, [String]) +processArgs argv = + case getOpt' Permute options argv of + (o,_,n,[]) -> case foldl (flip id) defaultOptions o of + opts | False <- get optHelp opts -> return (opts, n) + opts | True <- get optBench opts -> return (opts, "--help":n) + _ -> putStrLn (helpMsg []) >> exitSuccess + (_,_,_,err) -> error (helpMsg err) + where + helpMsg err = concat err ++ usageInfo header options + header = unlines + [ "accelerate-mandelbrot (c) [2011..2012] The Accelerate Team" + , "" + , "Usage: accelerate-mandelbrot [OPTIONS]" + ] + diff --git a/examples/mandelbrot/Main.hs b/examples/mandelbrot/Main.hs new file mode 100644 --- /dev/null +++ b/examples/mandelbrot/Main.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE CPP #-} +-- +-- A Mandelbrot set generator. Submitted by Simon Marlow as part of Issue #49. +-- + + +import Config +import Data.Label +import Control.Monad +import Control.Exception +import Foreign.Ptr +import Foreign.ForeignPtr +import System.IO.Unsafe +import System.Environment +import Criterion.Main ( defaultMain, bench, whnf ) +import Data.Array.Accelerate.Array.Data ( ptrsOfArrayData ) +import Data.Array.Accelerate.Array.Sugar ( Array(..) ) + +import Prelude as P +import Data.Array.Accelerate as A hiding ( size ) +import qualified Graphics.Gloss as G + + +-- Mandelbrot Set -------------------------------------------------------------- + +type F = Float -- Double not supported on all devices + +type Complex = (F,F) +type ComplexPlane = Array DIM2 Complex + +mandelbrot :: F -> F -> F -> F -> Int -> Int -> Int -> Acc (Array DIM2 (F,F,Int)) +mandelbrot x y x' y' screenX screenY depth + = foldl (flip ($)) zs0 (P.take depth (repeat go)) + where + cs = genPlane x y x' y' screenX screenY + zs0 = mkinit cs + + go :: Acc (Array DIM2 (F,F,Int)) -> Acc (Array DIM2 (F,F,Int)) + go = A.zipWith iter cs + + +genPlane :: F -> F + -> F -> F + -> Int + -> Int + -> Acc ComplexPlane +genPlane lowx lowy highx highy viewx viewy + = generate (constant (Z:.viewy:.viewx)) + (\ix -> let pr = unindex2 ix + x = A.fromIntegral (A.fst pr) + y = A.fromIntegral (A.snd pr) + in + lift ( elowx + (x * exsize) / eviewx + , elowy + (y * eysize) / eviewy)) + where + elowx, elowy, exsize, eysize, eviewx, eviewy :: Exp F + + elowx = constant lowx + elowy = constant lowy + + exsize = constant (highx - lowx) + eysize = constant (highy - lowy) + + eviewx = constant (P.fromIntegral viewx) + eviewy = constant (P.fromIntegral viewy) + + +next :: Exp Complex -> Exp Complex -> Exp Complex +next c z = c `plus` (z `times` z) + + +plus :: Exp Complex -> Exp Complex -> Exp Complex +plus = lift2 f + where f :: (Exp F, Exp F) -> (Exp F, Exp F) -> (Exp F, Exp F) + f (x1,y1) (x2,y2) = (x1+x2,y1+y2) + +times :: Exp Complex -> Exp Complex -> Exp Complex +times = lift2 f + where f :: (Exp F, Exp F) -> (Exp F, Exp F) -> (Exp F, Exp F) + f (x,y) (x',y') = (x*x'-y*y', x*y'+y*x') + +dot :: Exp Complex -> Exp F +dot = lift1 f + where f :: (Exp F, Exp F) -> Exp F + f (x,y) = x*x + y*y + + +iter :: Exp Complex -> Exp (F,F,Int) -> Exp (F,F,Int) +iter c z = f (unlift z) + where + f :: (Exp F, Exp F, Exp Int) -> Exp (F,F,Int) + f (x,y,i) = + (dot z' >* 4.0) ? ( lift (x,y,i) + , lift (A.fst z', A.snd z', i+1) ) + where z' = A.curry (next c) x y + + +mkinit :: Acc ComplexPlane -> Acc (Array DIM2 (F,F,Int)) +mkinit cs = A.map (lift1 f) cs + where f :: (Exp F, Exp F) -> (Exp F, Exp F, Exp Int) + f (x,y) = (x,y,0) + + +-- Rendering ------------------------------------------------------------------- + +type RGBA = Word32 + +prettyRGBA :: Exp Int -> Exp (F, F, Int) -> Exp RGBA +prettyRGBA lIMIT s' = r + g + b + a + where + (_, _, s) = unlift s' :: (Exp F, Exp F, Exp Int) + t = A.fromIntegral $ ((lIMIT - s) * 255) `quot` lIMIT + r = (t `mod` 128 + 64) * 0x1000000 + g = (t * 2 `mod` 128 + 64) * 0x10000 + b = (t * 3 `mod` 256 ) * 0x100 + a = 0xFF + + +makePicture :: Options -> Int -> Acc (Array DIM2 (F, F, Int)) -> G.Picture +makePicture opt limit zs = pic + where + arrPixels = run opt $ A.map (prettyRGBA (constant limit)) zs + (Z:.h:.w) = arrayShape arrPixels + + {-# NOINLINE rawData #-} + rawData = let (Array _ adata) = arrPixels + ((), ptr) = ptrsOfArrayData adata + in + unsafePerformIO $ newForeignPtr_ (castPtr ptr) + + pic = G.bitmapOfForeignPtr h w rawData False + + +-- Main ------------------------------------------------------------------------ + +main :: IO () +main + = do (config, nops) <- processArgs =<< getArgs + let size = get optSize config + limit = get optLimit config + -- + x = -0.25 -- should get this from command line as well + y = -1.0 + x' = 0.0 + y' = -0.75 + -- + force arr = indexArray arr (Z:.0:.0) `seq` arr + image = makePicture config limit + $ mandelbrot x y x' y' size size limit + + void $ evaluate image + + if get optBench config + then withArgs nops $ defaultMain + [ bench "mandelbrot" $ + whnf (force . run config . mandelbrot x y x' y' size size) limit ] + +#ifndef ACCELERATE_ENABLE_GUI + else return () + +#elif MIN_VERSION_gloss(1,6,0) + else G.display + (G.InWindow "Mandelbrot" (size, size) (10, 10)) + G.black + image +#else + else G.displayInWindow + "Mandelbrot" + (size, size) + (10, 10) + G.black + image +#endif + diff --git a/examples/tests/simple/BlackScholes.hs b/examples/tests/simple/BlackScholes.hs --- a/examples/tests/simple/BlackScholes.hs +++ b/examples/tests/simple/BlackScholes.hs @@ -17,14 +17,14 @@ ------------------------------- horner :: Num a => [a] -> a -> a -horner coeff x = foldr1 madd coeff +horner coeff x = x * foldr1 madd coeff where - madd a b = b*x + a + madd a b = a + x*b cnd' :: Floating a => a -> a cnd' d = let poly = horner coeff - coeff = [0.0,0.31938153,-0.356563782,1.781477937,-1.821255978,1.330274429] + coeff = [0.31938153,-0.356563782,1.781477937,-1.821255978,1.330274429] rsqrt2pi = 0.39894228040143267793994605993438 k = 1.0 / (1.0 + 0.2316419 * abs d) in @@ -36,18 +36,18 @@ where go x = let (price, strike, years) = Acc.unlift x - r = Acc.constant riskfree - v = Acc.constant volatility - sqrtT = sqrt years - d1 = (log (price / strike) + (r + 0.5 * v * v) * years) / (v * sqrtT) - d2 = d1 - v * sqrtT - cnd d = d >* 0 ? (1.0 - cnd' d, cnd' d) - cndD1 = cnd d1 - cndD2 = cnd d2 - expRT = exp (-r * years) + r = Acc.constant riskfree + v = Acc.constant volatility + v_sqrtT = v * sqrt years + d1 = (log (price / strike) + (r + 0.5 * v * v) * years) / v_sqrtT + d2 = d1 - v_sqrtT + cnd d = let c = cnd' d in d >* 0 ? (1.0 - c, c) + cndD1 = cnd d1 + cndD2 = cnd d2 + x_expRT = strike * exp (-r * years) in - Acc.lift ( price * cndD1 - strike * expRT * cndD2 - , strike * expRT * (1.0 - cndD2) - price * (1.0 - cndD1)) + Acc.lift ( price * cndD1 - x_expRT * cndD2 + , x_expRT * (1.0 - cndD2) - price * (1.0 - cndD1)) blackscholesRef :: IArray.Array Int (Float,Float,Float) -> IArray.Array Int (Float,Float)