为什么并行化这段代码在六核机器上几乎没有产生任何性能提升？

Question

为什么并行化这段代码在六核机器上几乎没有产生任何性能提升？

sup*_*ate 5 parallel-processing performance haskell

我正在使用 Simon Marlow 的书学习 Haskell 中的并行编程。在关于并行数独求解器的章节中，我决定使用回溯算法编写自己的求解器。问题是，当我尝试在 6 个核心之间分配 6 个案例时，几乎没有性能增益。当我尝试使用更多情况进行示例时，我获得了更显着的性能提升，但距离理论上的最大值（应在 5 到 6 之间）仍然很远。我知道某些情况可能运行得慢得多，但 threadscope 图显示没有理由这么少获得。有人可以解释一下我做错了什么吗？也许 ST 线程有一些我不理解的地方？

这是代码：

数独.hs

{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}

module Sudoku (getSudokus, solve) where

import Data.Vector(Vector, (!), generate, thaw, freeze)
import Data.List ( nub )
import qualified Data.Vector.Mutable as MV
import Text.Trifecta
import Control.Monad ( replicateM, when )
import Control.Applicative ((<|>))
import Control.Monad.ST
import Control.DeepSeq (NFData)
import GHC.Generics (Generic)

data Cell = Given Int
        | Filled Int
        | Empty
        deriving (Generic, NFData)

newtype Sudoku = Sudoku (Vector Cell)
    deriving (Generic, NFData)

instance Show Cell where
    show Empty = "   "
    show (Filled x) = " " ++ show x ++ " " 
    show (Given x) = "[" ++ show x ++ "]"

instance Show Sudoku where
    show (Sudoku vc) = "\n" ++
                    "+ -  -  - + -  -  - + -  -  - +" ++ "\n" ++
                    "|" ++ i 0 ++ i 1 ++ i 2 ++ "|" ++ i 3 ++ i 4 ++ i 5 ++ "|" ++ i 6 ++ i 7 ++ i 8 ++ "|" ++ "\n" ++
                    "|" ++ i 9 ++ i 10 ++ i 11 ++ "|" ++ i 12 ++ i 13 ++ i 14 ++ "|" ++ i 15 ++ i 16 ++ i 17 ++ "|" ++ "\n" ++
                    "|" ++ i 18 ++ i 19 ++ i 20 ++ "|" ++ i 21 ++ i 22 ++ i 23 ++ "|" ++ i 24 ++ i 25 ++ i 26 ++ "|" ++ "\n" ++
                    "+ -  -  - + -  -  - + -  -  - +" ++ "\n" ++
                    "|" ++ i 27 ++ i 28 ++ i 29 ++ "|" ++ i 30 ++ i 31 ++ i 32 ++ "|" ++ i 33 ++ i 34 ++ i 35 ++ "|" ++ "\n" ++
                    "|" ++ i 36 ++ i 37 ++ i 38 ++ "|" ++ i 39 ++ i 40 ++ i 41 ++ "|" ++ i 42 ++ i 43 ++ i 44 ++ "|" ++ "\n" ++
                    "|" ++ i 45 ++ i 46 ++ i 47 ++ "|" ++ i 48 ++ i 49 ++ i 50 ++ "|" ++ i 51 ++ i 52 ++ i 53 ++ "|" ++ "\n" ++
                    "+ -  -  - + -  -  - + -  -  - +" ++ "\n" ++
                    "|" ++ i 54 ++ i 55 ++ i 56 ++ "|" ++ i 57 ++ i 58 ++ i 59 ++ "|" ++ i 60 ++ i 61 ++ i 62 ++ "|" ++ "\n" ++
                    "|" ++ i 63 ++ i 64 ++ i 65 ++ "|" ++ i 66 ++ i 67 ++ i 68 ++ "|" ++ i 69 ++ i 70 ++ i 71 ++ "|" ++ "\n" ++
                    "|" ++ i 72 ++ i 73 ++ i 74 ++ "|" ++ i 75 ++ i 76 ++ i 77 ++ "|" ++ i 78 ++ i 79 ++ i 80 ++ "|" ++ "\n" ++
                    "+ -  -  - + -  -  - + -  -  - +" ++ "\n"
                    where i x = show (vc ! x)

