Haskell计算密集线程阻塞其他线程，超时程序挂起问题咨询

你的程序挂起的核心原因和Haskell的线程调度机制、以及纯计算线程的特性有关，我们分两种编译情况拆解：

1. 非-threaded编译的情况 #

GHC的非线程化运行时是协作式调度的——也就是说，只有当一个线程主动执行了会阻塞的操作（比如threadDelay、MVar读写、IO操作等），才会让出CPU给其他线程。

你的计算线程在执行fibs 1234 == 100时，这是一个纯计算任务，而且fibs 1234的计算量极其庞大（斐波那契数列第1234项是天文数字，计算时间会远超你的超时时间），这个线程会一直霸占CPU，完全没有机会让出控制权。而超时线程（tid）根本得不到运行的机会，自然无法往MVar里写入值，主线程就一直阻塞在takeMVar mvar上，程序也就挂起了。

2. -threaded编译的情况 #

即使启用了线程化运行时，默认情况下也可能出现同样的问题：
GHC的线程化运行时会使用OS线程来调度Haskell轻量线程，但对于纯计算的轻量线程，GHC的调度器默认会在执行一定数量的指令后才进行抢占。但-O2的优化会把fibs的递归计算优化成非常紧凑的循环，可能跳过了调度器的抢占检查点，导致计算线程一直霸占一个OS线程，超时线程还是得不到运行的机会。

而当你在计算线程里添加threadDelay (2 * 1000 * 1000)时，这个操作会让计算线程主动让出CPU，超时线程终于有机会被调度执行，1秒后往MVar里写入值，主线程拿到值后就可以终止所有线程，程序也就正常结束了。

针对这个问题，有几种更可靠的处理方式：

方式一：使用async库简化超时逻辑 #

async库提供了race函数，可以让两个任务“赛跑”，哪个先完成就返回哪个的结果，并且会自动终止未完成的任务，不需要手动管理MVar和线程，代码更简洁安全。

首先需要安装async库：

cabal install async

修改后的代码：

import Control.Concurrent
import Control.Concurrent.Async

fibs :: Int -> Int
fibs 0 = 0
fibs 1 = 1
fibs n = fibs (n-1) + fibs (n-2)

main = do
    putStrLn "Waiting for result or timeout"
    -- 让超时任务和计算任务赛跑
    raceResult <- race 
        (threadDelay (1 * 1000 * 1000) >> return "Timeout occurred")
        (do
            let isCorrect = fibs 1234 == 100
            if isCorrect
                then putStrLn "Incorrect answer" >> return "Result: False"
                else putStrLn "Maybe correct answer" >> return "Result: True"
        )
    case raceResult of
        Left timeoutMsg -> putStrLn timeoutMsg
        Right resultMsg -> putStrLn resultMsg

方式二：调整RTS参数强制抢占 #

如果你坚持用自己的实现方式，可以在运行-threaded编译的程序时，添加RTS参数来强制调度器更频繁地抢占纯计算线程：

./Test +RTS -C1 -N

• -C1：设置每1毫秒进行一次上下文切换检查，确保纯计算线程不会霸占CPU太久
• -N：启用多核调度，让计算线程和超时线程可以在不同的OS线程上并行运行

方式三：让计算线程主动让出CPU #

你可以修改fibs的实现，在递归过程中插入yield操作（需要把fibs改成IO函数），让计算线程主动给其他线程让出CPU：

import Control.Concurrent

fibs :: Int -> IO Int
fibs 0 = return 0
fibs 1 = return 1
fibs n = do
    yield -- 主动让出CPU
    a <- fibs (n-1)
    b <- fibs (n-2)
    return (a + b)

main = do
    mvar <- newEmptyMVar
    tid <- forkIO $ do
        threadDelay (1 * 1000 * 1000)
        putMVar mvar Nothing
    tid' <- forkIO $ do
        res <- fibs 1234
        if res == 100
            then putStrLn "Incorrect answer" >> putMVar mvar (Just False)
            else putStrLn "Maybe correct answer" >> putMVar mvar (Just True)
    putStrLn "Waiting for result or timeout"
    result <- takeMVar mvar
    killThread tid
    killThread tid'

不过这种方式会大幅降低fibs的计算效率，只适合对计算性能要求不高的场景。

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