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

Engage multiple threads

Browse Source
This commit is contained in:
justin
2021-09-23 21:19:38 +01:00
parent 85edd98d62
commit 4a1501a358
6 changed files with 69 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appDodge/Main.hs
+10 -4
View File
@@ -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
package.yaml
+5
View File
@@ -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
src/Dodge/Event.hs
+2 -5
View File
@@ -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
src/Dodge/Render.hs
+14 -9
View File
@@ -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)
src/Shader/Poke.hs
+30 -17
View File
@@ -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
stack.yaml
+8
View File
@@ -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