Engage multiple threads

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
     

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

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 :: Event -> World -> Maybe World
-handleEvent = flip handleEvent'
+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

@@ -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
+    -- attempt to do this poking in parallel
-    -- poke wall points and colors
+    (nWalls,(nShapeVs,nIndices,nSilIndices)) <- MP.bindM3 (\ _ a b -> return (a,b))
-    nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
+        -- pictures poking
-    (nShapeVs,nIndices,nSilIndices) <- pokeShape
+        ( pokeBindFoldableLayer shadV layerCounts $ worldPictures w )
-        (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata)
+        -- poke wall points and colors
-        (_eboPtr $ _shapeEBO pdata)
+        ( poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol )
-        (_eboPtr $ _silhouetteEBO pdata)
+        ( pokeShape 
-        $ worldShape w
+            (_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

@@ -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
+pokeTopPrism size ptr iptr ieptr (nv,ni,nei) svs = do
-    count' <- pokeTopPrismIndices size iptr count >>= pokeTopPrismEdgeIndices size ieptr
+    MP.bindM3 (\a b c -> return (a,b,c))
-    VS.foldlM' (pokeJustV ptr) count' (VS.fromList svs)
+        (VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs) )
-
+        (UV.foldM (pokeTopPrismIndex nv iptr)      ni  (memoTopPrismIndices     V.! (size - 2)) )
-pokeTopPrismIndices :: Int -> Ptr GLushort -> (Int,Int,Int) -> IO (Int,Int,Int)
+        (UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2)) )
-pokeTopPrismIndices size iptr (nv,ni,nei) = do
+--    ni'  <- UV.foldM (pokeTopPrismIndex nv iptr)      ni  (memoTopPrismIndices     V.! (size - 2))
-    ni' <- foldM (pokeTopPrismIndex nv iptr) ni (topPrismIndices size)
+--    nei' <- UV.foldM (pokeTopPrismEdgeIndex nv ieptr) nei (memoTopPrismEdgeIndices V.! (size - 2))
-    return (nv,ni',nei)
+--    nv'  <- VS.foldlM' (pokeJustV ptr) nv (VS.fromList svs)
-
+--    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')
 
 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 Float -> Int -> ShapeV -> IO Int
-pokeJustV ptr (nv,ni,nei) sh = do
+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

@@ -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