parseSudoku :: Parser Sudoku
parseSudoku = do
            lst <- replicateM 81 field
            (newline *> return ()) <|> eof
            return $ Sudoku $ generate 81 (lst !!)
        where field = (char '.' >> return Empty) <|> (Given . read . return <$> digit)

getSudokus :: String -> Maybe [Sudoku]
getSudokus raw = case parseString (some parseSudoku) mempty raw of
                    Success ss -> Just ss
                    Failure _ -> Nothing

data Direction = Back | Forward

solve :: Sudoku -> Maybe Sudoku
solve sudoku@(Sudoku puzzle) =  if isValid sudoku then
                                Just $ runST $ do
                                    puzzle' <- thaw puzzle
                                    go puzzle' 0 Forward
                                    Sudoku <$> freeze puzzle'
                                else Nothing
                                where go _ 81 _ = return ()
                                    go vector position direction = do
                                        cell <- MV.read vector position
                                        case (cell, direction) of
                                            (Empty, Back) -> error "Calling back Empty cell, this should not ever occur"
                                            (Empty, Forward) -> MV.write vector position (Filled 1) >> go vector position Forward
                                            (Given _, Back) -> go vector (position-1) Back
                                            (Given _, Forward) -> go vector (position+1) Forward
                                            (Filled 10, Back) -> MV.write vector position Empty >> go vector (position-1) Back
                                            (Filled 10, Forward) -> go vector position Back
                                            (Filled x, Forward) -> do
                                                let (r, c, s) = calculatePositions position
                                                row <- getRowMV r vector
                                                col <- getColumnMV c vector
                                                sqr <- getSquareMV s vector
                                                if isUnique row && isUnique col && isUnique sqr
                                                    then go vector (position+1) Forward
                                                    else MV.write vector position (Filled (x+1)) >> go vector position Forward
                                            (Filled x, Back) -> MV.write vector position (Filled (x+1)) >> go vector position Forward 
                                    

calculatePositions :: Int -> (Int, Int, Int)
calculatePositions i = let (row, col) = divMod i 9
                        sqr = (row `div` 3)*3 + (col `div` 3)
                        in (row, col, sqr)


isValid :: Sudoku -> Bool
isValid sudoku = go 0
            where go 9 = True
                go i = isUnique (getRow i sudoku) && isUnique (getColumn i sudoku) && isUnique (getSquare i sudoku) && go (i+1)

getRow :: Int -> Sudoku -> [Cell]
getRow l (Sudoku vector) = go 0
            where go 9 = []
                go c = vector ! (l*9 + c) : go (c+1)

getRowMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) Cell -> m [Cell]
getRowMV l mv = go 0
            where go 9 = return []
                go c = do
                    n <- MV.read mv (l*9 + c)
                    rl <- go (c+1)
                    return (n:rl)

getColumn :: Int -> Sudoku -> [Cell]
getColumn c (Sudoku vector) = go 0
            where go 9 = []
                go i = vector ! (c + i*9) : go (i+1)

getColumnMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) Cell -> m [Cell]
getColumnMV c mv = go 0
            where go 9 = return []
                go i = do
                    n <- MV.read mv (c + i*9)
                    rl <- go (i+1)
                    return (n:rl)

getSquare :: Int -> Sudoku -> [Cell]
getSquare q (Sudoku vector) = let (y, x) = quotRem q 3
                                start = x*3 + y*3*9
                            in [ vector ! start, vector ! (start + 1), vector ! (start + 2)
                                , vector ! (start + 9), vector ! (start + 10), vector ! (start + 11)
                                , vector ! (start + 18), vector ! (start + 19), vector ! (start + 20)]

