X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelConc.lhs;h=e01106003937832a754399ea380e3fdfa4553d12;hb=6009d77ae17f1b03e7ed208b40e65d1117544050;hp=d75bbca426dee3791207b0909988a566ea3fc78c;hpb=3e567b6507f58971899bc0a7fa6640cd033b95e1;p=ghc-hetmet.git

diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs
index d75bbca..e011060 100644
--- a/ghc/lib/std/PrelConc.lhs
+++ b/ghc/lib/std/PrelConc.lhs
@@ -1,5 +1,7 @@
+% -----------------------------------------------------------------------------
+% $Id: PrelConc.lhs,v 1.25 2001/09/14 15:49:56 simonpj Exp $
 %
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The University of Glasgow, 1994-2000
 %
 
 \section[PrelConc]{Module @PrelConc@}
@@ -7,7 +9,7 @@
 Basic concurrency stuff
 
 \begin{code}
-{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude #-}
 
 module PrelConc
 	( ThreadId(..)
@@ -15,9 +17,9 @@ 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
+	, pseq 		-- :: a -> b -> b
 	, yield         -- :: IO ()
 
 	-- Waiting
@@ -31,22 +33,21 @@ 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
-	, takeMaybeMVar -- :: MVar a -> IO (Maybe a)
+	, tryTakeMVar   -- :: MVar a -> IO (Maybe a)
+	, tryPutMVar  	-- :: MVar a -> a -> IO Bool
 	, isEmptyMVar	-- :: MVar a -> IO Bool
+	, addMVarFinalizer -- :: MVar a -> IO () -> IO ()
 
     ) where
 
 import PrelBase
 import PrelMaybe
-import PrelErr ( parError, seqError )
-import PrelST	  	( liftST )
-import PrelIOBase	( IO(..), MVar(..), unsafePerformIO )
+import PrelErr		( parError, seqError )
+import PrelIOBase	( IO(..), MVar(..) )
 import PrelBase		( Int(..) )
 import PrelException    ( Exception(..), AsyncException(..) )
 
-infixr 0 `par`, `seq`
+infixr 0 `par`, `pseq`
 \end{code}
 
 %************************************************************************
@@ -67,8 +68,8 @@ 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
@@ -79,7 +80,10 @@ yield :: IO ()
 yield = IO $ \s -> 
    case (yield# s) of s1 -> (# s1, () #)
 
--- "seq" is defined a bit wierdly (see below)
+-- 	Nota Bene: 'pseq' used to be 'seq'
+--		   but 'seq' is now defined in PrelGHC
+--
+-- "pseq" 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
@@ -90,9 +94,9 @@ yield = IO $ \s ->
 -- 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 pseq  #-}
+pseq :: a -> b -> b
+pseq  x y = case (seq#  x) of { 0# -> seqError; _ -> y }
 
 {-# INLINE par  #-}
 par :: a -> b -> b
@@ -129,28 +133,22 @@ putMVar (MVar mvar#) x = IO $ \ s# ->
     case putMVar# mvar# x s# of
         s2# -> (# s2#, () #)
 
+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
-
--- takeMaybeMVar is a non-blocking takeMVar
-takeMaybeMVar :: MVar a -> IO (Maybe a)
-takeMaybeMVar (MVar m) = IO $ \ s ->
-    case takeMaybeMVar# m s of
+-- 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
 
@@ -161,7 +159,7 @@ takeMaybeMVar (MVar m) = IO $ \ s ->
  the MVar may have been filled (or emptied) - so be extremely
  careful when using this operation.  
 
- Use takeMaybeMVar instead if possible.
+ 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,
@@ -172,6 +170,11 @@ 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}