X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FConc.lhs;h=8476498c1f2d1caba26efdd6a7b0d53c3919b417;hb=04a66406a173c23a85081d3768a0364a03d6af5c;hp=93ffba76c774eb931e27f12fbf40461a0e1dda27;hpb=bb534f206682be14daf72b33c6105ab27295c6ac;p=ghc-base.git

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 93ffba7..8476498 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -14,6 +14,12 @@
 -- 
 -----------------------------------------------------------------------------
 
+-- No: #hide, because bits of this module are exposed by the stm package.
+-- However, we don't want this module to be the home location for the
+-- bits it exports, we'd rather have Control.Concurrent and the other
+-- higher level modules be the home.  Hence:
+
+-- #not-home
 module GHC.Conc
 	( ThreadId(..)
 
@@ -81,7 +87,6 @@ import GHC.Pack		( packCString# )
 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 import GHC.STRef
 import Data.Typeable
-#include "Typeable.h"
 
 infixr 0 `par`, `pseq`
 \end{code}
@@ -93,7 +98,7 @@ infixr 0 `par`, `pseq`
 %************************************************************************
 
 \begin{code}
-data ThreadId = ThreadId ThreadId#
+data ThreadId = ThreadId ThreadId# deriving( Typeable )
 -- ToDo: data ThreadId = ThreadId (Weak ThreadId#)
 -- But since ThreadId# is unlifted, the Weak type must use open
 -- type variables.
@@ -115,9 +120,6 @@ This misfeature will hopefully be corrected at a later date.
 it defines 'ThreadId' as a synonym for ().
 -}
 
-INSTANCE_TYPEABLE0(ThreadId,threadIdTc,"ThreadId")
-
-
 --forkIO has now been hoisted out into the Concurrent library.
 
 {- | 'killThread' terminates the given thread (GHC only).
@@ -206,9 +208,7 @@ TVars are shared memory locations which support atomic memory
 transactions.
 
 \begin{code}
-newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #))
-
-INSTANCE_TYPEABLE1(STM,stmTc,"STM" )
+newtype STM a = STM (State# RealWorld -> (# State# RealWorld, a #)) deriving( Typeable )
 
 unSTM :: STM a -> (State# RealWorld -> (# State# RealWorld, a #))
 unSTM (STM a) = a
@@ -266,9 +266,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
 
-data TVar a = TVar (TVar# RealWorld a)
-
-INSTANCE_TYPEABLE1(TVar,tvarTc,"TVar" )
+data TVar a = TVar (TVar# RealWorld a) deriving( Typeable )
 
 instance Eq (TVar a) where
 	(TVar tvar1#) == (TVar tvar2#) = sameTVar# tvar1# tvar2#
@@ -308,8 +306,6 @@ writes.
 \begin{code}
 --Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
 
-INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
-
 -- |Create an 'MVar' which is initially empty.
 newEmptyMVar  :: IO (MVar a)
 newEmptyMVar = IO $ \ s# ->
@@ -577,24 +573,26 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
   fdSet wakeup readfds
   maxfd <- buildFdSets 0 readfds writefds reqs
 
-  -- check the current time and wake up any thread in threadDelay whose
-  -- timeout has expired.  Also find the timeout value for the select() call.
-  now <- getTicksOfDay
-  (delays', timeout) <- getDelay now ptimeval delays
-
   -- perform the select()
-  let do_select = do
+  let do_select delays = do
+	  -- check the current time and wake up any thread in
+	  -- threadDelay whose timeout has expired.  Also find the
+	  -- timeout value for the select() call.
+	  now <- getTicksOfDay
+	  (delays', timeout) <- getDelay now ptimeval delays
+
 	  res <- c_select ((max wakeup maxfd)+1) readfds writefds 
 			nullPtr timeout
 	  if (res == -1)
 	     then do
 		err <- getErrno
 		if err == eINTR
-			then do_select
-			else return res
+			then do_select delays'
+			else return (res,delays')
 	     else
-		return res
-  res <- do_select
+		return (res,delays')
+
+  (res,delays') <- do_select delays
   -- ToDo: check result
 
   b <- takeMVar prodding