getSquareMV :: MV.PrimMonad m => Int -> MV.MVector (MV.PrimState m) a -> m [a]
getSquareMV q mv = let (y, x) = quotRem q 3
                    start = x*3 + y*3*9
                    in do
                        a1 <- MV.read mv start
                        a2 <- MV.read mv (start +  1)
                        a3 <- MV.read mv (start +  2)
                        b1 <- MV.read mv (start +  9)
                        b2 <- MV.read mv (start + 10)
                        b3 <- MV.read mv (start + 11)
                        c1 <- MV.read mv (start + 18)
                        c2 <- MV.read mv (start + 19)
                        c3 <- MV.read mv (start + 20)
                        return [a1,a2,a3,b1,b2,b3,c1,c2,c3]



isUnique :: [Cell] -> Bool
isUnique xs =  let sv = strip xs
                in length sv == length (nub sv)
            where strip (Empty:xs) = strip xs
                strip ((Given x):xs) = x : strip xs
                strip ((Filled x):xs) = x : strip xs
                strip [] = []

Run Code Online (Sandbox Code Playgroud)

主要.hs

module Main where

import Control.Parallel.Strategies
import Control.Monad
import Control.DeepSeq ( force )
import Sudoku
import System.Environment (getArgs)

main :: IO ()
main = do
    filename <- head <$> getArgs
    contents <- readFile filename
    case getSudokus contents of
        Just sudokus -> print $ runEval $ do
            start <- forM sudokus (rpar . force . solve)
            forM start rseq
        Nothing -> putStrLn "Error during parsing"

Run Code Online (Sandbox Code Playgroud)

我正在使用以下标志编译它：

ghc-选项：-O2 -rtsopts -线程 -eventlog

使用以下标志执行：

cabal 执行数独 -- sudoku17.6.txt +RTS -N1 -s -l

给出以下性能报告和线程范围图：

堆中分配了 950,178,477,200 字节

GC 期间复制了 181,465,696 字节

121,832 字节最大驻留（7 个样本）

最大斜率 30,144 字节

使用中的总内存为 7 MiB（由于碎片而丢失 0 MB）

总时间（已过去）平均暂停最大暂停

Gen 0 227776 科尔斯，0 标准杆 1.454s 1.633s 0.0000s 0.0011s

第 1 代 7 项，0 面值 0.001s 0.001s 0.0001s 0.0002s

任务：4（1 个绑定，3 个峰值工作人员（总共 3 个），使用 -N1）

SPARKS：6（0 个已转换，0 个溢出，0 个无用，0 个 GC，6 个失败）

INIT时间0.001s（经过0.001s）

MUT 时间 220.452 秒（已过去 220.037 秒）

GC 时间 1.455 秒（经过 1.634 秒）

退出时间 0.000s（经过 0.008s）

总时间 221.908 秒（已过去 221.681 秒）

分配速率 4,310,140,685 字节/MUT 秒

生产力占总用户的 99.3%，占总用户的 99.3%

并行执行：

cabal 执行数独 -- sudoku17.6.txt +RTS -N6 -s -l

堆中分配了 950,178,549,616 字节

GC 期间复制了 325,450,104 字节

142,704 字节最大驻留（7 个样本）

82,088 字节最大斜率

使用中的总内存为 32 MiB（由于碎片而丢失 0 MB）

总时间（已过去）平均暂停最大暂停

Gen 0 128677 杆，128677 杆 37.697s 30.612s 0.0002s 0.0035s

第 1 代 7 杆，6 杆 0.005s 0.004s 0.0006s 0.0012s

并行GC工作平衡：11.66%（串行0%，完美100%）

任务：14（1 个绑定，13 个峰值工人（总共 13 个），使用 -N6）

SPARKS：6（5 个已转换，0 个溢出，0 个无用，0 个 GC，1 个失败）

INIT 时间 0.010s（经过 0.009s）

MUT 时间 355.227s（已过去 184.035s）

GC 时间 37.702 秒（已过去 30.616 秒）

