[project @ 2001-02-13 15:23:33 by rrt]

[ghc-hetmet.git] / ghc / lib / std / PrelConc.lhs

diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs
index 06265f5..0122dd8 100644 (file)
--- a/ghc/lib/std/PrelConc.lhs
+++ b/ghc/lib/std/PrelConc.lhs
@@ -1,5 +1,7 @@
+% -----------------------------------------------------------------------------
+% $Id: PrelConc.lhs,v 1.22 2001/02/13 15:23:33 rrt Exp $
 %
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (c) The University of Glasgow, 1994-2000
 %
 
 \section[PrelConc]{Module @PrelConc@}
@@ -15,12 +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
        , yield         -- :: IO ()
 
-       {-threadDelay, threadWaitRead, threadWaitWrite,-}
+       -- Waiting
+       , threadDelay           -- :: Int -> IO ()
+       , threadWaitRead        -- :: Int -> IO ()
+       , threadWaitWrite       -- :: Int -> IO ()
 
        -- MVars
        , MVar          -- abstract
@@ -28,20 +33,19 @@ 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)
        , isEmptyMVar   -- :: MVar a -> IO Bool
 
     ) where
 
 import PrelBase
+import PrelMaybe
 import PrelErr ( parError, seqError )
-import PrelST          ( liftST )
-import PrelIOBase      ( IO(..), MVar(..), unsafePerformIO )
+import PrelIOBase      ( IO(..), MVar(..) )
 import PrelBase                ( Int(..) )
 import PrelException    ( Exception(..), AsyncException(..) )
 
-infixr 0 `par`
+infixr 0 `par`, `seq`
 \end{code}
 
 %************************************************************************
@@ -62,8 +66,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
@@ -74,7 +78,7 @@ yield :: IO ()
 yield = IO $ \s -> 
    case (yield# s) of s1 -> (# s1, () #)
 
--- "seq" is defined a bit wierdly (see below)
+-- "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
@@ -89,14 +93,9 @@ yield = 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}
 
 %************************************************************************
@@ -116,52 +115,40 @@ 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
+-- 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,
@@ -194,19 +181,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}