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

[Bas van Dijk]

On 10 December 2012 12:51, Simon Marlow <marlowsd at gmail.com> wrote:
> 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
>
>

Great!

I would like to understand what went wrong. I looked at the retry and
catchRetry PrimOps but didn't understand them well enough to figure
out the bug. Do you have a link to your patch?

Thanks,

Bas