Haskell中BFS实现的空间泄漏问题

Question

我已经连续几天在努力解决一个Haskell空间泄漏问题（自然是堆栈溢出的那种）。这令人沮丧，因为我试图直接模仿CLR中的BFS算法，而这个算法并不是自然递归的。注意：我已经启用了BangPatterns，并且在可能到达的每个位置前都加了一个bang，以尝试通过分支和限制来解决这个问题，但没有效果。我之前也曾遇到过空间泄漏的问题，我不想放弃并在这个问题上求助，但目前我卡住了。我喜欢使用Haskell编程，我对函数式编程的Zen理解得很好，但调试空间泄漏就像在装满图钉的地板上打滚一样无聊。

话虽如此，我的问题似乎是典型的“累加器”类型的空间泄漏。显然，在下面的代码中，对bfs'的调用会导致堆栈积累。如果有任何空间泄漏技巧，请不吝赐教。

import qualified Data.Map as M
import qualified Data.IntSet as IS
import qualified Data.Sequence as S
import qualified Data.List as DL

data BfsColor = White | Gray | Black deriving Show
data Node =
Node {
  neighbors :: !IS.IntSet,
  color     :: !BfsColor,
  depth     :: !Int
   }

type NodeID = Int
type NodeQueue = S.Seq NodeID
type Graph = M.Map NodeID Node

bfs :: Graph -> NodeID -> Graph
bfs graph start_node =
  bfs' (S.singleton start_node) graph

bfs' :: NodeQueue -> Graph -> Graph
bfs' !queue !graph
  | S.null queue = graph
  | otherwise =
  let (u,q1) = pop_left queue
      Node children _ n = graph M.! u
      (g2,q2) = IS.fold (enqueue_child_at_depth $ n+1) (graph,q1) children
      g3 = set_color u Black g2
  in bfs' q2 g3

enqueue_child_at_depth :: Int -> NodeID -> (Graph, NodeQueue)
                                        -> (Graph, NodeQueue)
enqueue_child_at_depth depth child (graph,!queue)  =
  case get_color child graph of
    White     -> (set_color child Gray $ set_depth child depth graph,
                   queue S.|> child)
    otherwise -> (graph,queue)

pop_left :: NodeQueue -> (NodeID, NodeQueue)
pop_left queue =
  let (a,b) = S.splitAt 1 queue
  in (a `S.index` 0, b)

set_color :: NodeID -> BfsColor -> Graph -> Graph
set_color node_id c graph =
  M.adjust (\node -> node{color=c}) node_id graph

get_color :: NodeID -> Graph -> BfsColor
get_color node_id graph = color $ graph M.! node_id

set_depth :: NodeID -> Int -> Graph -> Graph
set_depth node_id d graph =
  M.adjust (\node -> node{depth=d}) node_id graph

- colin

---

你的代码很难读懂。我建议将图形抽象化一些，引入 type NodeId = Int 和像 neighbors :: NodeId -> Graph -> [NodeId] 这样的函数。为了解决空间泄漏问题，你的代码必须尽可能简单。 - Heinrich Apfelmus

需要记住的一件事是，过度使用严格的注释可能会导致内存峰值而不是改善它们。如果您有一个庞大的结构体 - 如果您迫使所有其元素，它将变得非常庞大。 - stephen tetley

Cormen Leiserson Rivest。但我现在可以看到，CLR在这里更经常出现。因此，我已经删除了标签。 - colin

你错过了 Stein。我一直听人们称其为 CLRS。 - Alex M

现在我过时了。自第二版以来，Stein已经被添加了，而我没有注意到。 - colin

Answer 1

这看起来要容易理解多了（虽然你仍然可以将代码缩小一半）。

现在，空间泄漏的本质变得明显起来。也就是说，从不被计算的是 depth。它将积累成一个大表达式1+1+...。您可以删除所有惊叹号模式，然后在一个位置添加一个单一的惊叹号。

enqueue_child_at_depth !depth child (graph,queue)

为了消除空间泄漏。

（更多代码提示：您可以将IS.IntSet替换为简单的列表。队列最好按以下方式拆解和重构：

go depth qs graph = case viewl qs of
    EmptyL  -> graph
    q :< qs ->
        let
            qs' = (qs ><) . Seq.fromList
                . filter (\q -> isWhite q graph)
                . neighbors q $ graph
        in ...

)

- Heinrich Apfelmus

---

再次感谢您，海因里希。我会进一步研究它。(作为一个Haskell的新手，如果您愿意输入一些收缩提示，我将不胜感激)。 - colin

更新：算了，我很享受自己努力工作的过程！问候，C - colin

Answer 2

首先，如果您能提供一些简单的测试用例（以代码形式），演示这个东西如何导致堆栈溢出，那将非常有帮助。否则，我个人只能对其原因进行猜测。

作为一种猜测：IS.fold 是否足够严格？例如，以下最简单的代码也会导致堆栈溢出（使用 -O2 的 GHC）：

{-# LANGUAGE BangPatterns #-}
import qualified Data.IntSet as IS

test s = IS.fold it 1 s
    where it !e !s = s+e

main = print $ test (IS.fromList [1..1000000])

这段代码的溢出问题可以通过hackafixed（是否有更好的方法？）解决：

test s = foldl' it 1 (IS.toList s)
    where it !e !s = s+e

也许你也想在代码中查看 IS.fold。

- Ed'ka

---

谢谢Ed'ka。我想到了这一点，但修复它并没有帮助，所以我将代码保留为原样（尽管我注意到在haskell.org上有添加Maps和IntSets的严格折叠等功能请求，很快我们就不会孤单了）。 - colin