multithreading - Haskell:并行代码比顺序版本慢

Question

对于Haskell线程(和一般的并行编程)来说，我还很陌生，我不确定为什么我的算法的并行版本比相应的顺序版本运行得慢。

该算法尝试在不使用递归的情况下找到所有k个组合。为此，我使用了this帮助函数，该函数给定一个设置了k位的数字，然后返回设置了相同位数的下一个数字:

import Data.Bits    

nextKBitNumber :: Integer -> Integer
nextKBitNumber n
  | n == 0      = 0
  | otherwise   = ripple .|. ones
                       where smallest     = n .&. (-n)
                             ripple       = n + smallest
                             newSmallest  = ripple .&. (-ripple)
                             ones         = (newSmallest `div` smallest) `shiftR` 1 - 1

现在很容易依次获得[[2 ^ k-1)，(2 ^(n-k)+ ... + 2 ^(n-1))范围内的所有k组合:

import qualified Data.Stream as ST

combs :: Int -> Int -> [Integer]
combs n k = ST.takeWhile (<= end) $ kBitNumbers start
  where start = 2^k - 1
        end   = sum $ fmap (2^) [n-k..n-1]

kBitNumbers :: Integer -> ST.Stream Integer
kBitNumbers = ST.iterate nextKBitNumber

main :: IO ()
main = do
  params <- getArgs
  let n = read $ params !! 0
      k = read $ params !! 1
  print $ length (combs n k)

我的想法是，这应该很容易并行化，将范围分成较小的部分。例如:

start :: Int -> Integer
start k = 2 ^ k - 1

end :: Int -> Int -> Integer
end n k = sum $ fmap (2 ^) [n-k..n-1]

splits :: Int -> Int -> Int -> [(Integer, Integer, Int)]
splits n k numSplits = fixedRanges ranges []
  where s                       = start k
        e                       = end n k
        step                    = (e-s) `div` (min (e-s) (toInteger numSplits))
        initSplits              = [s,s+step..e]
        ranges                  = zip initSplits (tail initSplits)
        fixedRanges [] acc      = acc
        fixedRanges [x] acc     = acc ++ [(fst x, e, k)]
        fixedRanges (x:xs) acc  = fixedRanges xs (acc ++ [(fst x, snd x, k)])

在这一点上，我想并行运行每个拆分，例如:

runSplit :: (Integer, Integer, Int) -> [Integer]
runSplit (start, end, k) = ST.takeWhile (<= end) $ kBitNumbers (fixStart start)
  where fixStart s
                   | popCount s == k = s
                   | otherwise       = fixStart $ s + 1

为了实现通用化，我使用了 monad-par包:

import Control.Monad.Par
import System.Environment
import qualified Data.Set as S

main :: IO ()
main = do
  params <- getArgs
  let n               = read $ params !! 0
      k               = read $ params !! 1
      numTasks        = read $ params !! 2
      batches         = runPar $ parMap runSplit (splits n k numTasks)
      reducedNumbers  = foldl S.union S.empty $ fmap S.fromList batches
  print $ S.size reducedNumbers

结果是，顺序版本的速度更快，并且使用的内存很少，而并行版本则消耗大量的内存，并且速度明显较慢。

造成这种情况的原因可能是什么？线程是解决此问题的好方法吗？例如，每个线程都会生成一个(可能很大)整数列表，而主线程会减少结果。线程是需要大量内存还是仅仅是为了产生简单的结果(即仅CPU密集型计算)？

我使用 stack build --ghc-options -threaded --ghc-options -rtsopts --executable-profiling --library-profiling编译程序，并使用 ./.stack-work/install/x86_64-osx/lts-6.1/7.10.3/bin/combinatorics 20 3 4 +RTS -pa -N4 -RTS运行n = 20，k = 3和numSplits = 4。可以找到 here和顺序版本 here的并行版本的分析报告的示例。

Answer 1

在您的顺序版本中，调用combs不会在内存中建立列表，因为在length使用完一个元素之后，不再需要该元素并将其释放。实际上，GHC甚至可能没有为其分配存储。

例如，这将花费一些时间，但不会消耗大量内存:

main = print $ length [1..1000000000]  -- 1 billion

在并行版本中，您正在生成子列表，将它们连接在一起，构建Set等，因此每个子任务的结果都必须保存在内存中。

比较公平的比较是让每个并行任务在其分配的范围内计算k位数字的 length，然后将结果相加。这样，每个并行任务找到的k位数字就不必保存在内存中，并且可以像顺序版本一样操作。

更新

这是如何使用 parMap的示例。注意:在7.10.2之下，我获得了成功的并行处理，有时会触发并行性，有时却不会。 (弄清楚了-我使用的是 -RTS -N2而不是 +RTS -N2。)

{-
compile with: ghc -O2 -threaded -rtsopts foo.hs

compare:

  time ./foo 26 +RTS -N1
  time ./foo 26 +RTS -N2
-}

import Data.Bits    
import Control.Parallel.Strategies
import System.Environment

nextKBitNumber :: Integer -> Integer
nextKBitNumber n
  | n == 0      = 0
  | otherwise   = ripple .|. ones
                       where smallest     = n .&. (-n)
                             ripple       = n + smallest
                             newSmallest  = ripple .&. (-ripple)
                             ones         = (newSmallest `div` smallest) `shiftR` 1 - 1

combs :: Int -> Int -> [Integer]
combs n k = takeWhile (<= end) $ iterate nextKBitNumber start
  where start = 2^k - 1
        end   = shift start (n-k)

main :: IO ()
main = do
  ( arg1 : _) <- getArgs
  let n = read arg1
  print $ parMap rseq (length . combs n) [1..n]