Inline fold sub-functions for speed

2021-08-03 20:22:39 +02:00
parent 12e7af0755
commit 2f8a9fb86a
2 changed files with 107 additions and 37 deletions
@@ -142,7 +142,6 @@ drawTextureOnFramebuffer fs fbo to = do
    drawShader fs 4

 pokeBindFoldable
-    -- :: Foldable f
    :: RenderData
    -> [Verx]
    -> IO (PicShads Int)
@@ -6,11 +6,7 @@ module Shader.Poke
    , pokePoint3s
    , pokePoint33s
    , pokeVerxs
-    , pokeLayVerxs
    , pokeLayVerxsFold
-    , pokeLayVerxsPart
-    , pokeLayVerxsPartM
-    , pokeLayVerxsM
    , poke224s
    ) where
 import Shader.Data
@@ -23,7 +19,7 @@ import Layers
 --import Data.Maybe
 --import Data.List
 import Foreign
-import Control.Monad
+--import Control.Monad
 import qualified Control.Foldl as F
 --import qualified Data.IntMap.Strict as IM
 --import Control.Lens
@@ -40,7 +36,7 @@ pokeVerxs vbos = F.foldM $ F.FoldM

 -- this is very brittle, but want to optimise speed if possible here
 pokeVerx :: PicShads VBO -> PicShads Int -> Verx -> IO ()
