X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelConc.lhs;h=d75bbca426dee3791207b0909988a566ea3fc78c;hb=9579283cadf4ac68a6f4252244041b5127e16811;hp=9801d77d89de502c28fac67e9cd0d5753716f0e4;hpb=b052d2df1e9cce8b56bf2d4557020d68a1c3ab35;p=ghc-hetmet.git

diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs
index 9801d77..d75bbca 100644
--- a/ghc/lib/std/PrelConc.lhs
+++ b/ghc/lib/std/PrelConc.lhs
@@ -7,38 +7,46 @@
 Basic concurrency stuff
 
 \begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module PrelConc (
-
-		-- Thread Ids
-	ThreadId,
-
-		-- Forking and suchlike
-	forkIO,	
-	killThread,
-	par, fork, seq,
-	{-threadDelay, threadWaitRead, threadWaitWrite,-}
-
-  		-- MVars
-	MVar
-     , newMVar
-     , newEmptyMVar
-     , takeMVar
-     , putMVar
-     , readMVar
-     , swapMVar
-       -- use with care (see comment.)
-     , isEmptyMVar
+{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude #-}
+
+module PrelConc
+	( ThreadId(..)
+
+	-- Forking and suchlike
+	, myThreadId 	-- :: IO ThreadId
+	, killThread	-- :: ThreadId -> IO ()
+	, raiseInThread -- :: 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 ()
+	, readMVar 	-- :: MVar a -> IO a
+	, swapMVar 	-- :: MVar a -> a -> IO a
+	, takeMaybeMVar -- :: MVar a -> IO (Maybe a)
+	, isEmptyMVar	-- :: MVar a -> IO Bool
+
     ) where
 
 import PrelBase
+import PrelMaybe
 import PrelErr ( parError, seqError )
 import PrelST	  	( liftST )
 import PrelIOBase	( IO(..), MVar(..), unsafePerformIO )
 import PrelBase		( Int(..) )
+import PrelException    ( Exception(..), AsyncException(..) )
 
-infixr 0 `par`, `fork`
+infixr 0 `par`, `seq`
 \end{code}
 
 %************************************************************************
@@ -49,17 +57,27 @@ 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 (# s1, id #) -> (# s1, 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 s1 -> (# s1, () #)
+   case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #)
+
+raiseInThread :: ThreadId -> Exception -> IO ()
+raiseInThread (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 #)
+
+yield :: IO ()
+yield = IO $ \s -> 
+   case (yield# s) of s1 -> (# s1, () #)
 
 -- "seq" is defined a bit wierdly (see below)
 --
@@ -76,18 +94,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  _ y = y
-#endif
-
-fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y
-
 \end{code}
 
 %************************************************************************
@@ -107,52 +116,52 @@ 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)
-
 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
 
+-- takeMaybeMVar is a non-blocking takeMVar
+takeMaybeMVar :: MVar a -> IO (Maybe a)
+takeMaybeMVar (MVar m) = IO $ \ s ->
+    case takeMaybeMVar# 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 takeMaybeMVar instead if possible.
 
  If you can re-work your abstractions to avoid having to
  depend on isEmptyMVar, then you're encouraged to do so,
@@ -185,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}