never executed always true always false

    1 {-# LANGUAGE DeriveDataTypeable #-}
    2 {-# OPTIONS_GHC -funbox-strict-fields #-}
    3 module Distribution.Client.Compat.Semaphore
    4     ( QSem
    5     , newQSem
    6     , waitQSem
    7     , signalQSem
    8     ) where
    9 
   10 import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip)
   11 
   12 import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,
   13                                writeTVar)
   14 import Control.Exception (mask_, onException)
   15 import Control.Monad (join, unless)
   16 import Data.Typeable (Typeable)
   17 import Data.List.NonEmpty (NonEmpty (..))
   18 import qualified Data.List.NonEmpty as NE
   19 
   20 -- | 'QSem' is a quantity semaphore in which the resource is aqcuired
   21 -- and released in units of one. It provides guaranteed FIFO ordering
   22 -- for satisfying blocked `waitQSem` calls.
   23 --
   24 data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool])
   25   deriving (Eq, Typeable)
   26 
   27 newQSem :: Int -> IO QSem
   28 newQSem i = atomically $ do
   29   q <- newTVar i
   30   b1 <- newTVar []
   31   b2 <- newTVar []
   32   return (QSem q b1 b2)
   33 
   34 waitQSem :: QSem -> IO ()
   35 waitQSem s@(QSem q _b1 b2) =
   36   mask_ $ join $ atomically $ do
   37         -- join, because if we need to block, we have to add a TVar to
   38         -- the block queue.
   39         -- mask_, because we need a chance to set up an exception handler
   40         -- after the join returns.
   41      v <- readTVar q
   42      if v == 0
   43         then do b <- newTVar False
   44                 ys <- readTVar b2
   45                 writeTVar b2 (b:ys)
   46                 return (wait b)
   47         else do writeTVar q $! v - 1
   48                 return (return ())
   49   where
   50     --
   51     -- very careful here: if we receive an exception, then we need to
   52     --  (a) write True into the TVar, so that another signalQSem doesn't
   53     --      try to wake up this thread, and
   54     --  (b) if the TVar is *already* True, then we need to do another
   55     --      signalQSem to avoid losing a unit of the resource.
   56     --
   57     -- The 'wake' function does both (a) and (b), so we can just call
   58     -- it here.
   59     --
   60     wait t =
   61       flip onException (wake s t) $
   62       atomically $ do
   63         b <- readTVar t
   64         unless b retry
   65 
   66 
   67 wake :: QSem -> TVar Bool -> IO ()
   68 wake s x = join $ atomically $ do
   69       b <- readTVar x
   70       if b then return (signalQSem s)
   71            else do writeTVar x True
   72                    return (return ())
   73 
   74 {-
   75  property we want:
   76 
   77    bracket waitQSem (\_ -> signalQSem) (\_ -> ...)
   78 
   79  never loses a unit of the resource.
   80 -}
   81 
   82 signalQSem :: QSem -> IO ()
   83 signalQSem s@(QSem q b1 b2) =
   84   mask_ $ join $ atomically $ do
   85       -- join, so we don't force the reverse inside the txn
   86       -- mask_ is needed so we don't lose a wakeup
   87     v <- readTVar q
   88     if v /= 0
   89        then do writeTVar q $! v + 1
   90                return (return ())
   91        else do xs <- readTVar b1
   92                checkwake1 xs
   93   where
   94     checkwake1 [] = do
   95       ys <- readTVar b2
   96       checkwake2 ys
   97     checkwake1 (x:xs) = do
   98       writeTVar b1 xs
   99       return (wake s x)
  100 
  101     checkwake2 [] = do
  102       writeTVar q 1
  103       return (return ())
  104     checkwake2 (y:ys) = do
  105       let (z:|zs) = NE.reverse (y:|ys)
  106       writeTVar b1 zs
  107       writeTVar b2 []
  108       return (wake s z)