From 2f8a9fb86a25792d951da5fc13de12a16675aeac Mon Sep 17 00:00:00 2001 From: jgk Date: Tue, 3 Aug 2021 20:22:39 +0200 Subject: [PATCH] Inline fold sub-functions for speed --- src/Render.hs | 1 - src/Shader/Poke.hs | 143 +++++++++++++++++++++++++++++++++------------ 2 files changed, 107 insertions(+), 37 deletions(-) diff --git a/src/Render.hs b/src/Render.hs index 9ee638e78..93dc27464 100644 --- a/src/Render.hs +++ b/src/Render.hs @@ -142,7 +142,6 @@ drawTextureOnFramebuffer fs fbo to = do drawShader fs 4 pokeBindFoldable - -- :: Foldable f :: RenderData -> [Verx] -> IO (PicShads Int) diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index d4346ad09..f206da7bd 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -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