diff --git a/Control/Concurrent/Classy.hs b/Control/Concurrent/Classy.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy.hs @@ -0,0 +1,40 @@ +-- | +-- Module : Control.Concurrent.Classy +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : non-portable +-- +-- Classy concurrency. +-- +-- Concurrency is \"lightweight\", which means that both thread +-- creation and context switching overheads are extremely +-- low. Scheduling of Haskell threads is done internally in the +-- Haskell runtime system, and doesn't make use of any operating +-- system-supplied thread packages. +-- +-- Haskell threads can communicate via @MVar@s, a kind of synchronised +-- mutable variable (see "Control.Concurrent.Classy.MVar"). Several +-- common concurrency abstractions can be built from @MVar@s, and +-- these are provided by the "Control.Concurrent.Classy" +-- library. Threads may also communicate via exceptions. +module Control.Concurrent.Classy + ( module Control.Monad.Conc.Class + , module Control.Concurrent.Classy.Chan + , module Control.Concurrent.Classy.CRef + , module Control.Concurrent.Classy.MVar + , module Control.Concurrent.Classy.STM + , module Control.Concurrent.Classy.QSem + , module Control.Concurrent.Classy.QSemN + ) where + +import Control.Monad.Conc.Class +import Control.Concurrent.Classy.Chan +import Control.Concurrent.Classy.CRef +import Control.Concurrent.Classy.MVar +import Control.Concurrent.Classy.STM +import Control.Concurrent.Classy.QSem +import Control.Concurrent.Classy.QSemN + +{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-} diff --git a/Control/Concurrent/Classy/CRef.hs b/Control/Concurrent/Classy/CRef.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/CRef.hs @@ -0,0 +1,114 @@ +-- | +-- Module : Control.Concurrent.Classy.CRef +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- Mutable references in a concurrency monad. +-- +-- __Deviations:__ There is no @Eq@ instance for @MonadConc@ the +-- @CRef@ type. Furthermore, the @mkWeakIORef@ function is not +-- provided. +module Control.Concurrent.Classy.CRef + ( -- * CRefs + newCRef + , readCRef + , writeCRef + , modifyCRef + , modifyCRef' + , atomicModifyCRef + , atomicModifyCRef' + , atomicWriteCRef + + -- * Memory Model + + -- | In a concurrent program, @CRef@ operations may appear + -- out-of-order to another thread, depending on the memory model of + -- the underlying processor architecture. For example, on x86 (which + -- uses total store order), loads can move ahead of stores. Consider + -- this example: + -- + -- > crefs :: MonadConc m => m (Bool, Bool) + -- > crefs = do + -- > r1 <- newCRef False + -- > r2 <- newCRef False + -- > + -- > x <- spawn $ writeCRef r1 True >> readCRef r2 + -- > y <- spawn $ writeCRef r2 True >> readCRef r1 + -- > + -- > (,) <$> readMVar x <*> readMVar y + -- + -- Under a sequentially consistent memory model the possible results + -- are @(True, True)@, @(True, False)@, and @(False, True)@. Under + -- total or partial store order, @(False, False)@ is also a possible + -- result, even though there is no interleaving of the threads which + -- can lead to this. + -- + -- We can see this by testing with different memory models: + -- + -- > > autocheck' SequentialConsistency crefs + -- > [pass] Never Deadlocks (checked: 6) + -- > [pass] No Exceptions (checked: 6) + -- > [fail] Consistent Result (checked: 5) + -- > (False,True) S0-------S1-----S0--S2-----S0--- + -- > (True,False) S0-------S1-P2-----S1----S0---- + -- > (True,True) S0-------S1--P2-----S1---S0---- + -- > (False,True) S0-------S1---P2-----S1--S0---- + -- > (True,False) S0-------S2-----S1-----S0---- + -- > ... + -- > False + -- + -- > > autocheck' TotalStoreOrder crefs + -- > [pass] Never Deadlocks (checked: 303) + -- > [pass] No Exceptions (checked: 303) + -- > [fail] Consistent Result (checked: 302) + -- > (False,True) S0-------S1-----C-S0--S2-----C-S0--- + -- > (True,False) S0-------S1-P2-----C-S1----S0---- + -- > (True,True) S0-------S1-P2--C-S1----C-S0--S2---S0--- + -- > (False,True) S0-------S1-P2--P1--C-C-S1--S0--S2---S0--- + -- > (False,False) S0-------S1-P2--P1----S2---C-C-S0---- + -- > ... + -- > False + -- + -- Traces for non-sequentially-consistent memory models show where + -- writes to @CRef@s are /committed/, which makes a write visible to + -- all threads rather than just the one which performed the + -- write. Only 'writeCRef' is broken up into separate write and + -- commit steps, 'atomicModifyCRef' is still atomic and imposes a + -- memory barrier. + ) where + +import Control.Monad.Conc.Class + +-- | Mutate the contents of a @CRef@. +-- +-- Be warned that 'modifyCRef' does not apply the function strictly. +-- This means if the program calls 'modifyCRef' many times, but +-- seldomly uses the value, thunks will pile up in memory resulting in +-- a space leak. This is a common mistake made when using a @CRef@ as +-- a counter. For example, the following will likely produce a stack +-- overflow: +-- +-- >ref <- newCRef 0 +-- >replicateM_ 1000000 $ modifyCRef ref (+1) +-- >readCRef ref >>= print +-- +-- To avoid this problem, use 'modifyCRef'' instead. +modifyCRef :: MonadConc m => CRef m a -> (a -> a) -> m () +modifyCRef ref f = readCRef ref >>= writeCRef ref . f + +-- | Strict version of 'modifyCRef' +modifyCRef' :: MonadConc m => CRef m a -> (a -> a) -> m () +modifyCRef' ref f = do + x <- readCRef ref + writeCRef ref $! f x + +-- | Strict version of 'atomicModifyCRef'. This forces both the value +-- stored in the @CRef@ as well as the value returned. +atomicModifyCRef' :: MonadConc m => CRef m a -> (a -> (a,b)) -> m b +atomicModifyCRef' ref f = do + b <- atomicModifyCRef ref $ \a -> case f a of + v@(a',_) -> a' `seq` v + pure $! b diff --git a/Control/Concurrent/Classy/Chan.hs b/Control/Concurrent/Classy/Chan.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/Chan.hs @@ -0,0 +1,79 @@ +-- | +-- Module : Control.Concurrent.Classy.Chan +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- Unbounded channels. +-- +-- __Deviations:__ @Chan@ as defined here does not have an @Eq@ +-- instance, this is because the @MonadConc@ @MVar@ type does not have +-- an @Eq@ constraint. The deprecated @unGetChan@ and @isEmptyCHan@ +-- functions are not provided. Furthermore, the @getChanContents@ +-- function is not provided as it needs unsafe I/O. +module Control.Concurrent.Classy.Chan + ( -- * The 'Chan' type + Chan + + -- * Operations + , newChan + , writeChan + , readChan + , dupChan + + -- * Stream interface + , writeList2Chan + ) where + +import Control.Concurrent.Classy.MVar +import Control.Monad.Catch (mask_) +import Control.Monad.Conc.Class (MonadConc) + +-- | 'Chan' is an abstract type representing an unbounded FIFO +-- channel. +data Chan m a + = Chan (MVar m (Stream m a)) + (MVar m (Stream m a)) -- Invariant: the Stream a is always an empty MVar + +type Stream m a = MVar m (ChItem m a) + +data ChItem m a = ChItem a (Stream m a) + +-- | Build and returns a new instance of 'Chan'. +newChan :: MonadConc m => m (Chan m a) +newChan = do + hole <- newEmptyMVar + readVar <- newMVar hole + writeVar <- newMVar hole + pure (Chan readVar writeVar) + +-- | Write a value to a 'Chan'. +writeChan :: MonadConc m => Chan m a -> a -> m () +writeChan (Chan _ writeVar) val = do + new_hole <- newEmptyMVar + mask_ $ do + old_hole <- takeMVar writeVar + putMVar old_hole (ChItem val new_hole) + putMVar writeVar new_hole + +-- | Read the next value from the 'Chan'. +readChan :: MonadConc m => Chan m a -> m a +readChan (Chan readVar _) = modifyMVarMasked readVar $ \read_end -> do + (ChItem val new_read_end) <- readMVar read_end + pure (new_read_end, val) + +-- | Duplicate a 'Chan': the duplicate channel begins empty, but data +-- written to either channel from then on will be available from both. +-- Hence this creates a kind of broadcast channel, where data written +-- by anyone is seen by everyone else. +dupChan :: MonadConc m => Chan m a -> m (Chan m a) +dupChan (Chan _ writeVar) = do + hole <- readMVar writeVar + newReadVar <- newMVar hole + pure (Chan newReadVar writeVar) + +-- | Write an entire list of items to a 'Chan'. +writeList2Chan :: MonadConc m => Chan m a -> [a] -> m () +writeList2Chan = mapM_ . writeChan diff --git a/Control/Concurrent/Classy/MVar.hs b/Control/Concurrent/Classy/MVar.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/MVar.hs @@ -0,0 +1,128 @@ +-- | +-- Module : Control.Concurrent.Classy.MVar +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- An @'MVar' t@ is mutable location that is either empty or contains +-- a value of type @t@. It has two fundamental operations: 'putMVar' +-- which fills an 'MVar' if it is empty and blocks otherwise, and +-- 'takeMVar' which empties an 'MVar' if it is full and blocks +-- otherwise. They can be used in multiple different ways: +-- +-- 1. As synchronized mutable variables, +-- +-- 2. As channels, with 'takeMVar' and 'putMVar' as receive and +-- send, and +-- +-- 3. As a binary semaphore @'MVar' ()@, with 'takeMVar' and +-- 'putMVar' as wait and signal. +-- +-- __Deviations:__ There is no @Eq@ instance for @MonadConc@ the +-- @MVar@ type. Furthermore, the @mkWeakMVar@ and @addMVarFinalizer@ +-- functions are not provided. Finally, normal @MVar@s have a fairness +-- guarantee, which dejafu does not currently make use of when +-- generating schedules to test, so your program may be tested with +-- /unfair/ schedules. +module Control.Concurrent.Classy.MVar + ( -- *@MVar@s + MVar + , newEmptyMVar + , newEmptyMVarN + , newMVar + , newMVarN + , takeMVar + , putMVar + , readMVar + , swapMVar + , tryTakeMVar + , tryPutMVar + , isEmptyMVar + , withMVar + , withMVarMasked + , modifyMVar_ + , modifyMVar + , modifyMVarMasked_ + , modifyMVarMasked + ) where + +import Control.Monad.Catch (mask_, onException) +import Control.Monad.Conc.Class + +-- | Swap the contents of a @MVar@, and return the value taken. This +-- function is atomic only if there are no other producers fro this +-- @MVar@. +swapMVar :: MonadConc m => MVar m a -> a -> m a +swapMVar cvar a = mask_ $ do + old <- takeMVar cvar + putMVar cvar a + return old + +-- | Check if a @MVar@ is empty. +isEmptyMVar :: MonadConc m => MVar m a -> m Bool +isEmptyMVar cvar = do + val <- tryTakeMVar cvar + case val of + Just val' -> putMVar cvar val' >> return True + Nothing -> return False + +-- | Operate on the contents of a @MVar@, replacing the contents after +-- finishing. This operation is exception-safe: it will replace the +-- original contents of the @MVar@ if an exception is raised. However, +-- it is only atomic if there are no other producers for this @MVar@. +{-# INLINE withMVar #-} +withMVar :: MonadConc m => MVar m a -> (a -> m b) -> m b +withMVar cvar f = mask $ \restore -> do + val <- takeMVar cvar + out <- restore (f val) `onException` putMVar cvar val + putMVar cvar val + + return out + +-- | Like 'withMVar', but the @IO@ action in the second argument is +-- executed with asynchronous exceptions masked. +{-# INLINE withMVarMasked #-} +withMVarMasked :: MonadConc m => MVar m a -> (a -> m b) -> m b +withMVarMasked cvar f = mask_ $ do + val <- takeMVar cvar + out <- f val `onException` putMVar cvar val + putMVar cvar val + + return out + +-- | An exception-safe wrapper for modifying the contents of a @MVar@. +-- Like 'withMVar', 'modifyMVar' will replace the original contents of +-- the @MVar@ if an exception is raised during the operation. This +-- function is only atomic if there are no other producers for this +-- @MVar@. +{-# INLINE modifyMVar_ #-} +modifyMVar_ :: MonadConc m => MVar m a -> (a -> m a) -> m () +modifyMVar_ cvar f = modifyMVar cvar $ fmap (\a -> (a,())) . f + +-- | A slight variation on 'modifyMVar_' that allows a value to be +-- returned (@b@) in addition to the modified value of the @MVar@. +{-# INLINE modifyMVar #-} +modifyMVar :: MonadConc m => MVar m a -> (a -> m (a, b)) -> m b +modifyMVar cvar f = mask $ \restore -> do + val <- takeMVar cvar + (val', out) <- restore (f val) `onException` putMVar cvar val + putMVar cvar val' + return out + +-- | Like 'modifyMVar_', but the @IO@ action in the second argument is +-- executed with asynchronous exceptions masked. +{-# INLINE modifyMVarMasked_ #-} +modifyMVarMasked_ :: MonadConc m => MVar m a -> (a -> m a) -> m () +modifyMVarMasked_ cvar f = modifyMVarMasked cvar $ fmap (\a -> (a,())) . f + +-- | Like 'modifyMVar', but the @IO@ action in the second argument is +-- executed with asynchronous exceptions masked. +{-# INLINE modifyMVarMasked #-} +modifyMVarMasked :: MonadConc m => MVar m a -> (a -> m (a, b)) -> m b +modifyMVarMasked cvar f = mask_ $ do + val <- takeMVar cvar + (val', out) <- f val `onException` putMVar cvar val + putMVar cvar val' + return out diff --git a/Control/Concurrent/Classy/QSem.hs b/Control/Concurrent/Classy/QSem.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/QSem.hs @@ -0,0 +1,45 @@ +-- | +-- Module : Control.Concurrent.Classy.QSem +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- Simple quantity semaphores. +module Control.Concurrent.Classy.QSem + ( -- * Simple Quantity Semaphores + QSem + , newQSem + , waitQSem + , signalQSem + ) where + +import Control.Concurrent.Classy.QSemN +import Control.Monad.Conc.Class (MonadConc) + +-- | @QSem@ is a quantity semaphore in which the resource is acquired +-- and released in units of one. It provides guaranteed FIFO ordering +-- for satisfying blocked 'waitQSem' calls. +-- +-- The pattern +-- +-- > bracket_ qaitQSem signalSSem (...) +-- +-- is safe; it never loses a unit of the resource. +newtype QSem m = QSem (QSemN m) + +-- | Build a new 'QSem' with a supplied initial quantity. The initial +-- quantity must be at least 0. +newQSem :: MonadConc m => Int -> m (QSem m) +newQSem initial + | initial < 0 = fail "newQSem: Initial quantity mus tbe non-negative." + | otherwise = QSem <$> newQSemN initial + +-- | Wait for a unit to become available. +waitQSem :: MonadConc m => QSem m -> m () +waitQSem (QSem qSemN) = waitQSemN qSemN 1 + +-- | Signal that a unit of the 'QSem' is available. +signalQSem :: MonadConc m => QSem m -> m () +signalQSem (QSem qSemN) = signalQSemN qSemN 1 diff --git a/Control/Concurrent/Classy/QSemN.hs b/Control/Concurrent/Classy/QSemN.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/QSemN.hs @@ -0,0 +1,97 @@ +-- | +-- Module : Control.Concurrent.Classy.QSemN +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- Quantity semaphores in which each thread may wait for an arbitrary +-- \"amount\". +module Control.Concurrent.Classy.QSemN + ( -- * General Quantity Semaphores + QSemN + , newQSemN + , waitQSemN + , signalQSemN + ) where + +import Control.Monad.Conc.Class (MonadConc) +import Control.Concurrent.Classy.MVar +import Control.Monad.Catch (mask_, onException, uninterruptibleMask_) +import Data.Maybe + +-- | 'QSemN' is a quantity semaphore in which the resource is aqcuired +-- and released in units of one. It provides guaranteed FIFO ordering +-- for satisfying blocked `waitQSemN` calls. +-- +-- The pattern +-- +-- > bracket_ (waitQSemN n) (signalQSemN n) (...) +-- +-- is safe; it never loses any of the resource. +newtype QSemN m = QSemN (MVar m (Int, [(Int, MVar m ())], [(Int, MVar m ())])) + +-- | Build a new 'QSemN' with a supplied initial quantity. +-- The initial quantity must be at least 0. +newQSemN :: MonadConc m => Int -> m (QSemN m) +newQSemN initial + | initial < 0 = fail "newQSemN: Initial quantity must be non-negative" + | otherwise = QSemN <$> newMVar (initial, [], []) + +-- | Wait for the specified quantity to become available +waitQSemN :: MonadConc m => QSemN m -> Int -> m () +waitQSemN (QSemN m) sz = mask_ $ do + (quantity, b1, b2) <- takeMVar m + let remaining = quantity - sz + if remaining < 0 + -- Enqueue and block the thread + then do + b <- newEmptyMVar + putMVar m (quantity, b1, (sz,b):b2) + wait b + -- Claim the resource + else + putMVar m (remaining, b1, b2) + + where + wait b = takeMVar b `onException` uninterruptibleMask_ (do + (quantity, b1, b2) <- takeMVar m + r <- tryTakeMVar b + r' <- if isJust r + then signal sz (quantity, b1, b2) + else putMVar b () >> pure (quantity, b1, b2) + putMVar m r') + +-- | Signal that a given quantity is now available from the 'QSemN'. +signalQSemN :: MonadConc m => QSemN m -> Int -> m () +signalQSemN (QSemN m) sz = uninterruptibleMask_ $ do + r <- takeMVar m + r' <- signal sz r + putMVar m r' + +-- | Fix the queue and signal as many threads as we can. +signal :: MonadConc m + => Int + -> (Int, [(Int,MVar m ())], [(Int,MVar m ())]) + -> m (Int, [(Int,MVar m ())], [(Int,MVar m ())]) +signal sz0 (i,a1,a2) = loop (sz0 + i) a1 a2 where + -- No more resource left, done. + loop 0 bs b2 = pure (0, bs, b2) + + -- Fix the queue + loop sz [] [] = pure (sz, [], []) + loop sz [] b2 = loop sz (reverse b2) [] + + -- Signal as many threads as there is enough resource to satisfy, + -- stopping as soon as one thread requires more resource than there + -- is. + loop sz ((j,b):bs) b2 + | j > sz = do + r <- isEmptyMVar b + if r then pure (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 diff --git a/Control/Concurrent/Classy/STM.hs b/Control/Concurrent/Classy/STM.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/STM.hs @@ -0,0 +1,28 @@ +-- | +-- Module : Control.Concurrent.Classy.STM +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : non-portable +-- +-- Classy software transactional memory. +module Control.Concurrent.Classy.STM + ( module Control.Monad.STM.Class + , module Control.Concurrent.Classy.STM.TVar + , module Control.Concurrent.Classy.STM.TMVar + , module Control.Concurrent.Classy.STM.TChan + , module Control.Concurrent.Classy.STM.TQueue + , module Control.Concurrent.Classy.STM.TBQueue + , module Control.Concurrent.Classy.STM.TArray + ) where + +import Control.Monad.STM.Class +import Control.Concurrent.Classy.STM.TVar +import Control.Concurrent.Classy.STM.TMVar +import Control.Concurrent.Classy.STM.TChan +import Control.Concurrent.Classy.STM.TQueue +import Control.Concurrent.Classy.STM.TBQueue +import Control.Concurrent.Classy.STM.TArray + +{-# ANN module ("HLint: ignore Use import/export shortcut" :: String) #-} diff --git a/Control/Concurrent/Classy/STM/TArray.hs b/Control/Concurrent/Classy/STM/TArray.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/STM/TArray.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} + +-- | +-- Module : Control.Concurrent.Classy.STM. +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : FlexibleInstances, MultiParamTypeClasses +-- +-- TArrays: transactional arrays, for use in STM-like monads. +-- +-- __Deviations:__ @TArray@ as defined here does not have an @Eq@ +-- instance, this is because the @MonadSTM@ @TVar@ type does not have +-- an @Eq@ constraint. +module Control.Concurrent.Classy.STM.TArray (TArray) where + +import Data.Array (Array, bounds) +import Data.Array.Base (listArray, arrEleBottom, unsafeAt, MArray(..), + IArray(numElements)) +import Data.Ix (rangeSize) + +import Control.Monad.STM.Class + +-- | @TArray@ is a transactional array, supporting the usual 'MArray' +-- interface for mutable arrays. +-- +-- It is currently implemented as @Array ix (TVar stm e)@, but it may +-- be replaced by a more efficient implementation in the future (the +-- interface will remain the same, however). +newtype TArray stm i e = TArray (Array i (TVar stm e)) + +instance MonadSTM stm => MArray (TArray stm) e stm where + getBounds (TArray a) = pure (bounds a) + + newArray b e = do + a <- rep (rangeSize b) (newTVar e) + pure $ TArray (listArray b a) + + newArray_ b = newArray b arrEleBottom + + unsafeRead (TArray a) = readTVar . unsafeAt a + unsafeWrite (TArray a) = writeTVar . unsafeAt a + + getNumElements (TArray a) = pure (numElements a) + +-- | Like 'replicateM' but uses an accumulator to prevent stack overflows. +-- Unlike 'replicateM' the returned list is in reversed order. This +-- doesn't matter though since this function is only used to create +-- arrays with identical elements. +rep :: Monad m => Int -> m a -> m [a] +rep n m = go n [] where + go 0 xs = pure xs + go i xs = do + x <- m + go (i-1) (x:xs) diff --git a/Control/Concurrent/Classy/STM/TBQueue.hs b/Control/Concurrent/Classy/STM/TBQueue.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/STM/TBQueue.hs @@ -0,0 +1,146 @@ +-- | +-- Module : Control.Concurrent.Classy.STM.TBQueue +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- 'TBQueue' is a bounded version of 'TQueue'. The queue has a maximum +-- capacity set when it is created. If the queue already contains the +-- maximum number of elements, then 'writeTBQueue' blocks until an +-- element is removed from the queue. +-- +-- The implementation is based on the traditional purely-functional +-- queue representation that uses two lists to obtain amortised /O(1)/ +-- enqueue and dequeue operations. +-- +-- __Deviations:__ @TBQueue@ as defined here does not have an @Eq@ +-- instance, this is because the @MonadSTM@ @TVar@ type does not have +-- an @Eq@ constraint. Furthermore, the @newTBQueueIO@ function is not +-- provided. +module Control.Concurrent.Classy.STM.TBQueue + ( -- * TBQueue + TBQueue + , newTBQueue + , readTBQueue + , tryReadTBQueue + , peekTBQueue + , tryPeekTBQueue + , writeTBQueue + , unGetTBQueue + , isEmptyTBQueue + , isFullTBQueue + ) where + +import Control.Monad.STM.Class + +-- | 'TBQueue' is an abstract type representing a bounded FIFO +-- channel. +data TBQueue stm a + = TBQueue (TVar stm Int) + (TVar stm [a]) + (TVar stm Int) + (TVar stm [a]) + +-- | Build and returns a new instance of 'TBQueue' +newTBQueue :: MonadSTM stm + => Int -- ^ maximum number of elements the queue can hold + -> stm (TBQueue stm a) +newTBQueue size = do + readT <- newTVar [] + writeT <- newTVar [] + rsize <- newTVar 0 + wsize <- newTVar size + pure (TBQueue rsize readT wsize writeT) + +-- | Write a value to a 'TBQueue'; retries if the queue is full. +writeTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm () +writeTBQueue (TBQueue rsize _ wsize writeT) a = do + w <- readTVar wsize + if w /= 0 + then writeTVar wsize (w - 1) + else do + r <- readTVar rsize + if r /= 0 + then do + writeTVar rsize 0 + writeTVar wsize (r - 1) + else retry + listend <- readTVar writeT + writeTVar writeT (a:listend) + +-- | Read the next value from the 'TBQueue'. +readTBQueue :: MonadSTM stm => TBQueue stm a -> stm a +readTBQueue (TBQueue rsize readT _ writeT) = do + xs <- readTVar readT + r <- readTVar rsize + writeTVar rsize (r + 1) + case xs of + (x:xs') -> do + writeTVar readT xs' + pure x + [] -> do + ys <- readTVar writeT + case ys of + [] -> retry + _ -> do + let (z:zs) = reverse ys + writeTVar writeT [] + writeTVar readT zs + pure z + +-- | A version of 'readTBQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a) +tryReadTBQueue c = (Just <$> readTBQueue c) `orElse` pure Nothing + +-- | Get the next value from the @TBQueue@ without removing it, +-- retrying if the channel is empty. +peekTBQueue :: MonadSTM stm => TBQueue stm a -> stm a +peekTBQueue c = do + x <- readTBQueue c + unGetTBQueue c x + return x + +-- | A version of 'peekTBQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTBQueue :: MonadSTM stm => TBQueue stm a -> stm (Maybe a) +tryPeekTBQueue c = do + m <- tryReadTBQueue c + case m of + Nothing -> pure Nothing + Just x -> do + unGetTBQueue c x + pure m + +-- | Put a data item back onto a channel, where it will be the next item read. +-- Retries if the queue is full. +unGetTBQueue :: MonadSTM stm => TBQueue stm a -> a -> stm () +unGetTBQueue (TBQueue rsize readT wsize _) a = do + r <- readTVar rsize + if r > 0 + then writeTVar rsize (r - 1) + else do + w <- readTVar wsize + if w > 0 + then writeTVar wsize (w - 1) + else retry + xs <- readTVar readT + writeTVar readT (a:xs) + +-- | Returns 'True' if the supplied 'TBQueue' is empty. +isEmptyTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool +isEmptyTBQueue (TBQueue _ readT _ writeT) = do + xs <- readTVar readT + case xs of + (_:_) -> pure False + [] -> null <$> readTVar writeT + +-- | Returns 'True' if the supplied 'TBQueue' is full. +isFullTBQueue :: MonadSTM stm => TBQueue stm a -> stm Bool +isFullTBQueue (TBQueue rsize _ wsize _) = do + w <- readTVar wsize + if w > 0 + then pure False + else (>0) <$> readTVar rsize diff --git a/Control/Concurrent/Classy/STM/TChan.hs b/Control/Concurrent/Classy/STM/TChan.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/STM/TChan.hs @@ -0,0 +1,135 @@ +-- | +-- Module : Control.Concurrent.Classy.STM.TChan +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- Transactional channels +-- +-- __Deviations:__ @TChan@ as defined here does not have an @Eq@ +-- instance, this is because the @MonadSTM@ @TVar@ type does not have +-- an @Eq@ constraint. Furthermore, the @newTChanIO@ and +-- @newBroadcastTChanIO@ functions are not provided. +module Control.Concurrent.Classy.STM.TChan + ( -- * TChans + TChan + + -- * Construction + , newTChan + , newBroadcastTChan + , dupTChan + , cloneTChan + + -- * Reading and writing + , readTChan + , tryReadTChan + , peekTChan + , tryPeekTChan + , writeTChan + , unGetTChan + , isEmptyTChan + ) where + +import Control.Monad.STM.Class + +-- | 'TChan' is an abstract type representing an unbounded FIFO +-- channel. +data TChan stm a = TChan (TVar stm (TVarList stm a)) + (TVar stm (TVarList stm a)) + +type TVarList stm a = TVar stm (TList stm a) +data TList stm a = TNil | TCons a (TVarList stm a) + +-- |Build and return a new instance of 'TChan' +newTChan :: MonadSTM stm => stm (TChan stm a) +newTChan = do + hole <- newTVar TNil + readH <- newTVar hole + writeH <- newTVar hole + pure (TChan readH writeH) + +-- | Create a write-only 'TChan'. More precisely, 'readTChan' will 'retry' +-- even after items have been written to the channel. The only way to +-- read a broadcast channel is to duplicate it with 'dupTChan'. +newBroadcastTChan :: MonadSTM stm => stm (TChan stm a) +newBroadcastTChan = do + hole <- newTVar TNil + readT <- newTVar (error "reading from a TChan created by newBroadcastTChan; use dupTChan first") + writeT <- newTVar hole + pure (TChan readT writeT) + +-- | Write a value to a 'TChan'. +writeTChan :: MonadSTM stm => TChan stm a -> a -> stm () +writeTChan (TChan _ writeT) a = do + listend <- readTVar writeT + listend' <- newTVar TNil + writeTVar listend (TCons a listend') + writeTVar writeT listend' + +-- | Read the next value from the 'TChan'. +readTChan :: MonadSTM stm => TChan stm a -> stm a +readTChan tchan = tryReadTChan tchan >>= maybe retry pure + +-- | A version of 'readTChan' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a) +tryReadTChan (TChan readT _) = do + listhead <- readTVar readT + hd <- readTVar listhead + case hd of + TNil -> pure Nothing + TCons a tl -> do + writeTVar readT tl + pure (Just a) + +-- | Get the next value from the 'TChan' without removing it, +-- retrying if the channel is empty. +peekTChan :: MonadSTM stm => TChan stm a -> stm a +peekTChan tchan = tryPeekTChan tchan >>= maybe retry pure + +-- | A version of 'peekTChan' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTChan :: MonadSTM stm => TChan stm a -> stm (Maybe a) +tryPeekTChan (TChan readT _) = do + listhead <- readTVar readT + hd <- readTVar listhead + pure $ case hd of + TNil -> Nothing + TCons a _ -> Just a + +-- | Duplicate a 'TChan': the duplicate channel begins empty, but data written to +-- either channel from then on will be available from both. Hence +-- this creates a kind of broadcast channel, where data written by +-- anyone is seen by everyone else. +dupTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a) +dupTChan (TChan _ writeT) = do + hole <- readTVar writeT + readT' <- newTVar hole + return (TChan readT' writeT) + +-- | Put a data item back onto a channel, where it will be the next +-- item read. +unGetTChan :: MonadSTM stm => TChan stm a -> a -> stm () +unGetTChan (TChan readT _) a = do + listhead <- readTVar readT + head' <- newTVar (TCons a listhead) + writeTVar readT head' + +-- | Returns 'True' if the supplied 'TChan' is empty. +isEmptyTChan :: MonadSTM stm => TChan stm a -> stm Bool +isEmptyTChan (TChan readT _) = do + listhead <- readTVar readT + hd <- readTVar listhead + pure $ case hd of + TNil -> True + TCons _ _ -> False + +-- | Clone a 'TChan': similar to 'dupTChan', but the cloned channel starts with the +-- same content available as the original channel. +cloneTChan :: MonadSTM stm => TChan stm a -> stm (TChan stm a) +cloneTChan (TChan readT writeT) = do + readpos <- readTVar readT + readT' <- newTVar readpos + pure (TChan readT' writeT) diff --git a/Control/Concurrent/Classy/STM/TMVar.hs b/Control/Concurrent/Classy/STM/TMVar.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/STM/TMVar.hs @@ -0,0 +1,118 @@ +-- | +-- Module : Control.Concurrent.Classy.STM.TMVar +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- Transactional @MVar@s, for use with 'MonadSTM'. +-- +-- __Deviations:__ @TMVar@ as defined here does not have an @Eq@ +-- instance, this is because the @MonadSTM@ @TVar@ type does not have +-- an @Eq@ constraint. Furthermore, the @newTMVarIO@, +-- @newEmptyTMVarIO@, and @mkWeakTMVar@ functions are not provided. +module Control.Concurrent.Classy.STM.TMVar + ( -- * @TMVar@s + TMVar + , newTMVar + , newTMVarN + , newEmptyTMVar + , newEmptyTMVarN + , takeTMVar + , putTMVar + , readTMVar + , tryTakeTMVar + , tryPutTMVar + , tryReadTMVar + , isEmptyTMVar + , swapTMVar + ) where + +import Control.Monad (liftM, when, unless) +import Control.Monad.STM.Class +import Data.Maybe (isJust, isNothing) + +-- | A @TMVar@ is like an @MVar@ or a @mVar@, but using transactional +-- memory. As transactions are atomic, this makes dealing with +-- multiple @TMVar@s easier than wrangling multiple @mVar@s. +newtype TMVar stm a = TMVar (TVar stm (Maybe a)) + +-- | Create a 'TMVar' containing the given value. +newTMVar :: MonadSTM stm => a -> stm (TMVar stm a) +newTMVar = newTMVarN "" + +-- | Create a 'TMVar' containing the given value, with the given +-- name. +-- +-- Name conflicts are handled as usual for 'TVar's. The name is +-- prefixed with \"ctmvar-\". +newTMVarN :: MonadSTM stm => String -> a -> stm (TMVar stm a) +newTMVarN n a = do + let n' = if null n then "ctmvar" else "ctmvar-" ++ n + ctvar <- newTVarN n' $ Just a + return $ TMVar ctvar + +-- | Create a new empty 'TMVar'. +newEmptyTMVar :: MonadSTM stm => stm (TMVar stm a) +newEmptyTMVar = newEmptyTMVarN "" + +-- | Create a new empty 'TMVar' with the given name. +-- +-- Name conflicts are handled as usual for 'TVar's. The name is +-- prefixed with \"ctmvar-\". +newEmptyTMVarN :: MonadSTM stm => String -> stm (TMVar stm a) +newEmptyTMVarN n = do + let n' = if null n then "ctmvar" else "ctmvar-" ++ n + ctvar <- newTVarN n' Nothing + return $ TMVar ctvar + +-- | Take the contents of a 'TMVar', or 'retry' if it is empty. +takeTMVar :: MonadSTM stm => TMVar stm a -> stm a +takeTMVar ctmvar = do + taken <- tryTakeTMVar ctmvar + maybe retry return taken + +-- | Write to a 'TMVar', or 'retry' if it is full. +putTMVar :: MonadSTM stm => TMVar stm a -> a -> stm () +putTMVar ctmvar a = do + putted <- tryPutTMVar ctmvar a + unless putted retry + +-- | Read from a 'TMVar' without emptying, or 'retry' if it is empty. +readTMVar :: MonadSTM stm => TMVar stm a -> stm a +readTMVar ctmvar = do + readed <- tryReadTMVar ctmvar + maybe retry return readed + +-- | Try to take the contents of a 'TMVar', returning 'Nothing' if it +-- is empty. +tryTakeTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a) +tryTakeTMVar (TMVar ctvar) = do + val <- readTVar ctvar + when (isJust val) $ writeTVar ctvar Nothing + return val + +-- | Try to write to a 'TMVar', returning 'False' if it is full. +tryPutTMVar :: MonadSTM stm => TMVar stm a -> a -> stm Bool +tryPutTMVar (TMVar ctvar) a = do + val <- readTVar ctvar + when (isNothing val) $ writeTVar ctvar (Just a) + return $ isNothing val + +-- | Try to read from a 'TMVar' without emptying, returning 'Nothing' +-- if it is empty. +tryReadTMVar :: MonadSTM stm => TMVar stm a -> stm (Maybe a) +tryReadTMVar (TMVar ctvar) = readTVar ctvar + +-- | Check if a 'TMVar' is empty or not. +isEmptyTMVar :: MonadSTM stm => TMVar stm a -> stm Bool +isEmptyTMVar ctmvar = isNothing `liftM` tryReadTMVar ctmvar + +-- | Swap the contents of a 'TMVar' returning the old contents, or +-- 'retry' if it is empty. +swapTMVar :: MonadSTM stm => TMVar stm a -> a -> stm a +swapTMVar ctmvar a = do + val <- takeTMVar ctmvar + putTMVar ctmvar a + return val diff --git a/Control/Concurrent/Classy/STM/TQueue.hs b/Control/Concurrent/Classy/STM/TQueue.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/STM/TQueue.hs @@ -0,0 +1,113 @@ +-- | +-- Module : Control.Concurrent.Classy.STM.TQueue +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- A 'TQueue' is like a 'TChan', with two important differences: +-- +-- * it has faster throughput than both 'TChan' and 'Chan' (although +-- the costs are amortised, so the cost of individual operations +-- can vary a lot). +-- +-- * it does /not/ provide equivalents of the 'dupTChan' and +-- 'cloneTChan' operations. +-- +-- The implementation is based on the traditional purely-functional +-- queue representation that uses two lists to obtain amortised /O(1)/ +-- enqueue and dequeue operations. +-- +-- __Deviations:__ @TQueue@ as defined here does not have an @Eq@ +-- instance, this is because the @MonadSTM@ @TVar@ type does not have +-- an @Eq@ constraint. Furthermore, the @newTQueueIO@ function is not +-- provided. +module Control.Concurrent.Classy.STM.TQueue + ( -- * TQueue + TQueue + , newTQueue + , readTQueue + , tryReadTQueue + , peekTQueue + , tryPeekTQueue + , writeTQueue + , unGetTQueue + , isEmptyTQueue + ) where + +import Control.Monad.STM.Class + +-- | 'TQueue' is an abstract type representing an unbounded FIFO channel. +data TQueue stm a = TQueue (TVar stm [a]) + (TVar stm [a]) + +-- | Build and returns a new instance of 'TQueue' +newTQueue :: MonadSTM stm => stm (TQueue stm a) +newTQueue = do + readT <- newTVar [] + writeT <- newTVar [] + pure (TQueue readT writeT) + +-- | Write a value to a 'TQueue'. +writeTQueue :: MonadSTM stm => TQueue stm a -> a -> stm () +writeTQueue (TQueue _ writeT) a = do + listend <- readTVar writeT + writeTVar writeT (a:listend) + +-- | Read the next value from the 'TQueue'. +readTQueue :: MonadSTM stm => TQueue stm a -> stm a +readTQueue (TQueue readT writeT) = do + xs <- readTVar readT + case xs of + (x:xs') -> do + writeTVar readT xs' + pure x + [] -> do + ys <- readTVar writeT + case ys of + [] -> retry + _ -> case reverse ys of + [] -> error "readTQueue" + (z:zs) -> do + writeTVar writeT [] + writeTVar readT zs + pure z + +-- | A version of 'readTQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryReadTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a) +tryReadTQueue c = (Just <$> readTQueue c) `orElse` pure Nothing + +-- | Get the next value from the @TQueue@ without removing it, +-- retrying if the channel is empty. +peekTQueue :: MonadSTM stm => TQueue stm a -> stm a +peekTQueue c = do + x <- readTQueue c + unGetTQueue c x + pure x + +-- | A version of 'peekTQueue' which does not retry. Instead it +-- returns @Nothing@ if no value is available. +tryPeekTQueue :: MonadSTM stm => TQueue stm a -> stm (Maybe a) +tryPeekTQueue c = do + m <- tryReadTQueue c + case m of + Nothing -> pure Nothing + Just x -> do + unGetTQueue c x + pure m + +-- |Put a data item back onto a channel, where it will be the next item read. +unGetTQueue :: MonadSTM stm => TQueue stm a -> a -> stm () +unGetTQueue (TQueue readT _) a = do + xs <- readTVar readT + writeTVar readT (a:xs) + +-- |Returns 'True' if the supplied 'TQueue' is empty. +isEmptyTQueue :: MonadSTM stm => TQueue stm a -> stm Bool +isEmptyTQueue (TQueue readT writeT) = do + xs <- readTVar readT + case xs of + (_:_) -> pure False + [] -> null <$> readTVar writeT diff --git a/Control/Concurrent/Classy/STM/TVar.hs b/Control/Concurrent/Classy/STM/TVar.hs new file mode 100644 --- /dev/null +++ b/Control/Concurrent/Classy/STM/TVar.hs @@ -0,0 +1,62 @@ +-- | +-- Module : Control.Concurrent.Classy.STM.TVar +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : stable +-- Portability : portable +-- +-- Transactional variables, for use with 'MonadSTM'. +-- +-- __Deviations:__ There is no @Eq@ instance for @MonadSTM@ the @TVar@ +-- type. Furthermore, the @newTVarIO@ and @mkWeakTVar@ functions are +-- not provided. +module Control.Concurrent.Classy.STM.TVar + ( -- * @TVar@s + TVar + , newTVar + , newTVarN + , readTVar + , readTVarConc + , writeTVar + , modifyTVar + , modifyTVar' + , swapTVar + , registerDelay + ) where + +import Control.Monad.STM.Class +import Control.Monad.Conc.Class +import Data.Functor (void) + +-- * @TVar@s + +-- | Mutate the contents of a 'TVar'. This is non-strict. +modifyTVar :: MonadSTM stm => TVar stm a -> (a -> a) -> stm () +modifyTVar ctvar f = do + a <- readTVar ctvar + writeTVar ctvar $ f a + +-- | Mutate the contents of a 'TVar' strictly. +modifyTVar' :: MonadSTM stm => TVar stm a -> (a -> a) -> stm () +modifyTVar' ctvar f = do + a <- readTVar ctvar + writeTVar ctvar $! f a + +-- | Swap the contents of a 'TVar', returning the old value. +swapTVar :: MonadSTM stm => TVar stm a -> a -> stm a +swapTVar ctvar a = do + old <- readTVar ctvar + writeTVar ctvar a + return old + +-- | Set the value of returned 'TVar' to @True@ after a given number +-- of microseconds. The caveats associated with 'threadDelay' also +-- apply. +registerDelay :: MonadConc m => Int -> m (TVar (STM m) Bool) +registerDelay delay = do + var <- atomically (newTVar False) + void . fork $ do + threadDelay delay + atomically (writeTVar var True) + pure var diff --git a/Control/Monad/Conc/Class.hs b/Control/Monad/Conc/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/Conc/Class.hs @@ -0,0 +1,629 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Control.Monad.Conc.Class +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP, FlexibleContexts, PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies +-- +-- This module captures in a typeclass the interface of concurrency +-- monads. +-- +-- __Deviations:__ An instance of @MonadConc@ is not required to be +-- an instance of @MonadFix@, unlike @IO@. The @CRef@, @MVar@, and +-- @Ticket@ types are not required to be instances of @Show@ or @Eq@, +-- unlike their normal counterparts. The @threadCapability@, +-- @threadWaitRead@, @threadWaitWrite@, @threadWaitReadSTM@, +-- @threadWaitWriteSTM@, and @mkWeakThreadId@ functions are not +-- provided. The @threadDelay@ function is not required to delay the +-- thread, merely to yield it. Bound threads are not supported. The +-- @BlockedIndefinitelyOnMVar@ (and similar) exceptions are /not/ +-- thrown during testing, so do not rely on them at all. +module Control.Monad.Conc.Class + ( MonadConc(..) + + -- * Threads + , spawn + , forkFinally + , killThread + + -- ** Named Threads + , forkN + , forkOnN + + -- ** Bound Threads + + -- | @MonadConc@ does not support bound threads, if you need that + -- sort of thing you will have to use regular @IO@. + + , rtsSupportsBoundThreads + , isCurrentThreadBound + + -- * Exceptions + , throw + , catch + , mask + , uninterruptibleMask + + -- * Mutable State + , newMVar + , newMVarN + , cas + , peekTicket + + -- * Utilities for instance writers + , liftedF + , liftedFork + ) where + +-- for the class and utilities +import Control.Exception (Exception, AsyncException(ThreadKilled), SomeException) +import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask) +import qualified Control.Monad.Catch as Ca +import Control.Monad.STM.Class (MonadSTM, TVar, readTVar) +import Control.Monad.Trans.Control (MonadTransControl, StT, liftWith) +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable) + +-- for the 'IO' instance +import qualified Control.Concurrent as IO +import qualified Control.Concurrent.STM.TVar as IO +import qualified Control.Monad.STM as IO +import qualified Data.Atomics as IO +import qualified Data.IORef as IO + +-- for the transformer instances +import Control.Monad.Reader (ReaderT) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Identity (IdentityT) +import qualified Control.Monad.RWS.Lazy as RL +import qualified Control.Monad.RWS.Strict as RS +import qualified Control.Monad.State.Lazy as SL +import qualified Control.Monad.State.Strict as SS +import qualified Control.Monad.Writer.Lazy as WL +import qualified Control.Monad.Writer.Strict as WS + +{-# ANN module ("HLint: ignore Use const" :: String) #-} + +-- | @MonadConc@ is an abstraction over GHC's typical concurrency +-- abstraction. It captures the interface of concurrency monads in +-- terms of how they can operate on shared state and in the presence +-- of exceptions. +-- +-- Every @MonadConc@ has an associated 'MonadSTM', transactions of +-- which can be run atomically. +class ( Applicative m, Monad m + , MonadCatch m, MonadThrow m, MonadMask m + , MonadSTM (STM m) + , Ord (ThreadId m), Show (ThreadId m)) => MonadConc m where + + {-# MINIMAL + (forkWithUnmask | forkWithUnmaskN) + , (forkOnWithUnmask | forkOnWithUnmaskN) + , getNumCapabilities + , setNumCapabilities + , myThreadId + , yield + , (newEmptyMVar | newEmptyMVarN) + , putMVar + , tryPutMVar + , readMVar + , takeMVar + , tryTakeMVar + , (newCRef | newCRefN) + , atomicModifyCRef + , writeCRef + , readForCAS + , peekTicket' + , casCRef + , modifyCRefCAS + , atomically + , throwTo + #-} + + -- | The associated 'MonadSTM' for this class. + type STM m :: * -> * + + -- | The mutable reference type, like 'MVar's. This may contain one + -- value at a time, attempting to read or take from an \"empty\" + -- @MVar@ will block until it is full, and attempting to put to a + -- \"full\" @MVar@ will block until it is empty. + type MVar m :: * -> * + + -- | The mutable non-blocking reference type. These may suffer from + -- relaxed memory effects if functions outside the set @newCRef@, + -- @readCRef@, @atomicModifyCRef@, and @atomicWriteCRef@ are used. + type CRef m :: * -> * + + -- | When performing compare-and-swap operations on @CRef@s, a + -- @Ticket@ is a proof that a thread observed a specific previous + -- value. + type Ticket m :: * -> * + + -- | An abstract handle to a thread. + type ThreadId m :: * + + -- | Fork a computation to happen concurrently. Communication may + -- happen over @MVar@s. + -- + -- > fork ma = forkWithUnmask (\_ -> ma) + fork :: m () -> m (ThreadId m) + fork ma = forkWithUnmask (\_ -> ma) + + -- | Like 'fork', but the child thread is passed a function that can + -- be used to unmask asynchronous exceptions. This function should + -- not be used within a 'mask' or 'uninterruptibleMask'. + -- + -- > forkWithUnmask = forkWithUnmaskN "" + forkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) + forkWithUnmask = forkWithUnmaskN "" + + -- | Like 'forkWithUnmask', but the thread is given a name which may + -- be used to present more useful debugging information. + -- + -- If an empty name is given, the @ThreadId@ is used. If names + -- conflict, successive threads with the same name are given a + -- numeric suffix, counting up from 1. + -- + -- > forkWithUnmaskN _ = forkWithUnmask + forkWithUnmaskN :: String -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) + forkWithUnmaskN _ = forkWithUnmask + + -- | Fork a computation to happen on a specific processor. The + -- specified int is the /capability number/, typically capabilities + -- correspond to physical processors or cores but this is + -- implementation dependent. The int is interpreted modulo to the + -- total number of capabilities as returned by 'getNumCapabilities'. + -- + -- > forkOn c ma = forkOnWithUnmask c (\_ -> ma) + forkOn :: Int -> m () -> m (ThreadId m) + forkOn c ma = forkOnWithUnmask c (\_ -> ma) + + -- | Like 'forkWithUnmask', but the child thread is pinned to the + -- given CPU, as with 'forkOn'. + -- + -- > forkOnWithUnmask = forkOnWithUnmaskN "" + forkOnWithUnmask :: Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) + forkOnWithUnmask = forkOnWithUnmaskN "" + + -- | Like 'forkWithUnmaskN', but the child thread is pinned to the + -- given CPU, as with 'forkOn'. + -- + -- > forkOnWithUnmaskN _ = forkOnWithUnmask + forkOnWithUnmaskN :: String -> Int -> ((forall a. m a -> m a) -> m ()) -> m (ThreadId m) + forkOnWithUnmaskN _ = forkOnWithUnmask + + -- | Get the number of Haskell threads that can run simultaneously. + getNumCapabilities :: m Int + + -- | Set the number of Haskell threads that can run simultaneously. + setNumCapabilities :: Int -> m () + + -- | Get the @ThreadId@ of the current thread. + myThreadId :: m (ThreadId m) + + -- | Allows a context-switch to any other currently runnable thread + -- (if any). + yield :: m () + + -- | Yields the current thread, and optionally suspends the current + -- thread for a given number of microseconds. + -- + -- If suspended, there is no guarantee that the thread will be + -- rescheduled promptly when the delay has expired, but the thread + -- will never continue to run earlier than specified. + -- + -- > threadDelay _ = yield + threadDelay :: Int -> m () + threadDelay _ = yield + + -- | Create a new empty @MVar@. + -- + -- > newEmptyMVar = newEmptyMVarN "" + newEmptyMVar :: m (MVar m a) + newEmptyMVar = newEmptyMVarN "" + + -- | Create a new empty @MVar@, but it is given a name which may be + -- used to present more useful debugging information. + -- + -- If an empty name is given, a counter starting from 0 is used. If + -- names conflict, successive @MVar@s with the same name are given a + -- numeric suffix, counting up from 1. + -- + -- > newEmptyMVarN _ = newEmptyMVar + newEmptyMVarN :: String -> m (MVar m a) + newEmptyMVarN _ = newEmptyMVar + + -- | Put a value into a @MVar@. If there is already a value there, + -- this will block until that value has been taken, at which point + -- the value will be stored. + putMVar :: MVar m a -> a -> m () + + -- | Attempt to put a value in a @MVar@ non-blockingly, returning + -- 'True' (and filling the @MVar@) if there was nothing there, + -- otherwise returning 'False'. + tryPutMVar :: MVar m a -> a -> m Bool + + -- | Block until a value is present in the @MVar@, and then return + -- it. As with 'readMVar', this does not \"remove\" the value, + -- multiple reads are possible. + readMVar :: MVar m a -> m a + + -- | Take a value from a @MVar@. This \"empties\" the @MVar@, + -- allowing a new value to be put in. This will block if there is no + -- value in the @MVar@ already, until one has been put. + takeMVar :: MVar m a -> m a + + -- | Attempt to take a value from a @MVar@ non-blockingly, returning + -- a 'Just' (and emptying the @MVar@) if there was something there, + -- otherwise returning 'Nothing'. + tryTakeMVar :: MVar m a -> m (Maybe a) + + -- | Create a new reference. + -- + -- > newCRef = newCRefN "" + newCRef :: a -> m (CRef m a) + newCRef = newCRefN "" + + -- | Create a new reference, but it is given a name which may be + -- used to present more useful debugging information. + -- + -- If an empty name is given, a counter starting from 0 is used. If + -- names conflict, successive @CRef@s with the same name are given a + -- numeric suffix, counting up from 1. + -- + -- > newCRefN _ = newCRef + newCRefN :: String -> a -> m (CRef m a) + newCRefN _ = newCRef + + -- | Read the current value stored in a reference. + -- + -- > readCRef cref = readForCAS cref >>= peekTicket + readCRef :: CRef m a -> m a + readCRef cref = readForCAS cref >>= peekTicket + + -- | Atomically modify the value stored in a reference. This imposes + -- a full memory barrier. + atomicModifyCRef :: CRef m a -> (a -> (a, b)) -> m b + + -- | Write a new value into an @CRef@, without imposing a memory + -- barrier. This means that relaxed memory effects can be observed. + writeCRef :: CRef m a -> a -> m () + + -- | Replace the value stored in a reference, with the + -- barrier-to-reordering property that 'atomicModifyCRef' has. + -- + -- > atomicWriteCRef r a = atomicModifyCRef r $ const (a, ()) + atomicWriteCRef :: CRef m a -> a -> m () + atomicWriteCRef r a = atomicModifyCRef r $ const (a, ()) + + -- | Read the current value stored in a reference, returning a + -- @Ticket@, for use in future compare-and-swap operations. + readForCAS :: CRef m a -> m (Ticket m a) + + -- | Extract the actual Haskell value from a @Ticket@. + -- + -- The @proxy m@ is to determine the @m@ in the @Ticket@ type. + peekTicket' :: proxy m -> Ticket m a -> a + + -- | Perform a machine-level compare-and-swap (CAS) operation on a + -- @CRef@. Returns an indication of success and a @Ticket@ for the + -- most current value in the @CRef@. + -- + -- This is strict in the \"new\" value argument. + casCRef :: CRef m a -> Ticket m a -> a -> m (Bool, Ticket m a) + + -- | A replacement for 'atomicModifyCRef' using a compare-and-swap. + -- + -- This is strict in the \"new\" value argument. + modifyCRefCAS :: CRef m a -> (a -> (a, b)) -> m b + + -- | A variant of 'modifyCRefCAS' which doesn't return a result. + -- + -- > modifyCRefCAS_ cref f = modifyCRefCAS cref (\a -> (f a, ())) + modifyCRefCAS_ :: CRef m a -> (a -> a) -> m () + modifyCRefCAS_ cref f = modifyCRefCAS cref (\a -> (f a, ())) + + -- | Perform an STM transaction atomically. + atomically :: STM m a -> m a + + -- | Read the current value stored in a @TVar@. This may be + -- implemented differently for speed. + -- + -- > readTVarConc = atomically . readTVar + readTVarConc :: TVar (STM m) a -> m a + readTVarConc = atomically . readTVar + + -- | Throw an exception to the target thread. This blocks until the + -- exception is delivered, and it is just as if the target thread + -- had raised it with 'throw'. This can interrupt a blocked action. + throwTo :: Exception e => ThreadId m -> e -> m () + + -- | Does nothing. + -- + -- During testing, records a message which shows up in the trace. + -- + -- > _concMessage _ = pure () + _concMessage :: Typeable a => a -> m () + _concMessage _ = pure () + +------------------------------------------------------------------------------- +-- Utilities + +-- Threads + +-- | Create a concurrent computation for the provided action, and +-- return a @MVar@ which can be used to query the result. +spawn :: MonadConc m => m a -> m (MVar m a) +spawn ma = do + cvar <- newEmptyMVar + _ <- fork $ ma >>= putMVar cvar + pure cvar + +-- | Fork a thread and call the supplied function when the thread is +-- about to terminate, with an exception or a returned value. The +-- function is called with asynchronous exceptions masked. +-- +-- This function is useful for informing the parent when a child +-- terminates, for example. +forkFinally :: MonadConc m => m a -> (Either SomeException a -> m ()) -> m (ThreadId m) +forkFinally action and_then = + mask $ \restore -> + fork $ Ca.try (restore action) >>= and_then + +-- | Raise the 'ThreadKilled' exception in the target thread. Note +-- that if the thread is prepared to catch this exception, it won't +-- actually kill it. +killThread :: MonadConc m => ThreadId m -> m () +killThread tid = throwTo tid ThreadKilled + +-- | Like 'fork', but the thread is given a name which may be used to +-- present more useful debugging information. +-- +-- If no name is given, the @ThreadId@ is used. If names conflict, +-- successive threads with the same name are given a numeric suffix, +-- counting up from 1. +forkN :: MonadConc m => String -> m () -> m (ThreadId m) +forkN name ma = forkWithUnmaskN name (\_ -> ma) + +-- | Like 'forkOn', but the thread is given a name which may be used +-- to present more useful debugging information. +-- +-- If no name is given, the @ThreadId@ is used. If names conflict, +-- successive threads with the same name are given a numeric suffix, +-- counting up from 1. +forkOnN :: MonadConc m => String -> Int -> m () -> m (ThreadId m) +forkOnN name i ma = forkOnWithUnmaskN name i (\_ -> ma) + +-- Bound Threads + +-- | Provided for compatibility, always returns 'False'. +rtsSupportsBoundThreads :: Bool +rtsSupportsBoundThreads = False + +-- | Provided for compatibility, always returns 'False'. +isCurrentThreadBound :: MonadConc m => m Bool +isCurrentThreadBound = pure False + +-- Exceptions + +-- | Throw an exception. This will \"bubble up\" looking for an +-- exception handler capable of dealing with it and, if one is not +-- found, the thread is killed. +throw :: (MonadConc m, Exception e) => e -> m a +throw = Ca.throwM + +-- | Catch an exception. This is only required to be able to catch +-- exceptions raised by 'throw', unlike the more general +-- Control.Exception.catch function. If you need to be able to catch +-- /all/ errors, you will have to use 'IO'. +catch :: (MonadConc m, Exception e) => m a -> (e -> m a) -> m a +catch = Ca.catch + +-- | Executes a computation with asynchronous exceptions +-- /masked/. That is, any thread which attempts to raise an exception +-- in the current thread with 'throwTo' will be blocked until +-- asynchronous exceptions are unmasked again. +-- +-- The argument passed to mask is a function that takes as its +-- argument another function, which can be used to restore the +-- prevailing masking state within the context of the masked +-- computation. This function should not be used within an +-- 'uninterruptibleMask'. +mask :: MonadConc m => ((forall a. m a -> m a) -> m b) -> m b +mask = Ca.mask + +-- | Like 'mask', but the masked computation is not +-- interruptible. THIS SHOULD BE USED WITH GREAT CARE, because if a +-- thread executing in 'uninterruptibleMask' blocks for any reason, +-- then the thread (and possibly the program, if this is the main +-- thread) will be unresponsive and unkillable. This function should +-- only be necessary if you need to mask exceptions around an +-- interruptible operation, and you can guarantee that the +-- interruptible operation will only block for a short period of +-- time. The supplied unmasking function should not be used within a +-- 'mask'. +uninterruptibleMask :: MonadConc m => ((forall a. m a -> m a) -> m b) -> m b +uninterruptibleMask = Ca.uninterruptibleMask + +-- Mutable Variables + +-- | Create a new @MVar@ containing a value. +newMVar :: MonadConc m => a -> m (MVar m a) +newMVar a = do + cvar <- newEmptyMVar + putMVar cvar a + pure cvar + +-- | Create a new @MVar@ containing a value, but it is given a name +-- which may be used to present more useful debugging information. +-- +-- If no name is given, a counter starting from 0 is used. If names +-- conflict, successive @MVar@s with the same name are given a numeric +-- suffix, counting up from 1. +newMVarN :: MonadConc m => String -> a -> m (MVar m a) +newMVarN n a = do + cvar <- newEmptyMVarN n + putMVar cvar a + pure cvar + +-- | Extract the actual Haskell value from a @Ticket@. +-- +-- This doesn't do do any monadic computation, the @m@ appears in the +-- result type to determine the @m@ in the @Ticket@ type. +peekTicket :: forall m a. MonadConc m => Ticket m a -> m a +peekTicket t = pure $ peekTicket' (Proxy :: Proxy m) (t :: Ticket m a) + +-- | Compare-and-swap a value in a @CRef@, returning an indication of +-- success and the new value. +cas :: MonadConc m => CRef m a -> a -> m (Bool, a) +cas cref a = do + tick <- readForCAS cref + (suc, tick') <- casCRef cref tick a + a' <- peekTicket tick' + + pure (suc, a') + +------------------------------------------------------------------------------- +-- Concrete instances + +instance MonadConc IO where + type STM IO = IO.STM + type MVar IO = IO.MVar + type CRef IO = IO.IORef + type Ticket IO = IO.Ticket + type ThreadId IO = IO.ThreadId + + fork = IO.forkIO + forkOn = IO.forkOn + + forkWithUnmask = IO.forkIOWithUnmask + forkOnWithUnmask = IO.forkOnWithUnmask + + getNumCapabilities = IO.getNumCapabilities + setNumCapabilities = IO.setNumCapabilities + readMVar = IO.readMVar + myThreadId = IO.myThreadId + yield = IO.yield + threadDelay = IO.threadDelay + throwTo = IO.throwTo + newEmptyMVar = IO.newEmptyMVar + putMVar = IO.putMVar + tryPutMVar = IO.tryPutMVar + takeMVar = IO.takeMVar + tryTakeMVar = IO.tryTakeMVar + newCRef = IO.newIORef + readCRef = IO.readIORef + atomicModifyCRef = IO.atomicModifyIORef + writeCRef = IO.writeIORef + atomicWriteCRef = IO.atomicWriteIORef + readForCAS = IO.readForCAS + peekTicket' _ = IO.peekTicket + casCRef = IO.casIORef + modifyCRefCAS = IO.atomicModifyIORefCAS + atomically = IO.atomically + readTVarConc = IO.readTVarIO + +------------------------------------------------------------------------------- +-- Transformer instances + +#define INSTANCE(T,C,F) \ +instance C => MonadConc (T m) where { \ + type STM (T m) = STM m ; \ + type MVar (T m) = MVar m ; \ + type CRef (T m) = CRef m ; \ + type Ticket (T m) = Ticket m ; \ + type ThreadId (T m) = ThreadId m ; \ + \ + fork = liftedF F fork ; \ + forkOn = liftedF F . forkOn ; \ + \ + forkWithUnmask = liftedFork F forkWithUnmask ; \ + forkWithUnmaskN n = liftedFork F (forkWithUnmaskN n ) ; \ + forkOnWithUnmask i = liftedFork F (forkOnWithUnmask i) ; \ + forkOnWithUnmaskN n i = liftedFork F (forkOnWithUnmaskN n i) ; \ + \ + getNumCapabilities = lift getNumCapabilities ; \ + setNumCapabilities = lift . setNumCapabilities ; \ + myThreadId = lift myThreadId ; \ + yield = lift yield ; \ + threadDelay = lift . threadDelay ; \ + throwTo t = lift . throwTo t ; \ + newEmptyMVar = lift newEmptyMVar ; \ + newEmptyMVarN = lift . newEmptyMVarN ; \ + readMVar = lift . readMVar ; \ + putMVar v = lift . putMVar v ; \ + tryPutMVar v = lift . tryPutMVar v ; \ + takeMVar = lift . takeMVar ; \ + tryTakeMVar = lift . tryTakeMVar ; \ + newCRef = lift . newCRef ; \ + newCRefN n = lift . newCRefN n ; \ + readCRef = lift . readCRef ; \ + atomicModifyCRef r = lift . atomicModifyCRef r ; \ + writeCRef r = lift . writeCRef r ; \ + atomicWriteCRef r = lift . atomicWriteCRef r ; \ + readForCAS = lift . readForCAS ; \ + peekTicket' _ = peekTicket' (Proxy :: Proxy m) ; \ + casCRef r t = lift . casCRef r t ; \ + modifyCRefCAS r = lift . modifyCRefCAS r ; \ + atomically = lift . atomically ; \ + readTVarConc = lift . readTVarConc ; \ + \ + _concMessage = lift . _concMessage } + +-- | New threads inherit the reader state of their parent, but do not +-- communicate results back. +INSTANCE(ReaderT r, MonadConc m, id) + +INSTANCE(IdentityT, MonadConc m, id) + +-- | New threads inherit the writer state of their parent, but do not +-- communicate results back. +INSTANCE(WL.WriterT w, (MonadConc m, Monoid w), fst) +-- | New threads inherit the writer state of their parent, but do not +-- communicate results back. +INSTANCE(WS.WriterT w, (MonadConc m, Monoid w), fst) + +-- | New threads inherit the state of their parent, but do not +-- communicate results back. +INSTANCE(SL.StateT s, MonadConc m, fst) +-- | New threads inherit the state of their parent, but do not +-- communicate results back. +INSTANCE(SS.StateT s, MonadConc m, fst) + +-- | New threads inherit the states of their parent, but do not +-- communicate results back. +INSTANCE(RL.RWST r w s, (MonadConc m, Monoid w), (\(a,_,_) -> a)) +-- | New threads inherit the states of their parent, but do not +-- communicate results back. +INSTANCE(RS.RWST r w s, (MonadConc m, Monoid w), (\(a,_,_) -> a)) + +#undef INSTANCE + +------------------------------------------------------------------------------- + +-- | Given a function to remove the transformer-specific state, lift +-- a function invocation. +liftedF :: (MonadTransControl t, MonadConc m) + => (forall x. StT t x -> x) + -> (m a -> m b) + -> t m a + -> t m b +liftedF unst f ma = liftWith $ \run -> f (unst <$> run ma) + +-- | Given a function to remove the transformer-specific state, lift +-- a @fork(on)WithUnmask@ invocation. +liftedFork :: (MonadTransControl t, MonadConc m) + => (forall x. StT t x -> x) + -> (((forall x. m x -> m x) -> m a) -> m b) + -> ((forall x. t m x -> t m x) -> t m a) + -> t m b +liftedFork unst f ma = liftWith $ \run -> + f (\unmask -> unst <$> run (ma $ liftedF unst unmask)) diff --git a/Control/Monad/STM/Class.hs b/Control/Monad/STM/Class.hs new file mode 100644 --- /dev/null +++ b/Control/Monad/STM/Class.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Control.Monad.STM.Class +-- Copyright : (c) 2016 Michael Walker +-- License : MIT +-- Maintainer : Michael Walker +-- Stability : experimental +-- Portability : CPP, RankNTypes, TemplateHaskell, TypeFamilies +-- +-- This module provides an abstraction over 'STM', which can be used +-- with 'MonadConc'. +-- +-- This module only defines the 'STM' class; you probably want to +-- import "Control.Concurrent.Classy.STM" (which exports +-- "Control.Monad.STM.Class"). +-- +-- __Deviations:__ An instance of @MonadSTM@ is not required to be an +-- @Alternative@, @MonadPlus@, and @MonadFix@, unlike @STM@. The +-- @always@ and @alwaysSucceeds@ functions are not provided; if you +-- need these file an issue and I'll look into it. +module Control.Monad.STM.Class + ( MonadSTM(..) + , check + , throwSTM + , catchSTM + + -- * Utilities for instance writers + , liftedOrElse + ) where + +import Control.Exception (Exception) +import Control.Monad (unless) +import Control.Monad.Reader (ReaderT) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Control (MonadTransControl, StT, liftWith) +import Control.Monad.Trans.Identity (IdentityT) + +import qualified Control.Concurrent.STM as STM +import qualified Control.Monad.Catch as Ca +import qualified Control.Monad.RWS.Lazy as RL +import qualified Control.Monad.RWS.Strict as RS +import qualified Control.Monad.State.Lazy as SL +import qualified Control.Monad.State.Strict as SS +import qualified Control.Monad.Writer.Lazy as WL +import qualified Control.Monad.Writer.Strict as WS + +-- | @MonadSTM@ is an abstraction over 'STM'. +-- +-- This class does not provide any way to run transactions, rather +-- each 'MonadConc' has an associated @MonadSTM@ from which it can +-- atomically run a transaction. +class Ca.MonadCatch stm => MonadSTM stm where + {-# MINIMAL + retry + , orElse + , (newTVar | newTVarN) + , readTVar + , writeTVar + #-} + + -- | The mutable reference type. These behave like 'TVar's, in that + -- they always contain a value and updates are non-blocking and + -- synchronised. + type TVar stm :: * -> * + + -- | Retry execution of this transaction because it has seen values + -- in @TVar@s that it shouldn't have. This will result in the + -- thread running the transaction being blocked until any @TVar@s + -- referenced in it have been mutated. + retry :: stm a + + -- | Run the first transaction and, if it @retry@s, run the second + -- instead. If the monad is an instance of + -- 'Alternative'/'MonadPlus', 'orElse' should be the '(<|>)'/'mplus' + -- function. + orElse :: stm a -> stm a -> stm a + + -- | Create a new @TVar@ containing the given value. + -- + -- > newTVar = newTVarN "" + newTVar :: a -> stm (TVar stm a) + newTVar = newTVarN "" + + -- | Create a new @TVar@ containing the given value, but it is + -- given a name which may be used to present more useful debugging + -- information. + -- + -- If an empty name is given, a counter starting from 0 is used. If + -- names conflict, successive @TVar@s with the same name are given + -- a numeric suffix, counting up from 1. + -- + -- > newTVarN _ = newTVar + newTVarN :: String -> a -> stm (TVar stm a) + newTVarN _ = newTVar + + -- | Return the current value stored in a @TVar@. + readTVar :: TVar stm a -> stm a + + -- | Write the supplied value into the @TVar@. + writeTVar :: TVar stm a -> a -> stm () + +-- | Check whether a condition is true and, if not, call @retry@. +check :: MonadSTM stm => Bool -> stm () +check b = unless b retry + +-- | Throw an exception. This aborts the transaction and propagates +-- the exception. +throwSTM :: (MonadSTM stm, Exception e) => e -> stm a +throwSTM = Ca.throwM + +-- | Handling exceptions from 'throwSTM'. +catchSTM :: (MonadSTM stm, Exception e) => stm a -> (e -> stm a) -> stm a +catchSTM = Ca.catch + +instance MonadSTM STM.STM where + type TVar STM.STM = STM.TVar + + retry = STM.retry + orElse = STM.orElse + newTVar = STM.newTVar + readTVar = STM.readTVar + writeTVar = STM.writeTVar + +------------------------------------------------------------------------------- +-- Transformer instances + +#define INSTANCE(T,C,F) \ +instance C => MonadSTM (T stm) where { \ + type TVar (T stm) = TVar stm ; \ + \ + retry = lift retry ; \ + orElse = liftedOrElse F ; \ + newTVar = lift . newTVar ; \ + newTVarN n = lift . newTVarN n ; \ + readTVar = lift . readTVar ; \ + writeTVar v = lift . writeTVar v } + +INSTANCE(ReaderT r, MonadSTM stm, id) + +INSTANCE(IdentityT, MonadSTM stm, id) + +INSTANCE(WL.WriterT w, (MonadSTM stm, Monoid w), fst) +INSTANCE(WS.WriterT w, (MonadSTM stm, Monoid w), fst) + +INSTANCE(SL.StateT s, MonadSTM stm, fst) +INSTANCE(SS.StateT s, MonadSTM stm, fst) + +INSTANCE(RL.RWST r w s, (MonadSTM stm, Monoid w), (\(a,_,_) -> a)) +INSTANCE(RS.RWST r w s, (MonadSTM stm, Monoid w), (\(a,_,_) -> a)) + +#undef INSTANCE + +------------------------------------------------------------------------------- + +-- | Given a function to remove the transformer-specific state, lift +-- an @orElse@ invocation. +liftedOrElse :: (MonadTransControl t, MonadSTM stm) + => (forall x. StT t x -> x) + -> t stm a -> t stm a -> t stm a +liftedOrElse unst ma mb = liftWith $ \run -> + let ma' = unst <$> run ma + mb' = unst <$> run mb + in ma' `orElse` mb' diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015, Michael Walker + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/concurrency.cabal b/concurrency.cabal new file mode 100644 --- /dev/null +++ b/concurrency.cabal @@ -0,0 +1,113 @@ +-- Initial monad-conc.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: concurrency +version: 1.0.0.0 +synopsis: Typeclasses, functions, and data types for concurrency and STM. + +description: + A typeclass abstraction over much of Control.Concurrent (and some + extras!). If you're looking for a general introduction to Haskell + concurrency, you should check out the excellent Parallel and + Concurrent Programming in Haskell, by Simon Marlow. If you are + already familiar with concurrent Haskell, just change all the + imports from Control.Concurrent.* to Control.Concurrent.Classy.* and + fix the type errors. + . + A brief list of supported functionality: + . + * Threads: the @forkIO*@ and @forkOn*@ functions, although bound + threads are not supported. + . + * Getting and setting capablities. + . + * Yielding and delaying. + . + * Mutable state: STM, @MVar@, and @IORef@. + . + * Atomic compare-and-swap for @IORef@. + . + * Exceptions. + . + * All of the data structures in Control.Concurrent.* and + Control.Concurrent.STM.* have typeclass-abstracted equivalents. + . + This is quite a rich set of functionality, although it is not + complete. If there is something else you need, file an issue! + . + This used to be part of dejafu, but with the dejafu-0.4.0.0 release, + it was split out into its own package. + . + == Why and not something else? + . + * Why not base: like lifted-base, concurrency uses typeclasses to + make function types more generic. This automatically eliminates + calls to `lift` in many cases, resulting in clearer and simpler + code. + . + * Why not lifted-base: fundamentally, lifted-base is still using + actual threads and actual mutable variables. When using a + concurrency-specific typeclass, this isn't necessarily the case. + The dejafu library provides non-IO-based implementations to allow + testing concurrent programs. + . + * Why not IOSpec: IOSpec provides many of the operations this + library does, however it uses a free monad to do so, which has + extra allocation overhead. Furthermore, it does not expose enough + of the internals in order to accurately test real-execution + semantics, such as relaxed memory. + . + See the for more + details. + +homepage: https://github.com/barrucadu/dejafu +license: MIT +license-file: LICENSE +author: Michael Walker +maintainer: mike@barrucadu.co.uk +-- copyright: +category: Concurrency +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/barrucadu/dejafu.git + +source-repository this + type: git + location: https://github.com/barrucadu/dejafu.git + tag: concurrency-0.1.0.0 + +library + exposed-modules: Control.Monad.Conc.Class + , Control.Monad.STM.Class + + , Control.Concurrent.Classy + , Control.Concurrent.Classy.Chan + , Control.Concurrent.Classy.CRef + , Control.Concurrent.Classy.MVar + , Control.Concurrent.Classy.QSem + , Control.Concurrent.Classy.QSemN + , Control.Concurrent.Classy.STM + , Control.Concurrent.Classy.STM.TVar + , Control.Concurrent.Classy.STM.TMVar + , Control.Concurrent.Classy.STM.TChan + , Control.Concurrent.Classy.STM.TQueue + , Control.Concurrent.Classy.STM.TBQueue + , Control.Concurrent.Classy.STM.TArray + + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <5 + , array >=0.5 && <0.6 + , atomic-primops >=0.8 && <0.9 + , exceptions >=0.7 && <0.9 + , monad-control >=1.0 && <1.1 + , mtl >=2.2 && <2.3 + , stm >=2.4 && <2.5 + , transformers >=0.4 && <0.6 + -- hs-source-dirs: + default-language: Haskell2010 + ghc-options: -Wall