-{-# INLINE pokeVerx #-}
+--{-# INLINE pokeVerx #-}
 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
@@ -67,8 +63,10 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case t
        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 ()
--{-# INLINE poke34 #-}
+{-# INLINE poke34 #-}
 poke34 ptr (V3 a b c) (V4 d e f g) = do
    pokeElemOff ptr 0 a
    pokeElemOff ptr 1 b
@@ -78,8 +76,25 @@ poke34 ptr (V3 a b c) (V4 d e f g) = do
    pokeElemOff ptr 5 f
    pokeElemOff ptr 6 g

+addCountVerx' :: VertexType -> PicShads Int -> PicShads Int
+{-# INLINE addCountVerx' #-}
+addCountVerx' theType !ps@PicShads 
+    { _psPoly   = sPoly 
+    , _psPolyz  = sPolyz
+    , _psBez    = sBez  
+    , _psText   = sText 
+    , _psArc    = sArc  
+    , _psEll    = sEll  
+    } = 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}
+
 addCountVerx :: PicShads Int -> Verx -> PicShads Int
--{-# INLINE addCountVerx #-}
+{-# INLINE addCountVerx #-}
 addCountVerx !ps@PicShads 
    { _psPoly   = sPoly 
    , _psPolyz  = sPolyz
@@ -127,37 +142,70 @@ pokePoint3s ptr vals0 = go vals0 0
      where
        off i = n*3 + i

+comLayVerx :: PicShads VBO -> Layers (PicShads Int) -> Verx -> IO (Layers (PicShads Int))
+{-# INLINE comLayVerx #-}
+comLayVerx vbos counts vx = do
+    poke34 thePtr thePos theCol
+    pokeVerxType thePtr theType
+    return $ addLayCountVerx' counts theLayer theType
+  where
+    theLayer = _vxLayer vx
+    layCounts = getLay theLayer counts
+    theType = _vxType vx
+    thePos = _vxPos vx
+    theCol = _vxCol vx
+    basePtr = _vboPtr $ vboFromType vbos theType
+    layOff = theLayer * numSubElements
+    thePtr = plusPtr basePtr ((intFromType layCounts theType + layOff) * theStride * floatSize)
+    theStride = pokeStride theType
+
+pokeVerxType :: Ptr Float -> VertexType -> IO ()
+pokeVerxType thePtr vt = case vt of
+    PolyzV x            -> pokeElemOff thePtr 7 x
+    BezV   (V4 x y z w) -> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 8 y
+                            >> pokeElemOff thePtr 9 z >> pokeElemOff thePtr 10 w
+    TextV  (V2 x y)     -> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 8 y
+    ArcV   (V3 x y z)   -> pokeElemOff thePtr 7 x >> pokeElemOff thePtr 8 y
+                            >> pokeElemOff thePtr 9 z
+    _ -> return ()
+    
+
+intFromType :: PicShads Int -> VertexType -> Int
+intFromType ps vt = case vt of
+    PolyV       -> _psPoly ps
+    PolyzV{}    -> _psPolyz ps
+    BezV{}      -> _psBez ps
+    TextV{}     -> _psText ps
+    ArcV{}      -> _psArc ps
+    EllV        -> _psEll ps
+
+vboFromType :: PicShads VBO -> VertexType -> VBO
+vboFromType ps vt = case vt of
+    PolyV       -> _psPoly ps
+    PolyzV{}    -> _psPolyz ps
+    BezV{}      -> _psBez ps
+    TextV{}     -> _psText ps
+    ArcV{}      -> _psArc ps
+    EllV        -> _psEll ps
+
 pokeLayVerxsFold :: PicShads VBO -> [Verx] -> IO (Layers (PicShads Int))
-pokeLayVerxsFold !vbos = F.foldM $ F.FoldM
-    (\counts vx -> pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx))
-    (pure $ pure $ pure 0)
+pokeLayVerxsFold vbos = F.foldM $ F.FoldM
+    --(\counts vx -> pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx))
+    (comLayVerx vbos)
+    (pure . pure $ pure 0)
    return

-pokeLayVerxsM :: PicShads VBO -> [Verx] -> IO (Layers (PicShads Int))
-pokeLayVerxsM !vbos = foldM f (pure $ pure 0)
-  where
-    f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx)
-
-pokeLayVerxsPartM :: PicShads VBO -> [Verx] -> Layers (PicShads Int) -> IO (Layers (PicShads Int))
-pokeLayVerxsPartM !vbos vxs0 count0 = foldM f count0 vxs0
-  where
-    f counts vx = pokeLayVerx vbos counts vx >> return (addLayCountVerx counts vx)
-
-pokeLayVerxsPart :: PicShads VBO -> [Verx] -> Layers (PicShads Int) -> IO (Layers (PicShads Int))
-pokeLayVerxsPart !vbos vxs0 count0 = go vxs0 count0
-  where
-    go [] count = return count
-    go (!vx:vxs) !count = pokeLayVerx vbos count vx >> (go vxs $! addLayCountVerx count vx)
-
-pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (Layers (PicShads Int))
-pokeLayVerxs !vbos vxs0 = go vxs0 (pure (pure 0))
-  where
-    go [] count = return count
-    go (!vx:vxs) !count = pokeLayVerx vbos count vx >> (go vxs $! addLayCountVerx count vx)
+pokeStride :: VertexType -> Int
+pokeStride PolyV    = 7
+pokeStride PolyzV{} = 8
+pokeStride BezV{}   = 11
+pokeStride TextV{}  = 9
+pokeStride ArcV{}   = 10
+pokeStride EllV     = 7

 -- this is very brittle, but want to optimise speed if possible here
 pokeLayVerx :: PicShads VBO -> Layers (PicShads Int) -> Verx -> IO ()
--{-# INLINE pokeLayVerx #-}
+{-# INLINE pokeLayVerx #-}
 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
@@ -188,7 +236,7 @@ pokeLayVerx vbos imoffsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType, _vx
    offsets = getLay theLay imoffsets

 addLayCountVerx :: Layers (PicShads Int) -> Verx -> Layers (PicShads Int)
--{-# INLINE addLayCountVerx #-}
+{-# INLINE addLayCountVerx #-}
 addLayCountVerx !m@Layers
    { _lay0 = a0
    , _lay1 = a1
@@ -197,7 +245,30 @@ addLayCountVerx !m@Layers
    , _lay4 = a4
    , _lay5 = a5
    }
-    !vx = case _vxLayer vx of
+    vx = case _vxLayer vx of
+    0 -> m { _lay0 = f $! a0 }
+    1 -> m { _lay1 = f $! a1 }
+    2 -> m { _lay2 = f $! a2 }
+    3 -> m { _lay3 = f $! a3 }
+    4 -> m { _lay4 = f $! a4 }
+    5 -> m { _lay5 = f $! a5 }
+    _ -> undefined
+  where
+    f = flip addCountVerx vx
+
+
+
+addLayCountVerx' :: Layers (PicShads Int) -> Int -> VertexType -> Layers (PicShads Int)
+{-# INLINE addLayCountVerx' #-}
+addLayCountVerx' m@Layers
+    { _lay0 = a0
+    , _lay1 = a1
+    , _lay2 = a2
+    , _lay3 = a3
+    , _lay4 = a4
+    , _lay5 = a5
+    }
+    lay vt = case lay of
    0 -> m { _lay0 = f a0 }
    1 -> m { _lay1 = f a1 }
    2 -> m { _lay2 = f a2 }
@@ -206,7 +277,7 @@ addLayCountVerx !m@Layers
    5 -> m { _lay5 = f a5 }
    _ -> undefined
  where
-    f = flip addCountVerx vx
+    f = addCountVerx' vt

 poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
 poke224s ptr vals0 = go vals0 0