Haskell并发程序未返回问题排查：是否存在死锁？

问题背景 #

我写了一个基于Haskell和socat的简单双向通信程序，代码如下：

module Main where

import Control.Concurrent.Async
import Control.Concurrent.MVar
import System.Environment
import System.IO
import System.Process

main :: IO ()
main = do
  args <- getArgs
  (Just i, Just o, Nothing, p) <- createProcess (proc "socat" args)
                                                {std_in = CreatePipe, std_out = CreatePipe}
  sequence_ [hSetBuffering h NoBuffering | h <- [i, o, stdin, stdout]]
  hSetEcho stdin False
  mine <- newEmptyMVar
  res <- concurrently
    (do c <- getChar
        putMVar mine c
        hPutChar i c)
    (do other <- hGetChar o
        mine' <- takeMVar mine
        return (mine', other))
  print $ snd res
  terminateProcess p

复现步骤 #

在两个终端分别启动：

$ cabal run myprogram -- TCP-LISTEN:12345,fork -       # 终端1（监听端）
$ cabal run myprogram -- TCP-CONNECT:localhost:12345 - # 终端2（连接端）

启动后在两个终端各按一个按键，正常情况下双方都会打印对方的按键。但先按终端1的按键时，终端1进程经常卡住不返回，终端2却始终正常。

我的观察 #

• 终端2从未出现异常；
• 在print $ snd res前加putStrLn "hello"，终端1的异常几乎消失；
• 交换print和terminateProcess p的顺序，异常出现频率大幅提升；
• 我怀疑是死锁，但想不通：
  • 终端2正常返回，说明它的两个线程没有死锁；
  • 两个进程逻辑完全一致，仅socat参数不同，死锁不该只针对监听端；
  • 同一进程的两个线程分别对同一个MVar做putMVar和takeMVar，这两个操作应该互相唤醒，怎么会阻塞？

（注：极简示例异常频率低，几十次能复现；我还有结构类似但异常更频繁的版本，需要可补充。）

核心原因：socat fork参数导致的管道时序问题 #

终端1用了socat的fork参数，这会让socat在收到连接时fork子进程处理当前连接，原父进程继续监听新连接。这就导致了两个关键问题：

1. 进程生命周期不匹配：Haskell程序调用terminateProcess p终止的是socat父进程，但处理当前连接的是子进程，子进程不会被终止，会继续存活（被init进程接管）；
2. 管道关闭异常：当终端2关闭连接时，socat子进程会退出，但如果Haskell程序此时还在和管道交互，或者父进程被提前终止，管道的关闭时序会混乱，导致IO操作阻塞。

具体到卡住的场景：
当终端1先按键，线程1（读终端按键的线程）完成putMVar并向socat子进程写数据；终端2处理完后关闭连接，socat子进程退出，此时终端1的线程2（读socat输出的线程）可能因为管道异常（比如EOF）抛出未被捕获的异常，concurrently会取消另一个线程，但如果此时IO操作处于阻塞状态（比如hPutChar还在等待管道刷新），就会导致整个进程卡住。

另外，print前加putStrLn能缓解问题，是因为putStrLn会强制刷新输出缓冲区，改变了IO操作的时序，避免了管道关闭时的阻塞；交换print和terminateProcess顺序后异常变多，是因为提前终止socat父进程，导致子进程的管道状态更早陷入混乱。

解决方法 #

1. 去掉socat的fork参数 #

如果不需要同时监听多个连接，直接去掉fork，这样socat不会创建子进程，terminateProcess p会直接终止处理连接的进程，管道能正常关闭：

$ cabal run myprogram -- TCP-LISTEN:12345 -       # 终端1修改后的命令

2. 正确处理socat进程生命周期 #

用waitForProcess p替代terminateProcess p，等待socat进程（包括子进程）退出后再结束程序，避免管道异常：

-- 替换原有的 terminateProcess p
waitForProcess p >> return ()

3. 捕获IO异常 #

在IO操作中捕获IOException，避免因管道异常导致进程卡住：

import Control.Exception (catch, IOException)

-- 修改concurrently的两个线程
res <- concurrently
  (do c <- getChar
      putMVar mine c
      hPutChar i c `catch` (\(_::IOException) -> return ()) -- 捕获写管道异常
  )
  (do other <- hGetChar o `catch` (\(_::IOException) -> return '\0') -- 捕获读管道异常
      mine' <- takeMVar mine
      return (mine', other))

4. 确保IO操作完成后再终止进程 #

在terminateProcess前刷新所有管道，确保IO操作全部完成：

-- 在 terminateProcess p 前添加
hFlush i
hFlush o
terminateProcess p

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