multithreading - Haskell:没有利用所有内核的并行程序

Question

无论是否使用-threaded 编译，或者当我以单线程方式编写代码时，以下代码都具有相同的性能。两个 block (使用 par 和注释的 forkIO/forkOS/forkOn)产生相同的性能。事实上，并行版本的性能略有下降(推测是由于并行 GC 的开销)。从像 htop 这样的程序中查看 CPU 利用率显示只有一个 CPU 被锁定，这非常令人困惑，因为我对代码的阅读是它应该使用大部分内核。

forkOS 没有使用更多内核的事实尤其令人困惑，因为 ghc/rts/posix/OSThreads.c:forkOS_createThread 的相关部分似乎暗示它强制调用 pthread_create。

-- (Apologies if I have missed an import or two)

import Data.List
import GHC.Conc
import Control.Concurrent
import Control.DeepSeq
import qualified Data.HashMap.Lazy as HM
main :: IO ()
main = do
  let [one::Int, two] = [15, 1000000]
{-
  s <- numSparks
  putStrLn $ "Num sparks " <> show s
  n <- getNumCapabilities
  putStrLn $ "Num capabilities " <> show n
  m <- newEmptyMVar
  forkIO $ void $ forM [(1::Int)..one] $ \cpu -> do
    -- forkOn cpu $ void $ do
    forkOS $ void $ do
    -- forkIO $ void $ do
    -- void $ do
      putStrLn $ "core " <> show cpu
      s <- return $ sort $ HM.keys $ HM.fromList $ zip [cpu..two + cpu] (repeat (0::Int))
      putStrLn $ "core " <> show cpu <> " done " <> show (sum s)
      putMVar m ()
  forM [1..one] $ \i -> takeMVar m
  let s :: String = "hey!"
  putStrLn s
-}
  print one
  print two
  let __pmap__ f xs = case xs of
       [] -> []
       x:xs -> let y = f x
                   ys = __pmap__ f xs
                   in (y `par` ys) `pseq` (y: ys)
  n <- pure $ sum . concat $ flip __pmap__ [1..one] $ \i ->
    force $ sort $ HM.keys $ HM.fromList $ zip [i..(two + i)] (repeat (0::Int))
  putStrLn $ "sum " <> show n
  s <- numSparks
  putStrLn $ "Num sparks " <> show s

我的 .cabal 文件中的相关部分

  ghc-options:
    -threaded
    -rtsopts
    "-with-rtsopts=-N15 -qg1"

平台信息

$ stack --version
Version 1.2.0, Git revision 241cd07d576d9c0c0e712e83d947e3dd64541c42 (4054 commits) x86_64 hpack-0.14.0
$ stack exec ghc -- --version
The Glorious Glasgow Haskell Compilation System, version 7.10.3
$ lsb_release -a
No LSB modules are available.
Distributor ID: Ubuntu
Description:    Ubuntu 16.04.1 LTS
Release:    16.04
Codename:   xenial
$ uname -r
4.4.0-36-generic

为什么我的代码没有并行化？

编辑:如果有帮助，添加 -s 运行时标志会产生以下报告

  21,829,377,776 bytes allocated in the heap
 126,512,021,712 bytes copied during GC
      86,659,312 bytes maximum residency (322 sample(s))
       6,958,976 bytes maximum slop
             218 MB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0     41944 colls,     0 par   16.268s  17.272s     0.0004s    0.0011s
  Gen  1       322 colls,   321 par   237.056s  23.822s     0.0740s    0.2514s

  Parallel GC work balance: 13.01% (serial 0%, perfect 100%)

  TASKS: 32 (1 bound, 31 peak workers (31 total), using -N15)

  SPARKS: 15 (0 converted, 0 overflowed, 0 dud, 0 GC'd, 15 fizzled)

  INIT    time    0.004s  (  0.003s elapsed)
  MUT     time   12.504s  ( 13.301s elapsed)
  GC      time  253.324s  ( 41.094s elapsed)
  EXIT    time    0.000s  (  0.017s elapsed)
  Total   time  265.920s  ( 54.413s elapsed)

  Alloc rate    1,745,791,568 bytes per MUT second

  Productivity   4.7% of total user, 23.1% of total elapsed

gc_alloc_block_sync: 10725286
whitehole_spin: 0
gen[0].sync: 2171
gen[1].sync: 1057315

EDIT2:弄乱竞技场大小似乎有很大帮助。我在 RTS 选项中添加了 -H2G​​ -A1G，时间从 43 秒降到了 5.2 秒。对于获得 15 倍加速的情况，是否还有其他可以改进的地方？

EDIT3:编辑代码以反射(reflect)两个提供反馈的人建议的par、pseq 模式

Answer 1

问题是由 __pmap__ 的定义引起的。具体如下表达式有问题:

let y = f x
 in y `par` (y: __pmap__ f xs)

您可能希望这会导致 y 和 y: __pmap__ f xs 被并行计算，但事实并非如此。发生的情况是 GHC 尝试并行计算它们，但第二个子表达式包含 y，这是第一个子表达式。因此，第二个子表达式依赖于第一个子表达式，因此它们不能并行计算。上面表达式的正确写法是

let y = f x
    ys = __pmap__ f xs
 in y `par` (ys `pseq` (y : ys))

因为 pseq 将强制 ys 在 y : ys 之前被求值，因此第二个子表达式的求值可以在y 的评估正在运行。另见 thread对此进行一些讨论。

所以将它们放在一起，我们得到以下内容:

main :: IO ()
main = do
  let [one::Int, two] = [15, 1000000]
  print one
  print two
  let __pmap__ f xs = case xs of
        [] -> []
        x:xs -> let y = f x
                    ys = __pmap__ f xs
                 in y `par` ys `pseq` (y : ys)
  n <- pure $ sum . concat $ flip __pmap__ [1..one] $ \i ->
    traceShow i $ force $ sort $ HM.keys $ HM.fromList $ zip [i..(two + i)] (repeat (0::Int))
  putStrLn $ "sum " <> show n
  s <- numSparks
  putStrLn $ "Num sparks " <> show s

请注意，我添加了一个 traceShow(来自 Debug.Trace)。如果您在 rtsopts 中使用 -N1 运行它，您将看到列表将一次评估一个元素，而如果您使用 -N3，它将一次评估 3 个元素。

故事的寓意是 par 和 pseq 很容易被误用，因此您应该更喜欢更高级别的解决方案，例如 parMap rdeepseq (相当于您的 __pmap__)来自 parallel .