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

[Bas van Dijk]

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

The simplest program I can come up with which shows the same behavior:

$ cat stmTest.hs
import Control.Concurrent.STM
main = do
  x <- atomically $ do
         t <- newTVar 1
         writeTVar t 2
         ((readTVar t >> retry) `orElse` return ()) `orElse` return ()
         readTVar t
  print x

$ ghc --make stmTest.hs -fforce-recomp -threaded -o stmTest && ./stmTest
[1 of 1] Compiling Main             ( stmTest.hs, stmTest.o )
Linking stmTest ...
1