X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelConc.lhs;h=32240b4c8162c62eed0aa3770ed339a8cea81bbf;hb=c733579cc8f2940a955997b145cc243cd8c0011d;hp=8068864ec60c59c257d69be9421e0390ef9f22a8;hpb=fe91e2bd0fc7be5b8e0016da242b784ecf46bdf2;p=ghc-hetmet.git

diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs
index 8068864..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@}
@@ -8,67 +10,93 @@ Basic concurrency stuff
 
 \begin{code}
 {-# OPTIONS -fno-implicit-prelude #-}
-module PrelConc(
-		-- Forking and suchlike
-	ST,	forkST,
-	IO,	forkIO,	
-	par, fork,
-	threadDelay, threadWaitRead, threadWaitWrite,
-
-		-- MVars
-	MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
+
+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
+
     ) where
 
 import PrelBase
-import {-# SOURCE #-} PrelErr ( parError )
-import PrelST	  	( ST(..), STret(..), StateAndPtr#(..) )
-import PrelIOBase	( IO(..), IOResult(..), MVar(..) )
+import PrelMaybe
+import PrelErr		( parError, seqError )
+import PrelIOBase	( IO(..), MVar(..) )
 import PrelBase		( Int(..) )
-import PrelGHC		( fork#, delay#, waitRead#, waitWrite#,
-		  	  SynchVar#, newSynchVar#, takeMVar#, putMVar#,
-		  	  State#, RealWorld, par#
-			)
+import PrelException    ( Exception(..), AsyncException(..) )
 
-infixr 0 `par`, `fork`
+infixr 0 `par`, `seq`
 \end{code}
 
-
-
 %************************************************************************
 %*									*
-\subsection{@par@, and @fork@}
+\subsection{@ThreadId@, @par@, and @fork@}
 %*									*
 %************************************************************************
 
 \begin{code}
-forkST :: ST s a -> ST s a
-
-forkST (ST action) = ST $ \ s -> 
-	let d@(STret _ r) = action s in
-	d `fork` STret s r
-
-forkIO :: IO () -> IO ()
-forkIO (IO action) = IO $ \ s -> (action s) `fork` IOok s ()
-
-par, fork :: Eval a => a -> b -> b
+data ThreadId = ThreadId ThreadId#
+-- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
+-- But since ThreadId# is unlifted, the Weak type must use open
+-- type variables.
+
+--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, () #)
+
+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 #)
+
+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
+-- its second argument (even if it inlines seq at the call site).
+-- If it thinks seq is strict in "y", then it often evaluates
+-- "y" before "x", which is totally wrong.  
+--
+-- Just before converting from Core to STG there's a bit of magic
+-- that recognises the seq# and eliminates the duff case.
+
+{-# INLINE seq  #-}
+seq :: a -> b -> b
+seq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
 
 {-# INLINE par  #-}
-{-# INLINE fork #-}
-
-#if defined(__PARALLEL_HASKELL__) || defined (__GRANSIM__)
-par  x y = case (par#  x) of { 0# -> parError; _ -> y }
-#else
-par  x y = y
-#endif
-
-#if defined(__CONCURRENT_HASKELL__) || defined (__GRANSIM__)
-fork x y = case (fork# x) of { 0# -> parError; _ -> y }
-#else
-fork x y = y
-#endif
-
-runOrBlockIO m = m			-- ?????
-
+par :: a -> b -> b
+par  x y = case (par# x) of { 0# -> parError; _ -> y }
 \end{code}
 
 %************************************************************************
@@ -88,47 +116,56 @@ 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 newSynchVar# s# of
-        StateAndSynchVar# s2# svar# -> IOok s2# (MVar svar#)
+    case newMVar# s# of
+         (# s2#, svar# #) -> (# s2#, MVar svar# #)
 
 takeMVar :: MVar a -> IO a
-
-takeMVar (MVar mvar#) = IO $ \ s# ->
-    case takeMVar# mvar# s# of
-        StateAndPtr# s2# r -> IOok s2# r
+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# -> IOok s2# ()
+        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#) #)
 \end{code}
 
 
@@ -153,25 +190,7 @@ specified file descriptor is available for reading (just like select).
 \begin{code}
 threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO ()
 
-threadDelay (I# x#) = IO $ \ s# ->
-    case delay# x# s# of
-      s2# -> IOok s2# ()
-
-threadWaitRead (I# x#) = IO $ \ s# -> 
-    case waitRead# x# s# of
-      s2# -> IOok s2# ()
-
-threadWaitWrite (I# x#) = IO $ \ s# ->
-    case waitWrite# x# s# of
-      s2# -> IOok s2# ()
-\end{code}
-
-%*********************************************************
-%*							*
-\subsection{Ghastly return types}
-%*							*
-%*********************************************************
-
-\begin{code}
-data StateAndSynchVar# s elt = StateAndSynchVar# (State# s) (SynchVar# s elt)
+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}