退出时间 0.001s（经过 0.007s）

总时间 392.940 秒（已过去 214.667 秒）

分配速率 2,674,847,755 字节/MUT 秒

生产力占用户总数的 90.4%，占总用户的 85.7%

以下是sudoku17.6.txt的内容：

......2143..6......2.15.......637.......68.. .4.....23.........7....

......241..8......3......4..5..7.....1......3.. .....51.6..2..5..3...7...

.......24....1.........8.3.7...1..1..8..5.....2.... ..2.4...6.5...7.3.........

.......23.1..4..5........1.....4.....2...8....8.3.... ...5.16..4....7....3......

......21...5...3.4..6......21...8.......75.....6... ..4..8...1..7.....3.......

......215.3......6......1.4.6.7......5......2......48.3 ...1..7..2........

Answer 1

leh*_*ins 4

不管你相信与否，但你的问题可能与并行化无关。将来我建议您首先查看您尝试并行化的函数的输入。事实证明你总是尝试一个谜题。

编辑- @Noughtmare 指出，根据问题中发布的 Threadscope 结果，正在进行一些并行化。这是真的，这让我相信所发布的文件与用于创建结果的文件并不完全匹配。如果是这种情况，那么您可以跳到并行化部分来获取以下问题的答案：“为什么并行化此代码在六核机器上几乎没有产生任何性能改进？”

解析器

长话短说，您的解析器中有一个错误。如果你问我的真实意见，这实际上是包文档中的一个错误trifecta，因为它承诺完全消耗输入parseString：

将字符串完全解析为结果。

但它只消耗第一行并成功返回结果。然而，老实说，我以前从未使用过它，所以也许这是预期的行为。

让我们看看你的解析器：

parseSudoku :: Parser Sudoku
parseSudoku = do
  lst <- replicateM 81 field
  (newline *> return ()) <|> eof
  return $ Sudoku $ generate 81 (lst !!)
  where
    field = (char '.' >> return Empty) <|> (Given . read . return <$> digit)

Run Code Online (Sandbox Code Playgroud)

乍一看，它看起来很好，直到仔细检查输入。数据行之间的每个空行也包含一个换行符，但您的解析器最多需要一个换行符：

.......2143.......6........2.15..........637...........68...4.....23........7....
<this is also a newline>
.......241..8.............3...4..5..7.....1......3.......51.6....2....5..3...7...

Run Code Online (Sandbox Code Playgroud)

所以你的解析器应该是：

  many (newline *> return ()) <|> eof

Run Code Online (Sandbox Code Playgroud)

边注。如果由我决定，我会这样编写解析器：

.......2143.......6........2.15..........637...........68...4.....23........7....
<this is also a newline>
.......241..8.............3...4..5..7.....1......3.......51.6....2....5..3...7...

Run Code Online (Sandbox Code Playgroud)

并行化

当谈到并行化的实现时，看起来工作正常，但问题是工作负载确实不平衡。这就是为什么使用 6 核时速度仅提高约 2 倍。换句话说，并非所有谜题都同样困难。因此，使用 6 个核心并行解决 6 个难题始终最多只能获得最长解决方案的性能。因此，要从并行化中获得更多收益，您要么需要更多谜题，要么需要更少的 CPU 核心；）

编辑：这里有一些基准来支持我上面的解释。

以下是解决每个谜题的结果：

这两个分别是使用一核和六核的顺序和并行求解器。

正如您所看到的，使用索引解决第二个难题1花费了最长的时间，在我的计算机上花费了 100 秒多一点。这也是并行算法解决所有难题所需的时间。这是有道理的，因为所有其他 5 个谜题的解决速度都要快得多，而且那些被释放的核心没有其他工作要做。

另外，作为一项健全性检查，如果您总结解决谜题所需的各个时间，它将与顺序解决所有谜题所需的总时间非常匹配。

归档时间：	2 年，10 月前
查看次数：	240 次
最近记录：	2 年，10 月前