Move Eq, Ord, Show instances for ThreadId to GHC.Conc

[haskell-directory.git] / Control / Concurrent.hs

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index 97be321..f05ee5a 100644 (file)
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -91,11 +91,13 @@ import Prelude
 import Control.Exception as Exception
 
 #ifdef __GLASGOW_HASKELL__
-import GHC.Conc
+import GHC.Conc                ( ThreadId(..), myThreadId, killThread, yield,
+                         threadDelay, threadWaitRead, threadWaitWrite,
+                         forkIO, childHandler )
 import GHC.TopHandler   ( reportStackOverflow, reportError )
 import GHC.IOBase      ( IO(..) )
 import GHC.IOBase      ( unsafeInterleaveIO )
-import GHC.IOBase   ( newIORef, readIORef, writeIORef )
+import GHC.IOBase      ( newIORef, readIORef, writeIORef )
 import GHC.Base
 
 import Foreign.StablePtr
@@ -167,72 +169,6 @@ implement thread-friendly I\/O, so calling standard Haskell I\/O
 functions blocks only the thread making the call.
 -}
 
--- Thread Ids, specifically the instances of Eq and Ord for these things.
--- The ThreadId type itself is defined in std/PrelConc.lhs.
-
--- Rather than define a new primitve, we use a little helper function
--- cmp_thread in the RTS.
-
-#ifdef __GLASGOW_HASKELL__
-id2TSO :: ThreadId -> ThreadId#
-id2TSO (ThreadId t) = t
-
-foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> Int
--- Returns -1, 0, 1
-
-cmpThread :: ThreadId -> ThreadId -> Ordering
-cmpThread t1 t2 = 
-   case cmp_thread (id2TSO t1) (id2TSO t2) of
-      -1 -> LT
-      0  -> EQ
-      _  -> GT -- must be 1
-
-instance Eq ThreadId where
-   t1 == t2 = 
-      case t1 `cmpThread` t2 of
-         EQ -> True
-         _  -> False
-
-instance Ord ThreadId where
-   compare = cmpThread
-
-foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> Int
-
-instance Show ThreadId where
-   showsPrec d t = 
-       showString "ThreadId " . 
-        showsPrec d (getThreadId (id2TSO t))
-
-{- |
-This sparks off a new thread to run the 'IO' computation passed as the
-first argument, and returns the 'ThreadId' of the newly created
-thread.
-
-The new thread will be a lightweight thread; if you want to use a foreign
-library that uses thread-local storage, use 'forkOS' instead.
--}
-forkIO :: IO () -> IO ThreadId
-forkIO action = IO $ \ s -> 
-   case (fork# action_plus s) of (# s1, id #) -> (# s1, ThreadId id #)
- where
-  action_plus = Exception.catch action childHandler
-
-childHandler :: Exception -> IO ()
-childHandler err = Exception.catch (real_handler err) childHandler
-
-real_handler :: Exception -> IO ()
-real_handler ex =
-  case ex of
-       -- ignore thread GC and killThread exceptions:
-       BlockedOnDeadMVar            -> return ()
-       AsyncException ThreadKilled  -> return ()
-
-       -- report all others:
-       AsyncException StackOverflow -> reportStackOverflow False
-       other       -> reportError False other
-
-#endif /* __GLASGOW_HASKELL__ */
-
 #ifndef __HUGS__
 max_buff_size :: Int
 max_buff_size = 1
@@ -476,8 +412,8 @@ runInUnboundThread action = do
 
 >   myForkIO :: IO () -> IO (MVar ())
 >   myForkIO io = do
->     mvar \<- newEmptyMVar
->     forkIO (io \`finally\` putMVar mvar ())
+>     mvar <- newEmptyMVar
+>     forkIO (io `finally` putMVar mvar ())
 >     return mvar
 
       Note that we use 'finally' from the
@@ -488,25 +424,26 @@ runInUnboundThread action = do
       A better method is to keep a global list of all child
       threads which we should wait for at the end of the program:
 
->     children :: MVar [MVar ()]
->     children = unsafePerformIO (newMVar [])
->     
->     waitForChildren :: IO ()
->     waitForChildren = do
->      (mvar:mvars) \<- takeMVar children
->      putMVar children mvars
->      takeMVar mvar
->      waitForChildren
->     
->     forkChild :: IO () -> IO ()
->     forkChild io = do
->       mvar \<- newEmptyMVar
->       forkIO (p \`finally\` putMVar mvar ())
->       childs \<- takeMVar children
->       putMVar children (mvar:childs)
->     
->     later = flip finally
->     
+>    children :: MVar [MVar ()]
+>    children = unsafePerformIO (newMVar [])
+>    
+>    waitForChildren :: IO ()
+>    waitForChildren = do
+>      cs <- takeMVar children
+>      case cs of
+>        []   -> return ()
+>        m:ms -> do
+>          putMVar children ms
+>          takeMVar m
+>          waitForChildren
+>    
+>    forkChild :: IO () -> IO ()
+>    forkChild io = do
+>       mvar <- newEmptyMVar
+>       childs <- takeMVar children
+>       putMVar children (mvar:childs)
+>       forkIO (io `finally` putMVar mvar ())
+>
 >     main =
 >      later waitForChildren $
 >      ...