diff --git a/appDodge/Main.hs b/appDodge/Main.hs index 63109ae8e..1af8190a8 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -31,6 +31,8 @@ import qualified Data.IntMap as IM import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) import qualified SDL import qualified SDL.Mixer as Mix +--import qualified Control.Monad.Parallel as MP +import Control.Parallel main :: IO () main = do @@ -40,7 +42,7 @@ main = do theCleanup (firstWorldLoad (sizex,sizey)) theUpdateStep - handleEvent + (flip handleEvent) theCleanup :: World -> IO () theCleanup w = SDL.cursorVisible $= True >> cleanUpPreload (_preloadData w) @@ -55,13 +57,17 @@ firstWorldLoad (sizex,sizey) = do return $ w & preloadData .~ pdata theUpdateStep :: World -> IO World -theUpdateStep = doSideEffects . update +theUpdateStep = doSideEffects <=< updateRenderSplit + +updateRenderSplit :: World -> IO World +updateRenderSplit w = do + let preData = _preloadData w + update w `par` void (doDrawing (_renderData preData) w) + return $ update w doSideEffects :: World -> IO World doSideEffects w = do let preData = _preloadData w - void $ doDrawing (_renderData preData) w - --playPositionalSoundQueue (_loadedChunks $ _soundData preData) (_soundQueue w) newPlayingSounds <- playSoundAndUpdate (_soundData preData) (_playingSounds w) (_sounds w) w' <- _sideEffects w w diff --git a/package.yaml b/package.yaml index 254d992c9..6c927b7bf 100644 --- a/package.yaml +++ b/package.yaml @@ -51,6 +51,8 @@ dependencies: - primitive - streaming - repa +- monad-parallel +- parallel library: source-dirs: src @@ -66,7 +68,10 @@ executables: - -threaded - -O2 - -rtsopts + - -eventlog + - -with-rtsopts=+RTS - -with-rtsopts=-N + - -with-rtsopts=-l - -flate-dmd-anal - -fno-liberate-case - -fno-state-hack diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index e1ae5ab89..343b680df 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -35,11 +35,8 @@ import Control.Lens import qualified Data.Set as S import SDL -handleEvent :: World -> Event -> Maybe World -handleEvent = flip handleEvent' - -handleEvent' :: Event -> World -> Maybe World -handleEvent' e = case eventPayload e of +handleEvent :: Event -> World -> Maybe World +handleEvent e = case eventPayload e of KeyboardEvent kev -> handleKeyboardEvent kev MouseMotionEvent mmev -> handleMouseMotionEvent mmev MouseButtonEvent mbev -> handleMouseButtonEvent mbev diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 4e2401bfc..8216e277b 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -23,6 +23,7 @@ import Shader.Parameters import Foreign import Control.Lens import Control.Monad +import qualified Control.Monad.Parallel as MP import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate) import qualified SDL import qualified Data.Vector.Unboxed.Mutable as UMV @@ -42,16 +43,20 @@ doDrawing pdata w = do viewFrom3d = Vector3 vfx vfy 20 shadV = _pictureShaders pdata -- bind as much data into vbos as feasible at this point - -- pictures + -- pictures setup layerCounts <- UMV.replicate (6*6) 0 - pokeBindFoldableLayer shadV layerCounts $ worldPictures w - -- poke wall points and colors - nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol - (nShapeVs,nIndices,nSilIndices) <- pokeShape - (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) - (_eboPtr $ _shapeEBO pdata) - (_eboPtr $ _silhouetteEBO pdata) - $ worldShape w + -- attempt to do this poking in parallel + (nWalls,(nShapeVs,nIndices,nSilIndices)) <- MP.bindM3 (\ _ a b -> return (a,b)) + -- pictures poking + ( pokeBindFoldableLayer shadV layerCounts $ worldPictures w ) + -- poke wall points and colors + ( poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol ) + ( pokeShape + (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) + (_eboPtr $ _shapeEBO pdata) + (_eboPtr $ _silhouetteEBO pdata) + $ worldShape w + ) -- bind wall points, silhouette data, surface geometry uncurry bindShaderBuffers $ unzip [ ( _wallTextureShader pdata, nWalls) diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 6de017b34..6a0136498 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -17,11 +17,16 @@ import Geometry.Data import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate) import Foreign +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as UV import qualified Data.Vector.Unboxed.Mutable as UMV import qualified Data.Vector.Mutable as MV import qualified Data.Vector.Fusion.Stream.Monadic as VS import Control.Monad.Primitive -import Control.Monad +--import Control.Parallel.Strategies +--import System.Environment +import Control.Monad.Parallel as MP +--import Control.Monad --import qualified Data.DList as DL pokeVerxs @@ -63,30 +68,38 @@ pokeShapeObj ptr iptr ieptr counts (ShapeObj shType shVerts) = case shType of pokeTopPrism :: Int -> Ptr Float -> Ptr GLushort -> Ptr GLushort -> (Int,Int,Int) -> [ShapeV] -> IO (Int,Int,Int) -pokeTopPrism size ptr iptr ieptr count svs = do - count' <- pokeTopPrismIndices size iptr count >>= pokeTopPrismEdgeIndices size ieptr - VS.foldlM' (pokeJustV ptr) count' (VS.fromList svs) - -pokeTopPrismIndices :: Int -> Ptr GLushort -> (Int,Int,Int) -> IO (Int,Int,Int) -pokeTopPrismIndices size iptr (nv,ni,nei) = do - ni' <- foldM (pokeTopPrismIndex nv iptr) ni (topPrismIndices size) - return (nv,ni',nei) - -pokeTopPrismEdgeIndices :: Int -> Ptr GLushort -> (Int,Int,Int) -> IO (Int,Int,Int) -pokeTopPrismEdgeIndices size ieptr (nv,ni,nei) = do - nei' <- foldM (pokeTopPrismEdgeIndex nv ieptr) nei (topPrismEdgeIndices size) - return (nv,ni,nei') +pokeTopPrism size ptr iptr ieptr (nv,ni,nei) svs = do + MP.bindM3 (\a b c -> return (a,b,c)) + (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) ) + (UV.foldM (pokeTopPrismIndex nv iptr) ni (memoTopPrismIndices V.! (size - 2)) ) + (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) ) +-- ni' <- UV.foldM (pokeTopPrismIndex nv iptr) ni (memoTopPrismIndices V.! (size - 2)) +-- nei' <- UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) +-- nv' <- VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) +-- return (nv',ni',nei') pokeTopPrismEdgeIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int +{-# INLINE pokeTopPrismEdgeIndex #-} pokeTopPrismEdgeIndex nv iptr ni ioff = do pokeElemOff iptr ni (fromIntegral $ nv + ioff) return (ni + 1) pokeTopPrismIndex :: Int -> Ptr GLushort -> Int -> Int -> IO Int +{-# INLINE pokeTopPrismIndex #-} pokeTopPrismIndex nv iptr ni ioff = do pokeElemOff iptr ni (fromIntegral $ nv + ioff) return (ni + 1) +memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int) +memoTopPrismEdgeIndices = V.generate 6 f + where + f n = UV.fromList $ topPrismEdgeIndices (n + 2) + +memoTopPrismIndices :: V.Vector (UV.Vector Int) +memoTopPrismIndices = V.generate 6 f + where + f n = UV.fromList $ topPrismIndices (n + 2) + topPrismEdgeIndices :: Int -> [Int] topPrismEdgeIndices n = concatMap f [0..n-1] where @@ -108,8 +121,8 @@ topPrismIndices n = concatMap f [1..n-2] -- triangles on top face g x = [2*x,2*x+1,2*x+3 ,2*x,2*x+3,2*x+2] -pokeJustV :: Ptr Float -> (Int,Int,Int) -> ShapeV -> IO (Int,Int,Int) -pokeJustV ptr (nv,ni,nei) sh = do +pokeJustV :: Ptr Float -> Int -> ShapeV -> IO Int +pokeJustV ptr nv sh = do pokeElemOff ptr (off 0) a pokeElemOff ptr (off 1) b pokeElemOff ptr (off 2) c @@ -117,7 +130,7 @@ pokeJustV ptr (nv,ni,nei) sh = do pokeElemOff ptr (off 4) e pokeElemOff ptr (off 5) f pokeElemOff ptr (off 6) g - return (nv+1,ni,nei) + return (nv+1) where off i = nv*7 + i V3 a b c = _svPos sh diff --git a/stack.yaml b/stack.yaml index c32e218a6..5028917e9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -38,6 +38,14 @@ packages: extra-deps: - SDL-0.6.7.0@sha256:9d6ba75c0cab575ec38468c8277803983e985f9622437aeca6a53e6a7337a7d5,2045 - repa-3.4.1.4@sha256:5a99bde69fe96a18d70aae23f47c8f719b1134558dca3ee5a7c15423b68a132e,3323 + # # for threadscope + #- cairo-0.13.8.1@sha256:1938aaeb5d3504678d995774dfe870f6b66cbd43d336b692fa8779b23b2b67a9,4075 + #- ghc-events-0.15.1@sha256:b4052e98694a6426f46fb6ebb250b06d6f68a14fa0b7ceb7c01282c6bb5fe47e,3757 + #- glib-0.13.8.1@sha256:42670daf0c85309281e08ba8559df75daa2e3be642e79fdfa781bef5e59658b0,3156 + #- gtk-0.15.5@sha256:62b0ed14e07e57f13a575d36f37c6f250ee9ed45d68d492685e8bd26c35c2203,16598 + #- pango-0.13.8.1@sha256:877b121c0bf87c96d3619effae6751ecfd74b7f7f3227cf3fde012597aed5ed9,3917 + #- gio-0.13.8.1@sha256:7404841eefdfffb50c2b5f63879ffe4bf40fb5ddf90a7f633494eca0e23150a5,3136 + #- gtk2hs-buildtools-0.13.8.0@sha256:132f38155fc677430a47ea750918973161c876fb6f281d342ac2f07eb99229ce,5238 # - acme-missiles-0.3 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a