Inlined bindArrayBuffers, seemed to improve perfomance

src/Picture/Data.hs

@@ -15,11 +15,76 @@ import Foreign
 
 import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
 
+import qualified Control.Foldl as F
+
+import Control.Monad 
+
+import Data.Traversable
+
+data RenderType
+    = RenderPoly [(Point3,Point4)]
+    | RenderText [(Point3,Point4,Point3)]
+    | RenderCirc (Point3,Point4,Float)
+    | RenderArc  (Point3,Point4,Point4)
+    | RenderLine [(Point3,Point4)]
+    | RenderEllipse [(Point3,Point4)]
+
+
 data VAO = VAO
     { _vao :: VertexArrayObject
     , _vaoBufferTargets :: [(BufferObject,Ptr Float,Int)]
     }
+data FullShader = FullShader
+    { _shaderProgram :: Program
+    , _shaderUniforms :: [UniformLocation]
+    , _shaderVAO :: VAO
+    , _shaderPokeStrategy :: RenderType -> [[[Float]]]-- -> F.FoldM IO RenderType Int
+    , _shaderDrawPrimitive :: PrimitiveMode
+    }
 makeLenses ''VAO
+makeLenses ''FullShader
+
+bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
+bindShaderBuffers fss is =
+    zipWithM_ f fss is
+        where f fs i = bindArrayBuffers i $ _vaoBufferTargets $ _shaderVAO fs
+
+fSize = sizeOf (0 :: Float)
+
+bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
+{-# INLINE bindArrayBuffers #-}
+bindArrayBuffers numVs ps = do
+    forM_ ps $ \(bo,ptr,i) -> do
+        bindBuffer ArrayBuffer $= Just bo
+        bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
+        
+
+pokeShaders :: [FullShader] -> F.FoldM IO RenderType [Int]
+pokeShaders fss = traverse pokeShader fss
+
+pokeShader :: FullShader -> F.FoldM IO RenderType Int
+pokeShader fs = F.FoldM (pokeRender fls (zip ptrs nAtss))  (return 0) return
+  where vao = _shaderVAO fs
+        (_,ptrs,nAtss) = unzip3 $ _vaoBufferTargets $ vao
+        fls = _shaderPokeStrategy fs
+
+pokeRender :: (RenderType -> [[[Float]]])
+                -> [(Ptr Float,Int)] -> Int -> RenderType -> IO Int
+pokeRender toFs ptrs n rt = pokeList ptrs n (toFs rt)
+
+pokeList :: [(Ptr Float,Int)] -> Int -> [[[Float]]] -> IO Int
+pokeList ptrs n fsss = foldM (pokePtrs ptrs) n fsss
+
+pokePtrs :: [(Ptr Float,Int)] -> Int -> [[Float]] -> IO Int
+pokePtrs ptrIs n fss = do
+    zipWithM_ f ptrIs fss
+    return $ n + 1
+        where f (ptr,i) fs = pokeArrayOff ptr (i*n) fs
+
+pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
+pokeArrayOff ptr i xs =
+    zipWithM_ (pokeElemOff ptr) [i..] xs
+
 
 type RGBA = (Float,Float,Float,Float)
 type Color = (Float,Float,Float,Float)
@@ -65,21 +130,6 @@ flat4 (x,y,z,w) = [x,y,z,w]
 {-# INLINE flat3 #-}
 {-# INLINE flat4 #-}
 
-data FullShader = FullShader
-    { _shaderProgram :: Program
-    , _shaderUniforms :: [UniformLocation]
-    , _shaderVAO :: VAO
---    , _shaderPokeStrategy :: [Ptr Float] -> F.FoldM IO RenderType Int
-    }
-
-data RenderType
-    = RenderPoly [(Point3,Point4)]
-    | RenderText [(Point3,Point4,Point3)]
-    | RenderCirc (Point3,Point4,Float)
-    | RenderArc  (Point3,Point4,Point4)
-    | RenderLine [(Point3,Point4)]
-    | RenderEllipse [(Point3,Point4)]
-
 data Picture
     = Blank
     | Text Int String

src/Picture/Render.hs

@@ -333,13 +333,6 @@ rotate3 :: Float -> Point3 -> Point3
 rotate3 a (x,y,z) = (x',y',z)
     where (x',y') = rotateV a (x,y)
 
-fSize = sizeOf (0 :: Float)
-
-bindArrayBuffers :: Int -> [(BufferObject,Ptr Float,Int)] -> IO ()
-bindArrayBuffers numVs ps = do
-    forM_ ps $ \(bo,ptr,i) -> do
-        bindBuffer ArrayBuffer $= Just bo
-        bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
 
 twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float)
 {-# INLINE twoPtrsVAO #-}