diff --git a/.gitignore b/.gitignore index d5c3c640..32dbadbd 100644 --- a/.gitignore +++ b/.gitignore @@ -25,3 +25,4 @@ cabal.project.local~ tags io-sim/tags README.haddock +*.vim diff --git a/io-classes/CHANGELOG.md b/io-classes/CHANGELOG.md index 03d0e27b..d22282d2 100644 --- a/io-classes/CHANGELOG.md +++ b/io-classes/CHANGELOG.md @@ -6,6 +6,7 @@ ### Breaking changes +- Added `MonadChan`, `MonadQSem` and `MonadQSemN` classes. * Added `threadLabel` to `MonadThread` * Added `MonadLabelledMVar` class. * Added `labelMVar` to `Control.Concurrent.Class.MonadMVar.Strict` diff --git a/io-classes/io-classes.cabal b/io-classes/io-classes.cabal index 41a26940..bdde95ed 100644 --- a/io-classes/io-classes.cabal +++ b/io-classes/io-classes.cabal @@ -67,7 +67,10 @@ library -- At this experiment/prototype stage everything is exposed. -- This has to be tidied up once the design becomes clear. - exposed-modules: Control.Concurrent.Class.MonadMVar + exposed-modules: Control.Concurrent.Class.MonadChan + Control.Concurrent.Class.MonadQSem + Control.Concurrent.Class.MonadQSemN + Control.Concurrent.Class.MonadMVar Control.Concurrent.Class.MonadSTM Control.Concurrent.Class.MonadSTM.TArray Control.Concurrent.Class.MonadSTM.TBQueue diff --git a/io-classes/src/Control/Concurrent/Class/MonadChan.hs b/io-classes/src/Control/Concurrent/Class/MonadChan.hs new file mode 100644 index 00000000..3d934062 --- /dev/null +++ b/io-classes/src/Control/Concurrent/Class/MonadChan.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Control.Concurrent.Class.MonadChan (MonadChan (..)) where + +import Control.Concurrent.Chan qualified as IO + +import Data.Kind (Type) + +class Monad m => MonadChan m where + {-# MINIMAL newChan, + writeChan, readChan, + dupChan, getChanContents #-} + + type Chan m :: Type -> Type + + -- | See 'IO.newChan. + newChan :: m (Chan m a) + -- | See 'IO.writeChan'. + writeChan :: Chan m a -> a -> m () + -- | See 'IO.readChan'. + readChan :: Chan m a -> m a + -- | See 'IO.dupChan'. + dupChan :: Chan m a -> m (Chan m a) + -- | See 'IO.getChanContents'. + getChanContents :: Chan m a -> m [a] + -- | See 'IO.writeList2Chan' + writeList2Chan :: Chan m a -> [a] -> m () + + default writeList2Chan :: Chan m a -> [a] -> m () + writeList2Chan ch ls = sequence_ (map (writeChan ch) ls) + {-# INLINE writeList2Chan #-} + +-- +-- IO instance +-- + +instance MonadChan IO where + type Chan IO = IO.Chan + + newChan = IO.newChan + writeChan = IO.writeChan + readChan = IO.readChan + dupChan = IO.dupChan + getChanContents = IO.getChanContents diff --git a/io-classes/src/Control/Concurrent/Class/MonadQSem.hs b/io-classes/src/Control/Concurrent/Class/MonadQSem.hs new file mode 100644 index 00000000..2c43d10b --- /dev/null +++ b/io-classes/src/Control/Concurrent/Class/MonadQSem.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TypeFamilies #-} + +module Control.Concurrent.Class.MonadQSem (MonadQSem (..)) where + +import Control.Concurrent.QSem qualified as IO + +import Data.Kind (Type) + +class Monad m => MonadQSem m where + {-# MINIMAL newQSem, waitQSem, signalQSem #-} + + type QSem m :: Type + + -- | See 'IO.newQSem. + newQSem :: Int -> m (QSem m) + -- | See 'IO.waitQSem'. + waitQSem :: QSem m -> m () + -- | See 'IO.signalQSem'. + signalQSem :: QSem m -> m () + +-- +-- IO instance +-- + +instance MonadQSem IO where + type QSem IO = IO.QSem + + newQSem = IO.newQSem + waitQSem = IO.waitQSem + signalQSem = IO.signalQSem diff --git a/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs b/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs new file mode 100644 index 00000000..c37d8538 --- /dev/null +++ b/io-classes/src/Control/Concurrent/Class/MonadQSemN.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TypeFamilies #-} + +module Control.Concurrent.Class.MonadQSemN (MonadQSemN (..)) where + +import Control.Concurrent.QSemN qualified as IO + +import Data.Kind (Type) + +class Monad m => MonadQSemN m where + {-# MINIMAL newQSemN, waitQSemN, signalQSemN #-} + + type QSemN m :: Type + + -- | See 'IO.newQSemN. + newQSemN :: Int -> m (QSemN m) + -- | See 'IO.waitQSemN'. + waitQSemN :: QSemN m -> Int -> m () + -- | See 'IO.signalQSemN'. + signalQSemN :: QSemN m -> Int -> m () + +-- +-- IO instance +-- + +instance MonadQSemN IO where + type QSemN IO = IO.QSemN + + newQSemN = IO.newQSemN + waitQSemN = IO.waitQSemN + signalQSemN = IO.signalQSemN + diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index e390cc6e..6b780eff 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -2,6 +2,7 @@ ## next version +- Implements `MonadChan`, `MonadQSem` and `MonadQSemN` instances. - Support `threadLabel` (`io-classes-1.8`) - `IOSimPOR`'s `Effect` traces now will correctly show labels on read/written `TVars`. diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index a7915964..d945eeea 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/io-sim/src/Control/Monad/IOSim/Types.hs @@ -82,7 +82,13 @@ import Control.Exception qualified as IO import Control.Monad import Control.Monad.Fix (MonadFix (..)) +import Control.Concurrent.Class.MonadChan hiding (Chan) +import Control.Concurrent.Class.MonadChan qualified as MonadAsync import Control.Concurrent.Class.MonadMVar +import Control.Concurrent.Class.MonadQSem hiding (QSem) +import Control.Concurrent.Class.MonadQSem qualified as MonadQSem +import Control.Concurrent.Class.MonadQSemN hiding (QSemN) +import Control.Concurrent.Class.MonadQSemN qualified as MonadQSemN import Control.Concurrent.Class.MonadSTM.Strict.TVar (StrictTVar) import Control.Concurrent.Class.MonadSTM.Strict.TVar qualified as StrictTVar import Control.Monad.Class.MonadAsync hiding (Async) @@ -118,7 +124,7 @@ import Data.Bifunctor (bimap) import Data.Dynamic (Dynamic, toDyn) import Data.List.Trace qualified as Trace import Data.Map.Strict (Map) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Monoid (Endo (..)) import Data.Semigroup (Max (..)) import Data.STRef.Lazy @@ -776,6 +782,151 @@ instance MonadEventlog (IOSim s) where traceEventIO = traceM . EventlogEvent traceMarkerIO = traceM . EventlogMarker +data Chan m a + = Chan (MVar m (Stream m a)) + (MVar m (Stream m a)) + +type Stream m a = MVar m (ChanItem m a) + +data ChanItem m a = ChanItem a (Stream m a) + +instance MonadChan (IOSim s) where + type Chan (IOSim s) = Chan (IOSim s) + + newChan = do + hole <- newEmptyMVar + readVar <- newMVar hole + writeVar <- newMVar hole + return (Chan readVar writeVar) + + writeChan (Chan _ writeVar) val = do + new_hole <- newEmptyMVar + mask_ $ do + old_hole <- takeMVar writeVar + putMVar old_hole (ChanItem val new_hole) + putMVar writeVar new_hole + + readChan (Chan readVar _) = + modifyMVar readVar $ \read_end -> do + (ChanItem val new_read_end) <- readMVar read_end + return (new_read_end, val) + + dupChan (Chan _ writeVar) = do + hole <- readMVar writeVar + newReadVar <- newMVar hole + return (Chan newReadVar writeVar) + + getChanContents ch = do + x <- readChan ch + xs <- getChanContents ch + return (x:xs) + +newtype QSem m = QSem (MVar m (Int, [MVar m ()], [MVar m ()])) + +signal + :: MonadMVar m + => (Int, [MVar m ()], [MVar m ()]) + -> m (Int, [MVar m ()], [MVar m ()]) +signal (i,a1,a2) = + if i == 0 + then loop a1 a2 + else let !z = i+1 in return (z, a1, a2) + where + loop [] [] = return (1, [], []) + loop [] b2 = loop (reverse b2) [] + loop (b:bs) b2 = do + r <- tryPutMVar b () + if r then return (0, bs, b2) + else loop bs b2 + +instance MonadQSem (IOSim s) where + type QSem (IOSim s) = QSem (IOSim s) + + newQSem initial + | initial < 0 = fail "newQSem: Initial quantity must be non-negative" + | otherwise = do + sem <- newMVar (initial, [], []) + return (QSem sem) + + waitQSem (QSem m) = + mask_ $ do + (i,b1,b2) <- takeMVar m + if i == 0 + then do + b <- newEmptyMVar + putMVar m (i, b1, b:b2) + uninterruptibleWait b + else do + let !z = i-1 + putMVar m (z, b1, b2) + return () + where + uninterruptibleWait b = + takeMVar b `onException` + uninterruptibleMask_ (do + (i,b1,b2) <- takeMVar m + r <- tryTakeMVar b + r' <- if isJust r + then signal (i,b1,b2) + else do putMVar b (); return (i,b1,b2) + putMVar m r') + signalQSem (QSem m) = + uninterruptibleMask_ $ do + r <- takeMVar m + r' <- signal r + putMVar m r' + +newtype QSemN m = QSemN (MVar m (Int, [(Int, MVar m ())], [(Int, MVar m ())])) + +data MaybeMV m a = JustMV !(MVarDefault m a) + | NothingMV + +instance MonadQSemN (IOSim s) where + type QSemN (IOSim s) = QSemN (IOSim s) + + newQSemN initial + | initial < 0 = fail "newQSemN: Initial quantity must be non-negative" + | otherwise = do + sem <- newMVar (initial, [], []) + return (QSemN sem) + + waitQSemN qs@(QSemN m) sz = mask_ $ do + mmvar <- modifyMVar m $ \ (i,b1,b2) -> do + let z = i-sz + if z < 0 + then do + b <- newEmptyMVar + return ((i, b1, (sz,b):b2), JustMV b) + else return ((z, b1, b2), NothingMV) + + case mmvar of + NothingMV -> return () + JustMV b -> wait' b + where + wait' :: MVar (IOSim s) () -> IOSim s () + wait' b = + takeMVar b `onException` do + already_filled <- not <$> tryPutMVar b () + when already_filled $ signalQSemN qs sz + + signalQSemN (QSemN m) sz0 = do + unit <- modifyMVar m $ \(i,a1,a2) -> loop (sz0 + i) a1 a2 + + evaluate unit + where + loop 0 bs b2 = return ((0, bs, b2), ()) + loop sz [] [] = return ((sz, [], []), ()) + loop sz [] b2 = loop sz (reverse b2) [] + loop sz ((j,b):bs) b2 + | j > sz = do + r <- isEmptyMVar b + if r then return ((sz, (j,b):bs, b2), ()) + else loop sz bs b2 + | otherwise = do + r <- tryPutMVar b () + if r then loop (sz-j) bs b2 + else loop sz bs b2 + -- | 'Trace' is a recursive data type, it is the trace of a 'IOSim' -- computation. The trace will contain information about thread scheduling, -- blocking on 'TVar's, and other internal state changes of 'IOSim'. More