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

[Simon Marlow]

On 09/12/12 21:24, Bas van Dijk wrote:
> 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

Nice bug!  I have a fix, will try to get it into GHC 7.6.2.

Cheers,
	Simon