[project @ 2002-04-24 16:31:37 by simonmar]

[ghc-base.git] / Control / Concurrent.hs

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index 033f2cc..6b3ec94 100644 (file)
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- 
+-- |
 -- Module      :  Control.Concurrent
 -- Copyright   :  (c) The University of Glasgow 2001
 -- License     :  BSD-style (see the file libraries/core/LICENSE)
@@ -8,47 +8,40 @@
 -- Stability   :  experimental
 -- Portability :  non-portable
 --
--- $Id: Concurrent.hs,v 1.1 2001/06/28 14:15:01 simonmar Exp $
+-- $Id: Concurrent.hs,v 1.6 2002/04/24 16:31:37 simonmar Exp $
 --
 -- A common interface to a collection of useful concurrency
 -- abstractions.
 --
 -----------------------------------------------------------------------------
 
-module Control.Concurrent
-       ( module Control.Concurrent.Chan
-       , module Control.Concurrent.CVar
-       , module Control.Concurrent.MVar
-       , module Control.Concurrent.QSem
-       , module Control.Concurrent.QSemN
-       , module Control.Concurrent.SampleVar
+module Control.Concurrent (
+       module Control.Concurrent.Chan,
+       module Control.Concurrent.CVar,
+       module Control.Concurrent.MVar,
+       module Control.Concurrent.QSem,
+       module Control.Concurrent.QSemN,
+       module Control.Concurrent.SampleVar,
 
-#ifdef __HUGS__
-       , forkIO        -- :: IO () -> IO ()
-#elif defined(__GLASGOW_HASKELL__)
-        , ThreadId
+       forkIO,                 -- :: IO () -> IO ()
+       yield,                  -- :: IO ()
 
-       -- Forking and suchlike
-       , myThreadId    -- :: IO ThreadId
-       , killThread    -- :: ThreadId -> IO ()
-       , throwTo       -- :: ThreadId -> Exception -> IO ()
-#endif
-       , par           -- :: a -> b -> b
-       , seq           -- :: a -> b -> b
 #ifdef __GLASGOW_HASKELL__
-       , fork          -- :: a -> b -> b
-#endif
-       , yield         -- :: IO ()
+        ThreadId,
 
-#ifdef __GLASGOW_HASKELL__
-       , threadDelay           -- :: Int -> IO ()
-       , threadWaitRead        -- :: Int -> IO ()
-       , threadWaitWrite       -- :: Int -> IO ()
+       -- Forking and suchlike
+       myThreadId,             -- :: IO ThreadId
+       killThread,             -- :: ThreadId -> IO ()
+       throwTo,                -- :: ThreadId -> Exception -> IO ()
+
+       threadDelay,            -- :: Int -> IO ()
+       threadWaitRead,         -- :: Int -> IO ()
+       threadWaitWrite,        -- :: Int -> IO ()
 #endif
 
         -- merging of streams
-       , mergeIO       -- :: [a]   -> [a] -> IO [a]
-       , nmergeIO      -- :: [[a]] -> IO [a]
+       mergeIO,                -- :: [a]   -> [a] -> IO [a]
+       nmergeIO                -- :: [[a]] -> IO [a]
     ) where
 
 import Prelude
@@ -59,13 +52,12 @@ import Control.Exception as Exception
 import GHC.Conc
 import GHC.TopHandler   ( reportStackOverflow, reportError )
 import GHC.IOBase      ( IO(..) )
-import GHC.IOBase      ( unsafePerformIO , unsafeInterleaveIO )
-import GHC.Base                ( fork# )
-import GHC.Prim                ( Addr#, unsafeCoerce# )
+import GHC.IOBase      ( unsafeInterleaveIO )
+import GHC.Base
 #endif
 
 #ifdef __HUGS__
-import IOExts ( unsafeInterleaveIO, unsafePerformIO )
+import IOExts ( unsafeInterleaveIO )
 import ConcBase
 #endif
 
@@ -76,10 +68,6 @@ import Control.Concurrent.QSem
 import Control.Concurrent.QSemN
 import Control.Concurrent.SampleVar
 
-#ifdef __GLASGOW_HASKELL__
-infixr 0 `fork`
-#endif
-
 -- Thread Ids, specifically the instances of Eq and Ord for these things.
 -- The ThreadId type itself is defined in std/PrelConc.lhs.
 
@@ -87,7 +75,7 @@ infixr 0 `fork`
 -- cmp_thread in the RTS.
 
 #ifdef __GLASGOW_HASKELL__
-foreign import ccall "cmp_thread" unsafe cmp_thread :: Addr# -> Addr# -> Int
+foreign import ccall unsafe "cmp_thread" cmp_thread :: Addr# -> Addr# -> Int
 -- Returns -1, 0, 1
 
 cmpThread :: ThreadId -> ThreadId -> Ordering
@@ -106,6 +94,13 @@ instance Eq ThreadId where
 instance Ord ThreadId where
    compare = cmpThread
 
+foreign import ccall unsafe "rts_getThreadId" getThreadId :: Addr# -> Int
+
+instance Show ThreadId where
+   showsPrec d (ThreadId t) = 
+       showString "ThreadId " . 
+        showsPrec d (getThreadId (unsafeCoerce# t))
+
 forkIO :: IO () -> IO ThreadId
 forkIO action = IO $ \ s -> 
    case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
@@ -127,10 +122,6 @@ real_handler ex =
        ErrorCall s -> reportError False s
        other       -> reportError False (showsPrec 0 other "\n")
 
-{-# INLINE fork #-}
-fork :: a -> b -> b
-fork x y = unsafePerformIO (forkIO (x `seq` return ())) `seq` y
-
 #endif /* __GLASGOW_HASKELL__ */