(original) (raw)

{-# LANGUAGE Trustworthy #-} {-# OPTIONS_GHC -funbox-strict-fields #-}

module Control.Concurrent.QSemN (
QSemN,
newQSemN,
waitQSemN,
signalQSemN
) where

import Control.Concurrent.MVar ( MVar, newEmptyMVar, takeMVar , tryPutMVar, isEmptyMVar) import Control.Exception import Control.Monad (when) import Data.IORef (IORef, newIORef, atomicModifyIORef) import System.IO.Unsafe (unsafePerformIO)

data QSemN = QSemN !(IORef (Int, [(Int, MVar ())], [(Int, MVar ())]))

newQSemN :: Int -> IO QSemN newQSemN :: Int -> IO QSemN newQSemN Int initial | Int initial Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 = String -> IO QSemN forall (m :: * -> *) a. MonadFail m => String -> m a fail String "newQSemN: Initial quantity must be non-negative" | Bool otherwise = do IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) sem <- (Int, [(Int, MVar ())], [(Int, MVar ())]) -> IO (IORef (Int, [(Int, MVar ())], [(Int, MVar ())])) forall a. a -> IO (IORef a) newIORef (Int initial, [], []) QSemN -> IO QSemN forall (m :: * -> *) a. Monad m => a -> m a return (IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) -> QSemN QSemN IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) sem)

data MaybeMV a = JustMV !(MVar a) | NothingMV

waitQSemN :: QSemN -> Int -> IO ()

waitQSemN :: QSemN -> Int -> IO () waitQSemN qs :: QSemN qs@(QSemN IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) m) Int sz = IO () -> IO () forall a. IO a -> IO a mask_ (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ do

MaybeMV () mmvar <- IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ())) -> IO (MaybeMV ()) forall a b. IORef a -> (a -> (a, b)) -> IO b atomicModifyIORef IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) m (((Int, [(Int, MVar ())], [(Int, MVar ())]) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ())) -> IO (MaybeMV ())) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ())) -> IO (MaybeMV ()) forall a b. (a -> b) -> a -> b $ \ (Int i,[(Int, MVar ())] b1,[(Int, MVar ())] b2) -> IO ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) forall a. IO a -> a unsafePerformIO (IO ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ())) -> IO ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) forall a b. (a -> b) -> a -> b $ do let z :: Int z = Int iInt -> Int -> Int forall a. Num a => a -> a -> a -Int sz if Int z Int -> Int -> Bool forall a. Ord a => a -> a -> Bool < Int 0 then do MVar () b <- IO (MVar ()) forall a. IO (MVar a) newEmptyMVar ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) -> IO ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) forall (m :: * -> *) a. Monad m => a -> m a return ((Int i, [(Int, MVar ())] b1, (Int sz,MVar () b)(Int, MVar ()) -> [(Int, MVar ())] -> [(Int, MVar ())] forall a. a -> [a] -> [a] :[(Int, MVar ())] b2), MVar () -> MaybeMV () forall a. MVar a -> MaybeMV a JustMV MVar () b) else ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) -> IO ((Int, [(Int, MVar ())], [(Int, MVar ())]), MaybeMV ()) forall (m :: * -> *) a. Monad m => a -> m a return ((Int z, [(Int, MVar ())] b1, [(Int, MVar ())] b2), MaybeMV () forall a. MaybeMV a NothingMV)

case MaybeMV () mmvar of MaybeMV () NothingMV -> () -> IO () forall (m :: * -> *) a. Monad m => a -> m a return () JustMV MVar () b -> MVar () -> IO () wait MVar () b where wait :: MVar () -> IO () wait :: MVar () -> IO () wait MVar () b = MVar () -> IO () forall a. MVar a -> IO a takeMVar MVar () b IO () -> IO () -> IO () forall a b. IO a -> IO b -> IO a onException do Bool already_filled <- Bool -> Bool not (Bool -> Bool) -> IO Bool -> IO Bool forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> MVar () -> () -> IO Bool forall a. MVar a -> a -> IO Bool tryPutMVar MVar () b () Bool -> IO () -> IO () forall (f :: * -> *). Applicative f => Bool -> f () -> f () when Bool already_filled (IO () -> IO ()) -> IO () -> IO () forall a b. (a -> b) -> a -> b $ QSemN -> Int -> IO () signalQSemN QSemN qs Int sz

