X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=1deb1601acf73a93b8b2519d3ee60471effd1108;hb=567080c906535534628b1ab83a4a4425dcd4bb5e;hp=decd40657028b6a151b8599590c2280f8e588df5;hpb=45b7a6b356f0cb85ea96c2ac5f77fd3eac1103cf;p=haskell-directory.git diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index decd406..1deb160 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -19,11 +19,13 @@ -- bits it exports, we'd rather have Control.Concurrent and the other -- higher level modules be the home. Hence: +#include "Typeable.h" + -- #not-home module GHC.Conc ( ThreadId(..) - -- Forking and suchlike + -- * Forking and suchlike , forkIO -- :: IO a -> IO ThreadId , forkOnIO -- :: Int -> IO a -> IO ThreadId , childHandler -- :: Exception -> IO () @@ -35,13 +37,13 @@ module GHC.Conc , yield -- :: IO () , labelThread -- :: ThreadId -> String -> IO () - -- Waiting + -- * Waiting , threadDelay -- :: Int -> IO () , registerDelay -- :: Int -> IO (TVar Bool) , threadWaitRead -- :: Int -> IO () , threadWaitWrite -- :: Int -> IO () - -- MVars + -- * MVars , MVar -- abstract , newMVar -- :: a -> IO (MVar a) , newEmptyMVar -- :: IO (MVar a) @@ -52,12 +54,14 @@ module GHC.Conc , isEmptyMVar -- :: MVar a -> IO Bool , addMVarFinalizer -- :: MVar a -> IO () -> IO () - -- TVars + -- * 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 + , alwaysSucceeds -- :: STM a -> STM () + , always -- :: STM Bool -> STM () , TVar -- abstract , newTVar -- :: a -> STM (TVar a) , newTVarIO -- :: a -> STM (TVar a) @@ -65,6 +69,7 @@ module GHC.Conc , writeTVar -- :: a -> TVar a -> STM () , unsafeIOToSTM -- :: IO a -> STM a + -- * Miscellaneous #ifdef mingw32_HOST_OS , asyncRead -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) , asyncWrite -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int) @@ -290,11 +295,14 @@ TVars are shared memory locations which support atomic memory transactions. \begin{code} -newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) deriving( Typeable ) +-- |A monad supporting atomic memory transactions. +newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #)) unSTM (STM a) = a +INSTANCE_TYPEABLE1(STM,stmTc,"STM") + instance Functor STM where fmap f x = x >>= (return . f) @@ -326,6 +334,15 @@ unsafeIOToSTM :: IO a -> STM a unsafeIOToSTM (IO m) = STM m -- |Perform a series of STM actions atomically. +-- +-- You cannot use 'atomically' inside an 'unsafePerformIO' or 'unsafeInterleaveIO'. +-- Any attempt to do so will result in a runtime error. (Reason: allowing +-- this would effectively allow a transaction inside a transaction, depending +-- on exactly when the thunk is evaluated.) +-- +-- However, see 'newTVarIO', which can be called inside 'unsafePerformIO', +-- and which allows top-level TVars to be allocated. + atomically :: STM a -> IO a atomically (STM m) = IO (\s -> (atomically# m) s ) @@ -333,14 +350,15 @@ atomically (STM m) = IO (\s -> (atomically# m) s ) -- 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. +-- udpated. (GHC only) 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. +-- |Compose two alternative STM actions (GHC only). 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 @@ -348,7 +366,34 @@ orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s 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) deriving( Typeable ) +-- | Low-level primitive on which always and alwaysSucceeds are built. +-- checkInv differs form these in that (i) the invariant is not +-- checked when checkInv is called, only at the end of this and +-- subsequent transcations, (ii) the invariant failure is indicated +-- by raising an exception. +checkInv :: STM a -> STM () +checkInv (STM m) = STM (\s -> (check# m) s) + +-- | alwaysSucceeds adds a new invariant that must be true when passed +-- to alwaysSucceeds, at the end of the current transaction, and at +-- the end of every subsequent transaction. If it fails at any +-- of those points then the transaction violating it is aborted +-- and the exception raised by the invariant is propagated. +alwaysSucceeds :: STM a -> STM () +alwaysSucceeds i = do ( do i ; retry ) `orElse` ( return () ) + checkInv i + +-- | always is a variant of alwaysSucceeds in which the invariant is +-- expressed as an STM Bool action that must return True. Returning +-- False or raising an exception are both treated as invariant failures. +always :: STM Bool -> STM () +always i = alwaysSucceeds ( do v <- i + if (v) then return () else ( error "Transacional invariant violation" ) ) + +-- |Shared memory locations that support atomic memory transactions. +data TVar a = TVar (TVar# RealWorld a) + +INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar") instance Eq (TVar a) where (TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2# @@ -579,6 +624,7 @@ threadDelay time case delay# time# s of { s -> (# s, () #) }} +registerDelay :: Int -> IO (TVar Bool) registerDelay usecs #ifndef mingw32_HOST_OS | threaded = waitForDelayEventSTM usecs