Haskell parMap并行代码性能远低于串行代码是什么原因？

问题复现 #

对计算区间平方和的Haskell串行代码做并行改造后，性能反而大幅下降，复现代码与运行数据如下：

串行版本 #

module Main where

import System.Environment

sumRangeSquares :: (Num a, Enum a) => a -> a -> a
sumRangeSquares start end = sum $ map (^2) [start .. end]

main :: IO ()
main = do
    [start, end] <- map read <$> getArgs
    print $ sumRangeSquares start end

• 编译命令：stack ghc -- -O2 -rtsopts -eventlog -threaded src/Main.hs
• 运行命令：time ./src/Main 1 10000000
• 性能表现：耗时约0.4秒。

初版并行版本 #

module Main where

import Control.Parallel.Strategies
import System.Environment

sumRangeSquares :: (Num a, Enum a) => a -> a -> a
sumRangeSquares start end = sum $ parMap rseq (^2) [start .. end]

main :: IO ()
main = do
    [start, end] <- map read <$> getArgs
    print $ sumRangeSquares start end

• 编译命令：与串行版本一致
• 运行命令：time ./src/Main 1 10000000 +RTS -N4 -lf -s
• 性能表现：耗时超过6秒。
• RTS运行日志：

2,661,959,552 bytes allocated in the heap
   1,891,228,032 bytes copied during GC
     468,753,512 bytes maximum residency (12 sample(s))
     307,102,616 bytes maximum slop
            1226 MiB total memory in use (0 MB lost due to fragmentation)

                                     Tot time (elapsed)  Avg pause  Max pause
  Gen  0      1837 colls,  1837 par   10.483s   2.705s     0.0015s    0.0080s
  Gen  1        12 colls,    11 par    5.157s   1.391s     0.1159s    0.5573s

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

  TASKS: 10 (1 bound, 9 peak workers (9 total), using -N4)

  SPARKS: 10000000 (9998153 converted, 1847 overflowed, 0 dud, 0 GC'd, 0 fizzled)

  INIT    time    0.038s  (  0.038s elapsed)
  MUT     time    6.995s  (  2.158s elapsed)
  GC      time   15.639s  (  4.096s elapsed)
  EXIT    time    0.001s  (  0.005s elapsed)
  Total   time   22.673s  (  6.297s elapsed)

  Alloc rate    380,577,209 bytes per MUT second

  Productivity  30.8% of total user, 34.3% of total elapsed


real    0m6.374s
user    0m16.889s
sys 0m5.859s

• ThreadScope分析结论：4个HEC存在大量同步空闲时间，各HEC运行、空闲时间点高度重合，spark池负载不均、spark创建调度失衡，GC耗时占比极高，程序整体生产率仅30%左右。

性能劣化核心原因 #

• 并行粒度过细，调度开销远超计算收益：parMap rseq默认会为列表中每一个元素（共1000万个）创建独立spark，每个spark对应的计算逻辑仅为单次平方运算，计算开销远小于spark创建、入池、跨核调度、线程同步的固定成本，绝大多数CPU资源被消耗在并行框架的调度逻辑上，没有投入实际计算。
• 内存占用暴涨，GC成为主要瓶颈：千万级spark和中间thunk带来了远超串行版本的堆内存分配，总堆内存占用达1226MiB，GC总耗时占总运行时间的65%以上；同时并行GC工作平衡率仅26.09%，大量时间消耗在GC线程同步和内存拷贝上。
• 调度逻辑过载失效：过细的spark粒度导致spark池调度压力远超设计阈值，出现spark溢出、各核心负载不均问题，线程频繁进入同步等待状态，多核并行能力完全没有发挥。

优化方案 #

• 调整并行粒度，采用分块计算策略：不要对单个元素创建spark，而是将大区间拆分为与CPU核心数匹配的若干个大块，每个块作为一个独立调度单元，确保每个spark的计算量足够大，摊薄调度开销。
• 使用合适的求值策略：替换rseq为rdeepseq，确保每个块的计算结果被完全求值，避免惰性thunk带来的额外内存开销和spark泄漏问题。
• 优化后参考代码：

module Main where

import Control.Parallel.Strategies
import System.Environment

-- 计算单个块的平方和
chunkSumSquares :: (Enum a, Num a) => a -> a -> a
chunkSumSquares s e = sum $ map (^2) [s..e]

sumRangeSquares :: (Integral a, NFData a) => a -> a -> Int -> a
sumRangeSquares start end coreNum = 
  let totalLen = end - start + 1
      chunkSize = totalLen `div` fromIntegral coreNum
      -- 拆分区间，最后一个块处理剩余元素
      chunkRanges = [ (start + fromIntegral i * chunkSize, 
                       if i == coreNum - 1 then end 
                       else start + fromIntegral (i+1) * chunkSize - 1)
                    | i <- [0..coreNum-1] ]
  in sum $ parMap rdeepseq (\(s,e) -> chunkSumSquares s e) chunkRanges

main :: IO ()
main = do
    [start, end] <- map read <$> getArgs
    -- 按运行核心数调整分块数量，此处以4核为例
    print $ sumRangeSquares start end 4

• 可选RTS参数调优：运行时可通过-A参数调大新生代堆大小（如-A64M）降低GC频率，进一步提升性能。

相同编译参数、4核运行环境下，优化后版本耗时可降至0.12秒左右，加速比接近线性，程序生产率可达90%以上。

内容的提问来源于stack exchange，提问作者Lemma