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

[Bas van Dijk]

On 9 December 2012 20:50, Bas van Dijk <v.dijk.bas at gmail.com> wrote:
> 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

This is a simplified program which behaves in the same non-expected way:

main = do
  t <- newTVarIO 1
  atomically $ do
    writeTVar t 2
    ((readTVar t >> retry) `orElse` return ()) `orElse` return ()
  atomically (readTVar t) >>= print
  threadDelay 500000

This program prints 1 while I expect it to print 2.

It prints 2 when I remove the outer `orElse`:

main = do
  t <- newTVarIO 1
  atomically $ do
    writeTVar t 2
    ((readTVar t >> retry) `orElse` return ())
  atomically (readTVar t) >>= print
  threadDelay 500000

It also prints 2 when I remove the readTVar:

main = do
  t <- newTVarIO 1
  atomically $ do
    writeTVar t 2
    (retry `orElse` return ()) `orElse` return ()
  atomically (readTVar t) >>= print
  threadDelay 500000

Bas