From e816bd912de53222ae9baf9343236e9bd1462d23 Mon Sep 17 00:00:00 2001 From: tharris Date: Thu, 18 Nov 2004 09:56:59 +0000 Subject: [PATCH] [project @ 2004-11-18 09:56:58 by tharris] Support for atomic memory transactions and associated regression tests conc041-048 --- Control/Concurrent.hs | 1 + GHC/Conc.lhs | 99 +++++++++++++++++++++++++++++++++++++++++++++++++ GHC/IOBase.lhs | 5 +++ 3 files changed, 105 insertions(+) diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs index 02f74fb..f3e0082 100644 --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -226,6 +226,7 @@ real_handler ex = case ex of -- ignore thread GC and killThread exceptions: BlockedOnDeadMVar -> return () + BlockedIndefinitely -> return () AsyncException ThreadKilled -> return () -- report all others: diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 6488074..eb4c88a 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -43,6 +43,17 @@ module GHC.Conc , isEmptyMVar -- :: MVar a -> IO Bool , addMVarFinalizer -- :: MVar a -> IO () -> IO () + -- TVars + , STM -- abstract + , atomically -- :: STM a -> IO a + , retry -- :: STM a + , orElse -- :: STM a -> STM a -> STM a + , catchSTM -- :: STM a -> (Exception -> STM a) -> STM a + , TVar -- abstract + , newTVar -- :: a -> STM (TVar a) + , readTVar -- :: TVar a -> STM a + , writeTVar -- :: a -> TVar a -> STM () + #ifdef mingw32_TARGET_OS , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) @@ -179,6 +190,94 @@ par :: a -> b -> b par x y = case (par# x) of { _ -> lazy y } \end{code} + +%************************************************************************ +%* * +\subsection[stm]{Transactional heap operations} +%* * +%************************************************************************ + +TVars are shared memory locations which support atomic memory +transactions. + +\begin{code} +newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) + +unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #)) +unSTM (STM a) = a + +instance Functor STM where + fmap f x = x >>= (return . f) + +instance Monad STM where + {-# INLINE return #-} + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + m >> k = m >>= \_ -> k + return x = returnSTM x + m >>= k = bindSTM m k + +bindSTM :: STM a -> (a -> STM b) -> STM b +bindSTM (STM m) k = STM ( \s -> + case m s of + (# new_s, a #) -> unSTM (k a) new_s + ) + +thenSTM :: STM a -> STM b -> STM b +thenSTM (STM m) k = STM ( \s -> + case m s of + (# new_s, a #) -> unSTM k new_s + ) + +returnSTM :: a -> STM a +returnSTM x = STM (\s -> (# s, x #)) + +-- |Perform a series of STM actions atomically. +atomically :: STM a -> IO a +atomically (STM m) = IO (\s -> (atomically# m) s ) + +-- |Retry execution of the current memory transaction because it has seen +-- values in TVars which mean that it should not continue (e.g. the TVars +-- represent a shared buffer that is now empty). The implementation may +-- block the thread until one of the TVars that it has read from has been +-- udpated. +retry :: STM a +retry = STM $ \s# -> retry# s# + +-- |Compose two alternative STM actions. If the first action completes without +-- retrying then it forms the result of the orElse. Otherwise, if the first +-- action retries, then the second action is tried in its place. If both actions +-- retry then the orElse as a whole retries. +orElse :: STM a -> STM a -> STM a +orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s + +-- |Exception handling within STM actions. +catchSTM :: STM a -> (Exception -> STM a) -> STM a +catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s + +data TVar a = TVar (TVar# RealWorld a) + +instance Eq (TVar a) where + (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2# + +-- |Create a new TVar holding a value supplied +newTVar :: a -> STM (TVar a) +newTVar val = STM $ \s1# -> + case newTVar# val s1# of + (# s2#, tvar# #) -> (# s2#, TVar tvar# #) + +-- |Return the current value stored in a TVar +readTVar :: TVar a -> STM a +readTVar (TVar tvar#) = STM $ \s# -> readTVar# tvar# s# + +-- |Write the supplied value into a TVar +writeTVar :: TVar a -> a -> STM () +writeTVar (TVar tvar#) val = STM $ \s1# -> + case writeTVar# tvar# val s1# of + s2# -> (# s2#, () #) + +\end{code} + %************************************************************************ %* * \subsection[mvars]{M-Structures} diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs index 8700128..e87728c 100644 --- a/GHC/IOBase.lhs +++ b/GHC/IOBase.lhs @@ -568,6 +568,10 @@ data Exception -- ^The current thread was executing a call to -- 'Control.Concurrent.MVar.takeMVar' that could never return, -- because there are no other references to this 'MVar'. + | BlockedIndefinitely + -- ^The current thread was waiting to retry an atomic memory transaction + -- that could never become possible to complete because there are no other + -- threads referring to any of teh TVars involved. | Deadlock -- ^There are no runnable threads, so the program is -- deadlocked. The 'Deadlock' exception is @@ -705,6 +709,7 @@ instance Show Exception where showsPrec _ (DynException _err) = showString "unknown exception" showsPrec _ (AsyncException e) = shows e showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely" + showsPrec _ (BlockedIndefinitely) = showString "thread blocked indefinitely" showsPrec _ (NonTermination) = showString "<>" showsPrec _ (Deadlock) = showString "<>" -- 1.7.10.4