X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelConc.lhs;h=32240b4c8162c62eed0aa3770ed339a8cea81bbf;hb=2ac43a29c516fbba15ced9c4480f94cd05dc39d5;hp=10ebbe4d94ca0be8cf03f562b56d9129ec4f4474;hpb=65bec1e302ef3791d64f7ed51f5efeac8756ee87;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs index 10ebbe4..32240b4 100644 --- a/ghc/lib/std/PrelConc.lhs +++ b/ghc/lib/std/PrelConc.lhs @@ -1,5 +1,7 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelConc.lhs,v 1.23 2001/02/15 10:02:43 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The University of Glasgow, 1994-2000 % \section[PrelConc]{Module @PrelConc@} @@ -15,10 +17,15 @@ module PrelConc -- Forking and suchlike , myThreadId -- :: IO ThreadId , killThread -- :: ThreadId -> IO () - , raiseInThread -- :: ThreadId -> Exception -> IO () + , throwTo -- :: ThreadId -> Exception -> IO () , par -- :: a -> b -> b , seq -- :: a -> b -> b - {-threadDelay, threadWaitRead, threadWaitWrite,-} + , yield -- :: IO () + + -- Waiting + , threadDelay -- :: Int -> IO () + , threadWaitRead -- :: Int -> IO () + , threadWaitWrite -- :: Int -> IO () -- MVars , MVar -- abstract @@ -26,20 +33,20 @@ module PrelConc , newEmptyMVar -- :: IO (MVar a) , takeMVar -- :: MVar a -> IO a , putMVar -- :: MVar a -> a -> IO () - , readMVar -- :: MVar a -> IO a - , swapMVar -- :: MVar a -> a -> IO a + , tryTakeMVar -- :: MVar a -> IO (Maybe a) + , tryPutMVar -- :: MVar a -> a -> IO Bool , isEmptyMVar -- :: MVar a -> IO Bool ) where import PrelBase -import PrelErr ( parError, seqError ) -import PrelST ( liftST ) -import PrelIOBase ( IO(..), MVar(..), unsafePerformIO ) +import PrelMaybe +import PrelErr ( parError, seqError ) +import PrelIOBase ( IO(..), MVar(..) ) import PrelBase ( Int(..) ) import PrelException ( Exception(..), AsyncException(..) ) -infixr 0 `par` +infixr 0 `par`, `seq` \end{code} %************************************************************************ @@ -54,21 +61,25 @@ data ThreadId = ThreadId ThreadId# -- But since ThreadId# is unlifted, the Weak type must use open -- type variables. ---forkIO has now been hoisted out into the concurrent library. +--forkIO has now been hoisted out into the Concurrent library. killThread :: ThreadId -> IO () killThread (ThreadId id) = IO $ \ s -> case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #) -raiseInThread :: ThreadId -> Exception -> IO () -raiseInThread (ThreadId id) ex = IO $ \ s -> +throwTo :: ThreadId -> Exception -> IO () +throwTo (ThreadId id) ex = IO $ \ s -> case (killThread# id ex s) of s1 -> (# s1, () #) myThreadId :: IO ThreadId myThreadId = IO $ \s -> case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #) --- "seq" is defined a bit wierdly (see below) +yield :: IO () +yield = IO $ \s -> + case (yield# s) of s1 -> (# s1, () #) + +-- "seq" is defined a bit weirdly (see below) -- -- The reason for the strange "0# -> parError" case is that -- it fools the compiler into thinking that seq is non-strict in @@ -83,15 +94,9 @@ myThreadId = IO $ \s -> seq :: a -> b -> b seq x y = case (seq# x) of { 0# -> seqError; _ -> y } -par :: a -> b -> b - {-# INLINE par #-} -#if defined(__PARALLEL_HASKELL__) || defined (__GRANSIM__) +par :: a -> b -> b par x y = case (par# x) of { 0# -> parError; _ -> y } -#else -par _ y = y -#endif - \end{code} %************************************************************************ @@ -111,52 +116,46 @@ writes. \begin{code} --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) -instance Eq (MVar a) where - (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# - newEmptyMVar :: IO (MVar a) - newEmptyMVar = IO $ \ s# -> case newMVar# s# of (# s2#, svar# #) -> (# s2#, MVar svar# #) takeMVar :: MVar a -> IO a - takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# putMVar :: MVar a -> a -> IO () - putMVar (MVar mvar#) x = IO $ \ s# -> case putMVar# mvar# x s# of s2# -> (# s2#, () #) -newMVar :: a -> IO (MVar a) +tryPutMVar :: MVar a -> a -> IO Bool +tryPutMVar (MVar mvar#) x = IO $ \ s# -> + case tryPutMVar# mvar# x s# of + (# s, 0# #) -> (# s, False #) + (# s, _ #) -> (# s, True #) +newMVar :: a -> IO (MVar a) newMVar value = newEmptyMVar >>= \ mvar -> putMVar mvar value >> return mvar -readMVar :: MVar a -> IO a - -readMVar mvar = - takeMVar mvar >>= \ value -> - putMVar mvar value >> - return value - -swapMVar :: MVar a -> a -> IO a - -swapMVar mvar new = - takeMVar mvar >>= \ old -> - putMVar mvar new >> - return old +-- tryTakeMVar is a non-blocking takeMVar +tryTakeMVar :: MVar a -> IO (Maybe a) +tryTakeMVar (MVar m) = IO $ \ s -> + case tryTakeMVar# m s of + (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty + (# s, _, a #) -> (# s, Just a #) -- MVar is full {- Low-level op. for checking whether an MVar is filled-in or not. Notice that the boolean value returned is just a snapshot of the state of the MVar. By the time you get to react on its result, the MVar may have been filled (or emptied) - so be extremely - careful when using this operation. + careful when using this operation. + + Use tryTakeMVar instead if possible. If you can re-work your abstractions to avoid having to depend on isEmptyMVar, then you're encouraged to do so, @@ -189,19 +188,9 @@ specified file descriptor is available for reading (just like select). @threadWaitWrite@ is similar, but for writing on a file descriptor. \begin{code} -{- Not yet -- SDM threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO () -threadDelay (I# x#) = IO $ \ s# -> - case delay# x# s# of - s2# -> (# s2#, () #) - -threadWaitRead (I# x#) = IO $ \ s# -> - case waitRead# x# s# of - s2# -> (# s2#, () #) - -threadWaitWrite (I# x#) = IO $ \ s# -> - case waitWrite# x# s# of - s2# -> (# s2#, () #) --} +threadDelay (I# ms) = IO $ \s -> case delay# ms s of s -> (# s, () #) +threadWaitRead (I# fd) = IO $ \s -> case waitRead# fd s of s -> (# s, () #) +threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #) \end{code}