1{-# OPTIONS_GHC -Wall -fwarn-tabs #-} 2{-# LANGUAGE CPP, DeriveDataTypeable #-} 3 4-- HACK: in GHC 7.10, Haddock complains about Control.Monad.STM and 5-- System.IO.Unsafe being imported but unused. However, if we use 6-- CPP to avoid including them under Haddock, then it will fail to 7-- compile! 8#ifdef __HADDOCK__ 9{-# OPTIONS_GHC -fno-warn-unused-imports #-} 10#endif 11 12#if __GLASGOW_HASKELL__ >= 701 13# ifdef __HADDOCK__ 14{-# LANGUAGE Trustworthy #-} 15# else 16{-# LANGUAGE Safe #-} 17# endif 18#endif 19---------------------------------------------------------------- 20-- 2015.03.29 21-- | 22-- Module : Control.Concurrent.STM.TBMQueue 23-- Copyright : Copyright (c) 2011--2015 wren gayle romano 24-- License : BSD 25-- Maintainer : wren@community.haskell.org 26-- Stability : provisional 27-- Portability : non-portable (GHC STM, DeriveDataTypeable) 28-- 29-- A version of "Control.Concurrent.STM.TQueue" where the queue is 30-- bounded in length and closeable. This combines the abilities of 31-- "Control.Concurrent.STM.TBQueue" and "Control.Concurrent.STM.TMQueue". 32-- 33-- /Since: 2.0.0/ 34---------------------------------------------------------------- 35module Control.Concurrent.STM.TBMQueue 36 ( 37 -- * The TBMQueue type 38 TBMQueue() 39 -- ** Creating TBMQueues 40 , newTBMQueue 41 , newTBMQueueIO 42 -- ** Reading from TBMQueues 43 , readTBMQueue 44 , tryReadTBMQueue 45 , peekTBMQueue 46 , tryPeekTBMQueue 47 -- ** Writing to TBMQueues 48 , writeTBMQueue 49 , tryWriteTBMQueue 50 , unGetTBMQueue 51 -- ** Closing TBMQueues 52 , closeTBMQueue 53 -- ** Predicates 54 , isClosedTBMQueue 55 , isEmptyTBMQueue 56 , isFullTBMQueue 57 -- ** Other functionality 58 , estimateFreeSlotsTBMQueue 59 , freeSlotsTBMQueue 60 ) where 61 62import Prelude hiding (reads) 63import Data.Typeable (Typeable) 64#if __GLASGOW_HASKELL__ < 710 65import Control.Applicative ((<$>)) 66#endif 67import Control.Monad.STM (STM, retry) 68import Control.Concurrent.STM.TVar 69import Control.Concurrent.STM.TQueue -- N.B., GHC only 70 71-- N.B., we need a Custom cabal build-type for this to work. 72#ifdef __HADDOCK__ 73import Control.Monad.STM (atomically) 74import System.IO.Unsafe (unsafePerformIO) 75#endif 76---------------------------------------------------------------- 77 78-- | @TBMQueue@ is an abstract type representing a bounded closeable 79-- FIFO queue. 80data TBMQueue a = TBMQueue 81 {-# UNPACK #-} !(TVar Bool) 82 {-# UNPACK #-} !(TVar Int) 83 {-# UNPACK #-} !(TVar Int) 84 {-# UNPACK #-} !(TQueue a) 85 deriving (Typeable) 86-- The components are: 87-- * Whether the queue has been closed. 88-- * How many free slots we /know/ we have available. 89-- * How many slots have been freed up by successful reads since 90-- the last time the slot count was synchronized by 'isFullTBQueue'. 91-- * The underlying TQueue. 92 93 94-- | Build and returns a new instance of @TBMQueue@ with the given 95-- capacity. /N.B./, we do not verify the capacity is positive, but 96-- if it is non-positive then 'writeTBMQueue' will always retry and 97-- 'isFullTBMQueue' will always be true. 98newTBMQueue :: Int -> STM (TBMQueue a) 99newTBMQueue n = do 100 closed <- newTVar False 101 slots <- newTVar n 102 reads <- newTVar 0 103 queue <- newTQueue 104 return (TBMQueue closed slots reads queue) 105 106 107-- | @IO@ version of 'newTBMQueue'. This is useful for creating 108-- top-level @TBMQueue@s using 'unsafePerformIO', because using 109-- 'atomically' inside 'unsafePerformIO' isn't possible. 110newTBMQueueIO :: Int -> IO (TBMQueue a) 111newTBMQueueIO n = do 112 closed <- newTVarIO False 113 slots <- newTVarIO n 114 reads <- newTVarIO 0 115 queue <- newTQueueIO 116 return (TBMQueue closed slots reads queue) 117 118 119-- | Read the next value from the @TBMQueue@, retrying if the queue 120-- is empty (and not closed). We return @Nothing@ immediately if 121-- the queue is closed and empty. 122readTBMQueue :: TBMQueue a -> STM (Maybe a) 123readTBMQueue (TBMQueue closed _slots reads queue) = do 124 b <- readTVar closed 125 if b 126 then do 127 mx <- tryReadTQueue queue 128 case mx of 129 Nothing -> return mx 130 Just _x -> do 131 modifyTVar' reads (1 +) 132 return mx 133 else do 134 x <- readTQueue queue 135 modifyTVar' reads (1 +) 136 return (Just x) 137{- 138-- The above is slightly optimized over the clearer: 139readTBMQueue (TBMQueue closed _slots reads queue) = 140 b <- readTVar closed 141 b' <- isEmptyTQueue queue 142 if b && b' 143 then return Nothing 144 else do 145 x <- readTQueue queue 146 modifyTVar' reads (1 +) 147 return (Just x) 148-- TODO: compare Core and benchmarks; is the loss of clarity worth it? 149-} 150 151 152-- | A version of 'readTBMQueue' which does not retry. Instead it 153-- returns @Just Nothing@ if the queue is open but no value is 154-- available; it still returns @Nothing@ if the queue is closed 155-- and empty. 156tryReadTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a)) 157tryReadTBMQueue (TBMQueue closed _slots reads queue) = do 158 b <- readTVar closed 159 if b 160 then do 161 mx <- tryReadTQueue queue 162 case mx of 163 Nothing -> return Nothing 164 Just _x -> do 165 modifyTVar' reads (1 +) 166 return (Just mx) 167 else do 168 mx <- tryReadTQueue queue 169 case mx of 170 Nothing -> return (Just mx) 171 Just _x -> do 172 modifyTVar' reads (1 +) 173 return (Just mx) 174{- 175-- The above is slightly optimized over the clearer: 176tryReadTBMQueue (TBMQueue closed _slots reads queue) = 177 b <- readTVar closed 178 b' <- isEmptyTQueue queue 179 if b && b' 180 then return Nothing 181 else do 182 mx <- tryReadTBMQueue queue 183 case mx of 184 Nothing -> return (Just mx) 185 Just _x -> do 186 modifyTVar' reads (1 +) 187 return (Just mx) 188-- TODO: compare Core and benchmarks; is the loss of clarity worth it? 189-} 190 191 192-- | Get the next value from the @TBMQueue@ without removing it, 193-- retrying if the queue is empty. 194peekTBMQueue :: TBMQueue a -> STM (Maybe a) 195peekTBMQueue (TBMQueue closed _slots _reads queue) = do 196 b <- readTVar closed 197 if b 198 then do 199 b' <- isEmptyTQueue queue 200 if b' 201 then return Nothing 202 else Just <$> peekTQueue queue 203 else Just <$> peekTQueue queue 204{- 205-- The above is lazier reading from @queue@ than the clearer: 206peekTBMQueue (TBMQueue closed _slots _reads queue) = do 207 b <- isEmptyTQueue queue 208 b' <- readTVar closed 209 if b && b' 210 then return Nothing 211 else Just <$> peekTQueue queue 212-- TODO: compare Core and benchmarks; is the loss of clarity worth it? 213-} 214 215 216-- | A version of 'peekTBMQueue' which does not retry. Instead it 217-- returns @Just Nothing@ if the queue is open but no value is 218-- available; it still returns @Nothing@ if the queue is closed 219-- and empty. 220tryPeekTBMQueue :: TBMQueue a -> STM (Maybe (Maybe a)) 221tryPeekTBMQueue (TBMQueue closed _slots _reads queue) = do 222 b <- readTVar closed 223 if b 224 then fmap Just <$> tryPeekTQueue queue 225 else Just <$> tryPeekTQueue queue 226{- 227-- The above is lazier reading from @queue@ (and removes an extraneous isEmptyTQueue when using the compatibility layer) than the clearer: 228tryPeekTBMQueue (TBMQueue closed _slots _reads queue) = do 229 b <- isEmptyTQueue queue 230 b' <- readTVar closed 231 if b && b' 232 then return Nothing 233 else Just <$> tryPeekTQueue queue 234-- TODO: compare Core and benchmarks; is the loss of clarity worth it? 235-} 236 237 238-- | Write a value to a @TBMQueue@, retrying if the queue is full. 239-- If the queue is closed then the value is silently discarded. 240-- Use 'isClosedTBMQueue' to determine if the queue is closed 241-- before writing, as needed. 242writeTBMQueue :: TBMQueue a -> a -> STM () 243writeTBMQueue self@(TBMQueue closed slots _reads queue) x = do 244 b <- readTVar closed 245 if b 246 then return () -- Discard silently 247 else do 248 n <- estimateFreeSlotsTBMQueue self 249 if n <= 0 250 then retry 251 else do 252 writeTVar slots $! n - 1 253 writeTQueue queue x 254 255 256-- | A version of 'writeTBMQueue' which does not retry. Returns @Just 257-- True@ if the value was successfully written, @Just False@ if it 258-- could not be written (but the queue was open), and @Nothing@ 259-- if it was discarded (i.e., the queue was closed). 260tryWriteTBMQueue :: TBMQueue a -> a -> STM (Maybe Bool) 261tryWriteTBMQueue self@(TBMQueue closed slots _reads queue) x = do 262 b <- readTVar closed 263 if b 264 then return Nothing 265 else do 266 n <- estimateFreeSlotsTBMQueue self 267 if n <= 0 268 then return (Just False) 269 else do 270 writeTVar slots $! n - 1 271 writeTQueue queue x 272 return (Just True) 273 274 275-- | Put a data item back onto a queue, where it will be the next 276-- item read. If the queue is closed then the value is silently 277-- discarded; you can use 'peekTBMQueue' to circumvent this in certain 278-- circumstances. /N.B./, this could allow the queue to temporarily 279-- become longer than the specified limit, which is necessary to 280-- ensure that the item is indeed the next one read. 281unGetTBMQueue :: TBMQueue a -> a -> STM () 282unGetTBMQueue (TBMQueue closed slots _reads queue) x = do 283 b <- readTVar closed 284 if b 285 then return () -- Discard silently 286 else do 287 modifyTVar' slots (subtract 1) 288 unGetTQueue queue x 289 290 291-- | Closes the @TBMQueue@, preventing any further writes. 292closeTBMQueue :: TBMQueue a -> STM () 293closeTBMQueue (TBMQueue closed _slots _reads _queue) = 294 writeTVar closed True 295 296 297-- | Returns @True@ if the supplied @TBMQueue@ has been closed. 298isClosedTBMQueue :: TBMQueue a -> STM Bool 299isClosedTBMQueue (TBMQueue closed _slots _reads _queue) = 300 readTVar closed 301 302{- 303-- | Returns @True@ if the supplied @TBMQueue@ has been closed. 304isClosedTBMQueueIO :: TBMQueue a -> IO Bool 305isClosedTBMQueueIO (TBMQueue closed _slots _reads _queue) = 306 readTVarIO closed 307-} 308 309 310-- | Returns @True@ if the supplied @TBMQueue@ is empty (i.e., has 311-- no elements). /N.B./, a @TBMQueue@ can be both ``empty'' and 312-- ``full'' at the same time, if the initial limit was non-positive. 313isEmptyTBMQueue :: TBMQueue a -> STM Bool 314isEmptyTBMQueue (TBMQueue _closed _slots _reads queue) = 315 isEmptyTQueue queue 316 317 318-- | Returns @True@ if the supplied @TBMQueue@ is full (i.e., is 319-- over its limit). /N.B./, a @TBMQueue@ can be both ``empty'' and 320-- ``full'' at the same time, if the initial limit was non-positive. 321-- /N.B./, a @TBMQueue@ may still be full after reading, if 322-- 'unGetTBMQueue' was used to go over the initial limit. 323-- 324-- This is equivalent to: @liftM (<= 0) estimateFreeSlotsTBMQueue@ 325isFullTBMQueue :: TBMQueue a -> STM Bool 326isFullTBMQueue (TBMQueue _closed slots reads _queue) = do 327 n <- readTVar slots 328 if n <= 0 329 then do 330 m <- readTVar reads 331 let n' = n + m 332 writeTVar slots $! n' 333 writeTVar reads 0 334 return $! n' <= 0 335 else return False 336 337 338-- | Estimate the number of free slots. If the result is positive, 339-- then it's a minimum bound; if it's non-positive then it's exact. 340-- It will only be negative if the initial limit was negative or 341-- if 'unGetTBMQueue' was used to go over the initial limit. 342-- 343-- This function always contends with writers, but only contends 344-- with readers when it has to; compare against 'freeSlotsTBMQueue'. 345estimateFreeSlotsTBMQueue :: TBMQueue a -> STM Int 346estimateFreeSlotsTBMQueue (TBMQueue _closed slots reads _queue) = do 347 n <- readTVar slots 348 if n > 0 349 then return n 350 else do 351 m <- readTVar reads 352 let n' = n + m 353 writeTVar slots $! n' 354 writeTVar reads 0 355 return n' 356 357 358-- | Return the exact number of free slots. The result can be 359-- negative if the initial limit was negative or if 'unGetTBMQueue' 360-- was used to go over the initial limit. 361-- 362-- This function always contends with both readers and writers; 363-- compare against 'estimateFreeSlotsTBMQueue'. 364freeSlotsTBMQueue :: TBMQueue a -> STM Int 365freeSlotsTBMQueue (TBMQueue _closed slots reads _queue) = do 366 n <- readTVar slots 367 m <- readTVar reads 368 let n' = n + m 369 writeTVar slots $! n' 370 writeTVar reads 0 371 return n' 372 373---------------------------------------------------------------- 374----------------------------------------------------------- fin. 375