Почему происходит утечка памяти этого кода при добавлении `bracketOnError`?

Проблема представляет собой вариант классического сценария утечки, в котором мы сохраняем ссылку на начало ленивого списка во время его использования:

import Data.Foldable (traverse_)

main :: IO ()
main = do
    let xs = [1..]
    traverse_ print xs 
    traverse_ print xs -- commenting this statement solves the leak 

Здесь канал Source работает как своего рода ленивый список. Нам нужно сохранить ссылку на исходное исходное значение (server) даже при его использовании, поскольку в случае ошибки оно должно быть передано обработчику исключений. И все же обработчик исключений, похоже, не использует его.

Решение состоит в том, чтобы вырезать эту ссылку, как только основное вычисление, которое мы передаем в bracketOnError, получает значение. Мы можем использовать MVar для этой цели. Не из-за его возможностей синхронизации, а потому, что это изменяемая ссылка, которую можно оставить пустой.

Действие распределения вместо возврата значения (Source m r, a) может вернуть значение (MVar (Source m r), a). Затем основное вычисление будет выполняться из takeMVar для получения источника канала. Как только мы начнем потреблять исходный код, исходное значение будет удалено сборщиком мусора, потому что на него больше не останется ссылок.

Вот рабочий код, который ОП использовал после следующих предложений:

protoReceiver :: RIO FdsEnv ()
protoReceiver = retryForever $ do
  logItS Info ["Entering FarmPCMessage protoReceiver"]
  tMap <- liftIO $ newThreadMap
  fdsEnv <- ask
  let lgr = fdsLogger fdsEnv
  loopBody <- pure $ bracket
    (runResourceT $ do
      swTup <- protoServe fdsEnv tMap readFarmPCMessage
      serverMVar <- newMVar $ fst swTup
      pure (serverMVar, snd $! swTup)
      )
    (\(_, worker) -> do
      logLogItS Debug lgr ["Entering cleanup for protoReceiver"]
      killChildThreads tMap
      cancel worker
      )
    (\(serverMVar, _) -> do
      logLogItS Debug lgr ["Entering FarmPCMessage protoReceiver bracket"]
      server <- takeMVar serverMVar
      logLogItS Debug lgr ["FarmPCMessage protoReceiver bracket: got server"]
      server
        .| mapMC (liftIO . traverse_ (persistFarmEntry fdsEnv))
        .| mapMC ((logLogIt Info lgr) . pure)
        .| sinkUnits & runConduitRes
      )
  liftIO $ retryForever $ loopBody
  where
    killChildThreads = liftIO . killThreadHierarchy