Question

我正在尝试实现一个用于并发应用程序的堆栈。我想要以下语义：push永远不应该阻塞，pop应该阻止空堆栈上的调用线程，但仍然允许push es。我按如下方式实现了它（底部的无关位）：

data Stream a = Stream a (MVar (Stream a))
data Stack a = Stack (MVar (Int, MVar (Stream a)))

popStack :: Stack a -> IO a 
popStack (Stack stack) = do 
  (sz, mvar) <- takeMVar stack
  mbStream <- tryTakeMVar mvar 
  case mbStream of 
    Nothing -> putMVar stack (sz, mvar) >> popStack (Stack stack)
    Just (Stream x xs) -> putMVar stack (sz-1, xs) >> return x

如果流MVar为空，我必须释放堆栈上的锁，然后再试一次。但是，这看起来像一个kludge：如果一个线程在空堆栈上调用pop，它可能会在被挂起之前循环几次，即使MVar在执行该线程时不会变满。是否有更好的方法利用MVar来编写具有所需语义的pop？

import Control.Concurrent.MVar 
import Control.Monad 
import Control.Concurrent
import Text.Printf

newStack :: IO (Stack a) 
newStack = do 
  stream <- newEmptyMVar 
  Stack <$> newMVar (0, stream)

pushStack :: Stack a -> a -> IO ()
pushStack (Stack stack) val = do 
  (sz, stream) <- takeMVar stack
  stream' <- newMVar (Stream val stream)
  putMVar stack (sz+1, stream')

test = do 
  s <- newStack
  _ <- forkIO $ mapM_ (\a -> printf "pushing %c... " a >> pushStack s a >> threadDelay 100000) ['a' .. 'z']
  _ <- forkIO $ do 
         replicateM 13 (popStack s) >>= printf "\npopped 13 elems: %s\n"
         replicateM 13 (popStack s) >>= printf "\npopped 13 elems: %s\n"
  threadDelay (5*10^6)
  putStrLn "Done"

Answer 1

这不是很令人兴奋，但最简单的解决方案是使用STM（如果您使用cabal，则需要在依赖项列表中使用stm包。）

import Control.Concurrent.STM

newtype Stack a = Stack (TVar [a])

new :: STM (Stack a)
new = fmap Stack $ newTVar []

put :: a -> Stack a -> STM ()
put a (Stack v) = modifyTVar' v (a:)

get :: Stack a -> STM a
get (Stack v) = do
    stack <- readTVar v
    case stack of
         [] -> retry
         (a:as) -> do writeTVar v as
                      return a

您可以使用retry获得所需的阻止行为，这种行为的实现方式是在TVar更改为[]之外的其他内容之前不会唤醒线程。这也很好，因为您现在可以在更大的组合原子事务中使用堆栈，并且您不必担心确保异常不会破坏您的结构。

如果您尝试使用大量争用读取和/或写入的线程来执行高性能并发，您可能会发现这不够聪明。在这种情况下，您可以根据atomic-primops中基于fetch-and-add的计数器设计结构，或者查看hackage上还有其他可用的结构。

Answer 2

快速批评：

＆＃34; push永远不会阻止＆＃34;不是你要实际实现的东西。虽然你可能有一个perdonal定义＆＃34; block＆＃34;这与GHC意义不同。例如，你的pushStack会阻止。
空堆栈上的popStack进入一个非常繁忙的循环，重复进行并放置Stack MVar。你不想这样做，你甚至说＆＃34; pop应该阻止＆＃34;。
您使用takeMVar和putMVar而不是withMVar或modifyMVar。这意味着你没有考虑异常，而且Stack在通用库中不会很好。

所以你已经了解了MVars，并且你正在使用它们来了解更多信息。

此处StackData是具有数据（完整）或没有数据（空）的堆栈。当为空时，有一个初始空的MVar供饥饿的poppers等待。

type Lock = MVar ()
type Some a = (a, [a]) -- non empty version of list
data StackData a = Full !(Some a)
                 | Empty !Lock
data Stack a = Stack { stack :: MVar (StackData a) }

pop s = do
    x <- modifyMVar (stack s) $ \ sd ->
           case sd of
               Empty lock -> do
                   return (Empty lock, Left lock)
               Full (a, []) -> do
                   lock <- newEmptyMVar
                   return (Empty lock, Right a)
               Full (a, (b:bs)) -> return (Full (b, bs), Right a)
    case x of
        Left lock -> do
            withMVar lock return  -- wait on next pusher
            pop s
        Right a -> return a


 push s a = modifyMVar_ (stack s) $ \ sd ->
           case sd of
               Empty lock -> do
                   tryPutMVar lock () -- should succeed, releases waiting poppers
                   evaluate Full (a,[]) -- do not accumulate lazy thunks
               Full (b, bs) -> do
                   xs <- evaluate (b:bs) -- do not accumulate lazy thunks
                   evaluate (Full (a, xs)) -- do not accumulate lazy thunks

注意：我没有尝试编译它。

编辑：更安全的推送版本只需将（）放入锁中，当它成功将堆栈从Empty修改为Full时。这种确定性可以通过“面具”来实现。操作。恢复＆＃39;在里面使用＆＃39; modifyMVar＆＃39;但不是必需的：

push s a = mask $ \restore -> do
    mLock <- modifyMVar (stack s) $ \ sd -> restore $
           case sd of
               Empty lock -> do
                   n <- evaluate Full (a,[]) -- do not accumulate lazy thunks
                   return (n, Just lock)
               Full (b, bs) -> do
                   xs <- evaluate (b:bs) -- do not accumulate lazy thunks
                   n <- evaluate (Full (a, xs))
                   return (n, Nothing)
    whenJust mLock $ \ lock -> tryPutMVar lock ()

使用MVar的并发堆栈实现

2 个答案: