Why is my parallel code even slower than without parallelism? - haskell

Question

I followed Simon Marlow's book on parallel Haskell (Chapter 1) using rpar/rseq .
Below is the code (Solving the Squid Game bridge simulation):
{-# LANGUAGE FlexibleContexts #-}
import Control.DeepSeq (force)
import Control.Exception (evaluate)
import Control.Parallel.Strategies
import Data.Array.IO
( IOUArray,
getAssocs,
newListArray,
readArray,
writeArray,
)
import Data.Functor ((<&>))
import System.Environment (getArgs)
import System.Random (randomRIO)
game ::
Int -> -- number of steps
Int -> -- number of glass at each step
Int -> -- number of players
IO Int -- return the number of survivors
game totalStep totalGlass = go 1 totalGlass
where
go currentStep currentGlass numSurvivors
| numSurvivors == 0 || currentStep > totalStep = return numSurvivors
| otherwise = do
r <- randomRIO (1, currentGlass)
if r == 1
then go (currentStep + 1) totalGlass numSurvivors
else go currentStep (currentGlass - 1) (numSurvivors - 1)
simulate :: Int -> IO Int -> IO [(Int, Int)]
simulate n game =
(newListArray (0, 16) (replicate 17 0) :: IO (IOUArray Int Int))
>>= go 1
>>= getAssocs
where
go i marr
| i <= n = do
r <- game
readArray marr r >>= writeArray marr r . (+ 1)
go (i + 1) marr
| otherwise = return marr
main1 :: IO ()
main1 = do
[n, steps, glassNum, playNum] <- getArgs <&> Prelude.map read
res <- simulate n (game steps glassNum playNum)
mapM_ print res
main2 :: IO ()
main2 = do
putStrLn "Running main2"
[n, steps, glassNum, playNum] <- getArgs <&> Prelude.map read
res <- runEval $ do
r1 <- rpar $ simulate (div n 2) (game steps glassNum playNum) >>= evaluate . force
r2 <- rpar $ simulate (div n 2) (game steps glassNum playNum) >>= evaluate . force
rseq r1
rseq r2
return $
(\l1 l2 -> zipWith (\e1 e2 -> (fst e1, snd e1 + snd e2)) l1 l2)
<$> r1
<*> r2
mapM_ print res
main = main2
For main2, I've compiled using:
ghc -O2 -threaded ./squid.hs
and run as:
./squid 10000000 18 2 16 +RTS -N2
I can't understand why main1 is faster than main2 while main2 has parallelism in it.
Could anyone give me some comments on my code as to whether this is the correct use of parallelism?
Update:
Here's the updated version (the new random is quite cumbersome to use):
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
import Control.Monad.ST (ST, runST)
import Control.Parallel.Strategies (rpar, rseq, runEval)
import Data.Array.ST
( STUArray,
getAssocs,
newListArray,
readArray,
writeArray,
)
import Data.Functor ((<&>))
import System.Environment (getArgs)
import System.Random (StdGen)
import System.Random.Stateful
( StdGen,
applySTGen,
mkStdGen,
runSTGen,
uniformR,
)
game ::
Int -> -- number of steps
Int -> -- number of glass at each step
Int -> -- number of players
StdGen ->
ST s (Int, StdGen) -- return the number of survivors
game ns ng = go 1 ng
where
go
!cs -- current step number
!cg -- current glass number
!ns -- number of survivors
!pg -- pure generator
| ns == 0 || cs > ns = return (ns, pg)
| otherwise = do
let (r, g') = runSTGen pg (applySTGen (uniformR (1, cg)))
if r == 1
then go (cs + 1) ng ns g'
else go cs (cg - 1) (ns - 1) g'
simulate :: Int -> (forall s. StdGen -> ST s (Int, StdGen)) -> [(Int, Int)]
simulate n game =
runST $
(newListArray (0, 16) (replicate 17 0) :: ST s1 (STUArray s1 Int Int))
>>= go 1 (mkStdGen n)
>>= getAssocs
where
go !i !g !marr
| i <= n = do
(r, g') <- game g
readArray marr r >>= writeArray marr r . (+ 1)
go (i + 1) g' marr
| otherwise = return marr
main :: IO ()
main = do
[n, steps, glassNum, playNum] <- getArgs <&> Prelude.map read
let res = runEval $ do
r1 <- rpar $ simulate (div n 2 - 1) (game steps glassNum playNum)
r2 <- rpar $ simulate (div n 2 + 1) (game steps glassNum playNum)
rseq r1
rseq r2
return $ zipWith (\e1 e2 -> (fst e1, snd e1 + snd e2)) r1 r2
mapM_ print res
Update 2:
Use pure code and the elapsed time is down to 7 seconds.
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
import Control.Monad.ST ( runST, ST )
import Control.Parallel ( par, pseq )
import Data.Array.ST
( getAssocs, newListArray, readArray, writeArray, STUArray )
import Data.Functor ((<&>))
import System.Environment (getArgs)
import System.Random (StdGen, uniformR, mkStdGen)
game ::
Int -> -- number of total steps
Int -> -- number of glass at each step
Int -> -- number of players
StdGen ->
(Int, StdGen) -- return the number of survivors
game ts ng = go 1 ng
where
go
!cs -- current step number
!cg -- current glass number
!ns -- number of survivors
!pg -- pure generator
| ns == 0 || cs > ts = (ns, pg)
| otherwise = do
let (r, g') = uniformR (1, cg) pg
if r == 1
then go (cs + 1) ng ns g'
else go cs (cg - 1) (ns - 1) g'
simulate :: Int -> (StdGen -> (Int, StdGen)) -> [(Int, Int)]
simulate n game =
runST $
(newListArray (0, 16) (replicate 17 0) :: ST s1 (STUArray s1 Int Int))
>>= go 1 (mkStdGen n)
>>= getAssocs
where
go !i !g !marr
| i <= n = do
let (r, g') = game g
readArray marr r >>= writeArray marr r . (+ 1)
go (i + 1) g' marr
| otherwise = return marr
main :: IO ()
main = do
[n, steps, glassNum, playNum] <- getArgs <&> Prelude.map read
let r1 = simulate (div n 2 - 1) (game steps glassNum playNum)
r2 = simulate (div n 2 + 1) (game steps glassNum playNum)
res = zipWith (\e1 e2 -> (fst e1, snd e1 + snd e2)) r1 r2
res' = par r1 (pseq r2 res)
mapM_ print res'

Answer 1

You aren't actually using any parallelism. You write
r1 <- rpar $ simulate (div n 2) (game steps glassNum playNum) >>= evaluate . force
This sparks a thread to evaluate an IO action, not to run it. That's not useful.
Since your simulate is essentially pure, you should convert it from IO to ST s by swapping in the appropriate array types, etc. Then you can rpar (runST $ simulate ...) and actually do work in parallel. I don't think the force invocations are useful/appropriate in context; they'll free the arrays sooner, but at significant cost.