{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
module Distribution.Client.Compat.Semaphore
( QSem
, newQSem
, waitQSem
, signalQSem
) where
import Prelude (Bool (..), Eq (..), IO, Int, Num (..), flip, return, ($), ($!))
import Control.Concurrent.STM
( TVar
, atomically
, newTVar
, readTVar
, retry
, writeTVar
)
import Control.Exception (mask_, onException)
import Control.Monad (join, unless)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Typeable (Typeable)
data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool])
deriving (QSem -> QSem -> Bool
(QSem -> QSem -> Bool) -> (QSem -> QSem -> Bool) -> Eq QSem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: QSem -> QSem -> Bool
== :: QSem -> QSem -> Bool
$c/= :: QSem -> QSem -> Bool
/= :: QSem -> QSem -> Bool
Eq, Typeable)
newQSem :: Int -> IO QSem
newQSem :: Int -> IO QSem
newQSem Int
i = STM QSem -> IO QSem
forall a. STM a -> IO a
atomically (STM QSem -> IO QSem) -> STM QSem -> IO QSem
forall a b. (a -> b) -> a -> b
$ do
q <- Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar Int
i
b1 <- newTVar []
b2 <- newTVar []
return (QSem q b1 b2)
waitQSem :: QSem -> IO ()
waitQSem :: QSem -> IO ()
waitQSem s :: QSem
s@(QSem TVar Int
q TVar [TVar Bool]
_b1 TVar [TVar Bool]
b2) =
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
v <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
q
if v == 0
then do
b <- newTVar False
ys <- readTVar b2
writeTVar b2 (b : ys)
return (wait b)
else do
writeTVar q $! v - 1
return (return ())
where
wait :: TVar Bool -> IO ()
wait TVar Bool
t =
(IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
onException (QSem -> TVar Bool -> IO ()
wake QSem
s TVar Bool
t) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
t
unless b retry
wake :: QSem -> TVar Bool -> IO ()
wake :: QSem -> TVar Bool -> IO ()
wake QSem
s TVar Bool
x = IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
b <- TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
x
if b
then return (signalQSem s)
else do
writeTVar x True
return (return ())
signalQSem :: QSem -> IO ()
signalQSem :: QSem -> IO ()
signalQSem s :: QSem
s@(QSem TVar Int
q TVar [TVar Bool]
b1 TVar [TVar Bool]
b2) =
IO () -> IO ()
forall a. IO a -> IO a
mask_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ STM (IO ()) -> IO (IO ())
forall a. STM a -> IO a
atomically (STM (IO ()) -> IO (IO ())) -> STM (IO ()) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do
v <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
q
if v /= 0
then do
writeTVar q $! v + 1
return (return ())
else do
xs <- readTVar b1
checkwake1 xs
where
checkwake1 :: [TVar Bool] -> STM (IO ())
checkwake1 [] = do
ys <- TVar [TVar Bool] -> STM [TVar Bool]
forall a. TVar a -> STM a
readTVar TVar [TVar Bool]
b2
checkwake2 ys
checkwake1 (TVar Bool
x : [TVar Bool]
xs) = do
TVar [TVar Bool] -> [TVar Bool] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [TVar Bool]
b1 [TVar Bool]
xs
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (QSem -> TVar Bool -> IO ()
wake QSem
s TVar Bool
x)
checkwake2 :: [TVar Bool] -> STM (IO ())
checkwake2 [] = do
TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Int
q Int
1
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
checkwake2 (TVar Bool
y : [TVar Bool]
ys) = do
let (TVar Bool
z :| [TVar Bool]
zs) = NonEmpty (TVar Bool) -> NonEmpty (TVar Bool)
forall a. NonEmpty a -> NonEmpty a
NE.reverse (TVar Bool
y TVar Bool -> [TVar Bool] -> NonEmpty (TVar Bool)
forall a. a -> [a] -> NonEmpty a
:| [TVar Bool]
ys)
TVar [TVar Bool] -> [TVar Bool] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [TVar Bool]
b1 [TVar Bool]
zs
TVar [TVar Bool] -> [TVar Bool] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [TVar Bool]
b2 []
IO () -> STM (IO ())
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return (QSem -> TVar Bool -> IO ()
wake QSem
s TVar Bool
z)