Engage multiple threads

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