Question

以下程序创建两个并发运行的线程，在将一行文本打印到stdout之前，每个线程都会随机休眠一段时间。

import Control.Concurrent
import Control.Monad
import System.Random

randomDelay t = randomRIO (0, t) >>= threadDelay

printer str = forkIO . forever $ do
  randomDelay 1000000 -- μs
  putStrLn str

main = do
  printer "Hello"
  printer "World"
  return ()

输出通常类似于

>> main
Hello
World
World
Hello
WoHrelld
o
World
Hello
*Interrupted
>>

如何确保一次只有一个线程可以写入stdout？这似乎是STM应该擅长的事情，但是对于某些STM a，所有STM事务必须具有a类型，并且打印到屏幕的操作具有类型IO a似乎没有办法将IO嵌入STM。

Answer 1

使用STM处理输出的方法是拥有一个在所有线程之间共享的输出队列，并由单个线程处理。

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

randomDelay t = randomRIO (0, t) >>= threadDelay

printer queue str = forkIO . forever $ do
  randomDelay 1000000 -- μs
  atomically $ writeTChan queue str

prepareOutputQueue = do
    queue <- newTChanIO
    forkIO . forever $ atomically (readTChan queue) >>= putStrLn
    return queue

main = do
  queue <- prepareOutputQueue
  printer queue "Hello"
  printer queue "World"
  return ()

Answer 2

使用STM无法锁定您描述的方式。这是因为STM基于乐观锁定，因此每个事务必须在任何时候都可以重新启动。如果您将IO操作嵌入STM，则可以多次执行。

对于此问题，最简单的解决方案可能是使用MVar作为锁定：

import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad
import System.Random

randomDelay t = randomRIO (0, t) >>= threadDelay

printer lock str = forkIO . forever $ do
  randomDelay 1000000
  withMVar lock (\_ -> putStrLn str)

main = do
  lock <- newMVar ()
  printer lock "Hello"
  printer lock "World"
  return ()

在此解决方案中，锁定作为参数传递给printer。

有些人更喜欢将锁声明为top-level global variable，但目前这需要unsafePerformIO并且依赖于GHC的属性，AFAIK不属于Haskell语言报告（特别是它依赖于事实上，在执行程序期间，最多只评估一次具有非多态类型的全局变量。

Answer 3

基于Petr Pudlák's answer的一些研究表明，Control.Concurrent.Lock包中有一个模块concurrent-extra，它提供了基于MVar ()的锁的抽象。

使用该库的解决方案是

import           Control.Concurrent
import qualified Control.Concurrent.Lock as Lock
import           Control.Monad
import           System.Random

randomDelay t = randomRIO (0, t) >>= threadDelay

printer lock str = forkIO . forever $ do
  randomDelay 1000
  Lock.with lock (putStrLn str)

main = do
  lock <- Lock.new
  printer lock "Hello"
  printer lock "World"
  return ()

Answer 4

这是Petr提到的使用全局锁的示例。

import Control.Concurrent
import Control.Monad
import System.Random
import Control.Concurrent.MVar  (newMVar, takeMVar, putMVar, MVar)
import System.IO.Unsafe (unsafePerformIO)


{-# NOINLINE lock #-}
lock :: MVar ()
lock = unsafePerformIO $ newMVar ()



printer x = forkIO . forever $ do
   randomDelay 100000
   () <- takeMVar lock
   let atomicPutStrLn str =  putStrLn str >> putMVar lock ()
   atomicPutStrLn x

randomDelay t = randomRIO (0, t) >>= threadDelay



main = do
  printer "Hello"
  printer "World"
  return ()

Answer 5

尽管newtype Lock = Lock (TVar Status) data Status = Locked | Unlocked newLocked :: IO Lock newLocked = Lock <$> newTVarIO Locked newUnlocked :: IO Lock newUnlocked = Lock <$> newTVarIO Unlocked -- | Acquire a lock. acquire :: Lock -> IO () acquire (Lock tv) = atomically $ readTVar tv >>= \case Locked -> retry Unlocked -> writeTVar tv Locked -- | Try to acquire a lock. If the operation succeeds, -- return `True`. tryAcquire :: Lock -> IO Bool tryAcquire (Lock tv) = atomically $ readTVar tv >>= \case Locked -> pure False Unlocked -> True <$ writeTVar tv Locked -- | Release a lock. This version throws an exception -- if the lock is unlocked. release :: Lock -> IO () release (Lock tv) = atomically $ readTVar tv >>= \case Unlocked -> throwSTM DoubleRelease Locked -> writeTVar tv Unlocked data DoubleRelease = DoubleRelease deriving Show instance Exception DoubleRelease where displayException ~DoubleRelease = "Attempted to release an unlocked lock." -- | Release a lock. This version does nothing if -- the lock is unlocked. releaseIdempotent :: Lock -> IO () releaseIdempotent (Lock tv) = atomically $ writeTVar tv Unlocked -- | Get the status of a lock. isLocked :: Lock -> IO Status isLocked (Lock tv) = readTVarIO tv几乎肯定会表现更好，但实际上您可以根据需要使用STM来实现锁。

acquire

release / MVar对需要仔细的屏蔽和异常处理，就像原始的retry操作一样。该文档建议，但实际上并未声明，STM操作withMVar可以中断。假设这是正确的，则retry使用的相同方法将在此处工作。注意：我已经打开GHC ticket来记录getElementById()的可中断性。

阻止线程交错输出

5 个答案: