[stm] strange behavior with TQueue and STM's alternative instance

[Bas van Dijk]

On 9 December 2012 16:48, Patrick Palka <patrick at parcs.ath.cx> wrote:
> Hi,
>
> I'm getting strange behavior when using the 'many' combinator to read zero
> or more items off of a TQueue with readTQueue. The script that exhibits this
> behavior is as follows:
>
> import Control.Concurrent.STM
> import Control.Concurrent
> import Control.Monad
> import Control.Applicative
>
> main = do
>     q <- newTQueueIO
>     atomically $ writeTQueue q True
>     atomically $ writeTQueue q False
>     forever $ do
>         xs <- atomically $ many $ readTQueue q
>         print xs
>         threadDelay 500000
>
>
> I'd expect the output of the script to be:
> [True,False]
> []
> []
> ...
>
> However, that is not the case: the actual output of the script is:
> [True,False]
> [True,False]
> [True,False]
> ...
>
> This means that TQueue is incompatible with TChan, since if TQueue is
> replaced by TChan then the script behaves as one would expect.
>
> If 1 element (say, True) is written into the TQueue instead of 2, then the
> output of the script is:
> [True]
> []
> []
> ...
>
> Which is expected behavior, but inconsistent with the behavior when the
> TQueue has 2 or more elements in it.
>
> Is this considered a bug, or undocumented behavior of TQueue?
>
> _______________________________________________
> Libraries mailing list
> Libraries at haskell.org
> http://www.haskell.org/mailman/listinfo/libraries
>

This is puzzling me. It looks like a bug in STM. The following code
should have the same behavior. Interestingly, when I remove the
'readTVar write' marked "Remove me!!!" I get the desired behavior:

import Control.Concurrent.STM
    (STM, atomically, retry, TVar, newTVarIO, readTVar, writeTVar)
import Control.Concurrent
import Control.Monad
import Control.Applicative

main = do
  q@(TQueue read write) <- newTQueueIO
  atomically $ writeTQueue q True
  atomically $ writeTQueue q False
  forever $ do
    xs <- atomically $
      (((:) <$> readTQueue q <*>
        (((:) <$> readTQueue q <*>
          (((:) <$> (do readTVar read
                        readTVar write -- Remove me!!!
                        retry
                    ) <*> error "..."
           ) <|> pure []
          )
         ) <|> pure []
        )
       ) <|> pure []
      )
    print xs
    threadDelay 500000

data TQueue a = TQueue {-# UNPACK #-} !(TVar [a])
                       {-# UNPACK #-} !(TVar [a])

newTQueueIO :: IO (TQueue a)
newTQueueIO = do
  read  <- newTVarIO []
  write <- newTVarIO []
  return (TQueue read write)

writeTQueue :: TQueue a -> a -> STM ()
writeTQueue (TQueue _read write) a = do
  listend <- readTVar write
  writeTVar write (a:listend)

readTQueue :: Show a => TQueue a -> STM a
readTQueue (TQueue read write) = do
  xs <- readTVar read
  case xs of
    (x:xs') -> do writeTVar read xs'
                  return x
    [] -> do ys <- readTVar write
             case ys of
               [] -> retry
               _  -> case reverse ys of
                       [] -> error "readTQueue"
                       (z:zs) -> do writeTVar write []
                                    writeTVar read zs
                                    return z

Bas