TChan 写入是否集成到 Haskell STM 中？

Question

如果一个 STM 事务失败并重试，是否会重新执行对 writeTChan 的调用，从而最终得到两次写入，或者 STM 是否仅在事务提交时才实际执行写入？即，这个解决睡眠理发师问题的方法是否有效，或者如果enterShop 中的交易第一次失败，客户可能会得到两次理发？

import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import System.Random
import Text.Printf

runBarber :: TChan Int -> TVar Int -> IO ()
runBarber haircutRequestChan seatsLeftVar = forever $ do
  customerId <- atomically $ readTChan haircutRequestChan
  atomically $ do
    seatsLeft <- readTVar seatsLeftVar
    writeTVar seatsLeftVar $ seatsLeft + 1
  putStrLn $ printf "%d started cutting" customerId
  delay <- randomRIO (1,700)
  threadDelay delay
  putStrLn $ printf "%d finished cutting" customerId

enterShop :: TChan Int -> TVar Int -> Int -> IO ()
enterShop haircutRequestChan seatsLeftVar customerId = do
  putStrLn $ printf "%d entering shop" customerId
  hasEmptySeat <- atomically $ do
    seatsLeft <- readTVar seatsLeftVar
    let hasEmptySeat = seatsLeft > 0
    when hasEmptySeat $ do
      writeTVar seatsLeftVar $ seatsLeft - 1
      writeTChan haircutRequestChan customerId
    return hasEmptySeat
  when (not hasEmptySeat) $ do
    putStrLn $ printf "%d turned away" customerId    

main = do
  seatsLeftVar <- newTVarIO 3
  haircutRequestChan <- newTChanIO
  forkIO $ runBarber haircutRequestChan seatsLeftVar

  forM_ [1..20] $ \customerId -> do
    delay <- randomRIO (1,3)
    threadDelay delay
    forkIO $ enterShop haircutRequestChan seatsLeftVar customerId 

更新 直到上面的hairRequestChan 无论如何都不必成为交易的一部分，我才注意到。我可以使用常规的Chan 并在if 语句中执行writeChan，在atomically 块中的enterShop 之后。但是做出这种改进会破坏提出这个问题的全部原因，所以我将保持原样。

Answer 1

TChan 操作在事务提交时执行，就像其他 STM 操作一样，因此无论您的事务重试多少次，您总是会以单次写入结束。否则它们会有点没用。

为了说服自己，试试这个例子：

import Control.Concurrent
import Control.Concurrent.STM
import Control.Concurrent.STM.TChan

main = do
  ch <- atomically newTChan
  forkIO $ reader ch >>= putStrLn
  writer ch

reader = atomically . readTChan
writer ch = atomically $ writeTChan ch "hi!" >> retry

这将抛出一个异常，抱怨事务被无限期阻塞。如果writeTChan 导致在事务提交之前发生写入，程序将打印“hi！”在抛出异常之前。