Ticket #7104: 0001-TBQueue-Force-capacity-computations-so-they-don-t-pi.patch

File 0001-TBQueue-Force-capacity-computations-so-they-don-t-pi.patch, 3.2 KB (added by joeyadams, 3 years ago)

TBQueue: Force capacity computations so they don't pile up

  • Control/Concurrent/STM/TBQueue.hs

    From 22e3c1e69e48e9593b0508831db1aa30f25c1be4 Mon Sep 17 00:00:00 2001
    From: Joey Adams <[email protected]>
    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 b newTBQueue size = do 
    7777  read  <- newTVar [] 
    7878  write <- newTVar [] 
    7979  rsize <- newTVar 0 
    80   wsize <- newTVar size 
     80  wsize <- newTVar $! size 
    8181  return (TBQueue rsize read wsize write) 
    8282 
    8383-- |@IO@ version of 'newTBQueue'.  This is useful for creating top-level 
    newTBQueueIO size = do 
    8989  read  <- newTVarIO [] 
    9090  write <- newTVarIO [] 
    9191  rsize <- newTVarIO 0 
    92   wsize <- newTVarIO size 
     92  wsize <- newTVarIO $! size 
    9393  return (TBQueue rsize read wsize write) 
    9494 
    9595-- |Write a value to a 'TBQueue'; blocks if the queue is full. 
    writeTBQueue :: TBQueue a -> a -> STM () 
    9797writeTBQueue (TBQueue rsize _read wsize write) a = do 
    9898  w <- readTVar wsize 
    9999  if (w /= 0) 
    100      then do writeTVar wsize (w - 1) 
     100     then do writeTVar wsize $! w - 1 
    101101     else do 
    102102          r <- readTVar rsize 
    103103          if (r /= 0) 
    104104             then do writeTVar rsize 0 
    105                      writeTVar wsize (r - 1) 
     105                     writeTVar wsize $! r - 1 
    106106             else retry 
    107107  listend <- readTVar write 
    108108  writeTVar write (a:listend) 
    readTBQueue :: TBQueue a -> STM a 
    112112readTBQueue (TBQueue rsize read _wsize write) = do 
    113113  xs <- readTVar read 
    114114  r <- readTVar rsize 
    115   writeTVar rsize (r + 1) 
     115  writeTVar rsize $! r + 1 
    116116  case xs of 
    117117    (x:xs') -> do 
    118118      writeTVar read xs' 
    unGetTBQueue :: TBQueue a -> a -> STM () 
    158158unGetTBQueue (TBQueue rsize read wsize _write) a = do 
    159159  r <- readTVar rsize 
    160160  if (r > 0) 
    161      then do writeTVar rsize (r - 1) 
     161     then do writeTVar rsize $! r - 1 
    162162     else do 
    163163          w <- readTVar wsize 
    164164          if (w > 0) 
    165              then writeTVar wsize (w - 1) 
     165             then writeTVar wsize $! w - 1 
    166166             else retry 
    167167  xs <- readTVar read 
    168168  writeTVar read (a:xs)