X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=0b6bc91385edf4ff19050ab5209cffe64d478acf;hb=30464c0cb915c2ae900909568fa8677bba341e45;hp=11d78b8fe1197e29289e764aaaeac5f6e566a6cb;hpb=77a47fd973802d084a2a0118e4906368196edc11;p=haskell-directory.git

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 11d78b8..0b6bc91 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -23,7 +23,7 @@
 module GHC.Conc
 	( ThreadId(..)
 
-	-- Forking and suchlike
+	-- * Forking and suchlike
 	, forkIO	-- :: IO a -> IO ThreadId
 	, forkOnIO	-- :: Int -> IO a -> IO ThreadId
 	, childHandler  -- :: Exception -> IO ()
@@ -35,13 +35,13 @@ module GHC.Conc
 	, yield         -- :: IO ()
 	, labelThread	-- :: ThreadId -> String -> IO ()
 
-	-- Waiting
+	-- * Waiting
 	, threadDelay	  	-- :: Int -> IO ()
 	, registerDelay		-- :: Int -> IO (TVar Bool)
 	, threadWaitRead	-- :: Int -> IO ()
 	, threadWaitWrite	-- :: Int -> IO ()
 
-	-- MVars
+	-- * MVars
 	, MVar		-- abstract
 	, newMVar 	-- :: a -> IO (MVar a)
 	, newEmptyMVar  -- :: IO (MVar a)
@@ -52,7 +52,7 @@ module GHC.Conc
 	, isEmptyMVar	-- :: MVar a -> IO Bool
 	, addMVarFinalizer -- :: MVar a -> IO () -> IO ()
 
-   	-- TVars
+   	-- * TVars
 	, STM           -- abstract
 	, atomically    -- :: STM a -> IO a
 	, retry         -- :: STM a
@@ -65,6 +65,7 @@ module GHC.Conc
 	, writeTVar	-- :: a -> TVar a -> STM ()
 	, unsafeIOToSTM	-- :: IO a -> STM a
 
+   	-- * Miscellaneous
 #ifdef mingw32_HOST_OS
 	, asyncRead     -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
 	, asyncWrite    -- :: Int -> Int -> Int -> Ptr a -> IO (Int, Int)
@@ -99,6 +100,7 @@ import GHC.Exception    ( catchException, Exception(..), AsyncException(..) )
 import GHC.Pack		( packCString# )
 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 import GHC.STRef
+import GHC.Show		( Show(..), showString )
 import Data.Typeable
 
 infixr 0 `par`, `pseq`
@@ -133,6 +135,35 @@ This misfeature will hopefully be corrected at a later date.
 it defines 'ThreadId' as a synonym for ().
 -}
 
+instance Show ThreadId where
+   showsPrec d t = 
+   	showString "ThreadId " . 
+        showsPrec d (getThreadId (id2TSO t))
+
+foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> Int
+
+id2TSO :: ThreadId -> ThreadId#
+id2TSO (ThreadId t) = t
+
+foreign import ccall unsafe "cmp_thread" cmp_thread :: ThreadId# -> ThreadId# -> CInt
+-- 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
+
 {- |
 This sparks off a new thread to run the 'IO' computation passed as the
 first argument, and returns the 'ThreadId' of the newly created
@@ -260,6 +291,7 @@ TVars are shared memory locations which support atomic memory
 transactions.
 
 \begin{code}
+-- |A monad supporting atomic memory transactions.
 newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) deriving( Typeable )
 
 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
@@ -303,14 +335,15 @@ atomically (STM m) = IO (\s -> (atomically# m) s )
 -- values in TVars which mean that it should not continue (e.g. the TVars
 -- represent a shared buffer that is now empty).  The implementation may
 -- block the thread until one of the TVars that it has read from has been
--- udpated.
+-- udpated. (GHC only)
 retry :: STM a
 retry = STM $ \s# -> retry# s#
 
--- |Compose two alternative STM actions.  If the first action completes without
--- retrying then it forms the result of the orElse.  Otherwise, if the first
--- action retries, then the second action is tried in its place.  If both actions
--- retry then the orElse as a whole retries.
+-- |Compose two alternative STM actions (GHC only).  If the first action
+-- completes without retrying then it forms the result of the orElse.
+-- Otherwise, if the first action retries, then the second action is
+-- tried in its place.  If both actions retry then the orElse as a
+-- whole retries.
 orElse :: STM a -> STM a -> STM a
 orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 
@@ -318,6 +351,7 @@ orElse (STM m) e = STM $ \s -> catchRetry# m (unSTM e) s
 catchSTM :: STM a -> (Exception -> STM a) -> STM a
 catchSTM (STM m) k = STM $ \s -> catchSTM# m (\ex -> unSTM (k ex)) s
 
+-- |Shared memory locations that support atomic memory transactions.
 data TVar a = TVar (TVar# RealWorld a) deriving( Typeable )
 
 instance Eq (TVar a) where
@@ -549,6 +583,7 @@ threadDelay time
 	case delay# time# s of { s -> (# s, () #)
 	}}
 
+registerDelay :: Int -> IO (TVar Bool)
 registerDelay usecs 
 #ifndef mingw32_HOST_OS
   | threaded = waitForDelayEventSTM usecs
@@ -690,20 +725,24 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
 
   (wakeup_all,delays') <- do_select delays
 
-  if wakeup_all then return ()
-    else do
-      b <- fdIsSet wakeup readfds
-      if b == 0 
-        then return ()
-        else alloca $ \p -> do 
-	    c_read (fromIntegral wakeup) p 1; return ()
-	    s <- peek p		
-	    if (s == 0xff) 
-	      then return ()
-	      else do handler_tbl <- peek handlers
-		      sp <- peekElemOff handler_tbl (fromIntegral s)
-		      forkIO (do io <- deRefStablePtr sp; io)
-		      return ()
+  exit <-
+    if wakeup_all then return False
+      else do
+        b <- fdIsSet wakeup readfds
+        if b == 0 
+          then return False
+          else alloca $ \p -> do 
+	         c_read (fromIntegral wakeup) p 1; return ()
+		 s <- peek p		
+		 case s of
+		  _ | s == io_MANAGER_WAKEUP -> return False
+		  _ | s == io_MANAGER_DIE    -> return True
+		  _ -> do handler_tbl <- peek handlers
+		          sp <- peekElemOff handler_tbl (fromIntegral s)
+		          forkIO (do io <- deRefStablePtr sp; io)
+		          return False
+
+  if exit then return () else do
 
   takeMVar prodding
   putMVar prodding False
@@ -717,6 +756,9 @@ stick :: IORef Fd
 {-# NOINLINE stick #-}
 stick = unsafePerformIO (newIORef 0)
 
+io_MANAGER_WAKEUP = 0xff :: CChar
+io_MANAGER_DIE    = 0xfe :: CChar
+
 prodding :: MVar Bool
 {-# NOINLINE prodding #-}
 prodding = unsafePerformIO (newMVar False)
@@ -726,7 +768,8 @@ prodServiceThread = do
   b <- takeMVar prodding
   if (not b) 
     then do fd <- readIORef stick
-	    with 0xff $ \pbuf -> do c_write (fromIntegral fd) pbuf 1; return ()
+	    with io_MANAGER_WAKEUP $ \pbuf -> do 
+		c_write (fromIntegral fd) pbuf 1; return ()
     else return ()
   putMVar prodding True