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