justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Implement custom poking for vertices--speed regression?

Browse Source
This commit is contained in:
justin
2021-07-29 18:46:01 +02:00
parent 02a9f4badf
commit 192e2c9c57
8 changed files with 184 additions and 139 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Shader/Compile.hs
+2 -2
View File
@@ -149,7 +149,7 @@ setupVBO sizes = do
)
return $ VBO
{ _vbo = vboName
, _vboPointer = thePtr
, _vboPtr = thePtr
, _vboAttribSizes = sizes
, _vboStride = sum sizes
}
@@ -172,7 +172,7 @@ setupVBOSized sizes ndraw = do
)
return $ VBO
{ _vbo = vboName
, _vboPointer = thePtr
, _vboPtr = thePtr
, _vboAttribSizes = sizes
, _vboStride = sum sizes
}
src/Shader/Data.hs
+1 -1
View File
@@ -56,7 +56,7 @@ and a list of attribute pointer sizes.
Vertex attributes are interleaved within the vbo. -}
data VBO = VBO
{ _vbo :: BufferObject
, _vboPointer :: Ptr Float
, _vboPtr :: Ptr Float
, _vboAttribSizes :: [Int] -- ^ It is not clear to me if this is necessary to store or not
, _vboStride :: Int
}
src/Shader/Poke.hs
+140 -67
View File
@@ -1,40 +1,26 @@
--{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TupleSections #-}
module Shader.Poke
( pokeArrayOff
, pokeShader
, pokeShaderLayer
, pokeVX
, pokeVX'
, pokePoint3s
, pokePoint33s
, pokeVerxs
, pokeLayVerxs
) where
import Shader.Data
import Shader.Parameters
import Picture.Data
import Geometry.Data
--import Data.Maybe
--import Data.List
import Foreign
import Control.Monad
import qualified Control.Foldl as F
--import Control.Monad
--import qualified Control.Foldl as F
import qualified Data.IntMap.Strict as IM
import Control.Lens
pokeShader :: FullShader -> F.FoldM IO RenderType Int
pokeShader fs = F.FoldM (pokeVertices fls ptr stride) (return 0) return
where
theVBO = _vaoVBO $ _shaderVAO fs
ptr = _vboPointer theVBO
stride = _vboStride theVBO
fls = _shaderPokeStrategy fs
pokeVertices
:: (RenderType -> [[Float]])
-> Ptr Float
-> Int -- ^ stride
-> Int -- ^ number of vertices already poked
-> RenderType
-> IO Int
pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt)
getterPicShad :: VertexType -> PicShads a -> a
--{-# INLINE getterPicShad #-}
getterPicShad PolyV = _psPoly
@@ -59,11 +45,72 @@ pokeVX' shads count vx = do
vshad = g shads
n = g count
theVBO = _vaoVBO $ _vshaderVAO vshad
ptr = _vboPointer theVBO
ptr = _vboPtr theVBO
stride = _vboStride theVBO
pokeArrayOff ptr (stride * n) (toFls' vx)
return $ count & f +~ 1
pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int)
pokeVerxs vbos vxs0 = go vxs0 (pure 0)
where
go [] count = return count
go (vx:vxs) count = pokeVerx vbos count vx >> go vxs (addCountVerx count vx)
-- this is very brittle, but want to optimise speed if possible here
pokeVerx :: PicShads VBO -> PicShads Int -> Verx -> IO ()
pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case theType of
PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) (_psPoly offsets * 7 * floatSize)) thePos theCol
PolyzV x -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x
where
thePtr = plusPtr (_vboPtr $ _psPolyz vbos) (_psPolyz offsets * 8 * floatSize)
BezV (x,y,z,w) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y
>> pokeElemOff thePtr 9 z
>> pokeElemOff thePtr 10 w
where
thePtr = plusPtr (_vboPtr $ _psBez vbos) (_psBez offsets * 11 * floatSize)
TextV (x,y) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y
where
thePtr = plusPtr (_vboPtr $ _psText vbos) (_psText offsets * 9 * floatSize)
ArcV (x,y,z) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y
>> pokeElemOff thePtr 9 z
where
thePtr = plusPtr (_vboPtr $ _psArc vbos) (_psArc offsets * 10 * floatSize)
EllV -> poke34 (plusPtr (_vboPtr $ _psEll vbos) (_psEll offsets * 7 * floatSize)) thePos theCol
poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
poke34 ptr (a,b,c) (d,e,f,g) = do
pokeElemOff ptr 0 a
pokeElemOff ptr 1 b
pokeElemOff ptr 2 c
pokeElemOff ptr 3 d
pokeElemOff ptr 4 e
pokeElemOff ptr 5 f
pokeElemOff ptr 6 g
addCountVerx :: PicShads Int -> Verx -> PicShads Int
addCountVerx ps@PicShads
{ _psPoly = sPoly
, _psPolyz = sPolyz
, _psBez = sBez
, _psText = sText
, _psArc = sArc
, _psEll = sEll
} Verx{_vxType=theType} = case theType of
PolyV -> ps {_psPoly = sPoly + 1}
PolyzV _ -> ps {_psPolyz = sPolyz + 1}
BezV _ -> ps {_psBez = sBez + 1}
TextV _ -> ps {_psText = sText + 1}
ArcV _ -> ps {_psArc = sArc + 1}
EllV -> ps {_psEll = sEll + 1}
pokeVX :: PicShads VShader -> IM.IntMap (PicShads Int) -> Verx -> IO (IM.IntMap (PicShads Int))
pokeVX shads laycounts vx = do
let theType = _vxType vx
@@ -73,35 +120,12 @@ pokeVX shads laycounts vx = do
vshad = getF shads
n = getF counts
theVBO = _vaoVBO $ _vshaderVAO vshad
ptr = _vboPointer theVBO
ptr = _vboPtr theVBO
stride = _vboStride theVBO
pokeArrayOff ptr (stride * (n+offset * numSubElements)) (toFls' vx)
return $ laycounts & ix offset . setterPicShad theType +~ 1
pokeShaderLayer :: (Int,VShader) -> F.FoldM IO Verx Int
pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff ptr (_vshaderPokeTest fs) stride l) (return 0) return
where
theVBO = _vaoVBO $ _vshaderVAO fs
ptr = _vboPointer theVBO
stride = _vboStride theVBO
pokeVerticesOff
:: Ptr Float
-> (VertexType -> Bool)
-> Int -- ^ stride
-> Int -- ^ offset
-> Int -- ^ number of vertices already poked
-> Verx
-> IO Int
pokeVerticesOff ptr vtest stride offset n vx
| offset == i && typetest = do
foldM (pokeVertexOff ptr stride offset) n (toFls vx)
| otherwise = return n
where
i = _vxLayer vx
typetest = vtest (_vxType vx)
toFls' :: Verx -> [Float]
toFls' vx = flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)
where
@@ -111,27 +135,76 @@ toFls' vx = flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)
f (ArcV x) = flat3 x
f _ = []
toFls :: Verx -> [[Float]]
toFls vx = [flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)]
where
f (PolyzV x) = [x]
f (BezV x) = flat4 x
f (TextV x) = flat2 x
f (ArcV x) = flat3 x
f _ = []
pokeVertexOff :: Ptr Float -> Int -> Int -> Int -> [Float] -> IO Int
pokeVertexOff ptr stride offset n fs = do
pokeArrayOff ptr (stride * (n + offset * numSubElements)) fs
return $ n + 1
pokeVertex :: Ptr Float -> Int -> Int -> [Float] -> IO Int
pokeVertex ptr stride n fs = do
pokeArrayOff ptr (stride * n) fs
return $ n + 1
pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
--{-# INLINE pokeArrayOff #-}
--pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i))
pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
pokePoint33s ptr vals0 = go vals0 0
where
go [] n = return n
go ( ((a,b,c),(d,e,f)):vals) n = do
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c
pokeElemOff ptr (off 3) d
pokeElemOff ptr (off 4) e
pokeElemOff ptr (off 5) f
go vals (n+1)
where
off i = n*6 + i
pokePoint3s :: Ptr Float -> [Point3] -> IO Int
pokePoint3s ptr vals0 = go vals0 0
where
go [] n = return n
go ( (a,b,c):vals) n = do
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c
go vals (n+1)
where
off i = n*3 + i
pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (IM.IntMap (PicShads Int))
pokeLayVerxs vbos vxs0 = go vxs0 (IM.fromList $ (, pure 0) <$> [0..5])
where
go [] count = return count
go (vx:vxs) count = pokeLayVerx vbos count vx >> go vxs (addLayCountVerx count vx)
-- this is very brittle, but want to optimise speed if possible here
pokeLayVerx :: PicShads VBO -> IM.IntMap (PicShads Int) -> Verx -> IO ()
pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vxLayer = theLay} = case theType of
PolyV -> poke34 (plusPtr (_vboPtr $ _psPoly vbos) ((_psPoly offsets + layOff) * 7 * floatSize)) thePos theCol
PolyzV x -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x
where
thePtr = plusPtr (_vboPtr $ _psPolyz vbos) ((_psPolyz offsets + layOff) * 8 * floatSize)
BezV (x,y,z,w) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y
>> pokeElemOff thePtr 9 z
>> pokeElemOff thePtr 10 w
where
thePtr = plusPtr (_vboPtr $ _psBez vbos) ((_psBez offsets + layOff) * 11 * floatSize)
TextV (x,y) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y
where
thePtr = plusPtr (_vboPtr $ _psText vbos) ((_psText offsets + layOff) * 9 * floatSize)
ArcV (x,y,z) -> poke34 thePtr thePos theCol
>> pokeElemOff thePtr 7 x
>> pokeElemOff thePtr 8 y
>> pokeElemOff thePtr 9 z
where
thePtr = plusPtr (_vboPtr $ _psArc vbos) ((_psArc offsets + layOff) * 10 * floatSize)
EllV -> poke34 (plusPtr (_vboPtr $ _psEll vbos) ((_psEll offsets + layOff) * 7 * floatSize)) thePos theCol
where
layOff = theLay * numSubElements
offsets = imoffsets IM.! theLay
addLayCountVerx :: IM.IntMap (PicShads Int) -> Verx -> IM.IntMap (PicShads Int)
addLayCountVerx m vx = IM.adjust f (_vxLayer vx) m
where
f = flip addCountVerx vx