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
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase, RecordWildCards, KindSignatures, GADTs, DeriveDataTypeable, StandaloneDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- TODO: Formulate this module as a patch against lambdacube-gl.
module MaskableStream where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Writer
import Data.Data
import Data.Foldable
import Data.Function
import Data.Int
import Data.IORef
import Data.Maybe
import Data.Word
import qualified Data.Map.Strict as Map
import qualified Data.Vector as V
;import Data.Vector as V ((!),(//))
import Foreign.C.Types (CPtrdiff)
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Data.Dependent.Sum
import Data.Some
import Data.GADT.Show
import GHC.TypeLits
import System.IO
import LambdaCube.GL as LC
import LambdaCube.GL.Data -- (uploadCubeMapToGPU,uploadTextureBufferToGPU,updateTextureBuffer)
import LambdaCube.GL.Mesh as LC
import LambdaCube.GL.Type
import LambdaCube.IR as LC
import LambdaCube.GL.Util
import LambdaCube.GL.Input.Type
import LambdaCube.GL.Input hiding (createObjectCommands)
import Graphics.GL.Core33
data Witness c = c => Witness
tagTypable :: TypeTag c -> Witness (Typeable c)
tagTypable TypeBool = Witness
tagTypable TypeV2B = Witness
tagTypable TypeV3B = Witness
tagTypable TypeV4B = Witness
tagTypable TypeWord = Witness
tagTypable TypeV2U = Witness
tagTypable TypeV3U = Witness
tagTypable TypeV4U = Witness
tagTypable TypeInt = Witness
tagTypable TypeV2I = Witness
tagTypable TypeV3I = Witness
tagTypable TypeV4I = Witness
tagTypable TypeFloat = Witness
tagTypable TypeV2F = Witness
tagTypable TypeV3F = Witness
tagTypable TypeV4F = Witness
tagTypable TypeM22F = Witness
tagTypable TypeM23F = Witness
tagTypable TypeM24F = Witness
tagTypable TypeM32F = Witness
tagTypable TypeM33F = Witness
tagTypable TypeM34F = Witness
tagTypable TypeM42F = Witness
tagTypable TypeM43F = Witness
tagTypable TypeM44F = Witness
-- based on addMeshToObjectArray
addToObjectArray :: GLStorage
-> String -- ^ Slot name for a PrimitiveStream.
-> [String] -- ^ Uniform names. IORefs will be put in 'objUniSetup'.
-> GPUData
-> IO Object
addToObjectArray input slotName objUniNames (GPUData prim streams indices _) = do
let ObjectArraySchema _ slotStreams = fromMaybe (error $ "addMeshToObjectArray - missing object array: " ++ slotName)
$ Map.lookup slotName $! objectArrays $! schema input
addObject input slotName prim indices (Map.intersection streams slotStreams) objUniNames
setUniformCommand :: (String -> GLUniform)
-> (String,GLint)
-> GLObjectCommand
setUniformCommand ulookup (n,i) = GLSetUniform i (ulookup n)
bindTextureCommand :: (String -> IORef GLint)
-> (String -> GLUniform)
-> String
-> GLObjectCommand
bindTextureCommand tlookup ulookup n = GLBindTexture (inputTypeToTextureTarget $ uniInputType u) (tlookup n) u
where
u = ulookup n
uniInputType (GLTypedUniform ty _) = unwitnessType ty
uniInputType (GLUniform r) = objectType r
-- One of these:
-- VertexAttribPointer -- Array
-- VertexAttribIPointer -- streams.
-- VertexAttribI{1,2,3,4}[u]iv -- constant integer attribute.
-- Or some number of these in sequence:
-- VertexAttrib{1,2,3,4}fv -- constant vector or matrix of floats.
setVertexAttribCommmand :: (t -> Stream Buffer) -> (GLuint, t) -> GLObjectCommand
setVertexAttribCommmand alookup (i,name) = case alookup name of
Stream ty (Buffer arrs bo) arrIdx start len -> mkAttrCmd i bo n (arrayTypeToGLType arrType) (intPtrToPtr $! offset)
where
(n, mkAttrCmd) = classifyStreamType ty
ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
offset = fromIntegral (arrOffs + start * fromIntegral n * sizeOfArrayType arrType)
-- constant generic attribute
constAttr -> GLSetVertexAttrib i constAttr
lookupOrLookup :: (Ord k, Show k) => String -> Map.Map k a -> Map.Map k a -> k -> a
lookupOrLookup callsite objUnis topUnis n = Map.findWithDefault (topUni n) n objUnis
where
topUni n = Map.findWithDefault (error $ "internal error ("++callsite++"): " ++ show n) n topUnis
classifyStreamType :: StreamType -> ( GLint
, GLuint -> GLuint -> GLint -> GLenum -> Ptr () -> GLObjectCommand)
classifyStreamType = \case
Attribute_Word -> ( 1 , GLSetVertexAttribIArray )
Attribute_V2U -> ( 2 , GLSetVertexAttribIArray )
Attribute_V3U -> ( 3 , GLSetVertexAttribIArray )
Attribute_V4U -> ( 4 , GLSetVertexAttribIArray )
Attribute_Int -> ( 1 , GLSetVertexAttribIArray )
Attribute_V2I -> ( 2 , GLSetVertexAttribIArray )
Attribute_V3I -> ( 3 , GLSetVertexAttribIArray )
Attribute_V4I -> ( 4 , GLSetVertexAttribIArray )
Attribute_Float -> ( 1 , GLSetVertexAttribArray )
Attribute_V2F -> ( 2 , GLSetVertexAttribArray )
Attribute_V3F -> ( 3 , GLSetVertexAttribArray )
Attribute_V4F -> ( 4 , GLSetVertexAttribArray )
Attribute_M22F -> ( 4 , GLSetVertexAttribArray )
Attribute_M23F -> ( 6 , GLSetVertexAttribArray )
Attribute_M24F -> ( 8 , GLSetVertexAttribArray )
Attribute_M32F -> ( 6 , GLSetVertexAttribArray )
Attribute_M33F -> ( 9 , GLSetVertexAttribArray )
Attribute_M34F -> ( 12 , GLSetVertexAttribArray )
Attribute_M42F -> ( 8 , GLSetVertexAttribArray )
Attribute_M43F -> ( 12 , GLSetVertexAttribArray )
Attribute_M44F -> ( 16 , GLSetVertexAttribArray )
drawElementsCommand :: GLenum -> IndexStream Buffer -> GLObjectCommand
drawElementsCommand prim (IndexStream (Buffer arrs bo) arrIdx start idxCount)
= GLDrawElements prim (fromIntegral idxCount) idxType bo ptr
where
ArrayDesc arrType arrLen arrOffs arrSize = arrs ! arrIdx
idxType = arrayTypeToGLType arrType
ptr = intPtrToPtr $! fromIntegral (arrOffs + start * sizeOfArrayType arrType)
-- Note: all enabled attribute arrays should have the same count.
-- So an object should select similarly sized streams from 'dStreams' of GPUData.
-- So the 'mAttributes' map of a Mesh should contain equally sized arrays.
-- uploadMeshToGPU uses a single Buffer for all of a Mesh's attributes.
objectDrawStyle :: (GLsizei -> [(GLint,GLsizei)]) -- ^ mask, normally \x -> [(0,x)]
-> Object
-> Either [(GLint,GLsizei)] (IndexStream Buffer)
objectDrawStyle streamMask obj = case objIndices obj of
Nothing -> Left $ let cnt = head [c | Stream _ _ _ _ c <- Map.elems (objAttributes obj)]
in streamMask $ fromIntegral cnt
Just idxStream -> Right idxStream
-- backward-compatible non-masking interface.
createObjectCommands :: Map.Map String (IORef GLint) -> Map.Map String GLUniform -> Object -> GLProgram -> [GLObjectCommand]
createObjectCommands texUnitMap topUnis obj prg =
createObjectCommands_ (objectEnvironment texUnitMap topUnis obj (pure . ((,) 0))) prg
data ObjectEnvironment = ObjectEnvironment
{ envPrim :: GLenum -- GL version of LambdaCube.GL.Primitive
, envDrawStyle :: Either [(GLint,GLsizei)] -- Mask of array attributes (one draw command for pair).
(IndexStream Buffer) -- Indirect P_TriangleStripI or P_TrianglesI indices.
, tlookup :: String -> IORef GLint -- lookup texture unit
, ulookup :: String -> GLUniform -- lookup uniform
, alookup :: String -> Stream Buffer -- lookup vertex attribute
}
objectEnvironment :: Map.Map String (IORef GLint)
-> Map.Map String GLUniform
-> Object
-> (GLsizei -> [(GLint, GLsizei)])
-> ObjectEnvironment
objectEnvironment texUnitMap topUnis obj streamMask = ObjectEnvironment
{ envPrim = primitiveToGLType $ objPrimitive obj
, envDrawStyle = objectDrawStyle streamMask obj
, tlookup = \n -> Map.findWithDefault (error $ "missing texture unit: " ++ show n) n texUnitMap
, ulookup = lookupOrLookup "missing uniform: " (objUniSetup obj) topUnis
, alookup = \n -> Map.findWithDefault (error $ "missing attribute: " ++ n) n $ objAttributes obj
}
createObjectCommands_ :: ObjectEnvironment -> GLProgram -> [GLObjectCommand]
createObjectCommands_ ObjectEnvironment{..} prg = concat
[ map (setUniformCommand ulookup) $ Map.toList (inputUniforms prg)
, map (bindTextureCommand tlookup ulookup) $ toList (inputTextureUniforms prg)
, map (setVertexAttribCommmand alookup) $ Map.elems (inputStreams prg)
, case envDrawStyle of
Left ranges -> map (uncurry $ GLDrawArrays envPrim) ranges
Right indexed -> pure $ drawElementsCommand envPrim indexed
]
updateCommands :: GLStorage
-> Object
-> (GLsizei -> [(GLint,GLsizei)])
-> IO Object
updateCommands input obj mask = do
let cmdsRef = objCommands obj :: IORef (V.Vector (V.Vector [GLObjectCommand]))
slotIdx = objSlot obj :: Int
ppls <- readIORef $ pipelines input
cmds <- V.forM (ppls :: V.Vector (Maybe GLRenderer)) $ \mp -> case mp of
Nothing -> return V.empty
Just p -> do
let env = objectEnvironment (glTexUnitMapping p) (uniformSetup input) obj mask
Just ic <- readIORef $ glInput p
case icSlotMapInputToPipeline ic ! slotIdx of
Nothing -> return V.empty -- this slot is not used in that pipeline
Just pSlotIdx -> do
let emptyV = V.replicate (V.length $ glPrograms p) []
return $ emptyV // [(prgIdx,createObjectCommands_ env (glPrograms p ! prgIdx))
| prgIdx <- glSlotPrograms p ! pSlotIdx]
writeIORef cmdsRef cmds
return obj
componentCount :: GLABI c -> Int
componentCount x@(IsGLVector _) = fromIntegral $ natVal $ vectorLength x
componentCount x@(IsGLMatrix _) = let (r,c) = matrixDimensions x
in fromIntegral (natVal r) * fromIntegral (natVal c)
uploadDynamicBuffer :: Int -> [Parameter] -> IO GPUData
uploadDynamicBuffer sz params = do
bo <- alloca $! \pbo -> glGenBuffers 1 pbo >> peek pbo
glBindBuffer GL_ARRAY_BUFFER bo
let (mkstreams, mkarrays) = unzip $ mapMaybe attrInfo params
attrInfo (Parameter n typ) = do
atyp <- toStreamType typ
This tt <- witnessType typ
let abi = glABI tt
cnt = componentCount abi
arrtyp = let go :: GLPointerType typ -> ArrayType
go = \case GLPrimUInt -> ArrWord32
GLPrimInt -> ArrInt32
GLPrimFloat -> ArrFloat
in case abi of { IsGLVector p -> go p ; IsGLMatrix p -> go p }
return ( \b i -> (n, Stream atyp b i 0 sz)
, \offset -> ArrayDesc arrtyp (cnt * sz) offset (4 * sz * cnt))
streams = zipWith ($ buffer) mkstreams [0..]
arrays = foldr mk (const []) mkarrays 0
where mk f fin offset = let a = f offset
in a : fin (offset + arrSize a)
buffer = Buffer (V.fromList arrays) bo
byteCount = sum $ map arrSize arrays
glBufferData GL_ARRAY_BUFFER (fromIntegral byteCount) nullPtr GL_DYNAMIC_DRAW
glBindBuffer GL_ARRAY_BUFFER 0
let gd = GPUData PointList (Map.fromList streams) Nothing [buffer]
return gd
incrementalUpdateBuffer :: MonadIO m => Buffer -> GLintptr -> GLsizeiptr -> Ptr a -> m ()
incrementalUpdateBuffer b byteoffset bytecount ptr = do
glBindBuffer GL_ARRAY_BUFFER (bufGLObj b)
glBufferSubData GL_ARRAY_BUFFER byteoffset bytecount ptr
glBindBuffer GL_ARRAY_BUFFER 0
deriving instance Data InputType
deriving instance Data ArrayType
deriving instance Data ArrayDesc
deriving instance Data Buffer
instance Typeable c => Data (AttributeKey c) where
gfoldl f z (AttributeKey tt b offset) = z mk
`f` unwitnessType tt
`f` b
`f` fromIntegral offset
where
mk :: Typeable c => InputType -> Buffer -> Int64 -> AttributeKey c
mk t bo i = fix $ \ret -> case witnessType t of
Just (This tt) -> case tagTypable tt of
Witness -> case withTypes tt ret <$> eqT of
Just Refl -> AttributeKey tt bo (fromIntegral i)
toConstr _ = error "AttributeKey.toConstr"
gunfold _ _ = error "AttributeKey.gunfold"
#if MIN_VERSION_base(4,2,0)
dataTypeOf _ = mkNoRepType "MaskableStream.AttributeKey"
#else
dataTypeOf _ = mkNorepType "MaskableStream.AttributeKey"
#endif
data AttributeKey c = AttributeKey (TypeTag c) Buffer CPtrdiff
attributeKey :: TypeTagable c => GPUData -> String -> Maybe (AttributeKey c)
attributeKey dta name = do
stream <- Map.lookup name (dStreams dta)
fix $ \mp -> let typ = typeTag (fromJust mp) in case stream of
Stream t b i _ _ -> do
let a = bufArrays b ! i
-- arrType :: ArrayType
-- arrLength :: Int -- number of 32 bit values
-- arrOffset :: Int -- byte offset into buffer
-- arrSize :: Int -- byte count
off = arrOffset a
guard (fromStreamType t == unwitnessType typ)
Just $ AttributeKey typ b (fromIntegral off)
_ -> Nothing
lookupAttributeKey :: GPUData -> String -> Maybe (Some AttributeKey)
lookupAttributeKey dta name = do
stream <- Map.lookup name (dStreams dta)
case stream of
Stream t b i _ _ -> do
let a = bufArrays b ! i
off = arrOffset a
This tt <- witnessType (fromStreamType t)
Just $ This (AttributeKey tt b (fromIntegral off))
_ -> Nothing
(@<-) :: GLData a c => AttributeKey c -> a -> Writer [DSum AttributeKey GLUniformValue] ()
k @<- v = tell [k :=> GLUniformValue v]
updateAttributes :: Int -> Writer [DSum AttributeKey GLUniformValue] a -> IO ()
updateAttributes i writer = forM_ (execWriter writer) $ \case
AttributeKey typ b base :=> GLUniformValue a -> do
glBindBuffer GL_ARRAY_BUFFER (bufGLObj b)
let abi = glABI typ
attribSize = 4 * componentCount abi
case marshalUniform abi a of
Just (MarshalGLVector with) -> with $ \sz ptr -> do
let sz' = fromIntegral $ attribSize * (fromIntegral sz)
putStrLn $ "vector sz = " ++ show sz
glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr
Just (MarshalGLMatrix with) -> with $ \sz isrowcol ptr -> case isrowcol of
0 -> do
let sz' = fromIntegral $ attribSize * (fromIntegral sz)
glBufferSubData GL_ARRAY_BUFFER (base + fromIntegral i * sz') sz' ptr
_ -> hPutStrLn stderr $ "WARNING: (TODO) row-major matrix attribute update unimplemented."
Nothing -> hPutStrLn stderr $ "Warning: dimension mismatch updating " ++ show (unwitnessType typ) ++ " attribute."
glBindBuffer GL_ARRAY_BUFFER 0
|