为什么我的并行代码比没有并行的代码还要慢？

Question

我按照 Simon Marlow 的关于并行 Haskell 的书（第 1 章）使用rpar/ rseq。

下面是代码（解决Squid Game桥模拟）：

{-# 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

对于 main2，我使用以下方法进行编译：

ghc -O2 -threaded ./squid.hs

并运行为：

./squid 10000000 18 2 16 +RTS -N2

我不明白为什么main1比main2whilemain2具有并行性更快。

谁能给我一些关于我的代码的评论，看看这是否是并行性的正确使用？

更新： 这是更新的版本（新的random使用起来相当麻烦）：

{-# 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

更新2：

使用纯代码，耗时可降至 7 秒。

{-# 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

您实际上没有使用任何并行性。你写

    r1 <- rpar $ simulate (div n 2) (game steps glassNum playNum) >>= evaluate . force

这会引发一个线程来评估操作IO，而不是运行它。那没有用。

由于您simulate本质上是pure，因此您应该通过交换适当的数组类型等将其从 转换IO为。然后您就可以实际上并行工作。我认为这些调用在上下文中没有用/合适；他们会更快地释放阵列，但代价高昂。ST srpar (runST $ simulate ...)force