[GHC] #9539: TQueue can lead to thread starvation

[GHC]

#9539: TQueue can lead to thread starvation
-------------------------------------+-------------------------------------
        Reporter:  jwlato            |                Owner:  (none)
            Type:  bug               |               Status:  new
        Priority:  normal            |            Milestone:
       Component:  Core Libraries    |              Version:  7.8.2
      Resolution:                    |             Keywords:  stm
Operating System:  Unknown/Multiple  |         Architecture:
                                     |  Unknown/Multiple
 Type of failure:  None/Unknown      |            Test Case:
      Blocked By:                    |             Blocking:
 Related Tickets:                    |  Differential Rev(s):
       Wiki Page:                    |
-------------------------------------+-------------------------------------

Comment (by YitzGale):

 Here is an alternative safer proposal:

 We retain the well-understood behavior and performance of the classic
 functional queue. But we ensure that the amortized cost of the occasional
 reverse is shared fairly by the read and write ends of the queue. We do
 that by placing a singleton buffer in the middle, between the read and
 write buffers. Whoever first finds the middle buffer unavailable pays the
 price that time. Here is a simplistic initial implementation:

 {{{#!hs
 data TQueue a = TQueue !(TVar [a]) !(TMVar a) !(TVar [a])

 readTQueue :: TQueue a -> STM a
 readTQueue (TQueue read middle write) = readTVar read >>= \case
     x:xs -> pure x <* writeTVar read xs
     _    -> takeTMVar middle `orElse`
       (readTVar write >>= \case
         [] -> retry
         ys -> do
           writeTVar write []
           let z:zs = reverse ys
           pure z <* writeTVar read zs
       )

 writeTQueue :: TQueue a -> a -> STM ()
 writeTQueue (TQueue read middle write) x =
   (do
     putTMVar middle x
     readTVar write >>= \case
       [] -> pure ()
       ys -> do -- read must be empty in this case.
         -- strict reverse to ensure we pay the amortization price
         -- here and not in a read operation.
         writeTVar read $! reverse ys
         writeTVar write []
   ) `orElse` modifyTVar' write (x :)
 }}}

 The above code depends on the invariant that if the write buffer is non-
 empty and the middle is empty, then the read buffer is empty. We can
 observe that this is true because a read operation will only empty the
 middle if there is no data left in the read buffer, and once that happens
 the read buffer will remain empty until the next time that the write
 buffer is emptied. But the type does not enforce that invariant.

 Here is a safer implementation with a type which cannot represent the
 impossible state, but requires a few more cheap TVar operations:

 {{{#!hs
 newtype TQueue a = TQueue (TVar (TQueue' a))
 data TQueue' a =
     TQueueR !(TVar [a]) -- middle and write are empty
   | TQueueW !(TVar (NonEmpty a)) -- read and middle are empty
   | TQueueM !(TVar [a]) !(TVar a) !(TVar [a]) -- middle is non-empty

 readTQueue :: TQueue a -> STM a
 readTQueue (TQueue tvq) = readTVar tvq >>= \case
     TQueueR tvr -> readTVar tvr >>= \case
         x:xs' -> pure x <* writeTVar tvr xs'
         _     -> retry
     TQueueW tvw -> do
       ys <- readTVar tvw
       let z :| zs = NE.reverse ys
       pure z <* (newTVar zs >>= writeTVar tvq . TQueueR)
     TQueueM tvr tvm tvw -> readTVar tvr >>= \case
         x:xs' -> pure x <* writeTVar tvr xs'
         _     -> readTVar tvm <*
           (readTVar tvw >>= \case
               y : ys -> newTVar (y :| ys) >>= writeTVar tvq . TQueueW
               _      -> writeTVar tvq (TQueueR tvr) -- empty
           )

 writeTQueue :: TQueue a -> a -> STM ()
 writeTQueue (TQueue tvq) x = readTVar tvq >>= \case
     TQueueR tvr -> do
       tvm <- newTVar x
       tvw <- newTVar []
       writeTVar tvq (TQueueM tvr tvm tvw)
     TQueueW tvw -> do
       ys <- readTVar tvw
       -- strict reverse to ensure we pay the amortization price
       -- here and not in a read operation.
       tvr <- newTVar $! (reverse $ NE.toList ys)
       tvm <- newTVar x
       tvw' <- newTVar []
       writeTVar tvq (TQueueM tvr tvm tvw')
     TQueueM _ _ tvw -> modifyTVar' tvw (x :)
 }}}

-- 
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/9539#comment:18>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler