-----------------------------------------------------------------------------
---
+-- |
-- Module : Control.Concurrent
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/core/LICENSE)
-- Stability : experimental
-- Portability : non-portable
--
--- $Id: Concurrent.hs,v 1.1 2001/06/28 14:15:01 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
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
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.
-- 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
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 #)
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__ */