+% -----------------------------------------------------------------------------
+% $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@}
\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
+ , addMVarFinalizer -- :: MVar a -> IO () -> IO ()
+
) where
import PrelBase
-import PrelST ( ST(..), STret(..), StateAndPtr#(..) )
-import PrelIOBase ( IO(..), IOResult(..), MVar(..) )
-import PrelErr ( parError )
+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}
%************************************************************************
--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
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#) #)
+
+-- 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}
\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}
projects / ghc-hetmet.git / blobdiff