signalQSemN :: QSemN -> Int -> IO ()

signalQSemN :: QSemN -> Int -> IO () signalQSemN (QSemN IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) m) Int sz0 = do

() unit <- IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), ())) -> IO () forall a b. IORef a -> (a -> (a, b)) -> IO b atomicModifyIORef IORef (Int, [(Int, MVar ())], [(Int, MVar ())]) m (((Int, [(Int, MVar ())], [(Int, MVar ())]) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), ())) -> IO ()) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), ())) -> IO () forall a b. (a -> b) -> a -> b $ (Int i,[(Int, MVar ())] a1,[(Int, MVar ())] a2) -> IO ((Int, [(Int, MVar ())], [(Int, MVar ())]), ()) -> ((Int, [(Int, MVar ())], [(Int, MVar ())]), ()) forall a. IO a -> a unsafePerformIO (Int -> [(Int, MVar ())] -> [(Int, MVar ())] -> IO ((Int, [(Int, MVar ())], [(Int, MVar ())]), ()) forall {a}. (Num a, Ord a) => a -> [(a, MVar ())] -> [(a, MVar ())] -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) loop (Int sz0 Int -> Int -> Int forall a. Num a => a -> a -> a + Int i) [(Int, MVar ())] a1 [(Int, MVar ())] a2)

() -> IO () forall a. a -> IO a evaluate () unit where loop :: a -> [(a, MVar ())] -> [(a, MVar ())] -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) loop a 0 [(a, MVar ())] bs [(a, MVar ())] b2 = ((a, [(a, MVar ())], [(a, MVar ())]), ()) -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) forall (m :: * -> *) a. Monad m => a -> m a return ((a 0, [(a, MVar ())] bs, [(a, MVar ())] b2), ()) loop a sz [] [] = ((a, [(a, MVar ())], [(a, MVar ())]), ()) -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) forall (m :: * -> *) a. Monad m => a -> m a return ((a sz, [], []), ()) loop a sz [] [(a, MVar ())] b2 = a -> [(a, MVar ())] -> [(a, MVar ())] -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) loop a sz ([(a, MVar ())] -> [(a, MVar ())] forall a. [a] -> [a] reverse [(a, MVar ())] b2) [] loop a sz ((a j,MVar () b):[(a, MVar ())] bs) [(a, MVar ())] b2 | a j a -> a -> Bool forall a. Ord a => a -> a -> Bool > a sz = do Bool r <- MVar () -> IO Bool forall a. MVar a -> IO Bool isEmptyMVar MVar () b if Bool r then ((a, [(a, MVar ())], [(a, MVar ())]), ()) -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) forall (m :: * -> *) a. Monad m => a -> m a return ((a sz, (a j,MVar () b)(a, MVar ()) -> [(a, MVar ())] -> [(a, MVar ())] forall a. a -> [a] -> [a] :[(a, MVar ())] bs, [(a, MVar ())] b2), ()) else a -> [(a, MVar ())] -> [(a, MVar ())] -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) loop a sz [(a, MVar ())] bs [(a, MVar ())] b2 | Bool otherwise = do Bool r <- MVar () -> () -> IO Bool forall a. MVar a -> a -> IO Bool tryPutMVar MVar () b () if Bool r then a -> [(a, MVar ())] -> [(a, MVar ())] -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) loop (a sza -> a -> a forall a. Num a => a -> a -> a -a j) [(a, MVar ())] bs [(a, MVar ())] b2 else a -> [(a, MVar ())] -> [(a, MVar ())] -> IO ((a, [(a, MVar ())], [(a, MVar ())]), ()) loop a sz [(a, MVar ())] bs [(a, MVar ())] b2