From 22e3c1e69e48e9593b0508831db1aa30f25c1be4 Mon Sep 17 00:00:00 2001
From: Joey Adams <joeyadams3.14159@gmail.com>
Date: Sun, 29 Jul 2012 22:45:13 -0400
Subject: [PATCH 1/3] TBQueue: Force capacity computations so they don't pile up

writeTBQueue would have been fine, since it tests the value in wsize and rsize
immediately after reading it.  readTBQueue, on the other hand, simply
incremented the capacity without forcing the value.

Here is a test case that produces a stack overflow before this commit:

    import Control.Concurrent.STM
    import Control.Monad

    main :: IO ()
    main = do
        let n = 10000000
        tbq <- newTBQueueIO (n + 1)

        putStrLn "Writing"
        replicateM_ n $ atomically $ writeTBQueue tbq ()

        putStrLn "Reading"
        replicateM_ n $ atomically $ readTBQueue tbq

        putStrLn "Writing an item (will make CW full)"
        atomically $ writeTBQueue tbq ()

        putStrLn "Writing another item (will overflow CW, which will force CR)"
        atomically $ writeTBQueue tbq ()

        putStrLn "Done"

This is not typical usage, though.  The queue limit for a real application will
likely be much smaller.
---
 Control/Concurrent/STM/TBQueue.hs |   14 +++++++-------
 1 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/Control/Concurrent/STM/TBQueue.hs b/Control/Concurrent/STM/TBQueue.hs
index 82b46b3..6f531c0 100644
--- a/Control/Concurrent/STM/TBQueue.hs
+++ b/Control/Concurrent/STM/TBQueue.hs
@@ -77,7 +77,7 @@ newTBQueue size = do
   read  <- newTVar []
   write <- newTVar []
   rsize <- newTVar 0
-  wsize <- newTVar size
+  wsize <- newTVar $! size
   return (TBQueue rsize read wsize write)
 
 -- |@IO@ version of 'newTBQueue'.  This is useful for creating top-level
@@ -89,7 +89,7 @@ newTBQueueIO size = do
   read  <- newTVarIO []
   write <- newTVarIO []
   rsize <- newTVarIO 0
-  wsize <- newTVarIO size
+  wsize <- newTVarIO $! size
   return (TBQueue rsize read wsize write)
 
 -- |Write a value to a 'TBQueue'; blocks if the queue is full.
@@ -97,12 +97,12 @@ writeTBQueue :: TBQueue a -> a -> STM ()
 writeTBQueue (TBQueue rsize _read wsize write) a = do
   w <- readTVar wsize
   if (w /= 0)
-     then do writeTVar wsize (w - 1)
+     then do writeTVar wsize $! w - 1
      else do
           r <- readTVar rsize
           if (r /= 0)
              then do writeTVar rsize 0
-                     writeTVar wsize (r - 1)
+                     writeTVar wsize $! r - 1
              else retry
   listend <- readTVar write
   writeTVar write (a:listend)
@@ -112,7 +112,7 @@ readTBQueue :: TBQueue a -> STM a
 readTBQueue (TBQueue rsize read _wsize write) = do
   xs <- readTVar read
   r <- readTVar rsize
-  writeTVar rsize (r + 1)
+  writeTVar rsize $! r + 1
   case xs of
     (x:xs') -> do
       writeTVar read xs'
@@ -158,11 +158,11 @@ unGetTBQueue :: TBQueue a -> a -> STM ()
 unGetTBQueue (TBQueue rsize read wsize _write) a = do
   r <- readTVar rsize
   if (r > 0)
-     then do writeTVar rsize (r - 1)
+     then do writeTVar rsize $! r - 1
      else do
           w <- readTVar wsize
           if (w > 0)
-             then writeTVar wsize (w - 1)
+             then writeTVar wsize $! w - 1
              else retry
   xs <- readTVar read
   writeTVar read (a:xs)
-- 
1.7.0.4