/
NikolaV5.hs
150 lines (122 loc) · 4.49 KB
/
NikolaV5.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
{-# LANGUAGe BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGe TemplateHaskell #-}
module Mandelbrot.NikolaV5 (mandelbrotImageGenerator) where
import Control.Exception
import Data.IORef
import Data.Int
import Data.Word
import Foreign (sizeOf, nullPtr)
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL (($=))
import Foreign.CUDA.ForeignPtr (newForeignDevPtr_)
import qualified Foreign.CUDA.Driver.Graphics as CUG
import qualified Foreign.CUDA.Driver.Graphics.OpenGL as CUGL
import Data.Array.Nikola.Backend.CUDA.TH
import Data.Array.Repa
import Data.Array.Repa.Mutable
import Data.Array.Repa.Repr.CUDA.UnboxedForeign as CUF
import qualified Data.Vector.CUDA.Storable.Mutable as MVCS
import qualified Data.Vector.CUDA.UnboxedForeign as VCUF
import qualified Mandelbrot.NikolaV5.Implementation as I
type R = Double
type Complex = (R, R)
type RGBA = Word32
type Bitmap r = Array r DIM2 RGBA
type MBitmap r = MArray r DIM2 RGBA
type ComplexPlane r = Array r DIM2 Complex
type MComplexPlane r = MArray r DIM2 Complex
type StepPlane r = Array r DIM2 (Complex, Int32)
type MStepPlane r = MArray r DIM2 (Complex, Int32)
prettyMandelbrot :: Int32 -> StepPlane CUF -> MBitmap CUF -> IO ()
prettyMandelbrot = $(compile I.prettyMandelbrot)
mandelbrot :: R
-> R
-> R
-> R
-> Int32
-> Int32
-> Int32
-> MComplexPlane CUF
-> MStepPlane CUF
-> IO ()
mandelbrot = $(compile I.mandelbrot)
type MandelFun = R
-> R
-> R
-> R
-> Int
-> Int
-> Int
-> IO GL.BufferObject
data MandelState = MandelState
{ manDim :: DIM2
, manMCs :: MComplexPlane CUF
, manMZs :: MStepPlane CUF
}
mandelbrotImageGenerator :: IO MandelFun
mandelbrotImageGenerator = do
state <- newState (ix2 0 0)
stateRef <- newIORef state
[pbo] <- GL.genObjectNames 1
return $ mandelbrotImage stateRef pbo
where
mandelbrotImage :: IORef MandelState
-> GL.BufferObject
-> MandelFun
mandelbrotImage stateRef pbo lowx lowy highx highy viewx viewy depth = do
let sh = ix2 viewy viewx
state <- updateState stateRef pbo sh
let mcs = manMCs state
mzs = manMZs state
mandelbrot lowx' lowy' highx' highy' viewx' viewy' depth' mcs mzs
zs <- unsafeFreezeMArray mzs
withPBOResource pbo $ \pboRes ->
withMappedResource pboRes $
withResourceMBitmap sh pboRes $ \mbmapD ->
prettyMandelbrot depth' zs mbmapD
return pbo
where
lowx', lowy', highx', highy' :: R
lowx' = realToFrac lowx
lowy' = realToFrac lowy
highx' = realToFrac highx
highy' = realToFrac highy
viewx', viewy', depth' :: Int32
viewx' = fromIntegral viewx
viewy' = fromIntegral viewy
depth' = fromIntegral depth
newState :: DIM2 -> IO MandelState
newState sh = do
mcs <- newMArray sh
mzs <- newMArray sh
return $ MandelState sh mcs mzs
updateState :: IORef MandelState -> GL.BufferObject -> DIM2 -> IO MandelState
updateState stateRef pbo sh = do
state <- readIORef stateRef
if manDim state == sh
then return state
else do resizePBO pbo sh
state' <- newState sh
writeIORef stateRef state'
return state'
resizePBO :: GL.BufferObject -> DIM2 -> IO ()
resizePBO pbo sh = do
let nBytes = size sh*sizeOf (undefined :: RGBA)
GL.bindBuffer GL.PixelUnpackBuffer $= Just pbo
GL.bufferData GL.PixelUnpackBuffer $= (fromIntegral nBytes, nullPtr, GL.DynamicCopy)
GL.bindBuffer GL.PixelUnpackBuffer $= Nothing
withPBOResource :: GL.BufferObject -> (CUG.Resource -> IO a) -> IO a
withPBOResource pbo =
bracket (CUGL.registerBuffer pbo CUG.RegisterNone)
CUG.unregisterResource
withMappedResource :: CUG.Resource -> IO a -> IO a
withMappedResource res =
bracket_ (CUG.mapResources [res] Nothing)
(CUG.unmapResources [res] Nothing)
withResourceMBitmap :: DIM2 -> CUG.Resource -> (MBitmap CUF -> IO a) -> IO a
withResourceMBitmap sh res kont = do
(dptr, _) <- CUG.getMappedPointer res
fdptr <- newForeignDevPtr_ dptr
let mv = MVCS.unsafeFromForeignDevPtr0 fdptr (size sh)
kont $ CUF.fromMUnboxedForeign sh (VCUF.MV_Word32 mv)