X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelConc.lhs;h=0ffe3a9d5eab19d25631158f454789df86b3483c;hb=d9af408e5c512501cfa991f5e4a76c9154bca917;hp=f5a5d269fde89a6f28bcf6778708362533601bad;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs index f5a5d26..0ffe3a9 100644 --- a/ghc/lib/std/PrelConc.lhs +++ b/ghc/lib/std/PrelConc.lhs @@ -1,5 +1,7 @@ +% ----------------------------------------------------------------------------- +% $Id: PrelConc.lhs,v 1.24 2001/05/18 16:54:05 simonmar Exp $ % -% (c) The AQUA Project, Glasgow University, 1994-1996 +% (c) The University of Glasgow, 1994-2000 % \section[PrelConc]{Module @PrelConc@} @@ -9,30 +11,43 @@ Basic concurrency stuff \begin{code} {-# OPTIONS -fno-implicit-prelude #-} -module PrelConc ( +module PrelConc + ( ThreadId(..) + + -- Forking and suchlike + , myThreadId -- :: IO ThreadId + , killThread -- :: ThreadId -> IO () + , throwTo -- :: ThreadId -> Exception -> IO () + , par -- :: a -> b -> b + , seq -- :: a -> b -> b + , yield -- :: IO () + + -- Waiting + , threadDelay -- :: Int -> IO () + , threadWaitRead -- :: Int -> IO () + , threadWaitWrite -- :: Int -> IO () + + -- MVars + , MVar -- abstract + , newMVar -- :: a -> IO (MVar a) + , newEmptyMVar -- :: IO (MVar a) + , takeMVar -- :: MVar a -> IO a + , putMVar -- :: MVar a -> a -> IO () + , tryTakeMVar -- :: MVar a -> IO (Maybe a) + , tryPutMVar -- :: MVar a -> a -> IO Bool + , isEmptyMVar -- :: MVar a -> IO Bool + , addMVarFinalizer -- :: MVar a -> IO () -> IO () - -- Thread Ids - ThreadId, - - -- Forking and suchlike - forkIO, - killThread, - seq, par, fork, - {-threadDelay, threadWaitRead, threadWaitWrite, -} - - -- MVars - MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar ) where import PrelBase -import {-# SOURCE #-} PrelErr ( parError ) -import PrelST ( ST(..), STret(..), liftST ) -import PrelIOBase ( IO(..), MVar(..), liftIO, unsafePerformIO ) -import PrelErr ( parError ) +import PrelMaybe +import PrelErr ( parError, seqError ) +import PrelIOBase ( IO(..), MVar(..) ) import PrelBase ( Int(..) ) -import PrelErr ( seqError ) +import PrelException ( Exception(..), AsyncException(..) ) -infixr 0 `par`, `fork` +infixr 0 `par`, `seq` \end{code} %************************************************************************ @@ -43,19 +58,29 @@ infixr 0 `par`, `fork` \begin{code} data ThreadId = ThreadId ThreadId# --- ToDo: data ThreadId = ThreadId (WeakPair ThreadId# ()) --- But since ThreadId# is unlifted, the WeakPair type must use open +-- ToDo: data ThreadId = ThreadId (Weak ThreadId#) +-- But since ThreadId# is unlifted, the Weak type must use open -- type variables. -forkIO :: IO () -> IO ThreadId -forkIO action = IO $ \ s -> - case (fork# action s) of (# s, id #) -> (# s, ThreadId id #) +--forkIO has now been hoisted out into the Concurrent library. killThread :: ThreadId -> IO () killThread (ThreadId id) = IO $ \ s -> - case (killThread# id s) of s -> (# s, () #) + case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #) + +throwTo :: ThreadId -> Exception -> IO () +throwTo (ThreadId id) ex = IO $ \ s -> + case (killThread# id ex s) of s1 -> (# s1, () #) --- "seq" is defined a bit wierdly (see below) +myThreadId :: IO ThreadId +myThreadId = IO $ \s -> + case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #) + +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 @@ -70,18 +95,9 @@ killThread (ThreadId id) = IO $ \ s -> seq :: a -> b -> b seq x y = case (seq# x) of { 0# -> seqError; _ -> y } -par, fork :: a -> b -> b - {-# INLINE par #-} -{-# INLINE fork #-} -#if defined(__PARALLEL_HASKELL__) || defined (__GRANSIM__) +par :: a -> b -> b par x y = case (par# x) of { 0# -> parError; _ -> y } -#else -par x y = y -#endif - -fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y - \end{code} %************************************************************************ @@ -101,45 +117,61 @@ 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. + + 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, + i.e., consider yourself warned about the imprecision in + general of isEmptyMVar :-) +-} +isEmptyMVar :: MVar a -> IO Bool +isEmptyMVar (MVar mv#) = IO $ \ s# -> + case isEmptyMVar# mv# s# of + (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) + +-- Like addForeignPtrFinalizer, but for MVars +addMVarFinalizer :: MVar a -> IO () -> IO () +addMVarFinalizer (MVar m) finalizer = + IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) } \end{code} @@ -162,19 +194,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}