Haskell捕获POSIX信号后触发多子线程执行清理函数

核心问题分析 #

你当前代码的问题出在递归循环的每一层都绑定了catch处理器，当信号触发主线程抛出异常时，递归栈会逐层 unwind，每一层的handler都会被调用一次，导致重复执行cleanupChildren。同时递归参数传递子线程列表也破坏了尾递归优化的可能。

优化方案 #

解决思路是把活跃子线程的管理从递归栈中剥离，用可变状态统一维护，并且只在最外层绑定一次异常处理器：

• 用IORef [Async ()]存储所有活跃的工作线程，新增/结束线程时更新这个引用
• 仅在主线程的最外层设置一次异常捕获，确保清理逻辑只执行一次
• 子线程用bracket替代catch，更可靠地处理正常退出和异步中断的清理

修改后的完整代码 #

import Control.Concurrent.Async (Async, async, cancelWith, waitCatch)
import Control.Exception (AsyncException (..), Exception, SomeException, catch, throwIO, bracket)
import System.Posix (Signal)
import System.Posix.Signals (Handler (..), installHandler, sigHUP, sigINT, sigTERM, sigUSR1, sigUSR2, sigXCPU, sigXFSZ)
import Control.Concurrent (myThreadId, threadDelay, throwTo)
import Control.Monad (forM_, forever)
import Data.Data (Typeable)
import Data.Foldable (for_)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef')

data Result = Done | Aborted deriving (Show)

termMsg :: Int -> Result -> IO ()
termMsg n s = putStrLn $ "Thread " ++ show n ++ " terminated with " ++ show s

-- 子线程：用bracket确保清理逻辑一定会执行
thread :: Int -> IO ()
thread n = bracket
  (putStrLn $ "Thread " ++ show n ++ " started")  -- 启动前的初始化（可选）
  (\_ -> termMsg n Aborted)  -- 无论正常/异常退出，都会执行的清理
  (\_ -> do
      for_ ([0 .. 9] :: [Int]) $ \_ -> do
        putStrLn $ "Thread " ++ show n ++ " alive..."
        threadDelay $ 500000 * n
      termMsg n Done)

parent :: IO ()
parent = do
  workersRef <- newIORef []  -- 用IORef维护活跃子线程列表
  -- 只在最外层绑定一次异常处理器
  (forever $ do
      n <- readIORef workersRef >>= return . length
      putStrLn $ "Main thread alive (loop " ++ show n ++ ")"
      worker <- async (thread n)
      -- 启动子线程后，添加到列表；同时监听子线程结束，自动从列表移除
      modifyIORef' workersRef (worker :)
      _ <- async $ do
        waitCatch worker
        modifyIORef' workersRef (filter (/= worker))
      threadDelay 1000000)
    `catch` handler workersRef
  where
    handler :: IORef [Async ()] -> SomeException -> IO ()
    handler workersRef e = do
      print e
      putStrLn "Cleaning up children..."
      workers <- readIORef workersRef
      for_ workers $ \t -> cancelWith t ThreadKilled
      throwIO e

main :: IO ()
main = do
  installSignalHandlers
  parent `catch` someExceptionHandler

someExceptionHandler :: SomeException -> IO ()
someExceptionHandler e = do
  putStrLn $ "Terminating with " ++ show e
  throwIO e

data SignalException = SignalException Signal String
  deriving (Show, Typeable, Eq)
instance Exception SignalException

signalsToHandle :: [(Signal, String)]
signalsToHandle = [(sigHUP, "SIGHUP"), (sigINT, "SIGINT"), (sigTERM, "SIGTERM"), (sigUSR1, "SIGUSR1"), (sigUSR2, "SIGUSR2"), (sigXCPU, "SIGXCPU"), (sigXFSZ, "SIGXFSZ")]

installSignalHandlers :: IO ()
installSignalHandlers = do
  mainId <- myThreadId
  forM_ signalsToHandle $ \(sig, name) -> installHandler sig (Catch (throwTo mainId $ SignalException sig name)) Nothing

关键改动说明 #

1. 用IORef管理子线程：避免在递归参数中传递线程列表，同时自动移除已结束的子线程，防止列表无限增长
2. 单一层异常捕获：把catch移到forever循环外面，确保信号触发时只执行一次清理逻辑
3. bracket替代catch：bracket会在进入时执行初始化，退出（无论正常还是异常）时执行清理，比单独的catch更可靠，覆盖所有退出场景
4. 自动清理已结束线程：每个子线程启动后，额外启动一个监听线程，当子线程结束时自动从IORef中移除，避免无效的清理操作

预期运行效果 #

触发SIGINT/SIGTERM时，只会打印一次"Cleaning up children..."，所有活跃子线程都会执行清理逻辑（打印Aborted），然后程序正常终止，不会出现重复清理的情况。

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