Haskell性能异常：同时运行两段代码耗时远高于单独运行

问题背景 #

我写了一个Haskell程序，day11函数里包含这两行输出代码：

putStrLn $ "Day11: part1: " ++ show (sum $ bigManhattan 1 galaxies <$> pairs)
putStrLn $ "Day11: part2: " ++ show (sum $ bigManhattan 999999 galaxies <$> pairs)

单独注释掉任意一行时，程序运行仅需0.01秒；但同时保留两行，耗时直接飙升到90秒。想请教这是什么原因？会不会是两段代码访问数据时互相干扰？

编译选项如下：

ghc-options:
- -Wall
- -Wcompat
- -Widentities
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wmissing-export-lists
- -Wmissing-home-modules
- -Wpartial-fields
- -Wredundant-constraints
- -O2

使用GHC 9.4.7编译，完整代码：

module Day11(day11) where

import Data.List ((\\))
import Data.Maybe (catMaybes)


type Coord = (Int, Int)


manhattan :: Coord -> Coord -> Int
manhattan (x1, y1) (x2, y2) = abs (x1 - x2) + abs (y1 - y2)


getF :: (String -> a) -> Int -> IO a
getF f n = do
  s <- readFile $ "./Data/Day" ++ show n ++ ".in"
  return $ f s


getLines :: Int -> IO [String]
getLines = getF lines


parse :: [String] -> [Coord]
parse css = concatMap (catMaybes . (\(y, cs) -> (\(x, c) -> if c=='#' then Just (x,y) else Nothing) <$> zip [0..] cs)) (zip [0..] css)


nSize :: Int
nSize = 140


bigManhattan :: Int -> [Coord] -> (Coord, Coord) -> Int
bigManhattan k galaxies ((c1, r1), (c2, r2)) = manhattan (c1+newc1, r1+newr1) (c2+newc2, r2+newr2)
  where
    baseC, baseR :: [Int]
    baseC = [0..(nSize-1)] \\ (fst <$> galaxies)
    baseR = [0..(nSize-1)] \\  (snd <$> galaxies)
    newc1, newc2, newr1, newr2 :: Int
    newc1 = k * length (filter (c1>) baseC)
    newc2 = k * length (filter (c2>) baseC)
    newr1 = k * length (filter (r1>) baseR)
    newr2 = k * length (filter (r2>) baseR)


day11 :: IO ()
day11 = do
  ls <- getLines 11
  let galaxies = parse ls
      pairs = [(x,y) | x <- galaxies, y <- galaxies, x<y ]

  putStrLn $ "Day11: part1: " ++ show (sum $ bigManhattan 1 galaxies <$> pairs)
  --putStrLn $ "Day11: part2: " ++ show (sum $ bigManhattan 999999 galaxies <$> pairs)
  return ()

原因分析 #

核心问题出在bigManhattan函数的重复计算和GHC的优化策略差异上：

• 重复计算baseC和baseR：每次调用bigManhattan，都会重新计算baseC和baseR（这两个值仅依赖galaxies，完全可以只算一次）。当前代码里这两个值定义在函数的where块中，意味着每处理一对星系就会重复计算一次，计算量随星系对数成倍数增长。
• 单/双语句的优化差异：当只有一段计算时，GHC的-O2优化会自动做公共子表达式消除（CSE），把baseC/baseR的计算提升到循环外，避免重复计算。但同时存在两段计算时，GHC无法识别这两段代码中的baseC/baseR是相同的公共子表达式，导致每对星系的两次计算都要重复生成这两个列表，直接放大了重复计算的开销。
• 不存在数据干扰：两段代码都是纯函数计算，没有共享可变状态，不存在“访问数据互相干扰”的问题，本质就是重复计算导致的性能灾难。

解决方案 #

把baseC和baseR提前计算好，传入bigManhattan，从根源上避免重复计算：

优化后的核心代码 #

-- 重构bigManhattan，提前传入预计算的baseC和baseR
bigManhattan :: Int -> [Int] -> [Int] -> (Coord, Coord) -> Int
bigManhattan k baseC baseR ((c1, r1), (c2, r2)) = manhattan (c1+newc1, r1+newr1) (c2+newc2, r2+newr2)
  where
    newc1 = k * length (filter (c1>) baseC)
    newc2 = k * length (filter (c2>) baseC)
    newr1 = k * length (filter (r1>) baseR)
    newr2 = k * length (filter (r2>) baseR)

day11 :: IO ()
day11 = do
  ls <- getLines 11
  let galaxies = parse ls
      pairs = [(x,y) | x <- galaxies, y <- galaxies, x<y ]
      -- 提前计算baseC和baseR，仅执行一次
      baseC = [0..(nSize-1)] \\ (fst <$> galaxies)
      baseR = [0..(nSize-1)] \\ (snd <$> galaxies)

  putStrLn $ "Day11: part1: " ++ show (sum $ bigManhattan 1 baseC baseR <$> pairs)
  putStrLn $ "Day11: part2: " ++ show (sum $ bigManhattan 999999 baseC baseR <$> pairs)
  return ()

进一步优化（可选） #

还可以预计算每个星系坐标的偏移量，彻底避免在处理每对星系时调用filter和length：

-- 预计算每个坐标的偏移量
precomputeOffsets :: [Int] -> [Int] -> [Coord] -> [(Int, Int)]
precomputeOffsets baseC baseR galaxies = map (\(c,r) -> (length (filter (c>) baseC), length (filter (r>) baseR)) galaxies

day11 :: IO ()
day11 = do
  ls <- getLines 11
  let galaxies = parse ls
      pairs = [(x,y) | x <- galaxies, y <- galaxies, x<y ]
      baseC = [0..(nSize-1)] \\ (fst <$> galaxies)
      baseR = [0..(nSize-1)] \\ (snd <$> galaxies)
      offsets = precomputeOffsets baseC baseR galaxies
      -- 配对星系与偏移量
      galaxyWithOffsets = zip galaxies offsets
      -- 直接用预计算偏移量计算距离
      calcDist k (( (c1,r1), (oc1,or1) ), ( (c2,r2), (oc2,or2) )) = manhattan (c1 + k*oc1, r1 + k*or1) (c2 + k*oc2, r2 + k*or2)

  putStrLn $ "Day11: part1: " ++ show (sum $ calcDist 1 <$> pairs)
  putStrLn $ "Day11: part2: " ++ show (sum $ calcDist 999999 <$> pairs)
  return ()

优化后，不管是单语句还是双语句，运行速度都会保持在0.01秒左右。

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