Есть ли способ увеличить временной интервал, на основании которого RTS решает, что поток заблокирован на неопределенный срок в транзакции STM? Вот мой код:

import Control.Concurrent (ThreadId)
import Control.Concurrent.MVar (MVar,newMVar,withMVar)
import Control.Concurrent.STM
import qualified Control.Concurrent.ThreadManager as TM

data ThreadManager = ThreadManager { tmCounter::TVar Int, tmTM::MVar TM.ThreadManager }

data Settings = Settings {
    maxThreadsCount::Int }

createThreadManager :: Settings -> IO ThreadManager
createThreadManager s = do
    counter <- atomically $ newTVar (maxThreadsCount s)
    tm <- TM.make >>= newMVar
    return $ ThreadManager counter tm

forkManaged :: ThreadManager -> IO () -> IO ThreadId
forkManaged tm fn = do
    atomically $ do
        counter <- readTVar $ tmCounter tm
        check $ counter > 0
        writeTVar (tmCounter tm) (counter - 1)
    withMVar (tmTM tm) $ \thrdmgr -> TM.fork thrdmgr $ do
        fn
        atomically $ do
            counter <- readTVar $ tmCounter tm
            writeTVar (tmCounter tm) (counter + 1)

forkManaged гарантирует, что количество одновременно запущенных управляемых потоков не превышаетmaxThreadsCount, Работает нормально до большой нагрузки. Под большой нагрузкой РТС выдает исключение. Я думаю, что при большой нагрузке, в условиях жесткой параллельной конкуренции за ресурсы, некоторые потоки просто не успевают получить доступ к контексту STM. Поэтому я думаю, что увеличение временного интервала, когда RTS решит выбросить это исключение, может решить проблему.